mapserver: somewhat more decent logging

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