diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Handlers.hs | 79 | ||||
| -rw-r--r-- | server/HtmlOrphans.hs | 8 | ||||
| -rw-r--r-- | server/Main.hs | 13 | ||||
| -rw-r--r-- | server/Server.hs | 16 | ||||
| -rw-r--r-- | server/Worker.hs | 12 |
5 files changed, 71 insertions, 57 deletions
diff --git a/server/Handlers.hs b/server/Handlers.hs index a4ddab4..719b475 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -1,56 +1,36 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Handlers ( -- , submitImpl statusImpl -- , relintImpl - , adminOverviewImpl + , stateImpl , AdminOverview(..) ,MapService(..)) where import Universum -import Control.Concurrent.MVar (withMVar) -import Data.Aeson (ToJSON (..), (.=)) -import qualified Data.Aeson as A -import qualified Data.Map as M -import Servant (Handler, err404, throwError) -import Server (JobStatus (..), ServerState, Sha1, - getJobStatus, unState) - --- | annoying (and afaik unused), but has to be here for type system reasons --- instance MonadFail Handler where --- fail _ = throwError err500 - --- -- | someone submitted a map; lint it (synchronously for now) --- submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID --- submitImpl config state ref = do --- jobid <- liftIO UUID.nextRandom --- -- TODO: these two should really be atomic --- liftIO $ setJobStatus state ref Pending --- liftIO $ setRegistry state jobid ref --- cliconfig <- getCliConfig --- -- we'll just forget the thread id for now and trust this terminates … --- _ <- checkRef config cliconfig state ref --- -- the submission itself can't really fail or return anything useful --- pure jobid - --- relintImpl :: Config True -> MVar ServerState -> UUID -> App NoContent --- relintImpl config state uuid = do --- mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry) --- case mref of --- Nothing -> lift $ throwError err404 --- Just ref -> do --- cliconfig <- getCliConfig --- _ <- checkRef config cliconfig state ref --- pure NoContent +import CheckDir (DirResult (dirresultMaps)) +import CheckMap (MapResult (MapResult, mapresultBadges)) +import Data.Aeson (ToJSON (..), (.=)) +import qualified Data.Aeson as A +import qualified Data.Aeson.Key as A +import Data.Coerce (coerce) +import qualified Data.Map as M +import Servant (Handler, err404, throwError) +import Server (JobStatus (..), Org (orgUrl), + RemoteRef (RemoteRef, reponame), ServerState, + Sha1, getJobStatus, unState) -- | an info type wrapped around the server state, to carry serialisation instances. newtype AdminOverview = AdminOverview { unAdminOverview :: ServerState } + newtype MapService = MapService { unMapService :: ServerState } @@ -61,6 +41,23 @@ instance ToJSON AdminOverview where , "status" .= status ] +instance ToJSON MapService where + toJSON (MapService state) = + toJSON $ M.mapWithKey orgObject (view unState state) + where + orgObject org = A.object . mapMaybe worldObject . M.elems + where + worldObject (RemoteRef {..}, job) = case job of + Linted res rev -> + Just (A.fromText reponame .= + M.mapWithKey (mapInfo rev) (dirresultMaps res)) + _ -> Nothing + mapInfo rev mappath MapResult { .. } = A.object + [ "badges" .= mapresultBadges + , "url" .= (orgUrl org <> rev <> "/" <> toText mappath) ] + + + statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler JobStatus statusImpl state orgslug sha1 = do status <- liftIO $ getJobStatus state orgslug sha1 @@ -68,8 +65,10 @@ statusImpl state orgslug sha1 = do Just res -> pure $ snd res Nothing -> throwError err404 - -adminOverviewImpl :: MVar ServerState -> Handler AdminOverview -adminOverviewImpl state = do - state <- readMVar state - pure (AdminOverview state) +-- | since there are multiple apis that just get state information … +stateImpl + :: forall s + . Coercible s ServerState + => MVar ServerState + -> Handler s +stateImpl state = readMVar state <&> coerce diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs index 0472f24..c9fa852 100644 --- a/server/HtmlOrphans.hs +++ b/server/HtmlOrphans.hs @@ -52,7 +52,7 @@ instance ToHtml JobStatus where Pending -> do h1_ "Pending …" p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)" - Linted res -> do + Linted res _rev -> do h1_ "Linter Result" toHtml res Failed err -> do @@ -68,9 +68,9 @@ instance ToHtml AdminOverview where 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" + Pending -> badge Info "pending" + (Linted res rev) -> 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 diff --git a/server/Main.hs b/server/Main.hs index 0d5dfd6..8b41c92 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -19,9 +19,9 @@ import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue) import qualified Data.Text as T import Fmt ((+|), (|+)) -import Handlers (AdminOverview, - adminOverviewImpl, - statusImpl) +import Handlers (AdminOverview (AdminOverview), + MapService (MapService), + stateImpl, statusImpl) import HtmlOrphans () import Network.Wai.Handler.Warp (defaultSettings, runSettings, setPort) @@ -43,6 +43,9 @@ import Server (JobStatus, Org (..), import Worker (Job (Job), linterThread) +-- | that thing we need to replace the hub +type MapServiceAPI = "api" :> "maps" :> "list" :> Get '[JSON] MapService + -- | abstract api type API format = -- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID @@ -52,17 +55,19 @@ type API format = -- | actual set of routes: api for json & html + static pages from disk type Routes = "api" :> API JSON + :<|> MapServiceAPI :<|> API HTML -- websites mirror the API exactly :<|> Raw -- | API's implementation jsonAPI :: forall format. MVar ServerState -> Server (API format) jsonAPI state = statusImpl state - :<|> adminOverviewImpl state + :<|> stateImpl @AdminOverview state -- | Complete set of routes: API + HTML sites server :: MVar ServerState -> Server Routes server state = jsonAPI @JSON state + :<|> stateImpl @MapService state :<|> jsonAPI @HTML state :<|> serveDirectoryWebApp "./static" diff --git a/server/Server.hs b/server/Server.hs index 77eebbc..bcb96a0 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -37,8 +37,7 @@ 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.Platform (at, ix, makeLenses, traverseOf, - traversed) +import Lens.Micro.Platform (at, ix, makeLenses, traverseOf) import LintConfig (LintConfig') import Servant (FromHttpApiData) import Toml (TomlCodec, prettyTomlDecodeErrors, @@ -47,8 +46,10 @@ import qualified Toml as T -- | a reference in a remote git repository data RemoteRef = RemoteRef - { repourl :: Text - , reporef :: Text + { repourl :: Text + , reporef :: Text + , reponame :: Text + -- ^ the "world name" for the hub / world:// links } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show) type family ConfigRes (b :: Bool) a where @@ -78,6 +79,8 @@ data Org (loaded :: Bool) = Org , orgLintconfig :: ConfigRes loaded LintConfig' , orgEntrypoint :: FilePath , orgRepos :: [RemoteRef] + , orgUrl :: Text + , orgWebdir :: Text } deriving Generic -- | Orgs are compared via their slugs only @@ -116,6 +119,7 @@ remoteCodec :: TomlCodec RemoteRef remoteCodec = RemoteRef <$> T.text "url" .= repourl <*> T.text "ref" .= reporef + <*> T.text "name" .= reponame orgCodec :: TomlCodec (Org False) orgCodec = Org @@ -123,6 +127,8 @@ orgCodec = Org <*> T.string "lintconfig" .= orgLintconfig <*> T.string "entrypoint" .= orgEntrypoint <*> T.list remoteCodec "repo" .= orgRepos + <*> T.text "url" .= orgUrl + <*> T.text "webdir" .= orgWebdir configCodec :: TomlCodec (Config False) @@ -135,7 +141,7 @@ configCodec = Config -- | a job status (of a specific uuid) data JobStatus = - Pending | Linted DirResult | Failed Text + Pending | Linted DirResult Text | Failed Text deriving (Generic, ToJSON) -- | the server's global state; might eventually end up with more diff --git a/server/Worker.hs b/server/Worker.hs index 1672026..40a267b 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -13,7 +13,8 @@ import CheckDir (recursiveCheckDir) import Cli.Extras (CliConfig, ProcessFailure, Severity (..), callProcessAndLogOutput, - prettyProcessFailure, runCli) + prettyProcessFailure, + readProcessAndLogStderr, runCli) import Control.Concurrent.Async (async, link) import Control.Concurrent.STM.TQueue import qualified Data.Text as T @@ -54,16 +55,19 @@ runJob config Job {..} cliconfig done = runCli cliconfig $ do (callgit gitdir [ "clone", toString ref, "--bare" , "--depth", "1", "-b", toString ref]) + rev <- map T.strip -- git returns a newline here + $ readProcessAndLogStderr Error + $ gitProc gitdir ["rev-parse", 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 + pure (res, rev) liftIO $ setJobStatus done jobOrg jobRef $ case res of - Right res -> Linted res - Left err -> Failed (prettyProcessFailure err) + Right thing -> uncurry Linted thing + Left err -> Failed (prettyProcessFailure err) where url = repourl jobRef ref = reporef jobRef |