s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects 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 instance Applicative Runner where
pure v = Runner { pure v = Runner {
runRunner = \chan -> return $ RunnerOK v runRunner = \_ -> return $ RunnerOK v
} }
liftA2 f runner1 runner2 = Runner { liftA2 f runner1 runner2 = Runner {
runRunner = \chan -> do runRunner = \chan -> do
@ -44,8 +44,28 @@ instance Applicative Runner where
RunnerError e -> return $ RunnerError e RunnerError e -> return $ RunnerError e
} }
run :: Maybe FilePath -> FilePath -> [String] -> Runner () instance Monad Runner where
run workingDir programPath args = Runner { 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 runRunner = \chan -> do
(code, _) <- runProgram workingDir programPath args chan (code, _) <- runProgram workingDir programPath args chan
case code of 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] err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText]
return Nothing return Nothing
rawClone :: FilePath -> RepoCloningSpec -> Channel -> Handler (ExitCode) rawClone :: FilePath -> RepoCloningSpec -> Channel -> Handler ExitCode
rawClone tmpRepoDir repoCloningSpec chan = do rawClone tmpRepoDir repoCloningSpec chan = runWithChannel chan $ do
let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
let branch = repoSpecBranch $ cloningSpecRepo repoCloningSpec let branch = repoSpecBranch $ cloningSpecRepo repoCloningSpec
let referenceUrl = repoSpecUrl $ cloningSpecReferenceRepo repoCloningSpec let referenceUrl = repoSpecUrl $ cloningSpecReferenceRepo repoCloningSpec
let referenceBranch = repoSpecBranch $ cloningSpecReferenceRepo repoCloningSpec let referenceBranch = repoSpecBranch $ cloningSpecReferenceRepo repoCloningSpec
(exitCode, _) <- runProgram Nothing gitPath ["clone", runProg Nothing gitPath ["clone",
"--progress", "--progress",
"--branch", "--branch",
T.unpack referenceBranch, T.unpack referenceBranch,
T.unpack referenceUrl, T.unpack referenceUrl,
tmpRepoDir] chan tmpRepoDir]
if url /= referenceUrl || branch /= referenceBranch if url /= referenceUrl || branch /= referenceBranch
then then
do do
(exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["remote", runProg (Just tmpRepoDir) gitPath ["remote",
"set-url", "set-url",
"origin", "origin",
T.unpack url] chan T.unpack url]
case exitCode of runProg (Just tmpRepoDir) gitPath ["fetch",
ExitSuccess -> do "origin",
(exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["fetch", T.unpack branch]
"origin", runProg (Just tmpRepoDir) gitPath ["reset",
T.unpack branch] chan "--hard",
case exitCode of "FETCH_HEAD"]
ExitSuccess -> do
(exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["reset",
"--hard",
"FETCH_HEAD"] chan
return exitCode
_ -> return exitCode
_ -> return exitCode
else else
return exitCode return ()
getRepoDir :: Key Repo -> Handler FilePath getRepoDir :: Key Repo -> Handler FilePath
getRepoDir repoId = do getRepoDir repoId = do