server: switch to universum prelude, some cleanup

it's slightly less of a mess than it was before

1 files changed, 38 insertions, 43 deletions

diff --git a/server/Handlers.hs b/server/Handlers.hs
index ce1eb9b..e590cb7 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -1,50 +1,45 @@
 {-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications  #-}
 
 module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where
 
-import           Bindings.Cli.Git       (gitProc)
-import           CheckDir               (recursiveCheckDir)
-import           Cli.Extras             (CliConfig, CliT, ProcessFailure,
-                                         Severity (..), callProcessAndLogOutput,
-                                         getCliConfig, prettyProcessFailure,
-                                         putLog, runCli)
-import           Control.Concurrent     (MVar, ThreadId, forkIO, readMVar,
-                                         withMVar)
-import           Control.Monad.Extra    (ifM)
-import           Control.Monad.IO.Class (liftIO)
-import           Control.Monad.Trans    (lift)
-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           Lens.Micro.Extras      (view)
-import           Servant                (Handler, NoContent (NoContent), err404,
-                                         err500, throwError)
-import           Server                 (AdminOverview (AdminOverview),
-                                         Config (entrypoint, lintconfig, tmpdir),
-                                         JobStatus (..),
-                                         RemoteRef (reporef, repourl), State,
-                                         jobs, registry, setJobStatus,
-                                         setRegistry)
-import           System.Directory       (doesDirectoryExist)
-import           System.FilePath        ((</>))
+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 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 (entrypoint, lintconfig, tmpdir),
+                                          JobStatus (..),
+                                          RemoteRef (reporef, repourl),
+                                          ServerState, jobs, registry,
+                                          setJobStatus, setRegistry)
+import           System.Directory        (doesDirectoryExist)
+import           System.FilePath         ((</>))
 
 -- | this servant app can run cli programs!
 type App = CliT ProcessFailure Handler
 
 -- | annoying (and afaik unused), but has to be here for type system reasons
 instance MonadFail Handler where
-  fail _ = throwError $ err500
+  fail _ = throwError err500
 
 -- | someone submitted a map; lint it (synchronously for now)
-submitImpl :: Config True -> MVar State -> RemoteRef -> App UUID
+submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID
 submitImpl config state ref = do
   jobid <- liftIO UUID.nextRandom
   -- TODO: these two should really be atomic
@@ -56,7 +51,7 @@ submitImpl config state ref = do
   -- the submission itself can't really fail or return anything useful
   pure jobid
 
-relintImpl :: Config True -> MVar State -> UUID -> App NoContent
+relintImpl :: Config True -> MVar ServerState -> UUID -> App NoContent
 relintImpl config state uuid = do
   mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry)
   case mref of
@@ -66,7 +61,7 @@ relintImpl config state uuid = do
       _ <- checkRef config cliconfig state ref
       pure NoContent
 
-statusImpl :: MVar State -> UUID -> App JobStatus
+statusImpl :: MVar ServerState -> UUID -> App JobStatus
 statusImpl state uuid = do
    status <- liftIO $ withMVar state $ \state ->
      case M.lookup uuid (view registry state) of
@@ -77,28 +72,28 @@ statusImpl state uuid = do
      Nothing  -> lift $ throwError err404
 
 
-adminOverviewImpl :: MVar State -> App AdminOverview
+adminOverviewImpl :: MVar ServerState -> App AdminOverview
 adminOverviewImpl state = do
-  state <- liftIO $ readMVar state
+  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 -> CliConfig -> MVar State -> RemoteRef -> App ThreadId
+checkRef :: Config True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId
 checkRef config 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", T.unpack (reporef ref), "--depth", "1" ])
+         [ "fetch", "origin", toString (reporef ref), "--depth", "1" ])
         (callgit gitdir
-         [ "clone", T.unpack $ repourl ref, "--bare"
-         , "--depth", "1", "-b", T.unpack (reporef ref)])
+         [ "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", T.unpack (reporef ref) ]
+      callgit workdir [ "checkout", toString (reporef ref) ]
       res <- liftIO $ recursiveCheckDir (lintconfig config) workdir (entrypoint config)
       callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
       pure res
@@ -107,7 +102,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do
       Left err  -> Failed (prettyProcessFailure err)
   where
     callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
-    gitdir = tmpdir config </> hashedname
-    hashedname = fmap escapeSlash . T.unpack . repourl $ ref
+    gitdir = tmpdir config </> toString hashedname
+    hashedname = T.map escapeSlash . repourl $ ref
     escapeSlash = \case { '/' -> '-'; a -> a }