Hook up individual keys

2022-01-19 12:46:23 +01:00 · 2022-01-19 12:46:23 +01:00 · 9c13b1ddf4
commit 9c13b1ddf4
parent 3a16a9d0e1
3 changed files with 107 additions and 40 deletions
--- a/Handler/Runner.hs
+++ b/Handler/Runner.hs
@ -77,23 +77,32 @@ runWithChannel chan runner = do
             RunnerError e -> e

 runProg :: Maybe FilePath -> FilePath -> [String] -> Runner ()
-runProg workingDir programPath args = Runner {
+runProg workingDir programPath args = runProgWithEnv workingDir [] programPath args
+
+runProgWithEnv :: Maybe FilePath -> [(String, String)] -> FilePath -> [String] -> Runner ()
+runProgWithEnv workingDir extraEnv programPath args = Runner {
  runRunner = \chan -> do
-      (code, _) <- runProgram workingDir programPath args chan
+      (code, _) <- runProgramWithEnv workingDir extraEnv programPath args chan
      case code of
        ExitSuccess -> return $ RunnerOK ()
        _ -> return $ RunnerError code
  }

 runProgram :: Maybe FilePath -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text)
-runProgram workingDir programPath args chan = do
+runProgram workingDir programPath args chan =
+  runProgramWithEnv workingDir [] programPath args chan
+
+runProgramWithEnv :: Maybe FilePath -> [(String, String)] -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text)
+runProgramWithEnv workingDir extraEnv programPath args chan = do
+  liftIO $ putStrLn $ pack $ show extraEnv
+  liftIO $ putStrLn $ pack $ show args
  env <- liftIO $ getEnvironment
  (_, Just hout, Just herr, pid) <-
       liftIO $ createProcess (proc programPath args){
      std_out = CreatePipe,
      std_err = CreatePipe,
      -- https://serverfault.com/questions/544156/git-clone-fail-instead-of-prompting-for-credentials
-      env = Just (("GIT_TERMINAL_PROMPT", "0") : env),
+      env = Just (("GIT_TERMINAL_PROMPT", "0") : (env ++ extraEnv)),
      cwd = workingDir}
  (code, out) <- gatherOutput pid hout herr chan
  _ <- liftIO $ waitForProcess pid
--- a/Handler/Shared.hs
+++ b/Handler/Shared.hs
@ -22,6 +22,8 @@ import Database.Persist.Sql (fromSqlKey)
 import Control.Concurrent.Lifted (threadDelay)
 import Control.Concurrent (forkIO)

+import System.Directory
+
 import qualified Crypto.Hash.SHA1 as CHS

 import qualified Data.List as DL
@ -473,35 +475,89 @@ cloneRepo' userId repoCloningSpec chan = do
 fixGitRepoUrl :: Text -> Text
 fixGitRepoUrl = id

+fetchIndividualKeyPath user = do
+  arenaDir <- arena
+  let mLocalId = userLocalId user
+  case mLocalId of
+    Just localId -> do
+      let individualKeysDir = arenaDir ++ "/individual-keys"
+      let individualKeyPath = (unpack individualKeysDir) ++ "/" ++ (unpack localId)
+
+      isKeyGenerated <- liftIO $ doesFileExist individualKeyPath
+      if isKeyGenerated
+        then
+          return $ Just individualKeyPath
+        else
+          return Nothing
+    Nothing -> return Nothing
+
+isUserLocalRepo user repoCloningSpec =
+  case userLocalId user of
+    Just localId -> (("ssh://gitolite@gonito.net/" <> localId <> "/") `isPrefixOf` url
+                    || ("gitolite@gonito.net:" <> localId <> "/") `isPrefixOf` url)
+    Nothing -> False
+  where url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
+
+getGitEnv :: RepoCloningSpec -> Handler (Maybe [(String, String)])
+getGitEnv repoCloningSpec = do
+  maybeUser <- maybeAuth
+  if ((userIsAdmin <$> entityVal <$> maybeUser) == Just True)
+   then
+     return $ Just []
+   else
+     do
+       case maybeUser of
+          Just (Entity _ user) -> do
+            if isUserLocalRepo user repoCloningSpec
+              then
+                return $ Just []
+              else
+                do
+                 mInvidualPrivateKey <- fetchIndividualKeyPath user
+                 case mInvidualPrivateKey of
+                   Just individualPrivateKey -> do
+                     curr_dir <- liftIO $ getCurrentDirectory
+                     return $ Just [("GIT_SSH_COMMAND",
+                                     "/usr/bin/ssh -o StrictHostKeyChecking=no  -i " ++ curr_dir ++ "/" ++ individualPrivateKey)]
+                   Nothing -> return $ Nothing
+          Nothing -> return $ Nothing
+
 rawClone :: FilePath -> RepoCloningSpec -> Channel -> Handler ExitCode
-rawClone tmpRepoDir repoCloningSpec chan = runWithChannel chan $ do
-  let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
-  let branch = repoSpecBranch $ cloningSpecRepo repoCloningSpec
-  let referenceUrl = repoSpecUrl $ cloningSpecReferenceRepo repoCloningSpec
-  let referenceBranch = repoSpecBranch $ cloningSpecReferenceRepo repoCloningSpec
-  runProg Nothing gitPath ["clone",
-                           "--progress",
-                           "--single-branch",
-                           "--branch",
-                           T.unpack referenceBranch,
-                           T.unpack (fixGitRepoUrl referenceUrl),
-                           tmpRepoDir]
-  if url /= referenceUrl || branch /= referenceBranch
-    then
-      do
-       runProg (Just tmpRepoDir) gitPath ["remote",
-                                           "set-url",
-                                           "origin",
-                                           T.unpack (fixGitRepoUrl url)]
-       runProg (Just tmpRepoDir) gitPath ["fetch",
-                                           "origin",
-                                           T.unpack branch]
-       runProg (Just tmpRepoDir) gitPath ["reset",
-                                           "--hard",
-                                           "FETCH_HEAD"]
-       getStuffUsingGitAnnex tmpRepoDir (repoSpecGitAnnexRemote $ cloningSpecRepo repoCloningSpec)
-    else
-      return ()
+rawClone tmpRepoDir repoCloningSpec chan = do
+ gitEnv <- getGitEnv repoCloningSpec
+ case gitEnv of
+   Just extraEnv -> runWithChannel chan $ do
+      let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
+      let branch = repoSpecBranch $ cloningSpecRepo repoCloningSpec
+      let referenceUrl = repoSpecUrl $ cloningSpecReferenceRepo repoCloningSpec
+      let referenceBranch = repoSpecBranch $ cloningSpecReferenceRepo repoCloningSpec
+
+      runProgWithEnv Nothing extraEnv gitPath ["clone",
+                                               "--progress",
+                                               "--single-branch",
+                                               "--branch",
+                                               T.unpack referenceBranch,
+                                               T.unpack (fixGitRepoUrl referenceUrl),
+                                               tmpRepoDir]
+      if url /= referenceUrl || branch /= referenceBranch
+        then
+          do
+            runProg (Just tmpRepoDir) gitPath ["remote",
+                                               "set-url",
+                                                "origin",
+                                                T.unpack (fixGitRepoUrl url)]
+            runProgWithEnv (Just tmpRepoDir) extraEnv gitPath ["fetch",
+                                                               "origin",
+                                                               T.unpack branch]
+            runProg (Just tmpRepoDir) gitPath ["reset",
+                                               "--hard",
+                                               "FETCH_HEAD"]
+            getStuffUsingGitAnnex tmpRepoDir (repoSpecGitAnnexRemote $ cloningSpecRepo repoCloningSpec)
+        else
+          return ()
+   Nothing -> do
+      err chan "Wrong SSH key"
+      return (ExitFailure 1)

 getStuffUsingGitAnnex :: FilePath -> Maybe Text -> Runner ()
 getStuffUsingGitAnnex _ Nothing = return ()
--- a/Handler/YourAccount.hs
+++ b/Handler/YourAccount.hs
@ -46,9 +46,7 @@ fetchIndividualKey (Just localId) = do
  if not isKeyGenerated
   then
    do
-          _ <- liftIO $ createProcess (proc "/usr/bin/ssh-keygen" ["-t", "RSA", "-f", individualKeyPath, "-N",  "", "-C", individualComment]){
-            std_err = UseHandle stderr,
-            std_out = UseHandle stderr}
+          _ <- liftIO $ callProcess "/usr/bin/ssh-keygen" ["-t", "RSA", "-f", individualKeyPath, "-N",  "", "-C", individualComment]
          return ()
   else
    return ()
@ -66,20 +64,24 @@ postYourAccountR = do

    enableTriggerToken userId (userTriggerToken user)

-    mIndividualKey <- fetchIndividualKey $ userLocalId user
-
    let accountData = case result of
            FormSuccess res -> Just res
            _ -> Nothing
-    case accountData of
+    mIndividualKey <- case accountData of
        Just (name, localId, mPassword, sshPubKey, mAltRepoScheme, avatarFile, anonimised) -> do
          if checkPassword mPassword
            then
+             do
+              mIndKey <- fetchIndividualKey localId
              updateUserAccount userId name localId mPassword sshPubKey mAltRepoScheme avatarFile anonimised
-            else
-              tooWeakPasswordMessage
+              return mIndKey
+             else
+              do
+               tooWeakPasswordMessage
+               return Nothing
        Nothing -> do
          setMessage $ toHtml ("Something went wrong, probably the password did not match" :: Text)
+          return Nothing
    defaultLayout $ do
      setTitle "Your account"
      $(widgetFile "your-account")