summaryrefslogtreecommitdiff
path: root/server/Worker.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--server/Worker.hs41
1 files changed, 23 insertions, 18 deletions
diff --git a/server/Worker.hs b/server/Worker.hs
index b3ce1da..7de9cd3 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
module Worker (linterThread, Job(..)) where
@@ -23,10 +24,12 @@ import Server (Config, JobStatus (..),
ServerState, adjustedPath,
setJobStatus, tmpdir)
import System.Directory (doesDirectoryExist)
-import System.Exit (ExitCode (ExitFailure))
+import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import System.FilePath ((</>))
import System.Process
import WriteRepo (writeAdjustedRepository)
+import Control.Monad.Logger (runStdoutLoggingT, logErrorN, logInfoN, logError)
+import Fmt ((+|), (|+))
data Job = Job
{ jobRef :: RemoteRef
@@ -65,34 +68,36 @@ runJob config Job {..} done = do
, "--depth", "1", "-b", toString ref])
rev <- map T.strip -- git returns a newline here
$ readgit' gitdir ["rev-parse", toString ref]
+
+ let outPath = adjustedPath rev jobOrg
+
callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
>>= evaluateNF
- writeAdjustedRepository (orgLintconfig jobOrg) workdir (toString $ adjustedPath rev jobOrg) res
- >>= \case ExitFailure 1 ->
- -- error's in the result anyways
- pure ()
- ExitFailure 2 ->
- -- TODO: use a fastlogger for this or sth
- -- TODO: shouldn't have linted this map at all
- putTextLn "ERROR: outpath already exists"
- ExitFailure n -> do -- impossible
- print n
- pure ()
- _ -> pure () -- all good
-
- putTextLn "still here!"
+ writeAdjustedRepository (orgLintconfig jobOrg) workdir (toString outPath) res
+ >>= runStdoutLoggingT . \case
+ ExitSuccess ->
+ logInfoN $ "linted map "+| (show jobRef :: Text) |+"."
+ ExitFailure 1 ->
+ logInfoN $ "linted map "+| (show jobRef :: Text) |+ ", which failed."
+ ExitFailure 2 ->
+ -- TODO: shouldn't have linted this map at all
+ logErrorN $ "outpath "+|outPath|+" already exists!"
+ ExitFailure _ ->
+ -- writeAdjustedRepository does not return other codes
+ $(logError) "wtf, this is impossible"
+
setJobStatus done jobOrg jobRef $
Linted (shrinkDirResult res) rev
cleanup workdir = do
callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
- whoops (error :: IOException) = do
- -- TODO: should also log this error
- setJobStatus done jobOrg jobRef $ Failed (show error)
+ whoops (error :: IOException) = runStdoutLoggingT $ do
+ logErrorN (show error)
+ liftIO $ setJobStatus done jobOrg jobRef $ Failed (show error)
url = repourl jobRef
ref = reporef jobRef