server: repositores & orgs fixed in config

a very simple setup that might be usable for divoc and similar small events

1 files changed, 27 insertions, 66 deletions

diff --git a/server/Handlers.hs b/server/Handlers.hs
index afbb2b9..cb714d9 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -1,47 +1,28 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Handlers (App
+module Handlers (
                 -- , submitImpl
-                , statusImpl
+                 statusImpl
                 -- , relintImpl
                 , adminOverviewImpl
+                , AdminOverview(..)
                 ) where
 
 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           Data.Aeson              (ToJSON (..), (.=))
+import qualified Data.Aeson              as A
 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, orgs, tmpdir,
-                                          JobStatus (..),
-                                          RemoteRef (reporef, repourl),
-                                          ServerState, jobs, registry,
-                                          setJobStatus, setRegistry, Org (..))
-import           System.Directory        (doesDirectoryExist)
-import           System.FilePath         ((</>))
-
--- | this servant app can run cli programs!
-type App = CliT ProcessFailure Handler
+import           Servant                 (Handler, err404, throwError)
+import           Server                  (JobStatus (..), ServerState, Sha1,
+                                          unState)
 
 -- | annoying (and afaik unused), but has to be here for type system reasons
-instance MonadFail Handler where
-  fail _ = throwError err500
+-- instance MonadFail Handler where
+--   fail _ = throwError err500
 
 -- -- | someone submitted a map; lint it (synchronously for now)
 -- submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID
@@ -66,48 +47,28 @@ instance MonadFail Handler where
 --       _ <- checkRef config cliconfig state ref
 --       pure NoContent
 
-statusImpl :: MVar ServerState -> UUID -> App JobStatus
-statusImpl state uuid = do
+-- | an info type wrapped around the server state, to carry serialisation instances.
+-- TODO: should probably not be defined here
+newtype AdminOverview =
+  AdminOverview { unAdminOverview :: ServerState }
+
+instance ToJSON AdminOverview where
+  toJSON (AdminOverview state) =
+    toJSON $ view unState state <&> \(ref, status) ->
+      A.object [ "remote" .= ref
+               , "status" .= status
+               ]
+
+statusImpl :: MVar ServerState -> Sha1 -> Handler JobStatus
+statusImpl state sha1 = do
    status <- liftIO $ withMVar state $ \state ->
-     case M.lookup uuid (view registry state) of
-       Nothing  -> pure Nothing
-       Just ref -> pure $ M.lookup ref (view jobs state)
+     pure $ M.lookup sha1 (map snd $ view unState state)
    case status of
      Just res -> pure res
-     Nothing  -> lift $ throwError err404
+     Nothing  -> throwError err404
 
 
-adminOverviewImpl :: MVar ServerState -> App AdminOverview
+adminOverviewImpl :: MVar ServerState -> Handler AdminOverview
 adminOverviewImpl state = do
   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 -> 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!
-        (callgit gitdir
-         [ "fetch", "origin", toString (reporef ref), "--depth", "1" ])
-        (callgit gitdir
-         [ "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", toString (reporef ref) ]
-      res <- liftIO $ recursiveCheckDir (orgLintconfig org) workdir (orgEntrypoint org)
-      callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
-      pure res
-    liftIO $ setJobStatus state ref $ case res of
-      Right res -> Linted res
-      Left err  -> Failed (prettyProcessFailure err)
-  where
-    callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
-    gitdir = view tmpdir config </> toString hashedname
-    hashedname = T.map escapeSlash . repourl $ ref
-    escapeSlash = \case { '/' -> '-'; a -> a }
-