Hook up individual keys

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

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
+rawClone tmpRepoDir repoCloningSpec chan = do
-  let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
+ gitEnv <- getGitEnv repoCloningSpec
-  let branch = repoSpecBranch $ cloningSpecRepo repoCloningSpec
+ case gitEnv of
-  let referenceUrl = repoSpecUrl $ cloningSpecReferenceRepo repoCloningSpec
+   Just extraEnv -> runWithChannel chan $ do
-  let referenceBranch = repoSpecBranch $ cloningSpecReferenceRepo repoCloningSpec
+      let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
-  runProg Nothing gitPath ["clone",
+      let branch = repoSpecBranch $ cloningSpecRepo repoCloningSpec
-                           "--progress",
+      let referenceUrl = repoSpecUrl $ cloningSpecReferenceRepo repoCloningSpec
-                           "--single-branch",
+      let referenceBranch = repoSpecBranch $ cloningSpecReferenceRepo repoCloningSpec
-                           "--branch",
+
-                           T.unpack referenceBranch,
+      runProgWithEnv Nothing extraEnv gitPath ["clone",
-                           T.unpack (fixGitRepoUrl referenceUrl),
+                                               "--progress",
-                           tmpRepoDir]
+                                               "--single-branch",
-  if url /= referenceUrl || branch /= referenceBranch
+                                               "--branch",
-    then
+                                               T.unpack referenceBranch,
-      do
+                                               T.unpack (fixGitRepoUrl referenceUrl),
-       runProg (Just tmpRepoDir) gitPath ["remote",
+                                               tmpRepoDir]
-                                           "set-url",
+      if url /= referenceUrl || branch /= referenceBranch
-                                           "origin",
+        then
-                                           T.unpack (fixGitRepoUrl url)]
+          do
-       runProg (Just tmpRepoDir) gitPath ["fetch",
+            runProg (Just tmpRepoDir) gitPath ["remote",
-                                           "origin",
+                                               "set-url",
-                                           T.unpack branch]
+                                                "origin",
-       runProg (Just tmpRepoDir) gitPath ["reset",
+                                                T.unpack (fixGitRepoUrl url)]
-                                           "--hard",
+            runProgWithEnv (Just tmpRepoDir) extraEnv gitPath ["fetch",
-                                           "FETCH_HEAD"]
+                                                               "origin",
-       getStuffUsingGitAnnex tmpRepoDir (repoSpecGitAnnexRemote $ cloningSpecRepo repoCloningSpec)
+                                                               T.unpack branch]
-    else
+            runProg (Just tmpRepoDir) gitPath ["reset",
-      return ()
+                                               "--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 ()

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]){
+          _ <- liftIO $ callProcess "/usr/bin/ssh-keygen" ["-t", "RSA", "-f", individualKeyPath, "-N",  "", "-C", individualComment]
-            std_err = UseHandle stderr,
-            std_out = UseHandle stderr}
           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
+              return mIndKey
-              tooWeakPasswordMessage
+             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")