diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Main.hs | 16 | ||||
| -rw-r--r-- | server/Worker.hs | 41 |
2 files changed, 30 insertions, 27 deletions
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 |