server: repositores & orgs fixed in config

a very simple setup that might be usable for divoc and similar small events

8 files changed, 245 insertions, 199 deletions

diff --git a/config.toml b/config.toml
index 3886597..1c8825b 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 7dacce8..2265b4e 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 afbb2b9..cb714d9 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 4d03234..8b2df52 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 04a2010..02f7ed3 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 bdfa77f..e392f89 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 0000000..7609d48
--- /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 a00fb6e..80c23ba 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