diff options
Diffstat (limited to '')
| -rw-r--r-- | config.toml | 13 | ||||
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | server/Handlers.hs | 61 | ||||
| -rw-r--r-- | server/Main.hs | 28 | ||||
| -rw-r--r-- | server/Server.hs | 82 | ||||
| -rw-r--r-- | walint.cabal | 1 |
6 files changed, 115 insertions, 71 deletions
diff --git a/config.toml b/config.toml index ff3ef8e..3886597 100644 --- a/config.toml +++ b/config.toml @@ -4,6 +4,17 @@ port = 8080 verbose = true tmpdir = "/tmp" -entrypoint = "main.json" + + +[[org]] +slug = "divoc" lintconfig = "./config.json" +entrypoint = "main.json" + +[[org.repo]] # I hate TOML +url = "https://gitlab.infra4future.de/hacc/events/hacc-map" +ref = "master" +[[org.repo]] +url = "https://github.com/namiko/assembly_2021" +ref = "master" diff --git a/package.yaml b/package.yaml index 652cb37..7dacce8 100644 --- a/package.yaml +++ b/package.yaml @@ -75,6 +75,7 @@ executables: - cli-extras - extra - uuid + - microlens - microlens-th - tomland - dotgen diff --git a/server/Handlers.hs b/server/Handlers.hs index e590cb7..afbb2b9 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -3,7 +3,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where +module Handlers (App + -- , submitImpl + , statusImpl + -- , relintImpl + , adminOverviewImpl + ) where import Universum @@ -23,11 +28,11 @@ import qualified Data.UUID.V4 as UUID import Servant (Handler, NoContent (NoContent), err404, err500, throwError) import Server (AdminOverview (AdminOverview), - Config (entrypoint, lintconfig, tmpdir), + Config, orgs, tmpdir, JobStatus (..), RemoteRef (reporef, repourl), ServerState, jobs, registry, - setJobStatus, setRegistry) + setJobStatus, setRegistry, Org (..)) import System.Directory (doesDirectoryExist) import System.FilePath ((</>)) @@ -38,28 +43,28 @@ type App = CliT ProcessFailure Handler instance MonadFail Handler where fail _ = throwError err500 --- | someone submitted a map; lint it (synchronously for now) -submitImpl :: Config True -> MVar ServerState -> 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 … - _ <- checkRef config cliconfig state ref - -- the submission itself can't really fail or return anything useful - pure jobid +-- -- | someone submitted a map; lint it (synchronously for now) +-- submitImpl :: Config True -> MVar ServerState -> 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 … +-- _ <- checkRef config cliconfig state ref +-- -- the submission itself can't really fail or return anything useful +-- pure jobid -relintImpl :: Config True -> MVar ServerState -> 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 +-- relintImpl :: Config True -> MVar ServerState -> 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 ServerState -> UUID -> App JobStatus statusImpl state uuid = do @@ -80,8 +85,8 @@ adminOverviewImpl state = do -- | 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 ServerState -> RemoteRef -> App ThreadId -checkRef config cliconfig state ref = liftIO $ forkIO $ do +checkRef :: Config True -> Org True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId +checkRef config org 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! @@ -94,7 +99,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand) callgit gitdir [ "worktree", "add", workdir ] callgit workdir [ "checkout", toString (reporef ref) ] - res <- liftIO $ recursiveCheckDir (lintconfig config) workdir (entrypoint config) + res <- liftIO $ recursiveCheckDir (orgLintconfig org) workdir (orgEntrypoint org) callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ] pure res liftIO $ setJobStatus state ref $ case res of @@ -102,7 +107,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do Left err -> Failed (prettyProcessFailure err) where callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir - gitdir = tmpdir config </> toString hashedname + gitdir = view tmpdir config </> toString hashedname hashedname = T.map escapeSlash . repourl $ ref escapeSlash = \case { '/' -> '-'; a -> a } diff --git a/server/Main.hs b/server/Main.hs index fd66ad3..04a2010 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -17,8 +17,8 @@ import Cli.Extras (CliConfig, import qualified Data.ByteString.Lazy.Char8 as C8 import Data.UUID (UUID) import Handlers (App, adminOverviewImpl, - relintImpl, statusImpl, - submitImpl) + statusImpl, + ) import HtmlOrphans () import Network.Wai.Handler.Warp (defaultSettings, runSettings, setPort) @@ -42,14 +42,14 @@ import Server (AdminOverview, Config (..), JobStatus, RemoteRef (..), ServerState, - defaultState, loadConfig) + defaultState, loadConfig, verbose, port, orgs, Org (orgEntrypoint, orgRepos)) -- | Main API type type API format = - "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID - :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus - :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent + -- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID + "status" :> Capture "jobid" UUID :> Get '[format] JobStatus + -- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent :<|> "admin" :> "overview" :> Get '[format] AdminOverview type Routes = @@ -61,9 +61,9 @@ type Routes = -- | API's implementation jsonAPI :: Config True -> MVar ServerState -> ServerT (API JSON) App jsonAPI config state = - submitImpl config state - :<|> statusImpl state - :<|> relintImpl config state + -- submitImpl config state + statusImpl state + -- :<|> relintImpl config state :<|> adminOverviewImpl state server :: Config True -> MVar ServerState -> ServerT Routes App @@ -92,12 +92,16 @@ main = do state <- newMVar defaultState -- TODO: i really don't like all this cli logging stuff, replace it with -- fast-logger at some point … - cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | verbose config] + cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | view verbose config] loggerMiddleware <- mkRequestLogger - $ def { outputFormat = Detailed (verbose config) } + $ def { outputFormat = Detailed (view verbose config) } + + -- print (keys $ view orgs config) + print (map orgEntrypoint $ view orgs config) + print (map orgRepos $ view orgs config) let warpsettings = - setPort (port config) + setPort (view port config) defaultSettings runSettings warpsettings diff --git a/server/Server.hs b/server/Server.hs index 8014053..bdfa77f 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -11,9 +11,11 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE LambdaCase #-} module Server ( loadConfig - , Config(..) + , Org(..) + , Config, tmpdir, port, verbose, orgs , RemoteRef(..) , ServerState, registry, jobs, defaultState , JobStatus(..) @@ -26,45 +28,68 @@ import Universum import CheckDir (DirResult) import Control.Concurrent (modifyMVar_) -import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, - (.=)) +import Data.Aeson (FromJSON, ToJSON (toJSON), + (.=), eitherDecodeFileStrict') import qualified Data.Aeson as A -import qualified Data.ByteString.Lazy as LB import qualified Data.Map as M import Data.UUID (UUID) +import Lens.Micro (traverseOf) import Lens.Micro.TH import LintConfig (LintConfig') -import Toml (TomlCodec) +import Toml (TomlCodec, prettyTomlDecodeErrors) import qualified Toml as T -- | a reference in a remote git repository data RemoteRef = RemoteRef { repourl :: Text , reporef :: Text - } deriving (Generic, FromJSON, ToJSON, Eq, Ord) + } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show) type family ConfigRes (b :: Bool) a where ConfigRes True a = a ConfigRes False a = FilePath + +data Org (loaded :: Bool) = Org + { orgSlug :: Text + , orgLintconfig :: ConfigRes loaded LintConfig' + , orgEntrypoint :: FilePath + , orgRepos :: [RemoteRef] + } + + -- | the server's configuration data Config (loaded :: Bool) = Config - { tmpdir :: FilePath + { _tmpdir :: FilePath -- ^ dir to clone git things in - , port :: Int - , verbose :: Bool + , _port :: Int + , _verbose :: Bool -- ^ port to bind to - , entrypoint :: FilePath - , lintconfig :: ConfigRes loaded LintConfig' + , _orgs :: [Org loaded] } deriving Generic +makeLenses ''Config + + +remoteCodec :: TomlCodec RemoteRef +remoteCodec = RemoteRef + <$> T.text "url" T..= repourl + <*> T.text "ref" T..= reporef + +orgCodec :: TomlCodec (Org False) +orgCodec = Org + <$> T.text "slug" T..= orgSlug + <*> T.string "lintconfig" T..= orgLintconfig + <*> T.string "entrypoint" T..= orgEntrypoint + <*> T.list remoteCodec "repo" T..= orgRepos + + configCodec :: TomlCodec (Config False) configCodec = Config - <$> T.string "tmpdir" T..= tmpdir - <*> T.int "port" T..= port - <*> T.bool "verbose" T..= verbose - <*> T.string "entrypoint" T..= entrypoint - <*> T.string "lintconfig" T..= lintconfig + <$> T.string "tmpdir" T..= _tmpdir + <*> T.int "port" T..= _port + <*> T.bool "verbose" T..= _verbose + <*> T.list orgCodec "org" T..= _orgs -- | a job status (of a specific uuid) data JobStatus = @@ -81,6 +106,8 @@ makeLenses ''ServerState defaultState :: ServerState defaultState = ServerState mempty mempty +-- | an info type wrapped around the server state, to carry serialisation instances. +-- TODO: should probably not be defined here newtype AdminOverview = AdminOverview { unAdminOverview :: ServerState } @@ -92,24 +119,19 @@ instance ToJSON AdminOverview where , "status" .= M.lookup ref (view jobs state) ] - - loadConfig :: FilePath -> IO (Config True) loadConfig path = do res <- T.decodeFileEither configCodec path case res of - Right config -> loadConfig' config - Left err -> do - print err - exitFailure - -loadConfig' :: Config False -> IO (Config True) -loadConfig' config = do - loaded <- LB.readFile (lintconfig config) >>= \res -> - case eitherDecode res :: Either String LintConfig' of - Left err -> error $ "config file invalid: " <> show err - Right file -> pure file - pure $ config { lintconfig = loaded } + Right config -> traverseOf orgs (mapM loadOrg) config + Left err -> error $ prettyTomlDecodeErrors err + where + loadOrg :: Org False -> IO (Org True) + loadOrg org = do + lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case + Right c -> pure c + Left err -> error $ show err + pure $ org { orgLintconfig = lintconfig } setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO () diff --git a/walint.cabal b/walint.cabal index 5b82fec..a00fb6e 100644 --- a/walint.cabal +++ b/walint.cabal @@ -104,6 +104,7 @@ executable walint-server , filepath , http-types , lucid + , microlens , microlens-th , mtl , servant |