From ac81f4a118cc7a067ff26d8f4fd30410cac07e3c Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 16 Feb 2022 00:14:41 +0100
Subject: … 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?)
---
 server/Handlers.hs | 61 +++++++++++++++++++++++++++++-------------------------
 1 file changed, 33 insertions(+), 28 deletions(-)

(limited to 'server/Handlers.hs')

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 }
 
-- 
cgit v1.2.3