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

server: repositores & orgs fixed in config 

a very simple setup that might be usable for divoc and similar small events
parent ac81f4a1
Branches
No related tags found
No related merge requests found
Show whitespace changes
Inline Side-by-side
config.toml
+ 2
− 0
View file @ 3e002615
......@@ -5,6 +5,8 @@ verbose = true
tmpdir = "/tmp"
# linting interval in seconds
interval = 30
[[org]]
slug = "divoc"
......
package.yaml
+ 6
− 1
View file @ 3e002615
......@@ -74,8 +74,13 @@ executables:
- cli-git
- cli-extras
- extra
- uuid
- microlens
- microlens-th
- fmt
- tomland
- dotgen
- stm
- async
- cryptohash-sha1
- uuid
- base64-bytestring
server/Handlers.hs
+ 27
− 66
View file @ 3e002615
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Handlers (App
module Handlers (
-- , submitImpl
, statusImpl
statusImpl
-- , relintImpl
, adminOverviewImpl
, AdminOverview(..)
) where
import Universum
import Bindings.Cli.Git (gitProc)
import CheckDir (recursiveCheckDir)
import Cli.Extras (CliConfig, CliT, ProcessFailure,
Severity (..),
callProcessAndLogOutput, getCliConfig,
prettyProcessFailure, runCli)
import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.MVar (withMVar)
import Data.Aeson (ToJSON (..), (.=))
import qualified Data.Aeson as A
import qualified Data.Map as M
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, NoContent (NoContent),
err404, err500, throwError)
import Server (AdminOverview (AdminOverview),
Config, orgs, tmpdir,
JobStatus (..),
RemoteRef (reporef, repourl),
ServerState, jobs, registry,
setJobStatus, setRegistry, Org (..))
import System.Directory (doesDirectoryExist)
import System.FilePath ((</>))
-- | this servant app can run cli programs!
type App = CliT ProcessFailure Handler
import Servant (Handler, err404, throwError)
import Server (JobStatus (..), ServerState, Sha1,
unState)
-- | annoying (and afaik unused), but has to be here for type system reasons
instance MonadFail Handler where
fail _ = throwError err500
-- instance MonadFail Handler where
-- fail _ = throwError err500
-- -- | someone submitted a map; lint it (synchronously for now)
-- submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID
......@@ -66,48 +47,28 @@ instance MonadFail Handler where
-- _ <- checkRef config cliconfig state ref
-- pure NoContent
statusImpl :: MVar ServerState -> UUID -> App JobStatus
statusImpl state uuid = do
-- | an info type wrapped around the server state, to carry serialisation instances.
-- TODO: should probably not be defined here
newtype AdminOverview =
AdminOverview { unAdminOverview :: ServerState }
instance ToJSON AdminOverview where
toJSON (AdminOverview state) =
toJSON $ view unState state <&> \(ref, status) ->
A.object [ "remote" .= ref
, "status" .= status
]
statusImpl :: MVar ServerState -> Sha1 -> Handler JobStatus
statusImpl state sha1 = 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)
pure $ M.lookup sha1 (map snd $ view unState state)
case status of
Just res -> pure res
Nothing -> lift $ throwError err404
Nothing -> throwError err404
adminOverviewImpl :: MVar ServerState -> App AdminOverview
adminOverviewImpl :: MVar ServerState -> Handler AdminOverview
adminOverviewImpl state = do
state <- readMVar state
pure (AdminOverview state)
-- | 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 -> 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!
(callgit gitdir
[ "fetch", "origin", toString (reporef ref), "--depth", "1" ])
(callgit gitdir
[ "clone", toString $ repourl ref, "--bare"
, "--depth", "1", "-b", toString (reporef ref)])
rand <- liftIO UUID.nextRandom
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
callgit gitdir [ "worktree", "add", workdir ]
callgit workdir [ "checkout", toString (reporef ref) ]
res <- liftIO $ recursiveCheckDir (orgLintconfig org) workdir (orgEntrypoint org)
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 = view tmpdir config </> toString hashedname
hashedname = T.map escapeSlash . repourl $ ref
escapeSlash = \case { '/' -> '-'; a -> a }
server/HtmlOrphans.hs
+ 13
− 11
View file @ 3e002615
......@@ -19,18 +19,21 @@ import CheckDir (DirResult (..), MissingAsset (MissingAsset),
import CheckMap (MapResult (..))
import Data.List.Extra (escapeJSON)
import qualified Data.Map as M
import Handlers (AdminOverview (..))
import Lucid (HtmlT, ToHtml)
import Lucid.Base (ToHtml (toHtml))
import Lucid.Html5 (a_, body_, class_, code_, div_, em_, h1_, h2_,
h3_, h4_, h5_, head_, href_, html_, id_, li_,
link_, main_, p_, rel_, script_, span_, src_,
title_, type_, ul_)
import Server (AdminOverview (..), JobStatus (..),
RemoteRef (reporef, repourl), jobs, registry)
import Server (JobStatus (..), RemoteRef (reporef, repourl),
prettySha, unState)
import Text.Dot (showDot)
import Types (Hint (Hint), Level (..))
import Fmt
mono :: Monad m => HtmlT m () -> HtmlT m ()
mono = code_ [class_ "small text-muted"]
......@@ -59,16 +62,15 @@ instance ToHtml JobStatus where
instance ToHtml AdminOverview where
toHtml (AdminOverview state) = htmldoc $ do
h1_ "Map List"
if null (view registry state)
if null (view unState state)
then em_ "(nothing yet)"
else ul_ . flip M.foldMapWithKey (view registry state)
$ \uuid ref -> li_ $ do
case M.lookup ref (view jobs state) of
Just Pending -> badge Info "pending"
Just (Linted res) -> toHtml $ maximumLintLevel res
Just (Failed _) -> badge Error "system error"
Nothing -> toHtml Fatal
" "; a_ [href_ ("/status/"<>show uuid)] $ do
else ul_ . flip M.foldMapWithKey (view unState state) $
\sha1 (ref, status) -> li_ $ do
case status of
Pending -> badge Info "pending"
(Linted res) -> toHtml $ maximumLintLevel res
(Failed _) -> badge Error "system error"
" "; a_ [href_ ("/status/"+|prettySha sha1|+"/")] $ do
mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref
......
server/Main.hs
+ 60
− 62
View file @ 3e002615
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
......@@ -11,14 +12,16 @@ module Main where
import Universum
import Cli.Extras (CliConfig,
mkDefaultCliConfig,
runCli)
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.UUID (UUID)
import Handlers (App, adminOverviewImpl,
statusImpl,
)
import Cli.Extras (mkDefaultCliConfig)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, waitEither_)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO,
writeTQueue)
import qualified Data.Text as T
import Fmt ((+|), (|+))
import Handlers (AdminOverview,
adminOverviewImpl,
statusImpl)
import HtmlOrphans ()
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort)
......@@ -27,78 +30,68 @@ import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
RequestLoggerSettings (..),
mkRequestLogger)
import Servant (Application, Capture,
Get, Handler,
HasServer (ServerT),
JSON, NoContent, Post,
Raw, ReqBody,
ServerError (errBody),
err500, hoistServer,
serve, throwError,
type (:<|>) (..),
Get, JSON, Raw, Server,
serve, type (:<|>) (..),
type (:>))
import Servant.HTML.Lucid (HTML)
import Servant.Server.StaticFiles (serveDirectoryWebApp)
import Server (AdminOverview,
Config (..), JobStatus,
RemoteRef (..),
ServerState,
defaultState, loadConfig, verbose, port, orgs, Org (orgEntrypoint, orgRepos))
import Server (JobStatus, Org (..),
ServerState, Sha1,
defaultState, interval,
loadConfig, orgs, port,
verbose)
import Worker (Job (Job), linterThread)
-- | Main API type
type API format =
-- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
"status" :> Capture "jobid" UUID :> Get '[format] JobStatus
"status" :> Capture "jobid" Sha1 :> Get '[format] JobStatus
-- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
:<|> "admin" :> "overview" :> Get '[format] AdminOverview
type Routes =
"api" :> API JSON
:<|> "status" :> Capture "jobid" UUID :> Get '[HTML] JobStatus
:<|> "admin" :> "overview" :> Get '[HTML] AdminOverview
type Routes = "api" :> API JSON
:<|> API HTML -- websites mirror the API exactly
:<|> Raw
-- | API's implementation
jsonAPI :: Config True -> MVar ServerState -> ServerT (API JSON) App
jsonAPI config state =
-- submitImpl config state
statusImpl state
-- :<|> relintImpl config state
jsonAPI :: forall format. MVar ServerState -> Server (API format)
jsonAPI state = statusImpl state
:<|> adminOverviewImpl state
server :: Config True -> MVar ServerState -> ServerT Routes App
server config state =
jsonAPI config state
:<|> statusImpl state
:<|> adminOverviewImpl state
-- | Complete set of routes: API + HTML sites
server :: MVar ServerState -> Server Routes
server state = jsonAPI @JSON state
:<|> jsonAPI @HTML state
:<|> serveDirectoryWebApp "./static"
-- | make an application; convert any cli errors into a 500
app :: CliConfig -> Config True -> MVar ServerState -> Application
app cliconfig config =
serve api . hoistServer api conv . server config
where api = Proxy @Routes
conv :: App a -> Handler a
conv m = do
res <- runCli cliconfig m
case res of
Right a -> pure a
Left err -> throwError (err500 { errBody = C8.pack (show err) })
app :: MVar ServerState -> Application
app = serve (Proxy @Routes) . server
main :: IO ()
main = do
config <- loadConfig "./config.toml"
state <- newMVar defaultState
queue :: TQueue Job <- newTQueueIO
-- TODO: i really don't like all this cli logging stuff, replace it with
-- fast-logger at some point …
cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | view verbose config]
loggerMiddleware <- mkRequestLogger
$ def { outputFormat = Detailed (view verbose config) }
-- print (keys $ view orgs config)
print (map orgEntrypoint $ view orgs config)
print (map orgRepos $ view orgs config)
putTextLn "reading config …"
putTextLn $ T.concat $ map showInfo (view orgs config)
-- periodically ‘pokes’ jobs to re-lint each repo
poker <- async $ forever $ do
atomically $ forM_ (view orgs config) $ \org ->
forM_ (orgRepos org) $ \repo ->
writeTQueue queue (Job repo org)
-- microseconds for some reason
threadDelay (view interval config * 1000000)
-- spawns threads for each job in the queue
linter <- async $ void $ linterThread config cliconfig queue state
let warpsettings =
setPort (view port config)
......@@ -106,4 +99,9 @@ main = do
runSettings warpsettings
. loggerMiddleware
$ app cliconfig config state
$ app state
waitEither_ linter poker
where
showInfo org =
"→ org "+|orgSlug org|+" divoc ("+|length (orgRepos org)|+" repositoryies)\n" :: Text
server/Server.hs
+ 58
− 59
View file @ 3e002615
......@@ -5,38 +5,39 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
module Server ( loadConfig
, Org(..)
, Config, tmpdir, port, verbose, orgs
, Sha1
, Config, tmpdir, port, verbose, orgs, interval
, RemoteRef(..)
, ServerState, registry, jobs, defaultState
, ServerState, defaultState, unState
, JobStatus(..)
, setJobStatus
, setRegistry
, AdminOverview(..)
) where
, prettySha) where
import Universum
import CheckDir (DirResult)
import Control.Concurrent (modifyMVar_)
import Data.Aeson (FromJSON, ToJSON (toJSON),
(.=), eitherDecodeFileStrict')
import qualified Data.Aeson as A
import Crypto.Hash.SHA1
import Data.Aeson (FromJSON, ToJSON, ToJSONKey (..),
eitherDecodeFileStrict')
import qualified Data.ByteString.Base64.URL as Base64
import qualified Data.Map as M
import Data.UUID (UUID)
import Lens.Micro (traverseOf)
import Lens.Micro.TH
import LintConfig (LintConfig')
import Toml (TomlCodec, prettyTomlDecodeErrors)
import Servant (FromHttpApiData)
import Toml (TomlCodec, prettyTomlDecodeErrors,
(.=))
import qualified Toml as T
-- | a reference in a remote git repository
......@@ -49,6 +50,17 @@ type family ConfigRes (b :: Bool) a where
ConfigRes True a = a
ConfigRes False a = FilePath
newtype Sha1 = Sha1 Text
deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON)
-- | base64-encoded sha1
prettySha :: Sha1 -> Text
prettySha (Sha1 text) = text
instance ToJSONKey Sha1
toSha :: RemoteRef -> Sha1
toSha ref = Sha1 . decodeUtf8 . Base64.encode . hash . encodeUtf8 $ (show ref :: Text)
data Org (loaded :: Bool) = Org
{ orgSlug :: Text
......@@ -64,6 +76,7 @@ data Config (loaded :: Bool) = Config
-- ^ dir to clone git things in
, _port :: Int
, _verbose :: Bool
, _interval :: Int
-- ^ port to bind to
, _orgs :: [Org loaded]
} deriving Generic
......@@ -73,52 +86,42 @@ makeLenses ''Config
remoteCodec :: TomlCodec RemoteRef
remoteCodec = RemoteRef
<$> T.text "url" T..= repourl
<*> T.text "ref" T..= reporef
<$> T.text "url" .= repourl
<*> T.text "ref" .= 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
<$> T.text "slug" .= orgSlug
<*> T.string "lintconfig" .= orgLintconfig
<*> T.string "entrypoint" .= orgEntrypoint
<*> T.list remoteCodec "repo" .= orgRepos
configCodec :: TomlCodec (Config False)
configCodec = Config
<$> T.string "tmpdir" T..= _tmpdir
<*> T.int "port" T..= _port
<*> T.bool "verbose" T..= _verbose
<*> T.list orgCodec "org" T..= _orgs
<$> T.string "tmpdir" .= _tmpdir
<*> T.int "port" .= _port
<*> T.bool "verbose" .= _verbose
<*> T.int "interval" .= _interval
<*> T.list orgCodec "org" .= _orgs
-- | a job status (of a specific uuid)
data JobStatus =
Pending | Linted DirResult | Failed Text
deriving (Generic, ToJSON)
-- | the server's global state
data ServerState = ServerState
{ _jobs :: Map RemoteRef JobStatus
, _registry :: Map UUID RemoteRef
}
-- | the server's global state; might eventually end up with more
-- stuff in here, hence the newtype
newtype ServerState = ServerState
{ _unState :: Map Sha1 (RemoteRef, JobStatus) }
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 }
instance ToJSON AdminOverview where
toJSON (AdminOverview state) =
toJSON . flip M.mapWithKey (view registry state) $ \uuid ref ->
A.object [ "reference" .= uuid
, "remote" .= ref
, "status" .= M.lookup ref (view jobs state)
]
defaultState = ServerState mempty
-- | loads a config, along with all things linked in it
-- (e.g. linterconfigs for each org)
loadConfig :: FilePath -> IO (Config True)
loadConfig path = do
res <- T.decodeFileEither configCodec path
......@@ -136,8 +139,4 @@ loadConfig path = do
setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO ()
setJobStatus mvar !ref !status = modifyMVar_ mvar
$ pure . over jobs (M.insert ref status)
setRegistry :: MVar ServerState -> UUID -> RemoteRef -> IO ()
setRegistry mvar !uuid !ref = modifyMVar_ mvar
$ pure . over registry (M.insert uuid ref)
$ pure . over unState (M.insert (toSha ref) (ref, status))
server/Worker.hs 0 → 100644
+ 73
− 0
View file @ 3e002615
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Worker (linterThread, Job(..)) where
import Universum
import Bindings.Cli.Git (gitProc)
import CheckDir (recursiveCheckDir)
import Cli.Extras (CliConfig, ProcessFailure,
Severity (..),
callProcessAndLogOutput,
prettyProcessFailure, runCli)
import Control.Concurrent.Async (async, link)
import Control.Concurrent.STM.TQueue
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Server (Config, JobStatus (..),
Org (..),
RemoteRef (reporef, repourl),
ServerState, setJobStatus,
tmpdir)
import System.Directory (doesDirectoryExist)
import System.FilePath ((</>))
data Job = Job
{ jobRef :: RemoteRef
, jobOrg :: Org True
}
linterThread :: Config True -> CliConfig -> TQueue Job -> MVar ServerState -> IO Void
linterThread config cliconfig queue done = forever $ do
next <- atomically (readTQueue queue)
-- TODO: this doesn't guard against two jobs running on the same repo!
job <- async $ runJob config next cliconfig done
link job -- TODO: is this a good idea? will crash the server if a job fails
-- | 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
runJob :: Config True -> Job -> CliConfig -> MVar ServerState -> IO (Either ProcessFailure ())
runJob config Job {..} cliconfig done = runCli cliconfig $ do
res <- liftIO $ runCli cliconfig $ do
ifM (liftIO $ doesDirectoryExist gitdir)
-- TODO: these calls fail for dumb http, add some fallback!
(callgit gitdir
[ "fetch", "origin", toString ref, "--depth", "1" ])
(callgit gitdir
[ "clone", toString ref, "--bare"
, "--depth", "1", "-b", toString ref])
rand <- liftIO UUID.nextRandom
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
callgit gitdir [ "worktree", "add", workdir ]
callgit workdir [ "checkout", toString ref ]
res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
pure res
liftIO $ setJobStatus done jobRef $ case res of
Right res -> Linted res
Left err -> Failed (prettyProcessFailure err)
where
url = repourl jobRef
ref = reporef jobRef
callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
gitdir = view tmpdir config </> toString hashedname
hashedname = T.map escapeSlash url
where escapeSlash = \case { '/' -> '-'; a -> a }
walint.cabal
+ 6
− 0
View file @ 3e002615
......@@ -84,6 +84,7 @@ executable walint-server
Handlers
HtmlOrphans
Server
Worker
Paths_walint
hs-source-dirs:
server
......@@ -92,16 +93,20 @@ executable walint-server
ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
build-depends:
aeson
, async
, base
, base-compat
, base64-bytestring
, bytestring
, cli-extras
, cli-git
, containers
, cryptohash-sha1
, directory
, dotgen
, extra
, filepath
, fmt
, http-types
, lucid
, microlens
......@@ -110,6 +115,7 @@ executable walint-server
, servant
, servant-lucid
, servant-server
, stm
, text
, time
, tomland
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment

Impressum - Datenschutzerklärung