non-blocking server

1 files changed, 85 insertions, 0 deletions

diff --git a/server/Handlers.hs b/server/Handlers.hs
new file mode 100644
index 0000000..67c7cdf
--- /dev/null
+++ b/server/Handlers.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE DeriveAnyClass   #-}
+{-# LANGUAGE DeriveGeneric    #-}
+{-# LANGUAGE LambdaCase       #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Handlers (App, submitImpl,statusImpl) where
+
+import           Bindings.Cli.Git       (gitProc)
+import           CheckDir               (DirResult, recursiveCheckDir)
+import           Cli.Extras             (CliT, ProcessFailure, Severity (..),
+                                         callProcessAndLogOutput, getCliConfig,
+                                         prettyProcessFailure, runCli)
+import           Control.Concurrent     (MVar, forkIO, withMVar)
+import           Control.Monad.Extra    (ifM)
+import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.Trans    (lift)
+import qualified Data.Map               as M
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import qualified Data.UUID              as UUID
+import qualified Data.UUID.V4           as UUID
+import           Servant                (Handler, err404, err500, throwError)
+import           Server                 (Config (entrypoint, lintconfig, tmpdir),
+                                         JobStatus (..),
+                                         RemoteRef (reporef, repourl), State,
+                                         setJobStatus)
+import           System.Directory       (doesDirectoryExist)
+import           System.FilePath        ((</>))
+
+-- | this servant app can run cli programs!
+type App = CliT ProcessFailure Handler
+type App' = CliT ProcessFailure IO
+
+-- | annoying (and afaik unused), but has to be here for type system reasons
+instance MonadFail Handler where
+  fail _ = throwError $ err500
+
+-- | someone submitted a map; lint it (synchronously for now)
+submitImpl :: Config True -> MVar State -> RemoteRef -> App ()
+submitImpl config state ref = do
+  liftIO $ setJobStatus state ref Pending
+  cliconfig <- getCliConfig
+  -- we'll just forget the thread id for now and trust this terminates …
+  _ <- liftIO $ forkIO $ do
+    res <- runCli cliconfig $ do
+      ifM (liftIO $ doesDirectoryExist gitdir)
+        gitfetch gitclone
+      checkPath config gitdir (reporef ref)
+    setJobStatus state ref $ case res of
+      Right res -> Linted res
+      Left err  -> Failed (prettyProcessFailure err)
+  -- the submission itself can't really fail or return anything useful
+  pure ()
+  where
+    -- TODO: these calls fail for dumb http, add some fallback!
+    gitclone = callProcessAndLogOutput (Debug, Error)
+      $ gitProc gitdir [ "clone", T.unpack $ repourl ref, "--bare", "--depth", "1", "-b", T.unpack (reporef ref)]
+    gitfetch = callProcessAndLogOutput (Debug, Error)
+      $ gitProc gitdir [ "fetch", "origin", T.unpack (reporef ref), "--depth", "1" ]
+    gitdir = tmpdir config </> hashedname
+    hashedname = fmap escapeSlash . T.unpack . repourl $ ref
+    escapeSlash = \case { '/' -> '-'; a -> a }
+
+statusImpl :: MVar State -> RemoteRef -> App JobStatus
+statusImpl state ref = do
+   status <- liftIO $ withMVar state (pure . M.lookup ref)
+   case status of
+     Just res -> pure res
+     Nothing  -> lift $ throwError err404
+
+
+
+checkPath :: Config True -> FilePath -> Text -> App' DirResult
+checkPath config gitdir ref = do
+  rand <- liftIO UUID.nextRandom
+  let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
+  callProcessAndLogOutput (Debug, Error)
+    $ gitProc gitdir [ "worktree", "add", workdir ]
+  callProcessAndLogOutput (Debug, Error)
+    $ gitProc workdir [ "checkout", T.unpack ref ]
+  res <- liftIO $ recursiveCheckDir (lintconfig config) gitdir (entrypoint config)
+  callProcessAndLogOutput (Debug, Error)
+    $ gitProc gitdir [ "worktree", "remove", "-f", "-f", workdir ]
+  pure res