diff --git a/Handler/Runner.hs b/Handler/Runner.hs index 0cd074a..37ade31 100644 --- a/Handler/Runner.hs +++ b/Handler/Runner.hs @@ -30,7 +30,7 @@ instance Functor Runner where instance Applicative Runner where pure v = Runner { - runRunner = \chan -> return $ RunnerOK v + runRunner = \_ -> return $ RunnerOK v } liftA2 f runner1 runner2 = Runner { runRunner = \chan -> do @@ -44,8 +44,28 @@ instance Applicative Runner where RunnerError e -> return $ RunnerError e } -run :: Maybe FilePath -> FilePath -> [String] -> Runner () -run workingDir programPath args = Runner { +instance Monad Runner where + runner >>= k = Runner { + runRunner = \chan -> do + s <- (runRunner runner) chan + case s of + RunnerError e -> return $ RunnerError e + RunnerOK v -> do + sn <- (runRunner (k v)) chan + return $ case sn of + RunnerError e -> RunnerError e + RunnerOK w -> RunnerOK w + } + +runWithChannel :: Channel -> Runner () -> Handler ExitCode +runWithChannel chan runner = do + s <- (runRunner runner) chan + return $ case s of + RunnerOK () -> ExitSuccess + RunnerError e -> e + +runProg :: Maybe FilePath -> FilePath -> [String] -> Runner () +runProg workingDir programPath args = Runner { runRunner = \chan -> do (code, _) <- runProgram workingDir programPath args chan case code of diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 9f42c19..2a18f67 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -215,41 +215,33 @@ cloneRepo' repoCloningSpec chan = do err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText] return Nothing -rawClone :: FilePath -> RepoCloningSpec -> Channel -> Handler (ExitCode) -rawClone tmpRepoDir repoCloningSpec chan = do +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 - (exitCode, _) <- runProgram Nothing gitPath ["clone", - "--progress", - "--branch", - T.unpack referenceBranch, - T.unpack referenceUrl, - tmpRepoDir] chan + runProg Nothing gitPath ["clone", + "--progress", + "--branch", + T.unpack referenceBranch, + T.unpack referenceUrl, + tmpRepoDir] if url /= referenceUrl || branch /= referenceBranch then do - (exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["remote", - "set-url", - "origin", - T.unpack url] chan - case exitCode of - ExitSuccess -> do - (exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["fetch", - "origin", - T.unpack branch] chan - case exitCode of - ExitSuccess -> do - (exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["reset", - "--hard", - "FETCH_HEAD"] chan - return exitCode - _ -> return exitCode - _ -> return exitCode - + runProg (Just tmpRepoDir) gitPath ["remote", + "set-url", + "origin", + T.unpack url] + runProg (Just tmpRepoDir) gitPath ["fetch", + "origin", + T.unpack branch] + runProg (Just tmpRepoDir) gitPath ["reset", + "--hard", + "FETCH_HEAD"] else - return exitCode + return () getRepoDir :: Key Repo -> Handler FilePath getRepoDir repoId = do