non-blocking server

6 files changed, 134 insertions, 94 deletions

diff --git a/package.yaml b/package.yaml
index 95ed5fb..84e1e96 100644
--- a/package.yaml
+++ b/package.yaml
@@ -5,7 +5,7 @@ homepage: https://stuebinm.eu/git/walint
 author: stuebinm
 maintainer: stuebinm@disroot.org
 copyright: 2022 stuebinm
-ghc-options: -Wall -Wno-name-shadowing
+ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
 
 dependencies:
   - base
@@ -70,3 +70,4 @@ executables:
       - directory
       - walint
       - uuid
+      - containers
diff --git a/server/Git.hs b/server/Git.hs
deleted file mode 100644
index e32d801..0000000
--- a/server/Git.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# LANGUAGE DataKinds        #-}
-{-# LANGUAGE DeriveAnyClass   #-}
-{-# LANGUAGE DeriveGeneric    #-}
-{-# LANGUAGE LambdaCase       #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Git (App, submitImpl) where
-
-import           Bindings.Cli.Git       (gitProc)
-import           CheckDir               (DirResult, recursiveCheckDir)
-import           Cli.Extras             (CliT, ProcessFailure, Severity (..),
-                                         callProcessAndLogOutput)
-import           Control.Monad.Extra    (ifM)
-import           Control.Monad.IO.Class (liftIO)
-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
-import           Serverconfig
-import           System.Directory       (doesDirectoryExist)
-import           System.FilePath        ((</>))
-
-
--- | this servant app can run cli programs!
-type App = CliT ProcessFailure Handler
-
--- | 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 -> RemoteRef -> App DirResult
-submitImpl config ref = do
-  ifM (liftIO $ doesDirectoryExist gitdir)
-    (callProcessAndLogOutput (Debug, Error) gitfetch)
-    (callProcessAndLogOutput (Debug, Error) gitclone)
-  checkPath config gitdir (reporef ref)
-  where gitclone = gitProc gitdir -- TODO: these calls fail for dumb http, add some fallback!
-          [ "clone", T.unpack $ repourl ref, "--bare", "--depth", "1", "-b", T.unpack (reporef ref)]
-        gitfetch = 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
-
-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/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
diff --git a/server/Main.hs b/server/Main.hs
index 77c8fde..33c2c5c 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,15 +1,8 @@
 {-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE DeriveAnyClass             #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE LambdaCase                 #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE RankNTypes                 #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
@@ -18,16 +11,20 @@
 -- | simple server offering linting "as a service"
 module Main where
 
-import           CheckDir                   (DirResult)
 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           Data.Text                  (Text)
-import           Git                        (App, submitImpl)
+import           Handlers                   (App, statusImpl, submitImpl)
 import           Network.Wai.Handler.Warp   (run)
-import           Servant
-import           Serverconfig               (Config (..), RemoteRef (..),
-                                             loadConfig)
+import           Servant                    (Application, Get, Handler,
+                                             HasServer (ServerT), JSON,
+                                             Proxy (Proxy), ReqBody,
+                                             ServerError (errBody), err500,
+                                             hoistServer, serve, throwError,
+                                             type (:<|>) (..), type (:>), Post)
+import           Server                     (Config (..), JobStatus,
+                                             RemoteRef (..), State, loadConfig)
 
 {-
 Needed:
@@ -43,21 +40,20 @@ Needed:
 -}
 -- | Main API type
 type API format =
-       "submit" :> ReqBody '[JSON] RemoteRef :> Get '[format] DirResult
-  :<|> "status" :> Capture "sha1" Text :> Get '[format] [Int]
+       "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] ()
+  :<|> "status" :> ReqBody '[JSON] RemoteRef :> Get '[format] JobStatus
+
 
 -- | API's implementation
-jsonAPI :: Config True -> ServerT (API JSON) App
-jsonAPI config =
-  submitImpl config
-  :<|> (\sha -> do
-          liftIO $ print sha
-          pure [1])
+jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App
+jsonAPI config state =
+  submitImpl config state
+  :<|> statusImpl state
 
 -- | make an application; convert any cli errors into a 500
-app :: Config True -> Application
+app :: Config True -> MVar State -> Application
 app config =
-  serve api $ hoistServer api conv (jsonAPI config)
+  serve api . hoistServer api conv . jsonAPI config
   where api = Proxy @(API JSON)
         conv :: App a -> Handler a
         conv m = do
@@ -69,6 +65,7 @@ app config =
 
 main :: IO ()
 main = do
+  state <- newMVar (mempty :: State)
   let config = Config "/tmp" 8080 "main.json" "./config.json"
   config' <- loadConfig config
-  run (port config) (app config')
+  run (port config) (app config' state)
diff --git a/server/Serverconfig.hs b/server/Server.hs
index d919567..41e5bde 100644
--- a/server/Serverconfig.hs
+++ b/server/Server.hs
@@ -2,16 +2,20 @@
 {-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
 
-module Serverconfig (loadConfig, Config(..), RemoteRef(..)) where
+module Server (loadConfig, Config(..), RemoteRef(..), State, JobStatus(..),
+                    setJobStatus) where
 
-import           Data.Aeson           (FromJSON, eitherDecode)
+import           CheckDir             (DirResult)
+import           Control.Concurrent   (MVar, modifyMVar_)
+import           Data.Aeson           (FromJSON, ToJSON, eitherDecode)
 import qualified Data.ByteString.Lazy as LB
+import           Data.Map             (Map)
+import qualified Data.Map             as M
 import           Data.Text            (Text)
 import           GHC.Generics         (Generic)
 import           LintConfig           (LintConfig')
@@ -20,7 +24,7 @@ import           LintConfig           (LintConfig')
 data RemoteRef = RemoteRef
   { repourl :: Text
   , reporef :: Text
-  } deriving (Generic, FromJSON)
+  } deriving (Generic, FromJSON, Eq, Ord)
 
 type family ConfigRes (b :: Bool) a where
   ConfigRes True a = a
@@ -36,6 +40,13 @@ data Config l = Config
   , lintconfig :: ConfigRes l LintConfig'
   }
 
+data JobStatus =
+  Pending | Linted DirResult | Failed Text
+  deriving (Generic, ToJSON)
+
+type State = Map RemoteRef JobStatus
+
+
 loadConfig :: Config False -> IO (Config True)
 loadConfig config = do
   loaded <- LB.readFile (lintconfig config) >>= \res ->
@@ -43,3 +54,8 @@ loadConfig config = do
         Left err   -> error $ "config file invalid: " <> err
         Right file -> pure file
   pure $ config { lintconfig = loaded }
+
+
+setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO ()
+setJobStatus mvar ref status = modifyMVar_ mvar $ \state ->
+  pure $ M.insert ref status state
diff --git a/walint.cabal b/walint.cabal
index 096d396..3786ce5 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -34,7 +34,7 @@ library
       Paths_walint
   hs-source-dirs:
       lib
-  ghc-options: -Wall -Wno-name-shadowing
+  ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
   build-depends:
       HList
     , aeson
@@ -60,12 +60,12 @@ library
 executable server
   main-is: Main.hs
   other-modules:
-      Git
-      Serverconfig
+      Handlers
+      Server
       Paths_walint
   hs-source-dirs:
       server
-  ghc-options: -Wall -Wno-name-shadowing
+  ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
   build-depends:
       aeson
     , base
@@ -73,6 +73,7 @@ executable server
     , bytestring
     , cli-extras
     , cli-git
+    , containers
     , directory
     , extra
     , filepath
@@ -93,7 +94,7 @@ executable server
 
 executable walint
   main-is: Main.hs
-  ghc-options: -Wall -Wno-name-shadowing
+  ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
   build-depends:
       aeson
     , aeson-pretty