diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Main.hs | 8 | ||||
| -rw-r--r-- | server/Worker.hs | 86 |
2 files changed, 56 insertions, 38 deletions
diff --git a/server/Main.hs b/server/Main.hs index 8b41c92..660b69e 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -12,9 +12,8 @@ module Main where import Universum -import Cli.Extras (mkDefaultCliConfig) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (async, waitEither_) +import Control.Concurrent.Async (async, link, waitEither_) import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue) import qualified Data.Text as T @@ -81,7 +80,6 @@ main = do queue :: TQueue Job <- newTQueueIO -- TODO: i really don't like all this cli logging stuff, replace it with -- fast-logger at some point … - cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | view verbose config] loggerMiddleware <- mkRequestLogger $ def { outputFormat = Detailed (view verbose config) } @@ -99,7 +97,9 @@ main = do threadDelay (view interval config * 1000000) -- spawns threads for each job in the queue - linter <- async $ void $ linterThread config cliconfig queue state + linter <- async $ void $ linterThread config queue state + link linter + link poker let warpsettings = setPort (view port config) diff --git a/server/Worker.hs b/server/Worker.hs index 40a267b..24a774b 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -1,22 +1,18 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Worker (linterThread, Job(..)) where import Universum -import Bindings.Cli.Git (gitProc) import CheckDir (recursiveCheckDir) -import Cli.Extras (CliConfig, ProcessFailure, - Severity (..), - callProcessAndLogOutput, - prettyProcessFailure, - readProcessAndLogStderr, runCli) import Control.Concurrent.Async (async, link) import Control.Concurrent.STM.TQueue +import Control.Exception (IOException, handle) import qualified Data.Text as T import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID @@ -27,7 +23,7 @@ import Server (Config, JobStatus (..), tmpdir) import System.Directory (doesDirectoryExist) import System.FilePath ((</>)) - +import System.Process data Job = Job @@ -35,20 +31,30 @@ data Job = Job , jobOrg :: Org True } -linterThread :: Config True -> CliConfig -> TQueue Job -> MVar ServerState -> IO Void -linterThread config cliconfig queue done = forever $ do +linterThread :: Config True -> TQueue Job -> MVar ServerState -> IO Void +linterThread 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 cliconfig done - link job -- TODO: is this a good idea? will crash the server if a job fails + job <- async $ runJob config next done + -- TODO: is this a good idea? will crash the server if a job thread fails + link job --- | the actual check function. forks, calls out to git to update the +-- | 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 -runJob :: Config True -> Job -> CliConfig -> MVar ServerState -> IO (Either ProcessFailure ()) -runJob config Job {..} cliconfig done = runCli cliconfig $ do - res <- liftIO $ runCli cliconfig $ do - ifM (liftIO $ doesDirectoryExist gitdir) +-- delete that tree again. +-- +-- 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 + rand <- liftIO UUID.nextRandom + let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand) + + handle whoops + $ finally (lint workdir) (cleanup workdir) + where + lint workdir = do + ifM (doesDirectoryExist gitdir) -- TODO: these calls fail for dumb http, add some fallback! (callgit gitdir [ "fetch", "origin", toString ref, "--depth", "1" ]) @@ -56,22 +62,34 @@ runJob config Job {..} cliconfig done = runCli cliconfig $ do [ "clone", toString ref, "--bare" , "--depth", "1", "-b", toString ref]) rev <- map T.strip -- git returns a newline here - $ readProcessAndLogStderr Error - $ gitProc gitdir ["rev-parse", toString ref] - rand <- liftIO UUID.nextRandom - let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand) - callgit gitdir [ "worktree", "add", workdir ] - callgit workdir [ "checkout", toString ref ] + $ readgit' gitdir ["rev-parse", toString ref] + callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ] res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg) + setJobStatus done jobOrg jobRef $ + Linted res rev + + cleanup workdir = do callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ] - pure (res, rev) - liftIO $ setJobStatus done jobOrg jobRef $ case res of - Right thing -> uncurry Linted thing - Left err -> Failed (prettyProcessFailure err) - where + + whoops (error :: IOException) = do + -- TODO: should also log this error + setJobStatus done jobOrg jobRef $ Failed (show error) + url = repourl jobRef ref = reporef jobRef - callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir + callgit = callgit' 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) |