summaryrefslogtreecommitdiff
path: root/server/Handlers.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--server/Handlers.hs79
1 files changed, 39 insertions, 40 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