diff options
Diffstat (limited to 'server/Worker.hs')
| -rw-r--r-- | server/Worker.hs | 53 |
1 files changed, 30 insertions, 23 deletions
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 |