summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-rw-r--r--server/Main.hs16
-rw-r--r--server/Worker.hs41
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