From 358305b196e41ca88155fd0d71516cefe7e2732d Mon Sep 17 00:00:00 2001 From: stuebinm Date: Tue, 15 Feb 2022 22:28:24 +0100 Subject: server: switch to universum prelude, some cleanup it's slightly less of a mess than it was before --- server/Handlers.hs | 81 +++++++++++++++++++++++++----------------------------- 1 file changed, 38 insertions(+), 43 deletions(-) (limited to 'server/Handlers.hs') 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 } -- cgit v1.2.3