{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} module Worker (linterThread, Job(..)) where import Universum import CheckDir (recursiveCheckDir, 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.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 LintConfig (stuffConfig) import Server (Config, JobStatus (..), Org (..), RealtimeMsg (RelintPending, Reload), RemoteRef (..), ServerState, adjustedPath, newRealtimeChannel, overJobStatus, tmpdir) import System.Directory (doesDirectoryExist) import System.Exit (ExitCode (ExitFailure, ExitSuccess)) import System.FilePath (()) import System.Process import WriteRepo (writeAdjustedRepository) data Job = Job { jobRef :: RemoteRef , jobOrg :: Org True } 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 offline config next done -- TODO: is this a good idea? will crash the server if a job thread fails link job -- | the actual check function. Calls out to git to update the -- repository, create a new worktree, lints it, then tells git to -- delete that tree again. -- -- May occasionally be brittle (if someone else changed files) -- TODO: re-add proper fancy (colourful?) logging runJob :: Bool -> Config True -> Job -> MVar ServerState -> IO () runJob offline config Job {..} done = do rand <- UUID.nextRandom let workdir = "/tmp" ("worktree-" <> UUID.toString rand) handle whoops $ finally (lint workdir) (cleanup workdir) where lintConfig = stuffConfig (orgLintconfig jobOrg) (reponame jobRef) 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 <- liftIO $ overJobStatus done jobOrg jobRef $ \case Just (ref, Linted res rev (_, realtime), oldstatus) -> Just (ref, Linted res rev (True, realtime), oldstatus) a -> a -- send an update message to all connected websocket clients maybeRealtime <- case oldstate of Just (_, Linted _ _ (_, realtime), _) -> do atomically $ writeTChan realtime RelintPending pure (Just realtime) _ -> pure Nothing -- TODO: these calls fail for dumb http, add some fallback! 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 <> ":" <> ref) ]) rev <- map T.strip -- git returns a newline here $ readgit' gitdir ["rev-parse", toString ref] let outPath = adjustedPath rev jobOrg let humanOutPath = orgHumanWebdir jobOrg <> "/" <> reponame jobRef callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ] res <- liftIO $ recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg) >>= evaluateNF liftIO (writeAdjustedRepository lintConfig workdir (toString outPath) res) >>= \case ExitSuccess -> do logInfoN $ "linted map "+| (show jobRef :: Text) |+"." logInfoN $ "symlinking"+|outPath|+"into human web dir at"+|humanOutPath|+"" liftIO $ callProcess "ln" [ "-sfn", toString outPath, toString humanOutPath ] ExitFailure 1 -> logInfoN $ "linted map "+| (show jobRef :: Text) |+ ", which failed." ExitFailure 2 -> do -- TODO: shouldn't have linted this map at all logErrorN $ "outpath "+|outPath|+" already exists!" logInfoN $ "symlinking"+|outPath|+"into human web dir at"+|humanOutPath|+"" liftIO $ callProcess "ln" [ "-sfn", toString outPath, toString humanOutPath ] ExitFailure _ -> -- writeAdjustedRepository does not return other codes $(logError) "wtf, this is impossible" realtime <- case maybeRealtime of Just realtime -> do atomically $ writeTChan realtime Reload pure realtime Nothing -> liftIO newRealtimeChannel -- the fact that `realtime` can't be defined in here is horrifying void $ liftIO $ overJobStatus done jobOrg jobRef $ \maybeOld -> let status = Linted (shrinkDirResult res) rev (False, realtime) lastvalid = case maybeOld of Just (_,_,lastvalid) -> lastvalid Nothing -> Nothing in Just ( jobRef , status , if resultIsFatal lintConfig res then lastvalid else Just status ) cleanup workdir = do callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ] whoops (error :: IOException) = runStdoutLoggingT $ do logErrorN (show error) void $ liftIO $ overJobStatus done jobOrg jobRef $ \case Nothing -> Just (jobRef, Failed (show error), Nothing) Just (_,_,lastvalid) -> Just (jobRef, Failed (show error), lastvalid) url = repourl jobRef ref = reporef jobRef gitdir = view tmpdir config toString hashedname hashedname = T.map escapeSlash url where escapeSlash = \case { '/' -> '-'; a -> a } readgit' :: MonadIO m => FilePath -> [String] -> m Text readgit' dir args = map toText $ liftIO $ do print args readProcess "git" ([ "-C", toString dir ] <> args) "" callgit :: MonadIO m => FilePath -> [String] -> m () callgit dir args = liftIO $ do print args callProcess "git" ([ "-C", toString dir ] <> args)