diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Handlers.hs | 108 | ||||
| -rw-r--r-- | server/Main.hs | 42 | ||||
| -rw-r--r-- | server/Server.hs | 27 |
3 files changed, 110 insertions, 67 deletions
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) |