diff options
Diffstat (limited to '')
| -rw-r--r-- | server/Handlers.hs | 93 | ||||
| -rw-r--r-- | server/HtmlOrphans.hs | 24 | ||||
| -rw-r--r-- | server/Main.hs | 122 | ||||
| -rw-r--r-- | server/Server.hs | 117 | ||||
| -rw-r--r-- | server/Worker.hs | 73 |
5 files changed, 231 insertions, 198 deletions
diff --git a/server/Handlers.hs b/server/Handlers.hs index afbb2b9..cb714d9 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -1,47 +1,28 @@ {-# 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 } - diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs index 4d03234..8b2df52 100644 --- a/server/HtmlOrphans.hs +++ b/server/HtmlOrphans.hs @@ -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 diff --git a/server/Main.hs b/server/Main.hs index 04a2010..02f7ed3 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | simple server offering linting "as a service" @@ -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 - :<|> Raw +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 - :<|> adminOverviewImpl state - -server :: Config True -> MVar ServerState -> ServerT Routes App -server config state = - jsonAPI config state - :<|> statusImpl state - :<|> adminOverviewImpl 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) }) +jsonAPI :: forall format. MVar ServerState -> Server (API format) +jsonAPI 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" + +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 diff --git a/server/Server.hs b/server/Server.hs index bdfa77f..e392f89 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -5,39 +5,40 @@ {-# 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 qualified Data.Map as M -import Data.UUID (UUID) -import Lens.Micro (traverseOf) +import CheckDir (DirResult) +import Control.Concurrent (modifyMVar_) +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 Lens.Micro (traverseOf) import Lens.Micro.TH -import LintConfig (LintConfig') -import Toml (TomlCodec, prettyTomlDecodeErrors) -import qualified Toml as T +import LintConfig (LintConfig') +import Servant (FromHttpApiData) +import Toml (TomlCodec, prettyTomlDecodeErrors, + (.=)) +import qualified Toml as T -- | a reference in a remote git repository data RemoteRef = RemoteRef @@ -49,23 +50,35 @@ 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 + { orgSlug :: Text , orgLintconfig :: ConfigRes loaded LintConfig' , orgEntrypoint :: FilePath - , orgRepos :: [RemoteRef] + , 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 + , _interval :: Int -- ^ port to bind to - , _orgs :: [Org loaded] + , _orgs :: [Org loaded] } deriving Generic makeLenses ''Config @@ -73,71 +86,57 @@ 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 case res of Right config -> traverseOf orgs (mapM loadOrg) config - Left err -> error $ prettyTomlDecodeErrors err + Left err -> error $ prettyTomlDecodeErrors err where loadOrg :: Org False -> IO (Org True) loadOrg org = do lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case - Right c -> pure c + Right c -> pure c Left err -> error $ show err pure $ org { orgLintconfig = lintconfig } 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)) diff --git a/server/Worker.hs b/server/Worker.hs new file mode 100644 index 0000000..7609d48 --- /dev/null +++ b/server/Worker.hs @@ -0,0 +1,73 @@ +{-# 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 } |