diff options
Diffstat (limited to '')
| -rw-r--r-- | server/Main.hs | 18 | ||||
| -rw-r--r-- | server/Server.hs | 17 | ||||
| -rw-r--r-- | server/Worker.hs | 53 |
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 |