summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-rw-r--r--server/Main.hs18
-rw-r--r--server/Server.hs17
-rw-r--r--server/Worker.hs53
3 files changed, 56 insertions, 32 deletions
diff --git a/server/Main.hs b/server/Main.hs
index 60098b6..6806ee7 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,6 +1,9 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -39,7 +42,8 @@ import Servant (Application, Capture,
type (:>))
import Servant.HTML.Lucid (HTML)
import Servant.Server.StaticFiles (serveDirectoryWebApp)
-import Server (JobStatus, Org (..),
+import Server (CliOptions (..),
+ JobStatus, Org (..),
ServerState, Sha1,
emptyState, exneuland,
interval, loadConfig,
@@ -53,6 +57,8 @@ import Servant.API (Header)
import Servant.API.WebSocket (WebSocketPending)
import Servant.Client (ClientM, client,
mkClientEnv, runClientM)
+import Universum.Bool.Reexport (Bool)
+import WithCli (HasArguments, withCli)
type family PolyEndpoint method format payload where
PolyEndpoint Get format payload =
@@ -97,9 +103,11 @@ app queue = serve (Proxy @Routes) . server queue
postNewMaps :: Maybe Text -> MapService -> ClientM Text
postNewMaps = client (Proxy @(MapServiceAPI Post))
+
+
main :: IO ()
-main = do
- config <- loadConfig "./config.toml"
+main = withCli $ \CliOptions {..} -> do
+ config <- loadConfig (fromMaybe "./config.toml" config)
state <- newMVar (emptyState config)
queue :: TQueue Job <- newTQueueIO
loggerMiddleware <- mkRequestLogger
@@ -117,7 +125,7 @@ main = do
threadDelay (view interval config * 1000000)
-- TODO: what about tls / https?
- whenJust (view exneuland config) $ \baseurl -> do
+ unless offline $ whenJust (view exneuland config) $ \baseurl -> do
manager' <- newManager defaultManagerSettings
updater <- async $ runStdoutLoggingT $ forever $ do
done <- readMVar state
@@ -129,7 +137,7 @@ main = do
link updater
-- spawns threads for each job in the queue
- linter <- async $ void $ linterThread config queue state
+ linter <- async $ void $ linterThread offline config queue state
link linter
link poker
diff --git a/server/Server.hs b/server/Server.hs
index 3d783d7..3081997 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -24,6 +24,8 @@ module Server ( loadConfig
, Org(..)
, Sha1, toSha
, Config, tmpdir, port, verbose, orgs, interval, exneuland, token
+ , CliOptions(..)
+ , OfflineException
, RemoteRef(..)
, ServerState, emptyState, unState
, JobStatus(..)
@@ -57,6 +59,7 @@ import Toml (BiMap (BiMap), TomlBiMap,
TomlCodec,
prettyTomlDecodeErrors, (.=))
import qualified Toml as T
+import WithCli (HasArguments)
-- | a reference in a remote git repository
data RemoteRef = RemoteRef
@@ -134,6 +137,13 @@ data Config (loaded :: Bool) = Config
makeLenses ''Config
+data CliOptions = CliOptions
+ { offline :: Bool
+ , config :: Maybe FilePath
+ } deriving (Show, Generic, HasArguments)
+
+data OfflineException = OfflineException
+ deriving (Show, Exception)
remoteCodec :: TomlCodec RemoteRef
remoteCodec = RemoteRef
@@ -157,6 +167,7 @@ urlBimap = BiMap
(Right . show)
(mapLeft (ArbitraryError . show) . parseBaseUrl)
+
configCodec :: TomlCodec (Config False)
configCodec = Config
<$> T.string "tmpdir" .= _tmpdir
@@ -171,7 +182,7 @@ configCodec = Config
-- | loads a config, along with all things linked in it
-- (e.g. linterconfigs for each org)
loadConfig :: FilePath -> IO (Config True)
-loadConfig path = do
+loadConfig path = do
res <- T.decodeFileEither configCodec path
case res of
Right config -> traverseOf orgs (mapM loadOrg) config
@@ -183,10 +194,8 @@ loadConfig path = do
eitherDecodeFileStrict' orgLintconfig >>= \case
Right (c :: LintConfig Basic) -> pure c
Left err -> error $ show err
- let config = org { orgLintconfig =
+ pure $ org { orgLintconfig =
feedConfig lintconfig (map reponame orgRepos) orgSlug }
- print config
- pure config
data RealtimeMsg = RelintPending | Reload
deriving (Generic, ToJSON)
diff --git a/server/Worker.hs b/server/Worker.hs
index 57b5b9f..31ddcdc 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -5,23 +5,25 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
module Worker (linterThread, Job(..)) where
import Universum
import CheckDir (recursiveCheckDir,
- shrinkDirResult, resultIsFatal)
+ resultIsFatal, shrinkDirResult)
import Control.Concurrent.Async (async, link)
import Control.Concurrent.STM (writeTChan)
import Control.Concurrent.STM.TQueue
-import Control.Exception (IOException, handle)
+import Control.Exception (IOException, handle, throw)
import Control.Monad.Logger (logError, logErrorN, logInfoN,
runStdoutLoggingT)
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Fmt ((+|), (|+))
+import GHC.IO.Exception (ioException)
import LintConfig (stuffConfig)
import Server (Config, JobStatus (..),
Org (..),
@@ -29,7 +31,7 @@ import Server (Config, JobStatus (..),
RemoteRef (..), ServerState,
adjustedPath,
newRealtimeChannel,
- tmpdir, overJobStatus)
+ overJobStatus, tmpdir)
import System.Directory (doesDirectoryExist)
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import System.FilePath ((</>))
@@ -41,11 +43,11 @@ data Job = Job
, jobOrg :: Org True
}
-linterThread :: Config True -> TQueue Job -> MVar ServerState -> IO Void
-linterThread config queue done = forever $ do
+linterThread :: Bool -> Config True -> TQueue Job -> MVar ServerState -> IO Void
+linterThread offline config queue done = forever $ do
next <- atomically (readTQueue queue)
-- TODO: this doesn't guard against two jobs running on the same repo!
- job <- async $ runJob config next done
+ job <- async $ runJob offline config next done
-- TODO: is this a good idea? will crash the server if a job thread fails
link job
@@ -55,8 +57,8 @@ linterThread config queue done = forever $ do
--
-- May occasionally be brittle (if someone else changed files)
-- TODO: re-add proper fancy (colourful?) logging
-runJob :: Config True -> Job -> MVar ServerState -> IO ()
-runJob config Job {..} done = do
+runJob :: Bool -> Config True -> Job -> MVar ServerState -> IO ()
+runJob offline config Job {..} done = do
rand <- UUID.nextRandom
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
@@ -64,11 +66,11 @@ runJob config Job {..} done = do
$ finally (lint workdir) (cleanup workdir)
where
lintConfig = stuffConfig (orgLintconfig jobOrg) (reponame jobRef)
- lint workdir = do
+ lint workdir = runStdoutLoggingT $ do
-- set the "is being linted" flag in the assembly's state
-- (to show on the site even after reloads etc.)
- oldstate <- overJobStatus done jobOrg jobRef $ \case
+ oldstate <- liftIO $ overJobStatus done jobOrg jobRef $ \case
Just (ref, Linted res rev (_, realtime), oldstatus) ->
Just (ref, Linted res rev (True, realtime), oldstatus)
a -> a
@@ -80,13 +82,18 @@ runJob config Job {..} done = do
pure (Just realtime)
_ -> pure Nothing
- ifM (doesDirectoryExist gitdir)
-- TODO: these calls fail for dumb http, add some fallback!
- (callgit gitdir
- [ "fetch", "origin", toString ref, "--depth", "1" ])
- (callProcess "git"
- [ "clone", toString url, "--bare"
- , "--depth", "1", "-b", toString ref, gitdir])
+ liftIO (doesDirectoryExist gitdir) >>= \case
+ False | offline -> logErrorN $ "offline mode but not cached; linting "
+ <> show gitdir <> " will fail"
+ | otherwise ->
+ (liftIO $ callProcess "git"
+ [ "clone", toString url, "--bare"
+ , "--depth", "1", "-b", toString ref, gitdir])
+ True | offline -> logInfoN $ "offline mode: not updating " <> show gitdir
+ | otherwise ->
+ (liftIO $ callgit gitdir
+ [ "fetch", "origin", toString ref, "--depth", "1" ])
rev <- map T.strip -- git returns a newline here
$ readgit' gitdir ["rev-parse", toString ref]
@@ -94,11 +101,11 @@ runJob config Job {..} done = do
callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
- res <- recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg)
+ res <- liftIO $ recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg)
>>= evaluateNF
- writeAdjustedRepository lintConfig workdir (toString outPath) res
- >>= runStdoutLoggingT . \case
+ liftIO (writeAdjustedRepository lintConfig workdir (toString outPath) res)
+ >>= \case
ExitSuccess ->
logInfoN $ "linted map "+| (show jobRef :: Text) |+"."
ExitFailure 1 ->
@@ -115,14 +122,14 @@ runJob config Job {..} done = do
atomically $ writeTChan realtime Reload
pure realtime
Nothing ->
- newRealtimeChannel
+ liftIO newRealtimeChannel
-- the fact that `realtime` can't be defined in here is horrifying
- void $ overJobStatus done jobOrg jobRef $ \maybeOld ->
+ void $ liftIO $ overJobStatus done jobOrg jobRef $ \maybeOld ->
let status = Linted (shrinkDirResult res) rev (False, realtime)
lastvalid = case maybeOld of
Just (_,_,lastvalid) -> lastvalid
- Nothing -> Nothing
+ Nothing -> Nothing
in Just ( jobRef
, status
, if resultIsFatal lintConfig res
@@ -136,7 +143,7 @@ runJob config Job {..} done = do
whoops (error :: IOException) = runStdoutLoggingT $ do
logErrorN (show error)
void $ liftIO $ overJobStatus done jobOrg jobRef $ \case
- Nothing -> Just (jobRef, Failed (show error), Nothing)
+ Nothing -> Just (jobRef, Failed (show error), Nothing)
Just (_,_,lastvalid) -> Just (jobRef, Failed (show error), lastvalid)
url = repourl jobRef
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 16:54:31 +0000