internal state: sort according to org

(also, more lenses i guess)

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