From ff8eeb131db9e9a0d9d3cef60ddcaa83692fb62c Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 16 Feb 2022 16:57:49 +0100
Subject: server: add mapservice GET endpoint

---
 server/Handlers.hs | 79 +++++++++++++++++++++++++++---------------------------
 1 file changed, 39 insertions(+), 40 deletions(-)

(limited to 'server/Handlers.hs')

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
-- 
cgit v1.2.3