filipg/gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

start using Runner monad

Browse Source
This commit is contained in:
Filip Gralinski 2018-06-05 09:36:48 +02:00
parent dcdf71b5e6
commit e06f2120ea
2 changed files with 42 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
Handler/Runner.hs
View File

@ -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

46
Handler/Shared.hs
View File

@ -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