summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-rw-r--r--server/Handlers.hs61
-rw-r--r--server/Main.hs28
-rw-r--r--server/Server.hs82
3 files changed, 101 insertions, 70 deletions
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 ()