From 1a11fb5e4ad891d4f3230f386e78de3f6499fd30 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 3 Mar 2022 18:13:30 +0100
Subject: mapserver: somewhat more decent logging

---
 server/Main.hs   | 16 +++++++---------
 server/Worker.hs | 41 +++++++++++++++++++++++------------------
 2 files changed, 30 insertions(+), 27 deletions(-)

(limited to 'server')

diff --git a/server/Main.hs b/server/Main.hs
index cb1a65b..d9a8db7 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -49,6 +49,7 @@ import           Worker                               (Job (Job), linterThread)
 import           Servant.API                          (Header)
 import           Servant.Client                       (ClientM, client,
                                                        mkClientEnv, runClientM)
+import Control.Monad.Logger (logInfoN, runStdoutLoggingT)
 
 type family PolyEndpoint method format payload where
   PolyEndpoint Get format payload =
@@ -94,8 +95,6 @@ main = do
   config <- loadConfig "./config.toml"
   state <- newMVar (emptyState config)
   queue :: TQueue Job <- newTQueueIO
-  -- TODO: i really don't like all this cli logging stuff, replace it with
-  -- fast-logger at some point …
   loggerMiddleware <- mkRequestLogger
     $ def { outputFormat = Detailed (view verbose config) }
 
@@ -104,8 +103,6 @@ main = do
 
   -- periodically ‘pokes’ jobs to re-lint each repo
   poker <- async $ forever $ do
-    readMVar state >>= \state ->
-      print (length $ view unState state)
     atomically $ forM_ (view orgs config) $ \org ->
       forM_ (orgRepos org) $ \repo ->
         writeTQueue queue (Job repo org)
@@ -115,13 +112,13 @@ main = do
   -- TODO: what about tls / https?
   whenJust (view exneuland config) $ \baseurl -> do
     manager' <- newManager defaultManagerSettings
-    updater <- async $ forever $ do
+    updater <- async $ runStdoutLoggingT $ forever $ do
       done <- readMVar state
-      res <- runClientM
+      res <- liftIO $ runClientM
            (postNewMaps (view token config) (MapService done))
            (mkClientEnv manager' baseurl)
-      print res
-      threadDelay (view interval config * 1000000)
+      logInfoN $ "exneuland maps POST request: " <> show res
+      liftIO $ threadDelay (view interval config * 1000000)
     link updater
 
   -- spawns threads for each job in the queue
@@ -133,6 +130,7 @@ main = do
        setPort (view port config)
        defaultSettings
 
+  putTextLn $ "starting server on port " <> show (view port config)
   runSettings warpsettings
     . loggerMiddleware
     $ app state
@@ -140,4 +138,4 @@ main = do
   waitEither_ linter poker
   where
     showInfo org =
-      "→ org "+|orgSlug org|+" divoc ("+|length (orgRepos org)|+" repositoryies)\n" :: Text
+      "→ org "+|orgSlug org|+" ("+|length (orgRepos org)|+" repositories)\n" :: Text
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
-- 
cgit v1.2.3