server: add mapservice GET endpoint

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