diff options
| -rw-r--r-- | package.yaml | 3 | ||||
| -rw-r--r-- | server/Git.hs | 60 | ||||
| -rw-r--r-- | server/Handlers.hs | 85 | ||||
| -rw-r--r-- | server/Main.hs | 45 | ||||
| -rw-r--r-- | server/Server.hs (renamed from server/Serverconfig.hs) | 24 | ||||
| -rw-r--r-- | walint.cabal | 11 |
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 |