Spar Polysemy: In-memory interpreters

changelog.d/5-internal/in-mem-interpreters

@@ -0,0 +1 @@
+Add in-memory interpreters for most Spar effects

libs/wire-api/src/Wire/API/Cookie.hs

@@ -36,6 +36,7 @@ instance ToParamSchema SetBindCookie where
   toParamSchema _ = toParamSchema (Proxy @String)
 
 newtype BindCookie = BindCookie {fromBindCookie :: ST}
+  deriving (Eq, Ord)
 
 instance ToParamSchema BindCookie where
   toParamSchema _ = toParamSchema (Proxy @String)

libs/wire-api/src/Wire/API/User/Scim.hs

@@ -108,7 +108,7 @@ userSchemas =
 --
 -- For SCIM authentication and token handling logic, see "Spar.Scim.Auth".
 newtype ScimToken = ScimToken {fromScimToken :: Text}
-  deriving (Eq, Show, FromJSON, ToJSON, FromByteString, ToByteString)
+  deriving (Eq, Ord, Show, FromJSON, ToJSON, FromByteString, ToByteString)
 
 newtype ScimTokenHash = ScimTokenHash {fromScimTokenHash :: Text}
   deriving (Eq, Show)

services/spar/spar.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: f787f064cceffbeeef6ac5c1ca7475e519a51afc3fdd173bf7a7a86a9016b238
+-- hash: 34138a2c7fa249191ae03bc1581a7c95c94b12080f104da084a9bc37ac54c9ad
 
 name:           spar
 version:        0.1
@@ -38,14 +38,18 @@ library
       Spar.Scim.User
       Spar.Sem.AReqIDStore
       Spar.Sem.AReqIDStore.Cassandra
+      Spar.Sem.AReqIDStore.Mem
       Spar.Sem.AssIDStore
       Spar.Sem.AssIDStore.Cassandra
+      Spar.Sem.AssIDStore.Mem
       Spar.Sem.BindCookieStore
       Spar.Sem.BindCookieStore.Cassandra
+      Spar.Sem.BindCookieStore.Mem
       Spar.Sem.BrigAccess
       Spar.Sem.BrigAccess.Http
       Spar.Sem.DefaultSsoCode
       Spar.Sem.DefaultSsoCode.Cassandra
+      Spar.Sem.DefaultSsoCode.Mem
       Spar.Sem.GalleyAccess
       Spar.Sem.GalleyAccess.Http
       Spar.Sem.IdP
@@ -57,6 +61,7 @@ library
       Spar.Sem.Logger
       Spar.Sem.Logger.TinyLog
       Spar.Sem.Now
+      Spar.Sem.Now.Input
       Spar.Sem.Now.IO
       Spar.Sem.Random
       Spar.Sem.Random.IO
@@ -68,14 +73,19 @@ library
       Spar.Sem.SamlProtocolSettings.Servant
       Spar.Sem.SAMLUserStore
       Spar.Sem.SAMLUserStore.Cassandra
+      Spar.Sem.SAMLUserStore.Mem
       Spar.Sem.ScimExternalIdStore
       Spar.Sem.ScimExternalIdStore.Cassandra
+      Spar.Sem.ScimExternalIdStore.Mem
       Spar.Sem.ScimTokenStore
       Spar.Sem.ScimTokenStore.Cassandra
+      Spar.Sem.ScimTokenStore.Mem
       Spar.Sem.ScimUserTimesStore
       Spar.Sem.ScimUserTimesStore.Cassandra
+      Spar.Sem.ScimUserTimesStore.Mem
       Spar.Sem.VerdictFormatStore
       Spar.Sem.VerdictFormatStore.Cassandra
+      Spar.Sem.VerdictFormatStore.Mem
   other-modules:
       Paths_spar
   hs-source-dirs:

services/spar/src/Spar/Sem/AReqIDStore/Mem.hs

@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Spar.Sem.AReqIDStore.Mem where
+
+import qualified Data.Map as M
+import Imports
+import Polysemy
+import Polysemy.State
+import qualified SAML2.WebSSO.Types as SAML
+import Spar.Sem.AReqIDStore
+import Spar.Sem.Now
+import Wire.API.User.Saml (AReqId)
+
+aReqIDStoreToMem ::
+  Member Now r =>
+  Sem (AReqIDStore ': r) a ->
+  Sem r (Map AReqId SAML.Time, a)
+aReqIDStoreToMem = (runState mempty .) $
+  reinterpret $ \case
+    Store areqid ti -> modify $ M.insert areqid ti
+    UnStore areqid -> modify $ M.delete areqid
+    IsAlive areqid ->
+      gets (M.lookup areqid) >>= \case
+        Just time -> do
+          boolTTL False True time
+        Nothing -> pure False

services/spar/src/Spar/Sem/AssIDStore/Mem.hs

@@ -0,0 +1,25 @@
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Spar.Sem.AssIDStore.Mem where
+
+import qualified Data.Map as M
+import Imports
+import Polysemy
+import Polysemy.State
+import qualified SAML2.WebSSO.Types as SAML
+import Spar.Sem.AssIDStore
+import Spar.Sem.Now
+import Wire.API.User.Saml (AssId)
+
+assIdStoreToMem ::
+  Member Now r =>
+  Sem (AssIDStore ': r) a ->
+  Sem r (Map AssId SAML.Time, a)
+assIdStoreToMem = (runState mempty .) $
+  reinterpret $ \case
+    Store assid ti -> modify $ M.insert assid ti
+    UnStore assid -> modify $ M.delete assid
+    IsAlive assid ->
+      gets (M.lookup assid) >>= \case
+        Just time -> boolTTL False True time
+        Nothing -> pure False

services/spar/src/Spar/Sem/BindCookieStore/Mem.hs

@@ -0,0 +1,28 @@
+module Spar.Sem.BindCookieStore.Mem where
+
+import Data.Id (UserId)
+import qualified Data.Map as M
+import Data.String.Conversions (cs)
+import Imports
+import Polysemy
+import Polysemy.State
+import SAML2.WebSSO
+import qualified SAML2.WebSSO.Cookie as SAML
+import qualified SAML2.WebSSO.Types as SAML
+import Spar.Sem.BindCookieStore
+import Spar.Sem.Now
+import qualified Spar.Sem.Now as Now
+import qualified Web.Cookie as Cky
+import Wire.API.Cookie
+
+bindCookieStoreToMem :: Member Now r => Sem (BindCookieStore ': r) a -> Sem r (Map BindCookie (SAML.Time, UserId), a)
+bindCookieStoreToMem = (runState mempty .) $
+  reinterpret $ \case
+    Insert sbc uid ndt -> do
+      let ckyval = BindCookie . cs . Cky.setCookieValue . SAML.fromSimpleSetCookie . getSimpleSetCookie $ sbc
+      now <- Now.get
+      modify $ M.insert ckyval (addTime ndt now, uid)
+    Lookup bc -> do
+      gets (M.lookup bc) >>= \case
+        Just (time, uid) -> boolTTL Nothing (Just uid) time
+        Nothing -> pure Nothing

services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs

@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Spar.Sem.DefaultSsoCode.Mem where
+
+import Imports
+import Polysemy
+import Polysemy.State (get, put, runState)
+import qualified SAML2.WebSSO as SAML
+import Spar.Sem.DefaultSsoCode (DefaultSsoCode (..))
+
+defaultSsoCodeToMem :: Sem (DefaultSsoCode ': r) a -> Sem r (Maybe SAML.IdPId, a)
+defaultSsoCodeToMem = (runState Nothing .) $
+  reinterpret $ \case
+    Get -> get
+    Store ipi -> put $ Just ipi
+    Delete -> put Nothing

services/spar/src/Spar/Sem/Now.hs

@@ -1,9 +1,23 @@
 module Spar.Sem.Now where
 
+import Imports
 import Polysemy
 import qualified SAML2.WebSSO as SAML
 
 data Now m a where
   Get :: Now m SAML.Time
 
 makeSem ''Now
+
+-- | Check a time against 'Now', checking if it's still alive (hasn't occurred yet.)
+boolTTL ::
+  Member Now r =>
+  -- | The value to return if the TTL is expired
+  a ->
+  -- | The value to return if the TTL is alive
+  a ->
+  SAML.Time -> -- The time to check
+  Sem r a
+boolTTL f t time = do
+  now <- get
+  pure $ bool f t $ now <= time

services/spar/src/Spar/Sem/Now/Input.hs

@@ -0,0 +1,14 @@
+module Spar.Sem.Now.Input where
+
+import Imports
+import Polysemy
+import Polysemy.Input
+import qualified SAML2.WebSSO as SAML
+import Spar.Sem.Now
+
+nowToInput ::
+  Member (Input SAML.Time) r =>
+  Sem (Now ': r) a ->
+  Sem r a
+nowToInput = interpret $ \case
+  Get -> input

services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs

@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Spar.Sem.SAMLUserStore.Mem where
+
+import Control.Lens (view)
+import Data.Coerce (coerce)
+import Data.Id
+import qualified Data.Map as M
+import Imports
+import Polysemy
+import Polysemy.State (gets, modify, runState)
+import SAML2.WebSSO (uidTenant)
+import qualified SAML2.WebSSO as SAML
+import Spar.Sem.SAMLUserStore
+
+newtype UserRefOrd = UserRefOrd {unUserRefOrd :: SAML.UserRef}
+  deriving (Eq)
+
+instance Ord UserRefOrd where
+  compare (UserRefOrd (SAML.UserRef is ni)) (UserRefOrd (SAML.UserRef is' ni')) =
+    compare is is' <> compare ni ni'
+
+samlUserStoreToMem :: Sem (SAMLUserStore ': r) a -> Sem r (Map UserRefOrd UserId, a)
+samlUserStoreToMem = (runState @(Map UserRefOrd UserId) mempty .) $
+  reinterpret $ \case
+    Insert ur uid -> modify $ M.insert (UserRefOrd ur) uid
+    Get ur -> gets $ M.lookup $ UserRefOrd ur
+    GetAnyByIssuer is -> gets $ fmap snd . find (eqIssuer is . fst) . M.toList
+    GetSomeByIssuer is -> gets $ coerce . filter (eqIssuer is . fst) . M.toList
+    DeleteByIssuer is -> modify $ M.filterWithKey (\ref _ -> not $ eqIssuer is ref)
+    Delete _uid ur -> modify $ M.delete $ UserRefOrd ur
+  where
+    eqIssuer :: SAML.Issuer -> UserRefOrd -> Bool
+    eqIssuer is = (== is) . view uidTenant . unUserRefOrd

services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs

@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Spar.Sem.ScimExternalIdStore.Mem where
+
+import Data.Id (TeamId, UserId)
+import qualified Data.Map as M
+import Imports
+import Polysemy
+import Polysemy.State
+import Spar.Sem.ScimExternalIdStore
+import Wire.API.User.Identity (Email)
+
+scimExternalIdStoreToMem ::
+  Sem (ScimExternalIdStore ': r) a ->
+  Sem r (Map (TeamId, Email) UserId, a)
+scimExternalIdStoreToMem = (runState mempty .) $
+  reinterpret $ \case
+    Insert tid em uid -> modify $ M.insert (tid, em) uid
+    Lookup tid em -> gets $ M.lookup (tid, em)
+    Delete tid em -> modify $ M.delete (tid, em)

services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs

@@ -0,0 +1,21 @@
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Spar.Sem.ScimTokenStore.Mem where
+
+import qualified Data.Map as M
+import Imports
+import Polysemy
+import Polysemy.State
+import Spar.Scim
+import Spar.Sem.ScimTokenStore
+
+scimTokenStoreToMem ::
+  Sem (ScimTokenStore ': r) a ->
+  Sem r (Map ScimToken ScimTokenInfo, a)
+scimTokenStoreToMem = (runState mempty .) $
+  reinterpret $ \case
+    Insert st sti -> modify $ M.insert st sti
+    Lookup st -> gets $ M.lookup st
+    GetByTeam tid -> gets $ filter ((== tid) . stiTeam) . M.elems
+    Delete tid stid -> modify $ M.filter $ \sti -> not $ stiTeam sti == tid && stiId sti == stid
+    DeleteByTeam tid -> modify $ M.filter (not . (== tid) . stiTeam)

services/spar/src/Spar/Sem/ScimUserTimesStore.hs

@@ -8,7 +8,7 @@ import Web.Scim.Schema.Common (WithId)
 import Web.Scim.Schema.Meta (WithMeta)
 
 data ScimUserTimesStore m a where
-  Write :: WithMeta (WithId UserId a) -> ScimUserTimesStore m ()
+  Write :: WithMeta (WithId UserId t) -> ScimUserTimesStore m ()
   Read :: UserId -> ScimUserTimesStore m (Maybe (UTCTimeMillis, UTCTimeMillis))
   Delete :: UserId -> ScimUserTimesStore m ()
 

services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs

@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Spar.Sem.ScimUserTimesStore.Mem where
+
+import Data.Id (UserId)
+import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis)
+import qualified Data.Map as M
+import Imports
+import Polysemy
+import Polysemy.State
+import Spar.Sem.ScimUserTimesStore
+import Web.Scim.Schema.Common (WithId (WithId))
+import Web.Scim.Schema.Meta (WithMeta (WithMeta), created, lastModified)
+
+scimUserTimesStoreToMem ::
+  Sem (ScimUserTimesStore ': r) a ->
+  Sem r (Map UserId (UTCTimeMillis, UTCTimeMillis), a)
+scimUserTimesStoreToMem = (runState mempty .) $
+  reinterpret $ \case
+    Write (WithMeta meta (WithId uid _)) -> modify $ M.insert uid (toUTCTimeMillis $ created meta, toUTCTimeMillis $ lastModified meta)
+    Read uid -> gets $ M.lookup uid
+    Delete uid -> modify $ M.delete uid

services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs

@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Spar.Sem.VerdictFormatStore.Mem where
+
+import qualified Data.Map as M
+import Imports
+import Polysemy
+import Polysemy.State hiding (Get)
+import SAML2.WebSSO (addTime)
+import qualified SAML2.WebSSO.Types as SAML
+import Spar.Sem.Now (Now, boolTTL)
+import qualified Spar.Sem.Now as Now
+import Spar.Sem.VerdictFormatStore
+import Wire.API.User.Saml (AReqId, VerdictFormat)
+
+verdictFormatStoreToMem ::
+  Member Now r =>
+  Sem (VerdictFormatStore ': r) a ->
+  Sem r (Map AReqId (SAML.Time, VerdictFormat), a)
+verdictFormatStoreToMem =
+  (runState mempty .) $
+    reinterpret $ \case
+      Store ndt areqid vf -> do
+        now <- Now.get
+        modify $ M.insert areqid (addTime ndt now, vf)
+      Get areqid -> do
+        gets (M.lookup areqid) >>= \case
+          Just (time, vf) -> do
+            boolTTL Nothing (Just vf) time
+          Nothing -> pure Nothing