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