From 8272b6f16b0125382eb44cabd819859f29528a31 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Wed, 16 Feb 2022 17:59:19 +0100
Subject: [PATCH] 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!
---
package.yaml | 3 +-
server/Main.hs | 8 ++---
server/Worker.hs | 86 +++++++++++++++++++++++++++++-------------------
walint.cabal | 3 +-
4 files changed, 58 insertions(+), 42 deletions(-)
diff --git a/package.yaml b/package.yaml
index 64bf70b..3bcac30 100644
--- a/package.yaml
+++ b/package.yaml
@@ -71,8 +71,7 @@ executables:
- lucid
- servant-lucid
- http-types
- - cli-git
- - cli-extras
+ - process
- extra
- microlens-platform
- fmt
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)
diff --git a/walint.cabal b/walint.cabal
index 6a2ed46..e721b0d 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -98,8 +98,6 @@ executable walint-server
, base-compat
, base64-bytestring
, bytestring
- , cli-extras
- , cli-git
, containers
, cryptohash-sha1
, directory
@@ -111,6 +109,7 @@ executable walint-server
, lucid
, microlens-platform
, mtl
+ , process
, servant
, servant-lucid
, servant-server
--
GitLab