[WPB-8887] wire-subsystems: implement the GetBy* account queries, includes InvitationCodeStore.

Makefile

@@ -163,7 +163,7 @@ lint-all: formatc hlint-check-all lint-common
 # The extra 'hlint-check-pr' has been witnessed to be necessary due to
 # some bu in `hlint-inplace-pr`.  Details got lost in history.
 .PHONY: lint-all-shallow
-lint-all-shallow: formatf hlint-inplace-pr hlint-check-pr lint-common
+lint-all-shallow: lint-common formatf hlint-inplace-pr hlint-check-pr 
 
 .PHONY: lint-common
 lint-common: check-local-nix-derivations treefmt-check # weeder (does not work on CI yet)

changelog.d/5-internal/wpb-8887

@@ -0,0 +1 @@
+New user subsystem operation `getAccountsBy` for complex account lookups.

integration/test/Test/Spar.hs

@@ -29,8 +29,8 @@ testSparUserCreationInvitationTimeout = do
     res.status `shouldMatchInt` 409
 
   -- However, if we wait until the invitation timeout has passed
-  -- (assuming it is configured to 10s locally and in CI)...
-  liftIO $ threadDelay (11_000_000)
+  -- It's currently configured to 1s local/CI.
+  liftIO $ threadDelay (2_000_000)
 
   -- ...we should be able to create the user again
   retryT $ bindResponse (createScimUser OwnDomain tok scimUser) $ \res -> do

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

@@ -19,7 +19,6 @@ module Brig.Types.User
   ( ManagedByUpdate (..),
     RichInfoUpdate (..),
     PasswordResetPair,
-    HavePendingInvitations (..),
   )
 where
 

libs/cassandra-util/cassandra-util.cabal

@@ -18,6 +18,7 @@ library
     Cassandra.Helpers
     Cassandra.MigrateSchema
     Cassandra.Options
+    Cassandra.QQ
     Cassandra.Schema
     Cassandra.Settings
     Cassandra.Util
@@ -87,6 +88,7 @@ library
     , optparse-applicative  >=0.10
     , retry
     , split                 >=0.2
+    , template-haskell
     , text                  >=0.11
     , time                  >=1.4
     , tinylog               >=0.7

libs/cassandra-util/default.nix

@@ -19,6 +19,7 @@
 , optparse-applicative
 , retry
 , split
+, template-haskell
 , text
 , time
 , tinylog
@@ -44,6 +45,7 @@ mkDerivation {
     optparse-applicative
     retry
     split
+    template-haskell
     text
     time
     tinylog

libs/cassandra-util/src/Cassandra.hs

@@ -91,3 +91,4 @@ import Cassandra.Exec as C
     x1,
     x5,
   )
+import Cassandra.QQ as C (sql)

libs/cassandra-util/src/Cassandra/QQ.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module Cassandra.QQ (sql) where
+
+import Imports
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote (QuasiQuoter (..))
+
+-- | a simple quasi quoter to allow for tree-sitter syntax highlight injection.
+-- This uses the name sql because that is known to tree-sitter, unlike cql
+sql :: QuasiQuoter
+sql =
+  QuasiQuoter
+    { quotePat = error "Cassandra.QQ: sql quasiquoter cannot be used as pattern",
+      quoteType = error "Cassandra.QQ: sql quasiquoter cannot be used as type",
+      quoteDec = error "Cassandra.QQ: sql quasiquoter cannot be used as declaration",
+      quoteExp = appE [|fromString|] . stringE
+    }

libs/imports/src/Imports.hs

@@ -111,7 +111,6 @@ module Imports
     -- * Extra Helpers
     whenM,
     unlessM,
-    catMaybesToList,
 
     -- * Functor
     (<$$>),
@@ -385,6 +384,3 @@ infix 4 <$$>
 (<$$$>) = fmap . fmap . fmap
 
 infix 4 <$$$>
-
-catMaybesToList :: Maybe (Maybe a) -> [a]
-catMaybesToList = catMaybes . maybeToList

libs/types-common/default.nix

@@ -40,6 +40,7 @@
 , quickcheck-instances
 , random
 , schema-profunctor
+, scientific
 , servant-server
 , string-conversions
 , tagged
@@ -96,6 +97,7 @@ mkDerivation {
     quickcheck-instances
     random
     schema-profunctor
+    scientific
     servant-server
     tagged
     tasty

libs/types-common/src/Data/HavePendingInvitations.hs

@@ -0,0 +1,14 @@
+module Data.HavePendingInvitations where
+
+import Imports
+import Wire.Arbitrary
+
+data HavePendingInvitations
+  = WithPendingInvitations
+  | NoPendingInvitations
+  deriving (Eq, Show, Ord, Generic)
+  deriving (Arbitrary) via GenericUniform HavePendingInvitations
+
+fromBool :: Bool -> HavePendingInvitations
+fromBool True = WithPendingInvitations
+fromBool False = NoPendingInvitations

libs/types-common/src/Data/Qualified.hs

@@ -28,6 +28,7 @@ module Data.Qualified
     tUnqualified,
     tDomain,
     tUntagged,
+    tSplit,
     qTagUnsafe,
     Remote,
     toRemoteUnsafe,
@@ -92,6 +93,10 @@ tUnqualified = qUnqualified . tUntagged
 tDomain :: QualifiedWithTag t a -> Domain
 tDomain = qDomain . tUntagged
 
+-- | perform 'qUnqualified' and 'tDomain' at once. Useful in ViewPatterns.
+tSplit :: QualifiedWithTag t a -> (Domain, a)
+tSplit (tUntagged -> q) = (q.qDomain, q.qUnqualified)
+
 -- | A type representing a 'Qualified' value where the domain is guaranteed to
 -- be remote.
 type Remote = QualifiedWithTag 'QRemote

libs/types-common/src/Util/Timeout.hs

@@ -0,0 +1,32 @@
+module Util.Timeout
+  ( Timeout (..),
+    module Data.Time.Clock,
+  )
+where
+
+import Data.Aeson
+import Data.Aeson.Types
+import Data.Scientific
+import Data.Time.Clock
+import Imports
+
+newtype Timeout = Timeout
+  { timeoutDiff :: NominalDiffTime
+  }
+  deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show)
+
+instance Read Timeout where
+  readsPrec i s =
+    case readsPrec i s of
+      [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')]
+      _ -> []
+
+instance FromJSON Timeout where
+  parseJSON (Number n) =
+    let defaultV = 3600
+        bounded = toBoundedInteger n :: Maybe Int64
+     in pure $
+          Timeout $
+            fromIntegral @Int $
+              maybe defaultV fromIntegral bounded
+  parseJSON v = typeMismatch "activationTimeout" v

libs/types-common/types-common.cabal

@@ -19,6 +19,7 @@ library
     Data.Domain
     Data.ETag
     Data.Handle
+    Data.HavePendingInvitations
     Data.Id
     Data.Json.Util
     Data.LegalHold
@@ -38,6 +39,7 @@ library
     Util.Options
     Util.Options.Common
     Util.Test
+    Util.Timeout
     Wire.Arbitrary
 
   other-modules:      Paths_types_common
@@ -125,6 +127,7 @@ library
     , quickcheck-instances   >=0.3.16
     , random                 >=1.1
     , schema-profunctor
+    , scientific
     , servant-server
     , tagged                 >=0.8
     , tasty                  >=0.11

libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs

@@ -39,7 +39,7 @@ type OAuthAPI =
         :> Post '[JSON] OAuthClientCredentials
     )
     :<|> Named
-           "get-oauth-client"
+           "i-get-oauth-client"
            ( Summary "Get OAuth client by id"
                :> CanThrow 'OAuthFeatureDisabled
                :> CanThrow 'OAuthClientNotFound

libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs

@@ -566,7 +566,7 @@ type IMiscAPI =
                     (RespondEmpty 200 "OK")
            )
     :<|> Named
-           "add-bot"
+           "i-add-bot"
            ( -- This endpoint can lead to the following events being sent:
              -- - MemberJoin event to members
              CanThrow ('ActionDenied 'AddConversationMember)

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -268,7 +268,7 @@ type UserAPI =
            "get-rich-info"
            ( Summary "Get a user's rich info"
                :> CanThrow 'InsufficientTeamPermissions
-               :> ZUser
+               :> ZLocalUser
                :> "users"
                :> CaptureUserId "uid"
                :> "rich-info"
@@ -322,7 +322,7 @@ type SelfAPI =
           :> CanThrow 'MissingAuth
           :> CanThrow 'DeleteCodePending
           :> CanThrow 'OwnerDeletingSelf
-          :> ZUser
+          :> ZLocalUser
           :> "self"
           :> ReqBody '[JSON] DeleteUser
           :> MultiVerb 'DELETE '[JSON] DeleteSelfResponses (Maybe Timeout)
@@ -743,7 +743,7 @@ type UserClientAPI =
         :> CanThrow 'MalformedPrekeys
         :> CanThrow 'CodeAuthenticationFailed
         :> CanThrow 'CodeAuthenticationRequired
-        :> ZUser
+        :> ZLocalUser
         :> ZConn
         :> "clients"
         :> ReqBody '[JSON] NewClient
@@ -766,7 +766,7 @@ type UserClientAPI =
                :> CanThrow 'MalformedPrekeys
                :> CanThrow 'CodeAuthenticationFailed
                :> CanThrow 'CodeAuthenticationRequired
-               :> ZUser
+               :> ZLocalUser
                :> ZConn
                :> "clients"
                :> ReqBody '[JSON] NewClient

libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs

@@ -39,7 +39,7 @@ type OAuthAPI =
     ( Summary "Get OAuth client information"
         :> CanThrow 'OAuthFeatureDisabled
         :> CanThrow 'OAuthClientNotFound
-        :> ZUser
+        :> ZLocalUser
         :> "oauth"
         :> "clients"
         :> Capture' '[Description "The ID of the OAuth client"] "OAuthClientId" OAuthClientId
@@ -55,7 +55,7 @@ type OAuthAPI =
            "create-oauth-auth-code"
            ( Summary "Create an OAuth authorization code"
                :> Description "Currently only supports the 'code' response type, which corresponds to the authorization code flow."
-               :> ZUser
+               :> ZLocalUser
                :> "oauth"
                :> "authorization"
                :> "codes"
@@ -99,7 +99,7 @@ type OAuthAPI =
            "get-oauth-applications"
            ( Summary "Get OAuth applications with account access"
                :> Description "Get all OAuth applications with active account access for a user."
-               :> ZUser
+               :> ZLocalUser
                :> "oauth"
                :> "applications"
                :> MultiVerb1
@@ -110,7 +110,7 @@ type OAuthAPI =
     :<|> Named
            "revoke-oauth-account-access-v6"
            ( Summary "Revoke account access from an OAuth application"
-               :> ZUser
+               :> ZLocalUser
                :> Until 'V7
                :> "oauth"
                :> "applications"
@@ -125,7 +125,7 @@ type OAuthAPI =
            "revoke-oauth-account-access"
            ( Summary "Revoke account access from an OAuth application"
                :> CanThrow 'AccessDenied
-               :> ZUser
+               :> ZLocalUser
                :> From 'V7
                :> "oauth"
                :> "applications"
@@ -142,7 +142,7 @@ type OAuthAPI =
            "delete-oauth-refresh-token"
            ( Summary "Revoke an active OAuth session"
                :> Description "Revoke an active OAuth session by providing the refresh token ID."
-               :> ZUser
+               :> ZLocalUser
                :> CanThrow 'AccessDenied
                :> CanThrow 'OAuthClientNotFound
                :> "oauth"

libs/wire-api/src/Wire/API/Team/Invitation.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE StrictData #-}
 
 -- This file is part of the Wire Server implementation.
@@ -67,27 +68,27 @@ instance ToSchema InvitationRequest where
       InvitationRequest
         <$> locale
           .= optFieldWithDocModifier "locale" (description ?~ "Locale to use for the invitation.") (maybeWithDefault A.Null schema)
-        <*> role
+        <*> (.role)
           .= optFieldWithDocModifier "role" (description ?~ "Role of the invitee (invited user).") (maybeWithDefault A.Null schema)
-        <*> inviteeName
+        <*> (.inviteeName)
           .= optFieldWithDocModifier "name" (description ?~ "Name of the invitee (1 - 128 characters).") (maybeWithDefault A.Null schema)
-        <*> inviteeEmail
+        <*> (.inviteeEmail)
           .= fieldWithDocModifier "email" (description ?~ "Email of the invitee.") schema
 
 --------------------------------------------------------------------------------
 -- Invitation
 
 data Invitation = Invitation
-  { inTeam :: TeamId,
-    inRole :: Role,
-    inInvitation :: InvitationId,
-    inCreatedAt :: UTCTimeMillis,
+  { team :: TeamId,
+    role :: Role,
+    invitationId :: InvitationId,
+    createdAt :: UTCTimeMillis,
     -- | this is always 'Just' for new invitations, but for
     -- migration it is allowed to be 'Nothing'.
-    inCreatedBy :: Maybe UserId,
-    inInviteeEmail :: EmailAddress,
-    inInviteeName :: Maybe Name,
-    inInviteeUrl :: Maybe (URIRef Absolute)
+    createdBy :: Maybe UserId,
+    inviteeEmail :: EmailAddress,
+    inviteeName :: Maybe Name,
+    inviteeUrl :: Maybe (URIRef Absolute)
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform Invitation)
@@ -99,22 +100,22 @@ instance ToSchema Invitation where
       "Invitation"
       (description ?~ "An invitation to join a team on Wire")
       $ Invitation
-        <$> inTeam
+        <$> (.team)
           .= fieldWithDocModifier "team" (description ?~ "Team ID of the inviting team") schema
-        <*> inRole
+        <*> (.role)
           -- clients, when leaving "role" empty, can leave the default role choice to us
           .= (fromMaybe defaultRole <$> optFieldWithDocModifier "role" (description ?~ "Role of the invited user") schema)
-        <*> inInvitation
+        <*> (.invitationId)
           .= fieldWithDocModifier "id" (description ?~ "UUID used to refer the invitation") schema
-        <*> inCreatedAt
+        <*> (.createdAt)
           .= fieldWithDocModifier "created_at" (description ?~ "Timestamp of invitation creation") schema
-        <*> inCreatedBy
+        <*> (.createdBy)
           .= optFieldWithDocModifier "created_by" (description ?~ "ID of the inviting user") (maybeWithDefault A.Null schema)
-        <*> inInviteeEmail
+        <*> (.inviteeEmail)
           .= fieldWithDocModifier "email" (description ?~ "Email of the invitee") schema
-        <*> inInviteeName
+        <*> (.inviteeName)
           .= optFieldWithDocModifier "name" (description ?~ "Name of the invitee (1 - 128 characters)") (maybeWithDefault A.Null schema)
-        <*> (fmap (TE.decodeUtf8 . serializeURIRef') . inInviteeUrl)
+        <*> (fmap (TE.decodeUtf8 . serializeURIRef') . inviteeUrl)
           .= optFieldWithDocModifier "url" (description ?~ "URL of the invitation link to be sent to the invitee") (maybeWithDefault A.Null urlSchema)
     where
       urlSchema = parsedText "URIRef Absolute" (runParser (uriParser strictURIParserOptions) . TE.encodeUtf8)