summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-rw-r--r--server/Handlers.hs19
-rw-r--r--server/HtmlOrphans.hs25
-rw-r--r--server/Main.hs13
-rw-r--r--server/Server.hs64
-rw-r--r--server/Worker.hs2
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