From 662a01a74a13979830dacf1dc8c18161040f32cc Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 16 Feb 2022 03:07:35 +0100
Subject: server: repositores & orgs fixed in config

a very simple setup that might be usable for divoc and similar small events
---
 server/Worker.hs | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 73 insertions(+)
 create mode 100644 server/Worker.hs

(limited to 'server/Worker.hs')

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 }
-- 
cgit v1.2.3