diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Handlers.hs | 19 | ||||
| -rw-r--r-- | server/HtmlOrphans.hs | 25 | ||||
| -rw-r--r-- | server/Main.hs | 13 | ||||
| -rw-r--r-- | server/Server.hs | 64 | ||||
| -rw-r--r-- | server/Worker.hs | 2 |
5 files changed, 82 insertions, 41 deletions
diff --git a/server/Handlers.hs b/server/Handlers.hs index cb714d9..a4ddab4 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -8,7 +8,7 @@ module Handlers ( -- , relintImpl , adminOverviewImpl , AdminOverview(..) - ) where + ,MapService(..)) where import Universum @@ -18,7 +18,7 @@ import qualified Data.Aeson as A import qualified Data.Map as M import Servant (Handler, err404, throwError) import Server (JobStatus (..), ServerState, Sha1, - unState) + getJobStatus, unState) -- | annoying (and afaik unused), but has to be here for type system reasons -- instance MonadFail Handler where @@ -48,23 +48,24 @@ import Server (JobStatus (..), ServerState, Sha1, -- pure NoContent -- | an info type wrapped around the server state, to carry serialisation instances. --- TODO: should probably not be defined here newtype AdminOverview = AdminOverview { unAdminOverview :: ServerState } +newtype MapService = + MapService { unMapService :: ServerState } + instance ToJSON AdminOverview where toJSON (AdminOverview state) = - toJSON $ view unState state <&> \(ref, status) -> + toJSON $ view unState state <&> \org -> flip map org $ \(ref, status) -> A.object [ "remote" .= ref , "status" .= status ] -statusImpl :: MVar ServerState -> Sha1 -> Handler JobStatus -statusImpl state sha1 = do - status <- liftIO $ withMVar state $ \state -> - pure $ M.lookup sha1 (map snd $ view unState state) +statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler JobStatus +statusImpl state orgslug sha1 = do + status <- liftIO $ getJobStatus state orgslug sha1 case status of - Just res -> pure res + Just res -> pure $ snd res Nothing -> throwError err404 diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs index 8b2df52..0472f24 100644 --- a/server/HtmlOrphans.hs +++ b/server/HtmlOrphans.hs @@ -26,8 +26,9 @@ 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 (JobStatus (..), RemoteRef (reporef, repourl), - prettySha, unState) +import Server (JobStatus (..), Org (orgSlug), + RemoteRef (reporef, repourl), prettySha, + unState) import Text.Dot (showDot) import Types (Hint (Hint), Level (..)) @@ -62,16 +63,16 @@ instance ToHtml JobStatus where instance ToHtml AdminOverview where toHtml (AdminOverview state) = htmldoc $ do h1_ "Map List" - if null (view unState state) - then em_ "(nothing yet)" - 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 + flip M.foldMapWithKey (view unState state) $ \org jobs -> do + h2_ (toHtml $ orgSlug org) + if null jobs then em_ "(nothing yet)" + else flip M.foldMapWithKey jobs $ \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/"+|orgSlug org|+"/"+|prettySha sha1|+"/")] $ do + mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref badge :: Monad m => Level -> HtmlT m () -> HtmlT m () diff --git a/server/Main.hs b/server/Main.hs index 02f7ed3..0d5dfd6 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -37,19 +37,20 @@ import Servant.HTML.Lucid (HTML) import Servant.Server.StaticFiles (serveDirectoryWebApp) import Server (JobStatus, Org (..), ServerState, Sha1, - defaultState, interval, + emptyState, interval, loadConfig, orgs, port, - verbose) + unState, verbose) import Worker (Job (Job), linterThread) --- | Main API type +-- | abstract api type API format = -- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID - "status" :> Capture "jobid" Sha1 :> Get '[format] JobStatus + "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] JobStatus -- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent :<|> "admin" :> "overview" :> Get '[format] AdminOverview +-- | actual set of routes: api for json & html + static pages from disk type Routes = "api" :> API JSON :<|> API HTML -- websites mirror the API exactly :<|> Raw @@ -71,7 +72,7 @@ app = serve (Proxy @Routes) . server main :: IO () main = do config <- loadConfig "./config.toml" - state <- newMVar defaultState + state <- newMVar (emptyState config) queue :: TQueue Job <- newTQueueIO -- TODO: i really don't like all this cli logging stuff, replace it with -- fast-logger at some point … @@ -84,6 +85,8 @@ main = do -- periodically ‘pokes’ jobs to re-lint each repo poker <- async $ forever $ do + readMVar state >>= \state -> + print (length $ view unState state) atomically $ forM_ (view orgs config) $ \org -> forM_ (orgRepos org) $ \repo -> writeTQueue queue (Job repo org) diff --git a/server/Server.hs b/server/Server.hs index e392f89..77eebbc 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -7,8 +7,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -18,22 +21,24 @@ module Server ( loadConfig , Sha1 , Config, tmpdir, port, verbose, orgs, interval , RemoteRef(..) - , ServerState, defaultState, unState + , ServerState, emptyState, unState , JobStatus(..) , setJobStatus - , prettySha) where + , prettySha,getJobStatus) where import Universum import CheckDir (DirResult) -import Control.Concurrent (modifyMVar_) -import Crypto.Hash.SHA1 +import Control.Concurrent (modifyMVar_, withMVar) +import Crypto.Hash.SHA1 (hash) import Data.Aeson (FromJSON, ToJSON, ToJSONKey (..), eitherDecodeFileStrict') +import qualified Data.Aeson as A import qualified Data.ByteString.Base64.URL as Base64 +import Data.Functor.Contravariant (contramap) import qualified Data.Map as M -import Lens.Micro (traverseOf) -import Lens.Micro.TH +import Lens.Micro.Platform (at, ix, makeLenses, traverseOf, + traversed) import LintConfig (LintConfig') import Servant (FromHttpApiData) import Toml (TomlCodec, prettyTomlDecodeErrors, @@ -50,6 +55,7 @@ type family ConfigRes (b :: Bool) a where ConfigRes True a = a ConfigRes False a = FilePath +-- | the internal text is actually already base64-encoded newtype Sha1 = Sha1 Text deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON) @@ -60,15 +66,37 @@ prettySha (Sha1 text) = text instance ToJSONKey Sha1 toSha :: RemoteRef -> Sha1 -toSha ref = Sha1 . decodeUtf8 . Base64.encode . hash . encodeUtf8 $ (show ref :: Text) +toSha ref = Sha1 + . decodeUtf8 + . Base64.encode + . hash + . encodeUtf8 + $ (show ref :: Text) data Org (loaded :: Bool) = Org { orgSlug :: Text , orgLintconfig :: ConfigRes loaded LintConfig' , orgEntrypoint :: FilePath , orgRepos :: [RemoteRef] - } + } deriving Generic + +-- | Orgs are compared via their slugs only +-- TODO: the server should probably refuse to start if two orgs have the +-- same slug … (or really the toml format shouldn't allow that syntactically) +instance Eq (Org True) where + a == b = orgSlug a == orgSlug b + +instance Ord (Org True) where + a <= b = orgSlug a <= orgSlug b +-- this instance exists since it's required for ToJSONKey, +-- but it shouldn't really be used +instance ToJSON (Org True) where + toJSON Org { .. } = A.object [ "slug" A..= orgSlug ] + +-- orgs used as keys just reduce to their slug +instance ToJSONKey (Org True) where + toJSONKey = contramap orgSlug (toJSONKey @Text) -- | the server's configuration data Config (loaded :: Bool) = Config @@ -113,12 +141,15 @@ data JobStatus = -- | 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) } + { _unState :: Map (Org True) (Map Sha1 (RemoteRef, JobStatus)) } makeLenses ''ServerState -defaultState :: ServerState -defaultState = ServerState mempty +-- | the inital state must already contain empty orgs, since setJobStatus +-- will default to a noop otherwise +emptyState :: Config True -> ServerState +emptyState config = ServerState + $ M.fromList $ map (, mempty) (view orgs config) -- | loads a config, along with all things linked in it -- (e.g. linterconfigs for each org) @@ -137,6 +168,11 @@ loadConfig path = do pure $ org { orgLintconfig = lintconfig } -setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO () -setJobStatus mvar !ref !status = modifyMVar_ mvar - $ pure . over unState (M.insert (toSha ref) (ref, status)) +-- | NOTE: this does not create the org if it does not yet exist! +setJobStatus :: MVar ServerState -> Org True -> RemoteRef -> JobStatus -> IO () +setJobStatus mvar !org !ref !status = modifyMVar_ mvar + $ pure . over (unState . ix org . at (toSha ref)) (const $ Just (ref, status)) + +getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (RemoteRef, JobStatus)) +getJobStatus mvar orgslug sha = withMVar mvar $ \state -> + pure (M.lookup sha (view (unState . ix (Org { orgSlug = orgslug })) state)) diff --git a/server/Worker.hs b/server/Worker.hs index 7609d48..1672026 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -61,7 +61,7 @@ runJob config Job {..} cliconfig done = runCli cliconfig $ do res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg) callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ] pure res - liftIO $ setJobStatus done jobRef $ case res of + liftIO $ setJobStatus done jobOrg jobRef $ case res of Right res -> Linted res Left err -> Failed (prettyProcessFailure err) where |