diff --git a/config.toml b/config.toml
index 3886597dc8ff3276bbbc3146c67d78d23a1e68c9..1c8825ba73a23600e76650674cec3374c0a8b9e2 100644
--- a/config.toml
+++ b/config.toml
@@ -5,6 +5,8 @@ verbose = true
tmpdir = "/tmp"
+# linting interval in seconds
+interval = 30
[[org]]
slug = "divoc"
diff --git a/package.yaml b/package.yaml
index 7dacce8bd523fa538c99bff1c42c3c4b161f5f6b..2265b4ee36f8c7e93e163569dc5d4a2ab4ec242a 100644
--- a/package.yaml
+++ b/package.yaml
@@ -74,8 +74,13 @@ executables:
- cli-git
- cli-extras
- extra
- - uuid
- microlens
- microlens-th
+ - fmt
- tomland
- dotgen
+ - stm
+ - async
+ - cryptohash-sha1
+ - uuid
+ - base64-bytestring
diff --git a/server/Handlers.hs b/server/Handlers.hs
index afbb2b9b96d2c976b5a708c051366c6707b971ab..cb714d938080cb9388e84ba348d1af410f401f63 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -1,47 +1,28 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-module Handlers (App
+module Handlers (
-- , submitImpl
- , statusImpl
+ statusImpl
-- , relintImpl
, adminOverviewImpl
+ , AdminOverview(..)
) where
import Universum
-import Bindings.Cli.Git (gitProc)
-import CheckDir (recursiveCheckDir)
-import Cli.Extras (CliConfig, CliT, ProcessFailure,
- Severity (..),
- callProcessAndLogOutput, getCliConfig,
- prettyProcessFailure, runCli)
-import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.MVar (withMVar)
+import Data.Aeson (ToJSON (..), (.=))
+import qualified Data.Aeson as A
import qualified Data.Map as M
-import qualified Data.Text as T
-import Data.UUID (UUID)
-import qualified Data.UUID as UUID
-import qualified Data.UUID.V4 as UUID
-import Servant (Handler, NoContent (NoContent),
- err404, err500, throwError)
-import Server (AdminOverview (AdminOverview),
- Config, orgs, tmpdir,
- JobStatus (..),
- RemoteRef (reporef, repourl),
- ServerState, jobs, registry,
- setJobStatus, setRegistry, Org (..))
-import System.Directory (doesDirectoryExist)
-import System.FilePath ((</>))
-
--- | this servant app can run cli programs!
-type App = CliT ProcessFailure Handler
+import Servant (Handler, err404, throwError)
+import Server (JobStatus (..), ServerState, Sha1,
+ unState)
-- | annoying (and afaik unused), but has to be here for type system reasons
-instance MonadFail Handler where
- fail _ = throwError err500
+-- instance MonadFail Handler where
+-- fail _ = throwError err500
-- -- | someone submitted a map; lint it (synchronously for now)
-- submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID
@@ -66,48 +47,28 @@ instance MonadFail Handler where
-- _ <- checkRef config cliconfig state ref
-- pure NoContent
-statusImpl :: MVar ServerState -> UUID -> App JobStatus
-statusImpl state uuid = do
+-- | an info type wrapped around the server state, to carry serialisation instances.
+-- TODO: should probably not be defined here
+newtype AdminOverview =
+ AdminOverview { unAdminOverview :: ServerState }
+
+instance ToJSON AdminOverview where
+ toJSON (AdminOverview state) =
+ toJSON $ view unState state <&> \(ref, status) ->
+ A.object [ "remote" .= ref
+ , "status" .= status
+ ]
+
+statusImpl :: MVar ServerState -> Sha1 -> Handler JobStatus
+statusImpl state sha1 = do
status <- liftIO $ withMVar state $ \state ->
- case M.lookup uuid (view registry state) of
- Nothing -> pure Nothing
- Just ref -> pure $ M.lookup ref (view jobs state)
+ pure $ M.lookup sha1 (map snd $ view unState state)
case status of
Just res -> pure res
- Nothing -> lift $ throwError err404
+ Nothing -> throwError err404
-adminOverviewImpl :: MVar ServerState -> App AdminOverview
+adminOverviewImpl :: MVar ServerState -> Handler AdminOverview
adminOverviewImpl state = do
state <- readMVar state
pure (AdminOverview state)
-
--- | the actual check function. forks, calls out to git to update the
--- repository, create a new worktree, lints it, then tells git to
--- delete that tree again
-checkRef :: Config True -> Org True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId
-checkRef config org cliconfig state ref = liftIO $ forkIO $ do
- res <- liftIO $ runCli cliconfig $ do
- ifM (liftIO $ doesDirectoryExist gitdir)
- -- TODO: these calls fail for dumb http, add some fallback!
- (callgit gitdir
- [ "fetch", "origin", toString (reporef ref), "--depth", "1" ])
- (callgit gitdir
- [ "clone", toString $ repourl ref, "--bare"
- , "--depth", "1", "-b", toString (reporef ref)])
- rand <- liftIO UUID.nextRandom
- let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
- callgit gitdir [ "worktree", "add", workdir ]
- callgit workdir [ "checkout", toString (reporef ref) ]
- res <- liftIO $ recursiveCheckDir (orgLintconfig org) workdir (orgEntrypoint org)
- callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
- pure res
- liftIO $ setJobStatus state ref $ case res of
- Right res -> Linted res
- Left err -> Failed (prettyProcessFailure err)
- where
- callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
- gitdir = view tmpdir config </> toString hashedname
- hashedname = T.map escapeSlash . repourl $ ref
- escapeSlash = \case { '/' -> '-'; a -> a }
-
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index 4d0323481f0b19ff5f600fbe5293b06b45b63f23..8b2df52fb486c1164aebc70d9ac9b1a0a31c521f 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -19,18 +19,21 @@ import CheckDir (DirResult (..), MissingAsset (MissingAsset),
import CheckMap (MapResult (..))
import Data.List.Extra (escapeJSON)
import qualified Data.Map as M
+import Handlers (AdminOverview (..))
import Lucid (HtmlT, ToHtml)
import Lucid.Base (ToHtml (toHtml))
import Lucid.Html5 (a_, body_, class_, code_, div_, em_, h1_, h2_,
h3_, h4_, h5_, head_, href_, html_, id_, li_,
link_, main_, p_, rel_, script_, span_, src_,
title_, type_, ul_)
-import Server (AdminOverview (..), JobStatus (..),
- RemoteRef (reporef, repourl), jobs, registry)
+import Server (JobStatus (..), RemoteRef (reporef, repourl),
+ prettySha, unState)
import Text.Dot (showDot)
import Types (Hint (Hint), Level (..))
+import Fmt
+
mono :: Monad m => HtmlT m () -> HtmlT m ()
mono = code_ [class_ "small text-muted"]
@@ -59,16 +62,15 @@ instance ToHtml JobStatus where
instance ToHtml AdminOverview where
toHtml (AdminOverview state) = htmldoc $ do
h1_ "Map List"
- if null (view registry state)
+ if null (view unState state)
then em_ "(nothing yet)"
- else ul_ . flip M.foldMapWithKey (view registry state)
- $ \uuid ref -> li_ $ do
- case M.lookup ref (view jobs state) of
- Just Pending -> badge Info "pending"
- Just (Linted res) -> toHtml $ maximumLintLevel res
- Just (Failed _) -> badge Error "system error"
- Nothing -> toHtml Fatal
- " "; a_ [href_ ("/status/"<>show uuid)] $ do
+ else ul_ . flip M.foldMapWithKey (view unState state) $
+ \sha1 (ref, status) -> li_ $ do
+ case status of
+ Pending -> badge Info "pending"
+ (Linted res) -> toHtml $ maximumLintLevel res
+ (Failed _) -> badge Error "system error"
+ " "; a_ [href_ ("/status/"+|prettySha sha1|+"/")] $ do
mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref
diff --git a/server/Main.hs b/server/Main.hs
index 04a201067bf419e2d51a08fb4d2dc7b73e1a2278..02f7ed31facf1577eab8f11d53325b81c99dac01 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
-- | simple server offering linting "as a service"
@@ -11,14 +12,16 @@ module Main where
import Universum
-import Cli.Extras (CliConfig,
- mkDefaultCliConfig,
- runCli)
-import qualified Data.ByteString.Lazy.Char8 as C8
-import Data.UUID (UUID)
-import Handlers (App, adminOverviewImpl,
- statusImpl,
- )
+import Cli.Extras (mkDefaultCliConfig)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (async, waitEither_)
+import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO,
+ writeTQueue)
+import qualified Data.Text as T
+import Fmt ((+|), (|+))
+import Handlers (AdminOverview,
+ adminOverviewImpl,
+ statusImpl)
import HtmlOrphans ()
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort)
@@ -27,78 +30,68 @@ import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
RequestLoggerSettings (..),
mkRequestLogger)
import Servant (Application, Capture,
- Get, Handler,
- HasServer (ServerT),
- JSON, NoContent, Post,
- Raw, ReqBody,
- ServerError (errBody),
- err500, hoistServer,
- serve, throwError,
- type (:<|>) (..),
+ Get, JSON, Raw, Server,
+ serve, type (:<|>) (..),
type (:>))
import Servant.HTML.Lucid (HTML)
import Servant.Server.StaticFiles (serveDirectoryWebApp)
-import Server (AdminOverview,
- Config (..), JobStatus,
- RemoteRef (..),
- ServerState,
- defaultState, loadConfig, verbose, port, orgs, Org (orgEntrypoint, orgRepos))
+import Server (JobStatus, Org (..),
+ ServerState, Sha1,
+ defaultState, interval,
+ loadConfig, orgs, port,
+ verbose)
+import Worker (Job (Job), linterThread)
-- | Main API type
type API format =
-- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
- "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
+ "status" :> Capture "jobid" Sha1 :> Get '[format] JobStatus
-- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
:<|> "admin" :> "overview" :> Get '[format] AdminOverview
-type Routes =
- "api" :> API JSON
- :<|> "status" :> Capture "jobid" UUID :> Get '[HTML] JobStatus
- :<|> "admin" :> "overview" :> Get '[HTML] AdminOverview
- :<|> Raw
+type Routes = "api" :> API JSON
+ :<|> API HTML -- websites mirror the API exactly
+ :<|> Raw
-- | API's implementation
-jsonAPI :: Config True -> MVar ServerState -> ServerT (API JSON) App
-jsonAPI config state =
- -- submitImpl config state
- statusImpl state
- -- :<|> relintImpl config state
- :<|> adminOverviewImpl state
-
-server :: Config True -> MVar ServerState -> ServerT Routes App
-server config state =
- jsonAPI config state
- :<|> statusImpl state
- :<|> adminOverviewImpl state
- :<|> serveDirectoryWebApp "./static"
-
--- | make an application; convert any cli errors into a 500
-app :: CliConfig -> Config True -> MVar ServerState -> Application
-app cliconfig config =
- serve api . hoistServer api conv . server config
- where api = Proxy @Routes
- conv :: App a -> Handler a
- conv m = do
- res <- runCli cliconfig m
- case res of
- Right a -> pure a
- Left err -> throwError (err500 { errBody = C8.pack (show err) })
+jsonAPI :: forall format. MVar ServerState -> Server (API format)
+jsonAPI state = statusImpl state
+ :<|> adminOverviewImpl state
+-- | Complete set of routes: API + HTML sites
+server :: MVar ServerState -> Server Routes
+server state = jsonAPI @JSON state
+ :<|> jsonAPI @HTML state
+ :<|> serveDirectoryWebApp "./static"
+
+app :: MVar ServerState -> Application
+app = serve (Proxy @Routes) . server
main :: IO ()
main = do
config <- loadConfig "./config.toml"
state <- newMVar defaultState
+ 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) }
- -- print (keys $ view orgs config)
- print (map orgEntrypoint $ view orgs config)
- print (map orgRepos $ view orgs config)
+ putTextLn "reading config …"
+ putTextLn $ T.concat $ map showInfo (view orgs config)
+
+ -- periodically ‘pokes’ jobs to re-lint each repo
+ poker <- async $ forever $ do
+ atomically $ forM_ (view orgs config) $ \org ->
+ forM_ (orgRepos org) $ \repo ->
+ writeTQueue queue (Job repo org)
+ -- microseconds for some reason
+ threadDelay (view interval config * 1000000)
+
+ -- spawns threads for each job in the queue
+ linter <- async $ void $ linterThread config cliconfig queue state
let warpsettings =
setPort (view port config)
@@ -106,4 +99,9 @@ main = do
runSettings warpsettings
. loggerMiddleware
- $ app cliconfig config state
+ $ app state
+
+ waitEither_ linter poker
+ where
+ showInfo org =
+ "→ org "+|orgSlug org|+" divoc ("+|length (orgRepos org)|+" repositoryies)\n" :: Text
diff --git a/server/Server.hs b/server/Server.hs
index bdfa77f748f39f399142590af4c1d2c300adc3a4..e392f898ed98589bc05dd371f2f7d5e946df9782 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -5,39 +5,40 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE LambdaCase #-}
module Server ( loadConfig
, Org(..)
- , Config, tmpdir, port, verbose, orgs
+ , Sha1
+ , Config, tmpdir, port, verbose, orgs, interval
, RemoteRef(..)
- , ServerState, registry, jobs, defaultState
+ , ServerState, defaultState, unState
, JobStatus(..)
, setJobStatus
- , setRegistry
- , AdminOverview(..)
- ) where
+ , prettySha) where
import Universum
-import CheckDir (DirResult)
-import Control.Concurrent (modifyMVar_)
-import Data.Aeson (FromJSON, ToJSON (toJSON),
- (.=), eitherDecodeFileStrict')
-import qualified Data.Aeson as A
-import qualified Data.Map as M
-import Data.UUID (UUID)
-import Lens.Micro (traverseOf)
+import CheckDir (DirResult)
+import Control.Concurrent (modifyMVar_)
+import Crypto.Hash.SHA1
+import Data.Aeson (FromJSON, ToJSON, ToJSONKey (..),
+ eitherDecodeFileStrict')
+import qualified Data.ByteString.Base64.URL as Base64
+import qualified Data.Map as M
+import Lens.Micro (traverseOf)
import Lens.Micro.TH
-import LintConfig (LintConfig')
-import Toml (TomlCodec, prettyTomlDecodeErrors)
-import qualified Toml as T
+import LintConfig (LintConfig')
+import Servant (FromHttpApiData)
+import Toml (TomlCodec, prettyTomlDecodeErrors,
+ (.=))
+import qualified Toml as T
-- | a reference in a remote git repository
data RemoteRef = RemoteRef
@@ -49,23 +50,35 @@ type family ConfigRes (b :: Bool) a where
ConfigRes True a = a
ConfigRes False a = FilePath
+newtype Sha1 = Sha1 Text
+ deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON)
+
+-- | base64-encoded sha1
+prettySha :: Sha1 -> Text
+prettySha (Sha1 text) = text
+
+instance ToJSONKey Sha1
+
+toSha :: RemoteRef -> Sha1
+toSha ref = Sha1 . decodeUtf8 . Base64.encode . hash . encodeUtf8 $ (show ref :: Text)
data Org (loaded :: Bool) = Org
- { orgSlug :: Text
+ { orgSlug :: Text
, orgLintconfig :: ConfigRes loaded LintConfig'
, orgEntrypoint :: FilePath
- , orgRepos :: [RemoteRef]
+ , orgRepos :: [RemoteRef]
}
-- | the server's configuration
data Config (loaded :: Bool) = Config
- { _tmpdir :: FilePath
+ { _tmpdir :: FilePath
-- ^ dir to clone git things in
- , _port :: Int
- , _verbose :: Bool
+ , _port :: Int
+ , _verbose :: Bool
+ , _interval :: Int
-- ^ port to bind to
- , _orgs :: [Org loaded]
+ , _orgs :: [Org loaded]
} deriving Generic
makeLenses ''Config
@@ -73,71 +86,57 @@ makeLenses ''Config
remoteCodec :: TomlCodec RemoteRef
remoteCodec = RemoteRef
- <$> T.text "url" T..= repourl
- <*> T.text "ref" T..= reporef
+ <$> T.text "url" .= repourl
+ <*> T.text "ref" .= reporef
orgCodec :: TomlCodec (Org False)
orgCodec = Org
- <$> T.text "slug" T..= orgSlug
- <*> T.string "lintconfig" T..= orgLintconfig
- <*> T.string "entrypoint" T..= orgEntrypoint
- <*> T.list remoteCodec "repo" T..= orgRepos
+ <$> T.text "slug" .= orgSlug
+ <*> T.string "lintconfig" .= orgLintconfig
+ <*> T.string "entrypoint" .= orgEntrypoint
+ <*> T.list remoteCodec "repo" .= orgRepos
configCodec :: TomlCodec (Config False)
configCodec = Config
- <$> T.string "tmpdir" T..= _tmpdir
- <*> T.int "port" T..= _port
- <*> T.bool "verbose" T..= _verbose
- <*> T.list orgCodec "org" T..= _orgs
+ <$> T.string "tmpdir" .= _tmpdir
+ <*> T.int "port" .= _port
+ <*> T.bool "verbose" .= _verbose
+ <*> T.int "interval" .= _interval
+ <*> T.list orgCodec "org" .= _orgs
-- | a job status (of a specific uuid)
data JobStatus =
Pending | Linted DirResult | Failed Text
deriving (Generic, ToJSON)
--- | the server's global state
-data ServerState = ServerState
- { _jobs :: Map RemoteRef JobStatus
- , _registry :: Map UUID RemoteRef
- }
+-- | the server's global state; might eventually end up with more
+-- stuff in here, hence the newtype
+newtype ServerState = ServerState
+ { _unState :: Map Sha1 (RemoteRef, JobStatus) }
+
makeLenses ''ServerState
defaultState :: ServerState
-defaultState = ServerState mempty mempty
-
--- | an info type wrapped around the server state, to carry serialisation instances.
--- TODO: should probably not be defined here
-newtype AdminOverview =
- AdminOverview { unAdminOverview :: ServerState }
-
-instance ToJSON AdminOverview where
- toJSON (AdminOverview state) =
- toJSON . flip M.mapWithKey (view registry state) $ \uuid ref ->
- A.object [ "reference" .= uuid
- , "remote" .= ref
- , "status" .= M.lookup ref (view jobs state)
- ]
+defaultState = ServerState mempty
+-- | loads a config, along with all things linked in it
+-- (e.g. linterconfigs for each org)
loadConfig :: FilePath -> IO (Config True)
loadConfig path = do
res <- T.decodeFileEither configCodec path
case res of
Right config -> traverseOf orgs (mapM loadOrg) config
- Left err -> error $ prettyTomlDecodeErrors err
+ Left err -> error $ prettyTomlDecodeErrors err
where
loadOrg :: Org False -> IO (Org True)
loadOrg org = do
lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
- Right c -> pure c
+ Right c -> pure c
Left err -> error $ show err
pure $ org { orgLintconfig = lintconfig }
setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO ()
setJobStatus mvar !ref !status = modifyMVar_ mvar
- $ pure . over jobs (M.insert ref status)
-
-setRegistry :: MVar ServerState -> UUID -> RemoteRef -> IO ()
-setRegistry mvar !uuid !ref = modifyMVar_ mvar
- $ pure . over registry (M.insert uuid ref)
+ $ pure . over unState (M.insert (toSha ref) (ref, status))
diff --git a/server/Worker.hs b/server/Worker.hs
new file mode 100644
index 0000000000000000000000000000000000000000..7609d48c2eb9494b65a07900500112a6d8eb5fb7
--- /dev/null
+++ b/server/Worker.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Worker (linterThread, Job(..)) where
+
+import Universum
+
+import Bindings.Cli.Git (gitProc)
+import CheckDir (recursiveCheckDir)
+import Cli.Extras (CliConfig, ProcessFailure,
+ Severity (..),
+ callProcessAndLogOutput,
+ prettyProcessFailure, runCli)
+import Control.Concurrent.Async (async, link)
+import Control.Concurrent.STM.TQueue
+import qualified Data.Text as T
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+import Server (Config, JobStatus (..),
+ Org (..),
+ RemoteRef (reporef, repourl),
+ ServerState, setJobStatus,
+ tmpdir)
+import System.Directory (doesDirectoryExist)
+import System.FilePath ((</>))
+
+
+
+data Job = Job
+ { jobRef :: RemoteRef
+ , jobOrg :: Org True
+ }
+
+linterThread :: Config True -> CliConfig -> TQueue Job -> MVar ServerState -> IO Void
+linterThread config cliconfig 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
+
+-- | the actual check function. forks, 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)
+ -- TODO: these calls fail for dumb http, add some fallback!
+ (callgit gitdir
+ [ "fetch", "origin", toString ref, "--depth", "1" ])
+ (callgit gitdir
+ [ "clone", toString ref, "--bare"
+ , "--depth", "1", "-b", toString ref])
+ rand <- liftIO UUID.nextRandom
+ let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
+ callgit gitdir [ "worktree", "add", workdir ]
+ callgit workdir [ "checkout", toString ref ]
+ res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
+ callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
+ pure res
+ liftIO $ setJobStatus done jobRef $ case res of
+ Right res -> Linted res
+ Left err -> Failed (prettyProcessFailure err)
+ where
+ url = repourl jobRef
+ ref = reporef jobRef
+ callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
+ gitdir = view tmpdir config </> toString hashedname
+ hashedname = T.map escapeSlash url
+ where escapeSlash = \case { '/' -> '-'; a -> a }
diff --git a/walint.cabal b/walint.cabal
index a00fb6e8a9ebdbe2b6918a7fc0640dd2039953c2..80c23ba4477d7b6d808d263e36f501074a8e9bf3 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -84,6 +84,7 @@ executable walint-server
Handlers
HtmlOrphans
Server
+ Worker
Paths_walint
hs-source-dirs:
server
@@ -92,16 +93,20 @@ executable walint-server
ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
build-depends:
aeson
+ , async
, base
, base-compat
+ , base64-bytestring
, bytestring
, cli-extras
, cli-git
, containers
+ , cryptohash-sha1
, directory
, dotgen
, extra
, filepath
+ , fmt
, http-types
, lucid
, microlens
@@ -110,6 +115,7 @@ executable walint-server
, servant
, servant-lucid
, servant-server
+ , stm
, text
, time
, tomland