From 662a01a74a13979830dacf1dc8c18161040f32cc Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 16 Feb 2022 03:07:35 +0100 Subject: server: repositores & orgs fixed in config a very simple setup that might be usable for divoc and similar small events --- server/Main.hs | 122 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 60 insertions(+), 62 deletions(-) (limited to 'server/Main.hs') 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 -- cgit v1.2.3