internal state: sort according to org

(also, more lenses i guess)

1 files changed, 50 insertions, 14 deletions

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))