Skip to content
Snippets Groups Projects
Commit ac81f4a1 authored by stuebinm's avatar stuebinm
Browse files

… several hours of fighting with TOML later

WHO THOUGHT THIS SYNTAX WAS A GOOD IDEA??

(and who decided to write the least obvious combinator library to parse it?)
parent c69c90f3
No related branches found
No related tags found
No related merge requests found
...@@ -4,6 +4,17 @@ port = 8080 ...@@ -4,6 +4,17 @@ port = 8080
verbose = true verbose = true
tmpdir = "/tmp" tmpdir = "/tmp"
entrypoint = "main.json"
[[org]]
slug = "divoc"
lintconfig = "./config.json" 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"
...@@ -75,6 +75,7 @@ executables: ...@@ -75,6 +75,7 @@ executables:
- cli-extras - cli-extras
- extra - extra
- uuid - uuid
- microlens
- microlens-th - microlens-th
- tomland - tomland
- dotgen - dotgen
...@@ -3,7 +3,12 @@ ...@@ -3,7 +3,12 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where module Handlers (App
-- , submitImpl
, statusImpl
-- , relintImpl
, adminOverviewImpl
) where
import Universum import Universum
...@@ -23,11 +28,11 @@ import qualified Data.UUID.V4 as UUID ...@@ -23,11 +28,11 @@ import qualified Data.UUID.V4 as UUID
import Servant (Handler, NoContent (NoContent), import Servant (Handler, NoContent (NoContent),
err404, err500, throwError) err404, err500, throwError)
import Server (AdminOverview (AdminOverview), import Server (AdminOverview (AdminOverview),
Config (entrypoint, lintconfig, tmpdir), Config, orgs, tmpdir,
JobStatus (..), JobStatus (..),
RemoteRef (reporef, repourl), RemoteRef (reporef, repourl),
ServerState, jobs, registry, ServerState, jobs, registry,
setJobStatus, setRegistry) setJobStatus, setRegistry, Org (..))
import System.Directory (doesDirectoryExist) import System.Directory (doesDirectoryExist)
import System.FilePath ((</>)) import System.FilePath ((</>))
...@@ -38,28 +43,28 @@ type App = CliT ProcessFailure Handler ...@@ -38,28 +43,28 @@ type App = CliT ProcessFailure Handler
instance MonadFail Handler where instance MonadFail Handler where
fail _ = throwError err500 fail _ = throwError err500
-- | someone submitted a map; lint it (synchronously for now) -- -- | someone submitted a map; lint it (synchronously for now)
submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID -- submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID
submitImpl config state ref = do -- submitImpl config state ref = do
jobid <- liftIO UUID.nextRandom -- jobid <- liftIO UUID.nextRandom
-- TODO: these two should really be atomic -- -- TODO: these two should really be atomic
liftIO $ setJobStatus state ref Pending -- liftIO $ setJobStatus state ref Pending
liftIO $ setRegistry state jobid ref -- liftIO $ setRegistry state jobid ref
cliconfig <- getCliConfig -- cliconfig <- getCliConfig
-- we'll just forget the thread id for now and trust this terminates … -- -- we'll just forget the thread id for now and trust this terminates …
_ <- checkRef config cliconfig state ref -- _ <- checkRef config cliconfig state ref
-- the submission itself can't really fail or return anything useful -- -- the submission itself can't really fail or return anything useful
pure jobid -- pure jobid
relintImpl :: Config True -> MVar ServerState -> UUID -> App NoContent -- relintImpl :: Config True -> MVar ServerState -> UUID -> App NoContent
relintImpl config state uuid = do -- relintImpl config state uuid = do
mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry) -- mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry)
case mref of -- case mref of
Nothing -> lift $ throwError err404 -- Nothing -> lift $ throwError err404
Just ref -> do -- Just ref -> do
cliconfig <- getCliConfig -- cliconfig <- getCliConfig
_ <- checkRef config cliconfig state ref -- _ <- checkRef config cliconfig state ref
pure NoContent -- pure NoContent
statusImpl :: MVar ServerState -> UUID -> App JobStatus statusImpl :: MVar ServerState -> UUID -> App JobStatus
statusImpl state uuid = do statusImpl state uuid = do
...@@ -80,8 +85,8 @@ adminOverviewImpl state = do ...@@ -80,8 +85,8 @@ adminOverviewImpl state = do
-- | the actual check function. forks, calls out to git to update the -- | the actual check function. forks, calls out to git to update the
-- repository, create a new worktree, lints it, then tells git to -- repository, create a new worktree, lints it, then tells git to
-- delete that tree again -- delete that tree again
checkRef :: Config True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId checkRef :: Config True -> Org True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId
checkRef config cliconfig state ref = liftIO $ forkIO $ do checkRef config org cliconfig state ref = liftIO $ forkIO $ do
res <- liftIO $ runCli cliconfig $ do res <- liftIO $ runCli cliconfig $ do
ifM (liftIO $ doesDirectoryExist gitdir) ifM (liftIO $ doesDirectoryExist gitdir)
-- TODO: these calls fail for dumb http, add some fallback! -- TODO: these calls fail for dumb http, add some fallback!
...@@ -94,7 +99,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do ...@@ -94,7 +99,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand) let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
callgit gitdir [ "worktree", "add", workdir ] callgit gitdir [ "worktree", "add", workdir ]
callgit workdir [ "checkout", toString (reporef ref) ] 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 ] callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
pure res pure res
liftIO $ setJobStatus state ref $ case res of liftIO $ setJobStatus state ref $ case res of
...@@ -102,7 +107,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do ...@@ -102,7 +107,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do
Left err -> Failed (prettyProcessFailure err) Left err -> Failed (prettyProcessFailure err)
where where
callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
gitdir = tmpdir config </> toString hashedname gitdir = view tmpdir config </> toString hashedname
hashedname = T.map escapeSlash . repourl $ ref hashedname = T.map escapeSlash . repourl $ ref
escapeSlash = \case { '/' -> '-'; a -> a } escapeSlash = \case { '/' -> '-'; a -> a }
...@@ -17,8 +17,8 @@ import Cli.Extras (CliConfig, ...@@ -17,8 +17,8 @@ import Cli.Extras (CliConfig,
import qualified Data.ByteString.Lazy.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as C8
import Data.UUID (UUID) import Data.UUID (UUID)
import Handlers (App, adminOverviewImpl, import Handlers (App, adminOverviewImpl,
relintImpl, statusImpl, statusImpl,
submitImpl) )
import HtmlOrphans () import HtmlOrphans ()
import Network.Wai.Handler.Warp (defaultSettings, import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort) runSettings, setPort)
...@@ -42,14 +42,14 @@ import Server (AdminOverview, ...@@ -42,14 +42,14 @@ import Server (AdminOverview,
Config (..), JobStatus, Config (..), JobStatus,
RemoteRef (..), RemoteRef (..),
ServerState, ServerState,
defaultState, loadConfig) defaultState, loadConfig, verbose, port, orgs, Org (orgEntrypoint, orgRepos))
-- | Main API type -- | Main API type
type API format = type API format =
"submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID -- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
:<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
:<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent -- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
:<|> "admin" :> "overview" :> Get '[format] AdminOverview :<|> "admin" :> "overview" :> Get '[format] AdminOverview
type Routes = type Routes =
...@@ -61,9 +61,9 @@ type Routes = ...@@ -61,9 +61,9 @@ type Routes =
-- | API's implementation -- | API's implementation
jsonAPI :: Config True -> MVar ServerState -> ServerT (API JSON) App jsonAPI :: Config True -> MVar ServerState -> ServerT (API JSON) App
jsonAPI config state = jsonAPI config state =
submitImpl config state -- submitImpl config state
:<|> statusImpl state statusImpl state
:<|> relintImpl config state -- :<|> relintImpl config state
:<|> adminOverviewImpl state :<|> adminOverviewImpl state
server :: Config True -> MVar ServerState -> ServerT Routes App server :: Config True -> MVar ServerState -> ServerT Routes App
...@@ -92,12 +92,16 @@ main = do ...@@ -92,12 +92,16 @@ main = do
state <- newMVar defaultState state <- newMVar defaultState
-- TODO: i really don't like all this cli logging stuff, replace it with -- TODO: i really don't like all this cli logging stuff, replace it with
-- fast-logger at some point … -- fast-logger at some point …
cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | verbose config] cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | view verbose config]
loggerMiddleware <- mkRequestLogger 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 = let warpsettings =
setPort (port config) setPort (view port config)
defaultSettings defaultSettings
runSettings warpsettings runSettings warpsettings
......
...@@ -11,9 +11,11 @@ ...@@ -11,9 +11,11 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
module Server ( loadConfig module Server ( loadConfig
, Config(..) , Org(..)
, Config, tmpdir, port, verbose, orgs
, RemoteRef(..) , RemoteRef(..)
, ServerState, registry, jobs, defaultState , ServerState, registry, jobs, defaultState
, JobStatus(..) , JobStatus(..)
...@@ -26,45 +28,68 @@ import Universum ...@@ -26,45 +28,68 @@ import Universum
import CheckDir (DirResult) import CheckDir (DirResult)
import Control.Concurrent (modifyMVar_) 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.Aeson as A
import qualified Data.ByteString.Lazy as LB
import qualified Data.Map as M import qualified Data.Map as M
import Data.UUID (UUID) import Data.UUID (UUID)
import Lens.Micro (traverseOf)
import Lens.Micro.TH import Lens.Micro.TH
import LintConfig (LintConfig') import LintConfig (LintConfig')
import Toml (TomlCodec) import Toml (TomlCodec, prettyTomlDecodeErrors)
import qualified Toml as T import qualified Toml as T
-- | a reference in a remote git repository -- | a reference in a remote git repository
data RemoteRef = RemoteRef data RemoteRef = RemoteRef
{ repourl :: Text { repourl :: Text
, reporef :: Text , reporef :: Text
} deriving (Generic, FromJSON, ToJSON, Eq, Ord) } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show)
type family ConfigRes (b :: Bool) a where type family ConfigRes (b :: Bool) a where
ConfigRes True a = a ConfigRes True a = a
ConfigRes False a = FilePath ConfigRes False a = FilePath
data Org (loaded :: Bool) = Org
{ orgSlug :: Text
, orgLintconfig :: ConfigRes loaded LintConfig'
, orgEntrypoint :: FilePath
, orgRepos :: [RemoteRef]
}
-- | the server's configuration -- | the server's configuration
data Config (loaded :: Bool) = Config data Config (loaded :: Bool) = Config
{ tmpdir :: FilePath { _tmpdir :: FilePath
-- ^ dir to clone git things in -- ^ dir to clone git things in
, port :: Int , _port :: Int
, verbose :: Bool , _verbose :: Bool
-- ^ port to bind to -- ^ port to bind to
, entrypoint :: FilePath , _orgs :: [Org loaded]
, lintconfig :: ConfigRes loaded LintConfig'
} deriving Generic } 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 :: TomlCodec (Config False)
configCodec = Config configCodec = Config
<$> T.string "tmpdir" T..= tmpdir <$> T.string "tmpdir" T..= _tmpdir
<*> T.int "port" T..= port <*> T.int "port" T..= _port
<*> T.bool "verbose" T..= verbose <*> T.bool "verbose" T..= _verbose
<*> T.string "entrypoint" T..= entrypoint <*> T.list orgCodec "org" T..= _orgs
<*> T.string "lintconfig" T..= lintconfig
-- | a job status (of a specific uuid) -- | a job status (of a specific uuid)
data JobStatus = data JobStatus =
...@@ -81,6 +106,8 @@ makeLenses ''ServerState ...@@ -81,6 +106,8 @@ makeLenses ''ServerState
defaultState :: ServerState defaultState :: ServerState
defaultState = ServerState mempty mempty 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 = newtype AdminOverview =
AdminOverview { unAdminOverview :: ServerState } AdminOverview { unAdminOverview :: ServerState }
...@@ -92,24 +119,19 @@ instance ToJSON AdminOverview where ...@@ -92,24 +119,19 @@ instance ToJSON AdminOverview where
, "status" .= M.lookup ref (view jobs state) , "status" .= M.lookup ref (view jobs state)
] ]
loadConfig :: FilePath -> IO (Config True) loadConfig :: FilePath -> IO (Config True)
loadConfig path = do loadConfig path = do
res <- T.decodeFileEither configCodec path res <- T.decodeFileEither configCodec path
case res of case res of
Right config -> loadConfig' config Right config -> traverseOf orgs (mapM loadOrg) config
Left err -> do Left err -> error $ prettyTomlDecodeErrors err
print err where
exitFailure loadOrg :: Org False -> IO (Org True)
loadOrg org = do
loadConfig' :: Config False -> IO (Config True) lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
loadConfig' config = do Right c -> pure c
loaded <- LB.readFile (lintconfig config) >>= \res -> Left err -> error $ show err
case eitherDecode res :: Either String LintConfig' of pure $ org { orgLintconfig = lintconfig }
Left err -> error $ "config file invalid: " <> show err
Right file -> pure file
pure $ config { lintconfig = loaded }
setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO () setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO ()
......
...@@ -104,6 +104,7 @@ executable walint-server ...@@ -104,6 +104,7 @@ executable walint-server
, filepath , filepath
, http-types , http-types
, lucid , lucid
, microlens
, microlens-th , microlens-th
, mtl , mtl
, servant , servant
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment