diff --git a/Handler/Runner.hs b/Handler/Runner.hs index 3330693..e904aa6 100644 --- 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 diff --git a/Handler/Shared.hs b/Handler/Shared.hs index d58db4b..bf91598 100644 --- 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 () diff --git a/Handler/YourAccount.hs b/Handler/YourAccount.hs index a168ec1..31f2b03 100644 --- 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")