Spar Polysemy: In-memory interpreters (#1920)

* Now and AssIDStore interpreters

* Add AReqIDStore.Mem

* add boolTTL helper

* Add BindCookieStore.Mem

* Add SAMLUserStore.Mem

* Make format

* Add DefaultSsoCode.Mem

* Add ScimExternalIdStore.Mem

* Add ScimTokenStore.Mem

* Add ScimUserTimesStore.Mem

* make format

* Changelog

* Pull out VerdictFormatStore

* Remove stale comment

* Also emit internal state

* Hi CI

Author: isovector

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