diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Main.hs | 28 | ||||
| -rw-r--r-- | server/Server.hs | 21 | ||||
| -rw-r--r-- | server/Worker.hs | 5 |
3 files changed, 33 insertions, 21 deletions
diff --git a/server/Main.hs b/server/Main.hs index 1a18c6a..d9c548b 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -31,9 +31,9 @@ import Network.Wai.Middleware.RequestLogger (OutputFormat (..), RequestLoggerSettings (..), mkRequestLogger) import Servant (Application, Capture, - EmptyAPI, Get, JSON, - PlainText, Post, Raw, - ReqBody, Server, serve, + Get, JSON, PlainText, + Post, Raw, ReqBody, + Server, serve, type (:<|>) (..), type (:>)) import Servant.HTML.Lucid (HTML) @@ -47,10 +47,8 @@ import Server (JobStatus, Org (..), import Worker (Job (Job), linterThread) import Servant.API (Header) -import Servant.Client (BaseUrl (BaseUrl), - ClientM, Scheme (Http), - client, mkClientEnv, - runClientM) +import Servant.Client (ClientM, client, + mkClientEnv, runClientM) type family PolyEndpoint method format payload where PolyEndpoint Get format payload = Get format payload @@ -114,19 +112,19 @@ main = do -- TODO: what about tls / https? manager' <- newManager defaultManagerSettings - updater <- async $ forever $ do - done <- readMVar state - res <- runClientM - (postNewMaps (view token config) (MapService done)) - (mkClientEnv manager' (view exneuland config)) - print res - threadDelay (view interval config * 1000000) + -- updater <- async $ forever $ do + -- done <- readMVar state + -- res <- runClientM + -- (postNewMaps (view token config) (MapService done)) + -- (mkClientEnv manager' (view exneuland config)) + -- print res + -- threadDelay (view interval config * 1000000) -- spawns threads for each job in the queue linter <- async $ void $ linterThread config queue state link linter link poker - link updater + -- link updater let warpsettings = setPort (view port config) diff --git a/server/Server.hs b/server/Server.hs index 8f09ac7..f89dc7b 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -39,11 +39,12 @@ import qualified Data.ByteString.Base64.URL as Base64 import Data.Coerce (coerce) import Data.Either.Extra (mapLeft) import Data.Functor.Contravariant (contramap) -import qualified Data.Map as M +import qualified Data.Map.Strict as M import Lens.Micro.Platform (at, ix, makeLenses, traverseOf) import LintConfig (LintConfig') import Servant (FromHttpApiData) import Servant.Client (BaseUrl, parseBaseUrl) +import qualified Text.Show as TS import Toml (BiMap (BiMap), TomlBiMap, TomlBiMapError (ArbitraryError), TomlCodec, prettyTomlDecodeErrors, @@ -157,9 +158,15 @@ configCodec = Config -- | a job status (of a specific uuid) data JobStatus = - Pending | Linted DirResult Text | Failed Text + Pending | Linted !DirResult Text | Failed Text deriving (Generic, ToJSON) +instance TS.Show JobStatus where + show = \case + Pending -> "Pending" + Linted res rev -> "Linted result" + Failed err -> "Failed with: " <> show err + -- | the server's global state; might eventually end up with more -- stuff in here, hence the newtype newtype ServerState = ServerState @@ -192,8 +199,14 @@ loadConfig path = do -- | NOTE: this does not create the org if it does not yet exist! setJobStatus :: MVar ServerState -> Org True -> RemoteRef -> JobStatus -> IO () -setJobStatus mvar !org !ref !status = modifyMVar_ mvar - $ pure . over (unState . ix org . at (toSha ref)) (const $ Just (ref, status)) +setJobStatus mvar !org !ref !status = do + modifyMVar_ mvar $ \state -> do + -- will otherwise cause a thunk leak, since Data.Map is annoyingly un-strict + -- even in its strict variety. for some reason it also doesn't work when + -- moved inside the `over` though … + _ <- evaluateWHNF (view (unState . ix org) state) + pure $ over (unState . ix org . at (toSha ref)) + (const $ Just (ref, status)) state getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (RemoteRef, JobStatus)) getJobStatus mvar orgslug sha = withMVar mvar $ \state -> diff --git a/server/Worker.hs b/server/Worker.hs index 24a774b..b5d71fc 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -47,7 +47,7 @@ linterThread config queue done = forever $ do -- TODO: re-add proper fancy (colourful?) logging runJob :: Config True -> Job -> MVar ServerState -> IO () runJob config Job {..} done = do - rand <- liftIO UUID.nextRandom + rand <- UUID.nextRandom let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand) handle whoops @@ -64,7 +64,8 @@ runJob config Job {..} done = do rev <- map T.strip -- git returns a newline here $ readgit' gitdir ["rev-parse", toString ref] callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ] - res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg) + + res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg) setJobStatus done jobOrg jobRef $ Linted res rev |