[Polysemy] Effects Around the User Query Effect

changelog.d/5-internal/user-effects

@@ -0,0 +1 @@
+Add the UserQuery and supporting effects

libs/brig-types/src/Brig/Types/Common.hs

@@ -29,6 +29,15 @@ module Brig.Types.Common
     isValidPhonePrefix,
     allPrefixes,
     ExcludedPrefix (..),
+
+    -- * misc
+    foldKey,
+    keyText,
+    mkPhoneKey,
+    mkEmailKey,
+    EmailKey (..),
+    PhoneKey (..),
+    UserKey (..),
   )
 where
 
@@ -39,6 +48,7 @@ import Data.ByteString.Conversion
 import qualified Data.Text as Text
 import Data.Time.Clock (NominalDiffTime)
 import Imports
+import Wire.API.User.Identity
 
 ------------------------------------------------------------------------------
 --- PhoneBudgetTimeout
@@ -111,3 +121,74 @@ instance FromJSON ExcludedPrefix where
 
 instance ToJSON ExcludedPrefix where
   toJSON (ExcludedPrefix p c) = object ["phone_prefix" .= p, "comment" .= c]
+
+-------------------------------------------------------------------------------
+-- Unique Keys
+
+-- | An 'EmailKey' is an 'Email' in a form that serves as a unique lookup key.
+data EmailKey = EmailKey
+  { emailKeyUniq :: !Text,
+    emailKeyOrig :: !Email
+  }
+
+instance Show EmailKey where
+  showsPrec _ = shows . emailKeyUniq
+
+instance Eq EmailKey where
+  (EmailKey k _) == (EmailKey k' _) = k == k'
+
+-- | Turn an 'Email' into an 'EmailKey'.
+--
+-- The following transformations are performed:
+--
+--   * Both local and domain parts are forced to lowercase to make
+--     e-mail addresses fully case-insensitive.
+--   * "+" suffixes on the local part are stripped unless the domain
+--     part is contained in a trusted whitelist.
+mkEmailKey :: Email -> EmailKey
+mkEmailKey orig@(Email localPart domain) =
+  let uniq = Text.toLower localPart' <> "@" <> Text.toLower domain
+   in EmailKey uniq orig
+  where
+    localPart'
+      | domain `notElem` trusted = Text.takeWhile (/= '+') localPart
+      | otherwise = localPart
+    trusted = ["wearezeta.com", "wire.com", "simulator.amazonses.com"]
+
+data PhoneKey = PhoneKey
+  { -- | canonical form of 'phoneKeyOrig', without whitespace.
+    phoneKeyUniq :: !Text,
+    -- | phone number with whitespace.
+    phoneKeyOrig :: !Phone
+  }
+
+instance Show PhoneKey where
+  showsPrec _ = shows . phoneKeyUniq
+
+instance Eq PhoneKey where
+  (PhoneKey k _) == (PhoneKey k' _) = k == k'
+
+mkPhoneKey :: Phone -> PhoneKey
+mkPhoneKey orig =
+  let uniq = Text.filter (not . isSpace) (fromPhone orig)
+   in PhoneKey uniq orig
+
+-- | A natural identifier (i.e. unique key) of a user.
+data UserKey
+  = UserEmailKey !EmailKey
+  | UserPhoneKey !PhoneKey
+
+instance Eq UserKey where
+  (UserEmailKey k) == (UserEmailKey k') = k == k'
+  (UserPhoneKey k) == (UserPhoneKey k') = k == k'
+  _ == _ = False
+
+-- | Get the normalised text of a 'UserKey'.
+keyText :: UserKey -> Text
+keyText (UserEmailKey k) = emailKeyUniq k
+keyText (UserPhoneKey k) = phoneKeyUniq k
+
+foldKey :: (Email -> a) -> (Phone -> a) -> UserKey -> a
+foldKey f g k = case k of
+  UserEmailKey ek -> f (emailKeyOrig ek)
+  UserPhoneKey pk -> g (phoneKeyOrig pk)

libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal

@@ -13,6 +13,12 @@ build-type:    Simple
 library
   exposed-modules:
     Polysemy.TinyLog
+    Wire.Sem.Concurrency
+    Wire.Sem.Concurrency.IO
+    Wire.Sem.Concurrency.Sequential
+    Wire.Sem.Error
+    Wire.Sem.FireAndForget
+    Wire.Sem.FireAndForget.IO
     Wire.Sem.FromUTC
     Wire.Sem.Logger
     Wire.Sem.Logger.Level
@@ -25,9 +31,6 @@ library
     Wire.Sem.Paging.Cassandra
     Wire.Sem.Random
     Wire.Sem.Random.IO
-    Wire.Sem.Concurrency
-    Wire.Sem.Concurrency.IO
-    Wire.Sem.Concurrency.Sequential
 
   other-modules:      Paths_polysemy_wire_zoo
   hs-source-dirs:     src

libs/polysemy-wire-zoo/src/Wire/Sem/Error.hs

@@ -0,0 +1,37 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see <https://www.gnu.org/licenses/>.
+
+module Wire.Sem.Error where
+
+import Imports
+import Polysemy
+import Polysemy.Error
+import qualified UnliftIO.Exception as UnliftIO
+import Wire.API.Error
+
+interpretErrorToException ::
+  (Exception exc, Member (Embed IO) r) =>
+  (err -> exc) ->
+  Sem (Error err ': r) a ->
+  Sem r a
+interpretErrorToException f = either (embed @IO . UnliftIO.throwIO . f) pure <=< runError
+
+interpretWaiErrorToException ::
+  (APIError e, Member (Embed IO) r) =>
+  Sem (Error e ': r) a ->
+  Sem r a
+interpretWaiErrorToException = interpretErrorToException toWai

libs/polysemy-wire-zoo/src/Wire/Sem/FireAndForget.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see <https://www.gnu.org/licenses/>.
+
+module Wire.Sem.FireAndForget where
+
+import Polysemy
+
+data FireAndForget m a where
+  FireAndForgetOne :: m () -> FireAndForget m ()
+  SpawnMany :: [m ()] -> FireAndForget m ()
+
+makeSem ''FireAndForget
+
+fireAndForget :: Member FireAndForget r => Sem r () -> Sem r ()
+fireAndForget = fireAndForgetOne

services/galley/src/Galley/Effects/FireAndForget.hs → libs/polysemy-wire-zoo/src/Wire/Sem/FireAndForget/IO.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
-
 -- This file is part of the Wire Server implementation.
 --
 -- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
@@ -17,33 +15,22 @@
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
-module Galley.Effects.FireAndForget
-  ( FireAndForget,
-    fireAndForget,
-    spawnMany,
-    interpretFireAndForget,
-  )
-where
+module Wire.Sem.FireAndForget.IO (interpretFireAndForget) where
 
 import Imports
 import Polysemy
 import Polysemy.Final
 import UnliftIO.Async (pooledMapConcurrentlyN_)
-
-data FireAndForget m a where
-  FireAndForgetOne :: m () -> FireAndForget m ()
-  SpawnMany :: [m ()] -> FireAndForget m ()
-
-makeSem ''FireAndForget
-
-fireAndForget :: Member FireAndForget r => Sem r () -> Sem r ()
-fireAndForget = fireAndForgetOne
+import Wire.Sem.FireAndForget
 
 -- | Run actions in separate threads and ignore results.
 --
 -- /Note/: this will also ignore any state and error effects contained in the
 -- 'FireAndForget' action. Use with care.
-interpretFireAndForget :: Member (Final IO) r => Sem (FireAndForget ': r) a -> Sem r a
+interpretFireAndForget ::
+  Member (Final IO) r =>
+  Sem (FireAndForget ': r) a ->
+  Sem r a
 interpretFireAndForget = interpretFinal @IO $ \case
   FireAndForgetOne action -> do
     action' <- runS action

services/brig/brig.cabal

@@ -38,7 +38,6 @@ library
     Brig.AWS
     Brig.AWS.SesNotification
     Brig.AWS.Types
-    Brig.Budget
     Brig.Calling
     Brig.Calling.API
     Brig.Calling.Internal
@@ -55,20 +54,49 @@ library
     Brig.Data.Types
     Brig.Data.User
     Brig.Data.UserKey
+    Brig.Effects.ActivationKeyStore
+    Brig.Effects.ActivationKeyStore.Cassandra
+    Brig.Effects.ActivationSupply
+    Brig.Effects.ActivationSupply.IO
     Brig.Effects.BlacklistPhonePrefixStore
     Brig.Effects.BlacklistPhonePrefixStore.Cassandra
     Brig.Effects.BlacklistStore
     Brig.Effects.BlacklistStore.Cassandra
+    Brig.Effects.BudgetStore
+    Brig.Effects.BudgetStore.Cassandra
+    Brig.Effects.ClientStore
+    Brig.Effects.ClientStore.Cassandra
     Brig.Effects.CodeStore
     Brig.Effects.CodeStore.Cassandra
+    Brig.Effects.Common
+    Brig.Effects.CookieStore
+    Brig.Effects.CookieStore.Cassandra
     Brig.Effects.Delay
+    Brig.Effects.GalleyAccess
+    Brig.Effects.GalleyAccess.Http
+    Brig.Effects.GundeckAccess
+    Brig.Effects.GundeckAccess.Http
     Brig.Effects.JwtTools
     Brig.Effects.PasswordResetStore
     Brig.Effects.PasswordResetStore.CodeStore
+    Brig.Effects.PasswordResetSupply
+    Brig.Effects.PasswordResetSupply.IO
     Brig.Effects.PublicKeyBundle
     Brig.Effects.SFT
+    Brig.Effects.Twilio
+    Brig.Effects.Twilio.IO
+    Brig.Effects.UniqueClaimsStore
+    Brig.Effects.UniqueClaimsStore.Cassandra
+    Brig.Effects.UserHandleStore
+    Brig.Effects.UserHandleStore.Cassandra
+    Brig.Effects.UserKeyStore
+    Brig.Effects.UserKeyStore.Cassandra
     Brig.Effects.UserPendingActivationStore
     Brig.Effects.UserPendingActivationStore.Cassandra
+    Brig.Effects.UserQuery
+    Brig.Effects.UserQuery.Cassandra
+    Brig.Effects.VerificationCodeStore
+    Brig.Effects.VerificationCodeStore.Cassandra
     Brig.Email
     Brig.Federation.Client
     Brig.Index.Eval
@@ -93,6 +121,7 @@ library
     Brig.Queue.Stomp
     Brig.Queue.Types
     Brig.RPC
+    Brig.RPC.Decode
     Brig.Run
     Brig.SMTP
     Brig.Team.API
@@ -229,6 +258,7 @@ library
     , imports
     , insert-ordered-containers
     , iproute                    >=1.5
+    , iso3166-country-codes
     , iso639                     >=0.1
     , jwt-tools
     , lens                       >=3.8
@@ -247,7 +277,9 @@ library
     , optparse-applicative       >=0.11
     , pem                        >=0.2
     , polysemy
+    , polysemy-conc
     , polysemy-plugin
+    , polysemy-time
     , polysemy-wire-zoo
     , proto-lens                 >=0.1
     , random-shuffle             >=0.0.3

services/brig/src/Brig/API.hs

@@ -23,23 +23,71 @@ where
 import Brig.API.Handler (Handler)
 import qualified Brig.API.Internal as Internal
 import qualified Brig.API.Public as Public
+import Brig.API.Types
+import Brig.Effects.ActivationKeyStore
+import Brig.Effects.ActivationSupply
 import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore)
 import Brig.Effects.BlacklistStore (BlacklistStore)
+import Brig.Effects.BudgetStore
+import Brig.Effects.ClientStore
 import Brig.Effects.CodeStore
+import Brig.Effects.CookieStore
+import Brig.Effects.GalleyAccess
+import Brig.Effects.GundeckAccess (GundeckAccess)
 import Brig.Effects.PasswordResetStore (PasswordResetStore)
+import Brig.Effects.PasswordResetSupply (PasswordResetSupply)
+import Brig.Effects.Twilio
+import Brig.Effects.UniqueClaimsStore
+import Brig.Effects.UserHandleStore
+import Brig.Effects.UserKeyStore
 import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore)
+import Brig.Effects.UserQuery
+import Brig.Effects.VerificationCodeStore
+import Data.Qualified
 import qualified Data.Swagger.Build.Api as Doc
 import Network.Wai.Routing (Routes)
 import Polysemy
+import Polysemy.Async
+import Polysemy.Conc.Effect.Race
+import Polysemy.Error
+import Polysemy.Input
+import Polysemy.Resource
+import qualified Polysemy.TinyLog as P
+import qualified Ropes.Twilio as Twilio
+import Wire.Sem.Concurrency
+import Wire.Sem.Paging
 
 sitemap ::
   forall r p.
+  Paging p =>
   Members
-    '[ CodeStore,
-       PasswordResetStore,
+    '[ ActivationKeyStore,
+       ActivationSupply,
+       Async,
        BlacklistStore,
        BlacklistPhonePrefixStore,
-       UserPendingActivationStore p
+       BudgetStore,
+       ClientStore,
+       CodeStore,
+       Concurrency 'Unsafe,
+       CookieStore,
+       Error ReAuthError,
+       Error Twilio.ErrorResponse,
+       GalleyAccess,
+       GundeckAccess,
+       Input (Local ()),
+       P.TinyLog,
+       PasswordResetStore,
+       PasswordResetSupply,
+       Race,
+       Resource,
+       Twilio,
+       UniqueClaimsStore,
+       UserHandleStore,
+       UserKeyStore,
+       UserPendingActivationStore p,
+       UserQuery p,
+       VerificationCodeStore
      ]
     r =>
   Routes Doc.ApiBuilder (Handler r) ()