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!

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)