server: proper job handling

Note: the server will not check submissions for duplicates!
(nor does it do any kind of rate-limiting)

5 files changed, 114 insertions, 67 deletions

diff --git a/package.yaml b/package.yaml
index 84e1e96..7208cd9 100644
--- a/package.yaml
+++ b/package.yaml
@@ -71,3 +71,5 @@ executables:
       - walint
       - uuid
       - containers
+      - microlens
+      - microlens-th
diff --git a/server/Handlers.hs b/server/Handlers.hs
index 67c7cdf..382af64 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -1,85 +1,105 @@
 {-# LANGUAGE DataKinds        #-}
 {-# LANGUAGE DeriveAnyClass   #-}
 {-# LANGUAGE DeriveGeneric    #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase       #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Handlers (App, submitImpl,statusImpl) where
+module Handlers (App, submitImpl,statusImpl,relintImpl) 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           CheckDir               (recursiveCheckDir)
+import           Cli.Extras             (CliConfig, CliT, ProcessFailure,
+                                         Severity (..), callProcessAndLogOutput,
+                                         getCliConfig, prettyProcessFailure,
+                                         runCli)
+import           Control.Concurrent     (MVar, ThreadId, 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           Data.UUID              (UUID)
 import qualified Data.UUID              as UUID
 import qualified Data.UUID.V4           as UUID
-import           Servant                (Handler, err404, err500, throwError)
+import           Lens.Micro.Extras      (view)
+import           Servant                (Handler, NoContent (NoContent), err404,
+                                         err500, throwError)
 import           Server                 (Config (entrypoint, lintconfig, tmpdir),
                                          JobStatus (..),
                                          RemoteRef (reporef, repourl), State,
-                                         setJobStatus)
+                                         jobs, registry, setJobStatus,
+                                         setRegistry)
 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 True -> MVar State -> 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 …
-  _ <- 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)
+  _ <- checkRef config cliconfig state ref
   -- 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 }
+  pure jobid
+
+relintImpl :: Config True -> MVar State -> 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 State -> RemoteRef -> App JobStatus
-statusImpl state ref = do
-   status <- liftIO $ withMVar state (pure . M.lookup ref)
+statusImpl :: MVar State -> UUID -> App JobStatus
+statusImpl state uuid = 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)
    case status of
      Just res -> pure res
      Nothing  -> lift $ throwError err404
 
 
+-- | 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 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" ])
+        (callgit gitdir
+         [ "clone", T.unpack $ repourl ref, "--bare"
+         , "--depth", "1", "-b", T.unpack (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) ]
+      res <- liftIO $ recursiveCheckDir (lintconfig config) workdir (entrypoint config)
+      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 = tmpdir config </> hashedname
+    hashedname = fmap escapeSlash . T.unpack . repourl $ ref
+    escapeSlash = \case { '/' -> '-'; a -> a }
 
-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
diff --git a/server/Main.hs b/server/Main.hs
index 33c2c5c..ecaf6b7 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE KindSignatures             #-}
-{-# LANGUAGE LambdaCase                 #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RankNTypes                 #-}
-{-# LANGUAGE TypeApplications           #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE KindSignatures    #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE TypeOperators     #-}
 
 
 -- | simple server offering linting "as a service"
@@ -15,16 +15,20 @@ import           Cli.Extras                 (mkDefaultCliConfig, runCli)
 import           Control.Concurrent         (MVar, newMVar)
 import           Control.Monad.IO.Class     (liftIO)
 import qualified Data.ByteString.Lazy.Char8 as C8
-import           Handlers                   (App, statusImpl, submitImpl)
+import           Data.UUID                  (UUID)
+import           Handlers                   (App, relintImpl, statusImpl,
+                                             submitImpl)
 import           Network.Wai.Handler.Warp   (run)
-import           Servant                    (Application, Get, Handler,
+import           Servant                    (Application, Capture, Get, Handler,
                                              HasServer (ServerT), JSON,
-                                             Proxy (Proxy), ReqBody,
-                                             ServerError (errBody), err500,
-                                             hoistServer, serve, throwError,
-                                             type (:<|>) (..), type (:>), Post)
+                                             NoContent, Post, Proxy (Proxy),
+                                             ReqBody, ServerError (errBody),
+                                             err500, hoistServer, serve,
+                                             throwError, type (:<|>) (..),
+                                             type (:>))
 import           Server                     (Config (..), JobStatus,
-                                             RemoteRef (..), State, loadConfig)
+                                             RemoteRef (..), State,
+                                             defaultState, loadConfig)
 
 {-
 Needed:
@@ -40,8 +44,9 @@ Needed:
 -}
 -- | Main API type
 type API format =
-       "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] ()
-  :<|> "status" :> ReqBody '[JSON] RemoteRef :> Get '[format] JobStatus
+       "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
+  :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
+  :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
 
 
 -- | API's implementation
@@ -49,6 +54,7 @@ jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App
 jsonAPI config state =
   submitImpl config state
   :<|> statusImpl state
+  :<|> relintImpl config state
 
 -- | make an application; convert any cli errors into a 500
 app :: Config True -> MVar State -> Application
@@ -65,7 +71,7 @@ app config =
 
 main :: IO ()
 main = do
-  state <- newMVar (mempty :: State)
+  state <- newMVar defaultState
   let config = Config "/tmp" 8080 "main.json" "./config.json"
   config' <- loadConfig config
   run (port config) (app config' state)
diff --git a/server/Server.hs b/server/Server.hs
index 41e5bde..93bfb30 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -3,12 +3,13 @@
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE KindSignatures      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
 
-module Server (loadConfig, Config(..), RemoteRef(..), State, JobStatus(..),
-                    setJobStatus) where
+module Server (loadConfig, Config(..), RemoteRef(..), State, registry, jobs, JobStatus(..),
+                    setJobStatus,defaultState,setRegistry) where
 
 import           CheckDir             (DirResult)
 import           Control.Concurrent   (MVar, modifyMVar_)
@@ -17,9 +18,13 @@ import qualified Data.ByteString.Lazy as LB
 import           Data.Map             (Map)
 import qualified Data.Map             as M
 import           Data.Text            (Text)
+import           Data.UUID            (UUID)
 import           GHC.Generics         (Generic)
+import           Lens.Micro           (over)
+import           Lens.Micro.TH
 import           LintConfig           (LintConfig')
 
+
 -- | a reference in a remote git repository
 data RemoteRef = RemoteRef
   { repourl :: Text
@@ -44,7 +49,15 @@ data JobStatus =
   Pending | Linted DirResult | Failed Text
   deriving (Generic, ToJSON)
 
-type State = Map RemoteRef JobStatus
+data State = State
+  { _jobs     :: Map RemoteRef JobStatus
+  , _registry :: Map UUID RemoteRef
+  }
+
+makeLenses ''State
+
+defaultState :: State
+defaultState = State mempty mempty
 
 
 loadConfig :: Config False -> IO (Config True)
@@ -57,5 +70,9 @@ loadConfig config = do
 
 
 setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO ()
-setJobStatus mvar ref status = modifyMVar_ mvar $ \state ->
-  pure $ M.insert ref status state
+setJobStatus mvar ref status = modifyMVar_ mvar
+  $ pure . over jobs (M.insert ref status)
+
+setRegistry :: MVar State -> UUID -> RemoteRef -> IO ()
+setRegistry mvar uuid ref = modifyMVar_ mvar
+  $ pure . over registry (M.insert uuid ref)
diff --git a/walint.cabal b/walint.cabal
index a27852f..9846e7a 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -79,6 +79,8 @@ executable server
     , filepath
     , http-media
     , logging-effect
+    , microlens
+    , microlens-th
     , mtl
     , process
     , servant