diff --git a/changelog.d/5-internal/in-mem-interpreters b/changelog.d/5-internal/in-mem-interpreters new file mode 100644 index 0000000000..32d0dc0a45 --- /dev/null +++ b/changelog.d/5-internal/in-mem-interpreters @@ -0,0 +1 @@ +Add in-memory interpreters for most Spar effects diff --git a/libs/wire-api/src/Wire/API/Cookie.hs b/libs/wire-api/src/Wire/API/Cookie.hs index 6f42892d38..e77292ab4f 100644 --- a/libs/wire-api/src/Wire/API/Cookie.hs +++ b/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) diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 7ae904573a..8146ad0b0a 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/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) diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index f38adbacee..a71562b0f4 100644 --- a/services/spar/spar.cabal +++ b/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: diff --git a/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs b/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs new file mode 100644 index 0000000000..cd1343838c --- /dev/null +++ b/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 diff --git a/services/spar/src/Spar/Sem/AssIDStore/Mem.hs b/services/spar/src/Spar/Sem/AssIDStore/Mem.hs new file mode 100644 index 0000000000..45ae969f9c --- /dev/null +++ b/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 diff --git a/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs b/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs new file mode 100644 index 0000000000..c25acc7380 --- /dev/null +++ b/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 diff --git a/services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs b/services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs new file mode 100644 index 0000000000..a6be5be98b --- /dev/null +++ b/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 diff --git a/services/spar/src/Spar/Sem/Now.hs b/services/spar/src/Spar/Sem/Now.hs index 4c43be4a46..63d8e740ad 100644 --- a/services/spar/src/Spar/Sem/Now.hs +++ b/services/spar/src/Spar/Sem/Now.hs @@ -1,5 +1,6 @@ module Spar.Sem.Now where +import Imports import Polysemy import qualified SAML2.WebSSO as SAML @@ -7,3 +8,16 @@ 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 diff --git a/services/spar/src/Spar/Sem/Now/Input.hs b/services/spar/src/Spar/Sem/Now/Input.hs new file mode 100644 index 0000000000..738424f955 --- /dev/null +++ b/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 diff --git a/services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs b/services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs new file mode 100644 index 0000000000..26ae7ab48a --- /dev/null +++ b/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 diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs new file mode 100644 index 0000000000..efbbbcdba0 --- /dev/null +++ b/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) diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs new file mode 100644 index 0000000000..b983208bef --- /dev/null +++ b/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) diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore.hs index 63065c7ad6..47554a8d00 100644 --- a/services/spar/src/Spar/Sem/ScimUserTimesStore.hs +++ b/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 () diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs new file mode 100644 index 0000000000..b9ed6216b4 --- /dev/null +++ b/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 diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs b/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs new file mode 100644 index 0000000000..73ce931123 --- /dev/null +++ b/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