diff options
author | stuebinm | 2022-02-16 00:14:41 +0100 |
---|---|---|
committer | stuebinm | 2022-02-16 00:14:41 +0100 |
commit | 2e51b4b237003bc969434c960b3c0fa3cf5317a4 (patch) | |
tree | 405863bdd488d1f3444ef8dcfeffe419680c1e09 /server/Handlers.hs | |
parent | 358305b196e41ca88155fd0d71516cefe7e2732d (diff) |
… several hours of fighting with TOML later
WHO THOUGHT THIS SYNTAX WAS A GOOD IDEA??
(and who decided to write the least obvious combinator library to parse it?)
Diffstat (limited to '')
-rw-r--r-- | server/Handlers.hs | 61 |
1 files changed, 33 insertions, 28 deletions
diff --git a/server/Handlers.hs b/server/Handlers.hs index e590cb7..afbb2b9 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -3,7 +3,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where +module Handlers (App + -- , submitImpl + , statusImpl + -- , relintImpl + , adminOverviewImpl + ) where import Universum @@ -23,11 +28,11 @@ import qualified Data.UUID.V4 as UUID import Servant (Handler, NoContent (NoContent), err404, err500, throwError) import Server (AdminOverview (AdminOverview), - Config (entrypoint, lintconfig, tmpdir), + Config, orgs, tmpdir, JobStatus (..), RemoteRef (reporef, repourl), ServerState, jobs, registry, - setJobStatus, setRegistry) + setJobStatus, setRegistry, Org (..)) import System.Directory (doesDirectoryExist) import System.FilePath ((</>)) @@ -38,28 +43,28 @@ type App = CliT ProcessFailure Handler instance MonadFail Handler where fail _ = throwError err500 --- | someone submitted a map; lint it (synchronously for now) -submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID -submitImpl config state ref = do - jobid <- liftIO UUID.nextRandom - -- TODO: these two should really be atomic - liftIO $ setJobStatus state ref Pending - liftIO $ setRegistry state jobid ref - cliconfig <- getCliConfig - -- we'll just forget the thread id for now and trust this terminates … - _ <- checkRef config cliconfig state ref - -- the submission itself can't really fail or return anything useful - pure jobid +-- -- | someone submitted a map; lint it (synchronously for now) +-- submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID +-- submitImpl config state ref = do +-- jobid <- liftIO UUID.nextRandom +-- -- TODO: these two should really be atomic +-- liftIO $ setJobStatus state ref Pending +-- liftIO $ setRegistry state jobid ref +-- cliconfig <- getCliConfig +-- -- we'll just forget the thread id for now and trust this terminates … +-- _ <- checkRef config cliconfig state ref +-- -- the submission itself can't really fail or return anything useful +-- pure jobid -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 - Nothing -> lift $ throwError err404 - Just ref -> do - cliconfig <- getCliConfig - _ <- checkRef config cliconfig state ref - pure 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 +-- Nothing -> lift $ throwError err404 +-- Just ref -> do +-- cliconfig <- getCliConfig +-- _ <- checkRef config cliconfig state ref +-- pure NoContent statusImpl :: MVar ServerState -> UUID -> App JobStatus statusImpl state uuid = do @@ -80,8 +85,8 @@ adminOverviewImpl state = do -- | 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 ServerState -> RemoteRef -> App ThreadId -checkRef config cliconfig state ref = liftIO $ forkIO $ do +checkRef :: Config True -> Org True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId +checkRef config org 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! @@ -94,7 +99,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand) callgit gitdir [ "worktree", "add", workdir ] callgit workdir [ "checkout", toString (reporef ref) ] - res <- liftIO $ recursiveCheckDir (lintconfig config) workdir (entrypoint config) + res <- liftIO $ recursiveCheckDir (orgLintconfig org) workdir (orgEntrypoint org) callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ] pure res liftIO $ setJobStatus state ref $ case res of @@ -102,7 +107,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 </> toString hashedname + gitdir = view tmpdir config </> toString hashedname hashedname = T.map escapeSlash . repourl $ ref escapeSlash = \case { '/' -> '-'; a -> a } |