summaryrefslogtreecommitdiff
path: root/server/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to 'server/Server.hs')
-rw-r--r--server/Server.hs64
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))