From 3b144c97636620a6fbd3807a8847b5751f86a52d Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 16 Feb 2022 17:59:19 +0100
Subject: server: remove cli-git, cli-extras

both these packages are hard to use, seem to be either unfinished or
abandoned, and also generally not very good.

Also for some reason they depend on `lens`. Removing them dramatically
shrunk the dependency closure!
---
 server/Worker.hs | 86 ++++++++++++++++++++++++++++++++++----------------------
 1 file changed, 52 insertions(+), 34 deletions(-)

(limited to 'server/Worker.hs')

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