diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 74dcdfc45f4..24406334813 100644 --- a/libs/cassandra-util/src/Cassandra.hs +++ b/libs/cassandra-util/src/Cassandra.hs @@ -58,6 +58,7 @@ import Cassandra.Exec as C ( BatchM, Client, ClientState, + GeneralPaginationState (..), MonadClient, Page (..), PageWithState (..), @@ -74,6 +75,8 @@ import Cassandra.Exec as C paginate, paginateC, paginateWithState, + paginationStateCassandra, + paginationStatePostgres, params, paramsP, paramsPagingState, diff --git a/libs/cassandra-util/src/Cassandra/Exec.hs b/libs/cassandra-util/src/Cassandra/Exec.hs index 57fdf3ff2be..9d5c7a03d52 100644 --- a/libs/cassandra-util/src/Cassandra/Exec.hs +++ b/libs/cassandra-util/src/Cassandra/Exec.hs @@ -25,6 +25,9 @@ module Cassandra.Exec x5, x1, paginateC, + GeneralPaginationState (..), + paginationStateCassandra, + paginationStatePostgres, PageWithState (..), paginateWithState, paginateWithStateC, @@ -97,9 +100,23 @@ paginateC q p r = go =<< lift (retry r (paginate q p)) when (hasMore page) $ go =<< lift (retry r (liftClient (nextPage page))) -data PageWithState a = PageWithState - { pwsResults :: [a], - pwsState :: Maybe Protocol.PagingState +data GeneralPaginationState a + = PaginationStateCassandra Protocol.PagingState + | PaginationStatePostgres a + +paginationStateCassandra :: GeneralPaginationState pgState -> Maybe Protocol.PagingState +paginationStateCassandra = \case + PaginationStateCassandra state -> Just state + PaginationStatePostgres {} -> Nothing + +paginationStatePostgres :: GeneralPaginationState pgState -> Maybe pgState +paginationStatePostgres = \case + PaginationStatePostgres pgState -> Just pgState + PaginationStateCassandra {} -> Nothing + +data PageWithState state res = PageWithState + { pwsResults :: [res], + pwsState :: Maybe (GeneralPaginationState state) } deriving (Functor) @@ -107,13 +124,13 @@ data PageWithState a = PageWithState -- serialised and sent to consumers of the API. The state is not good for long -- term storage as the bytestring format may change when the schema of a table -- changes or when cassandra is upgraded. -paginateWithState :: (MonadClient m, Tuple a, Tuple b, RunQ q) => q R a b -> QueryParams a -> RetrySettings -> m (PageWithState b) +paginateWithState :: (MonadClient m, Tuple a, Tuple b, RunQ q) => q R a b -> QueryParams a -> RetrySettings -> m (PageWithState x b) paginateWithState q p retrySettings = do let p' = p {Protocol.pageSize = Protocol.pageSize p <|> Just 10000} r <- runQ q p' retry retrySettings (getResult r) >>= \case Protocol.RowsResult m b -> - pure $ PageWithState b (pagingState m) + pure $ PageWithState b (PaginationStateCassandra <$> pagingState m) _ -> throwM $ UnexpectedResponse (hrHost r) (hrResponse r) -- | Like 'paginateWithState' but returns a conduit instead of one page. @@ -128,20 +145,20 @@ paginateWithState q p retrySettings = do -- where -- getUsers state = paginateWithState getUsersQuery (paramsPagingState Quorum () 10000 state) -- @ -paginateWithStateC :: forall m a. (Monad m) => (Maybe Protocol.PagingState -> m (PageWithState a)) -> ConduitT () [a] m () +paginateWithStateC :: forall m res state. (Monad m) => (Maybe (GeneralPaginationState state) -> m (PageWithState state res)) -> ConduitT () [res] m () paginateWithStateC getPage = do go =<< lift (getPage Nothing) where - go :: PageWithState a -> ConduitT () [a] m () + go :: PageWithState state res -> ConduitT () [res] m () go page = do unless (null page.pwsResults) $ yield (page.pwsResults) when (pwsHasMore page) $ - go =<< lift (getPage page.pwsState) + go =<< lift (getPage $ page.pwsState) paramsPagingState :: Consistency -> a -> Int32 -> Maybe Protocol.PagingState -> QueryParams a paramsPagingState c p n state = QueryParams c False p (Just n) state Nothing Nothing {-# INLINE paramsPagingState #-} -pwsHasMore :: PageWithState a -> Bool +pwsHasMore :: PageWithState a b -> Bool pwsHasMore = isJust . pwsState diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Paging/Cassandra.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Paging/Cassandra.hs index 12210c3c8a3..a775a56beb3 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Paging/Cassandra.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Paging/Cassandra.hs @@ -43,7 +43,7 @@ data CassandraPaging type instance E.PagingState CassandraPaging a = PagingState -type instance E.Page CassandraPaging a = PageWithState a +type instance E.Page CassandraPaging a = PageWithState Void a type instance E.PagingBounds CassandraPaging TeamId = Range 1 100 Int32 diff --git a/libs/wire-api/src/Wire/API/Asset.hs b/libs/wire-api/src/Wire/API/Asset.hs index ac51bde02f9..d822626e0e3 100644 --- a/libs/wire-api/src/Wire/API/Asset.hs +++ b/libs/wire-api/src/Wire/API/Asset.hs @@ -94,6 +94,7 @@ import Imports import Servant import URI.ByteString import Wire.API.Error +import Wire.API.PostgresMarshall import Wire.API.Routes.MultiVerb import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) @@ -200,6 +201,12 @@ instance C.Cql AssetKey where fromCql (C.CqlText txt) = runParser parser . T.encodeUtf8 $ txt fromCql _ = Left "AssetKey: Text expected" +instance PostgresMarshall Text AssetKey where + postgresMarshall = assetKeyToText + +instance PostgresUnmarshall Text AssetKey where + postgresUnmarshall = mapLeft (\e -> "failed to parse AssetKey: " <> T.pack e) . runParser parser . T.encodeUtf8 + -------------------------------------------------------------------------------- -- AssetToken diff --git a/libs/wire-api/src/Wire/API/Locale.hs b/libs/wire-api/src/Wire/API/Locale.hs index 576c7eeeb10..a9005d0c549 100644 --- a/libs/wire-api/src/Wire/API/Locale.hs +++ b/libs/wire-api/src/Wire/API/Locale.hs @@ -47,6 +47,7 @@ import Data.Time.Format import Data.Time.LocalTime (TimeZone (..), utc) import Imports import Test.QuickCheck +import Wire.API.PostgresMarshall import Wire.API.User.Orphans () import Wire.Arbitrary @@ -181,6 +182,14 @@ instance C.Cql Language where Nothing -> Left "Language: ISO 639-1 expected." fromCql _ = Left "Language: ASCII expected" +instance PostgresMarshall Text Language where + postgresMarshall = lan2Text + +instance PostgresUnmarshall Text Language where + postgresUnmarshall = + mapLeft (\e -> "failed to parse Language: " <> Text.pack e) + . parseOnly languageParser + languageParser :: Parser Language languageParser = codeParser "language" $ fmap Language . checkAndConvert isLower @@ -206,6 +215,14 @@ instance C.Cql Country where Nothing -> Left "Country: ISO 3166-1-alpha2 expected." fromCql _ = Left "Country: ASCII expected" +instance PostgresMarshall Text Country where + postgresMarshall = con2Text + +instance PostgresUnmarshall Text Country where + postgresUnmarshall = + mapLeft (\e -> "failed to parse Country: " <> Text.pack e) + . parseOnly countryParser + countryParser :: Parser Country countryParser = codeParser "country" $ fmap Country . checkAndConvert isUpper diff --git a/libs/wire-api/src/Wire/API/Password.hs b/libs/wire-api/src/Wire/API/Password.hs index dfb16d1d250..03f0bc972e4 100644 --- a/libs/wire-api/src/Wire/API/Password.hs +++ b/libs/wire-api/src/Wire/API/Password.hs @@ -74,11 +74,15 @@ instance Cql Password where fromCql (CqlBlob lbs) = parsePassword . Text.decodeUtf8 . toStrict $ lbs fromCql _ = Left "password: expected blob" - toCql pw = CqlBlob . fromStrict $ Text.encodeUtf8 encoded - where - encoded = case pw of - Argon2Password argon2pw -> encodeArgon2HashedPassword argon2pw - ScryptPassword scryptpw -> encodeScryptPassword scryptpw + toCql = CqlBlob . fromStrict . Text.encodeUtf8 . postgresMarshall + +instance PostgresMarshall Text Password where + postgresMarshall = \case + Argon2Password argon2pw -> encodeArgon2HashedPassword argon2pw + ScryptPassword scryptpw -> encodeScryptPassword scryptpw + +instance PostgresUnmarshall Text Password where + postgresUnmarshall = mapLeft Text.pack . parsePassword ------------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/PostgresMarshall.hs b/libs/wire-api/src/Wire/API/PostgresMarshall.hs index 666b5b78c40..c69bb8f39a5 100644 --- a/libs/wire-api/src/Wire/API/PostgresMarshall.hs +++ b/libs/wire-api/src/Wire/API/PostgresMarshall.hs @@ -18,6 +18,7 @@ module Wire.API.PostgresMarshall ( PostgresMarshall (..), PostgresUnmarshall (..), + StoreAsJSON (..), lmapPG, rmapPG, dimapPG, @@ -31,12 +32,15 @@ import Data.ByteString.Conversion (toByteString') import Data.ByteString.Conversion qualified as BSC import Data.Code qualified as Code import Data.Domain +import Data.Handle import Data.Id +import Data.Json.Util (UTCTimeMillis (fromUTCTimeMillis), toUTCTimeMillis) import Data.Misc import Data.Profunctor import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as Text +import Data.Time (UTCTime) import Data.UUID import Data.Vector (Vector) import Data.Vector qualified as V @@ -520,6 +524,12 @@ instance PostgresMarshall Int64 Milliseconds where instance PostgresMarshall Text Domain where postgresMarshall = domainText +instance PostgresMarshall Text Handle where + postgresMarshall = fromHandle + +instance PostgresMarshall UTCTime UTCTimeMillis where + postgresMarshall = fromUTCTimeMillis + instance (PostgresMarshall a b) => PostgresMarshall (Maybe a) (Maybe b) where postgresMarshall = fmap postgresMarshall @@ -869,6 +879,12 @@ instance PostgresUnmarshall Text Code.Key where instance PostgresUnmarshall Text Code.Value where postgresUnmarshall = mapLeft Text.pack . BSC.runParser BSC.parser . Text.encodeUtf8 +instance PostgresUnmarshall Text Handle where + postgresUnmarshall = mapLeft Text.pack . parseHandleEither + +instance PostgresUnmarshall UTCTime UTCTimeMillis where + postgresUnmarshall = Right . toUTCTimeMillis + --- lmapPG :: (PostgresMarshall db domain, Profunctor p) => p db x -> p domain x @@ -882,3 +898,16 @@ dimapPG :: Statement dbIn dbOut -> Statement domainIn domainOut dimapPG = refineResult postgresUnmarshall . lmapPG + +--- + +newtype StoreAsJSON a = StoreAsJSON a + +instance (ToJSON a) => PostgresMarshall Value (StoreAsJSON a) where + postgresMarshall (StoreAsJSON a) = toJSON a + +instance (FromJSON a) => PostgresUnmarshall Value (StoreAsJSON a) where + postgresUnmarshall v = + case fromJSON v of + Error e -> Left $ Text.pack e + Success a -> Right $ StoreAsJSON a diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 37d226b9b16..ea3057dfd55 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -174,6 +174,7 @@ import Test.QuickCheck.Gen (suchThat) import URI.ByteString.QQ qualified as URI.QQ import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite +import Wire.API.PostgresMarshall import Wire.API.Routes.Named hiding (unnamed) import Wire.API.Routes.Version import Wire.API.Routes.Versioned @@ -2163,14 +2164,21 @@ instance FromByteString FeatureStatus where instance Cass.Cql FeatureStatus where ctype = Cass.Tagged Cass.IntColumn - fromCql (Cass.CqlInt n) = case n of - 0 -> pure FeatureStatusDisabled - 1 -> pure FeatureStatusEnabled - _ -> Left "fromCql: Invalid FeatureStatus" + fromCql (Cass.CqlInt n) = mapLeft T.unpack $ postgresUnmarshall n fromCql _ = Left "fromCql: FeatureStatus: CqlInt expected" - toCql FeatureStatusDisabled = Cass.CqlInt 0 - toCql FeatureStatusEnabled = Cass.CqlInt 1 + toCql = Cass.CqlInt . postgresMarshall + +instance PostgresMarshall Int32 FeatureStatus where + postgresMarshall = \case + FeatureStatusDisabled -> 0 + FeatureStatusEnabled -> 1 + +instance PostgresUnmarshall Int32 FeatureStatus where + postgresUnmarshall = \case + 0 -> Right FeatureStatusDisabled + 1 -> Right FeatureStatusEnabled + n -> Left $ "Invalid FeatureStatus: " <> T.pack (show n) -- | list of available features config types type Features :: [Type] diff --git a/libs/wire-api/src/Wire/API/Team/Member.hs b/libs/wire-api/src/Wire/API/Team/Member.hs index 2d75ce2e04d..55453872d7c 100644 --- a/libs/wire-api/src/Wire/API/Team/Member.hs +++ b/libs/wire-api/src/Wire/API/Team/Member.hs @@ -263,8 +263,13 @@ instance ToSchema TeamMembersPage where type TeamMembersPagingState = MultiTablePagingState TeamMembersPagingName TeamMembersTable -teamMemberPagingState :: PageWithState TeamMember -> TeamMembersPagingState -teamMemberPagingState p = MultiTablePagingState TeamMembersTable (LBS.toStrict . C.unPagingState <$> pwsState p) +teamMemberPagingState :: PageWithState Void TeamMember -> TeamMembersPagingState +teamMemberPagingState p = + MultiTablePagingState + TeamMembersTable + ( LBS.toStrict . C.unPagingState + <$> (C.paginationStateCassandra =<< p.pwsState) + ) instance ToParamSchema TeamMembersPagingState where toParamSchema _ = toParamSchema (Proxy @Text) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index defa322a590..4bef9277ccd 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -185,6 +185,7 @@ import Data.Schema import Data.Schema qualified as Schema import Data.Set qualified as Set import Data.Text qualified as T +import Data.Text qualified as Text import Data.Text.Ascii import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error @@ -205,6 +206,7 @@ import Wire.API.Error.Brig import Wire.API.Error.Brig qualified as E import Wire.API.Locale import Wire.API.Password +import Wire.API.PostgresMarshall import Wire.API.Provider.Service (ServiceRef) import Wire.API.Routes.MultiVerb import Wire.API.Team @@ -1838,21 +1840,28 @@ instance Schema.ToSchema AccountStatus where instance C.Cql AccountStatus where ctype = C.Tagged C.IntColumn - toCql Active = C.CqlInt 0 - toCql Suspended = C.CqlInt 1 - toCql Deleted = C.CqlInt 2 - toCql Ephemeral = C.CqlInt 3 - toCql PendingInvitation = C.CqlInt 4 - - fromCql (C.CqlInt i) = case i of - 0 -> pure Active - 1 -> pure Suspended - 2 -> pure Deleted - 3 -> pure Ephemeral - 4 -> pure PendingInvitation - n -> Left $ "unexpected account status: " ++ show n + toCql = C.CqlInt . postgresMarshall + + fromCql (C.CqlInt i) = mapLeft Text.unpack $ postgresUnmarshall i fromCql _ = Left "account status: int expected" +instance PostgresMarshall Int32 AccountStatus where + postgresMarshall = \case + Active -> 0 + Suspended -> 1 + Deleted -> 2 + Ephemeral -> 3 + PendingInvitation -> 4 + +instance PostgresUnmarshall Int32 AccountStatus where + postgresUnmarshall = \case + 0 -> Right Active + 1 -> Right Suspended + 2 -> Right Deleted + 3 -> Right Ephemeral + 4 -> Right PendingInvitation + n -> Left $ "unexpected account status: " <> Text.show n + data AccountStatusResp = AccountStatusResp {fromAccountStatusResp :: AccountStatus} deriving (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform AccountStatusResp) @@ -1992,6 +2001,12 @@ instance C.Cql (Imports.Set BaseProtocolTag) where fromCql (C.CqlInt bits) = pure $ protocolSetFromBits (fromIntegral bits) fromCql _ = Left "Protocol set: Int expected" +instance PostgresMarshall Int32 (Imports.Set BaseProtocolTag) where + postgresMarshall = fromIntegral . protocolSetBits + +instance PostgresUnmarshall Int32 (Imports.Set BaseProtocolTag) where + postgresUnmarshall = Right . protocolSetFromBits . fromIntegral + baseProtocolMask :: BaseProtocolTag -> Word32 baseProtocolMask BaseProtocolProteusTag = 1 baseProtocolMask BaseProtocolMLSTag = 2 diff --git a/libs/wire-api/src/Wire/API/User/EmailAddress.hs b/libs/wire-api/src/Wire/API/User/EmailAddress.hs index 1b3a58554e1..9bde18007ec 100644 --- a/libs/wire-api/src/Wire/API/User/EmailAddress.hs +++ b/libs/wire-api/src/Wire/API/User/EmailAddress.hs @@ -50,6 +50,7 @@ import Servant.API qualified as S import Test.QuickCheck import Text.Email.Parser import Text.Email.Validate +import Wire.API.PostgresMarshall -------------------------------------------------------------------------------- -- Email @@ -103,6 +104,14 @@ instance C.Cql EmailAddress where toCql = C.toCql . fromEmail +instance PostgresMarshall Text EmailAddress where + postgresMarshall = fromEmail + +instance PostgresUnmarshall Text EmailAddress where + postgresUnmarshall t = case emailAddressText t of + Just e -> Right e + Nothing -> Left "postgresUnmarshall: Invalid email" + fromEmail :: EmailAddress -> Text fromEmail = decodeUtf8 . toByteString diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 97a3c503e59..edcc3c3d842 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -71,6 +71,7 @@ import Text.Email.Parser import URI.ByteString qualified as URI import URI.ByteString.QQ (uri) import Web.Scim.Schema.User.Email () +import Wire.API.PostgresMarshall import Wire.API.User.EmailAddress import Wire.API.User.Phone import Wire.API.User.Profile (fromName, mkName) @@ -150,6 +151,7 @@ data UserSSOId | UserScimExternalId Text deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserSSOId) + deriving (PostgresMarshall A.Value, PostgresUnmarshall A.Value) via (StoreAsJSON UserSSOId) isUserSSOId :: UserSSOId -> Bool isUserSSOId (UserSSOId _) = True diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index d3634799df6..36cc322af0c 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -58,6 +58,7 @@ import Data.Text.Encoding qualified as TE import Imports import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) import Wire.API.Asset (AssetKey (..)) +import Wire.API.PostgresMarshall import Wire.API.User.Orphans () import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) @@ -69,7 +70,7 @@ import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) newtype Name = Name {fromName :: Text} deriving stock (Eq, Ord, Show, Generic) - deriving newtype (FromByteString, ToByteString) + deriving newtype (FromByteString, ToByteString, PostgresMarshall Text, PostgresUnmarshall Text) deriving (Arbitrary) via (Ranged 1 128 Text) deriving (FromJSON, ToJSON, S.ToSchema) via Schema Name @@ -88,7 +89,7 @@ deriving instance C.Cql Name newtype TextStatus = TextStatus {fromTextStatus :: Text} deriving stock (Eq, Ord, Show, Generic) - deriving newtype (FromByteString, ToByteString) + deriving newtype (FromByteString, ToByteString, PostgresMarshall Text, PostgresUnmarshall Text) deriving (Arbitrary) via (Ranged 1 256 Text) deriving (FromJSON, ToJSON, S.ToSchema) via Schema TextStatus @@ -105,7 +106,7 @@ deriving instance C.Cql TextStatus newtype ColourId = ColourId {fromColourId :: Int32} deriving stock (Eq, Ord, Show, Generic) - deriving newtype (Num, ToSchema, Arbitrary) + deriving newtype (Num, ToSchema, Arbitrary, PostgresMarshall Int32, PostgresUnmarshall Int32) deriving (FromJSON, ToJSON, S.ToSchema) via Schema ColourId defaultAccentId :: ColourId @@ -193,12 +194,21 @@ instance ToSchema AssetSize where instance C.Cql AssetSize where ctype = C.Tagged C.IntColumn - fromCql (C.CqlInt 0) = pure AssetPreview - fromCql (C.CqlInt 1) = pure AssetComplete + fromCql (C.CqlInt n) = mapLeft Text.unpack $ postgresUnmarshall n fromCql n = Left $ "Unexpected asset size: " ++ show n - toCql AssetPreview = C.CqlInt 0 - toCql AssetComplete = C.CqlInt 1 + toCql = C.CqlInt . postgresMarshall + +instance PostgresMarshall Int32 AssetSize where + postgresMarshall = \case + AssetPreview -> 0 + AssetComplete -> 1 + +instance PostgresUnmarshall Int32 AssetSize where + postgresUnmarshall = \case + 0 -> Right AssetPreview + 1 -> Right AssetComplete + n -> Left $ "Unexpected asset size: " <> Text.show n -------------------------------------------------------------------------------- -- ManagedBy @@ -260,6 +270,12 @@ instance C.Cql ManagedBy where toCql = C.CqlInt . managedByToInt32 +instance PostgresMarshall Int32 ManagedBy where + postgresMarshall = managedByToInt32 + +instance PostgresUnmarshall Int32 ManagedBy where + postgresUnmarshall = managedByFromInt32 + defaultManagedBy :: ManagedBy defaultManagedBy = ManagedByWire @@ -281,6 +297,7 @@ managedByFromInt32 = \case newtype Pict = Pict {fromPict :: [A.Object]} deriving stock (Eq, Ord, Show, Generic) deriving (FromJSON, ToJSON, S.ToSchema) via Schema Pict + deriving (PostgresMarshall A.Value, PostgresUnmarshall A.Value) via StoreAsJSON Pict instance ToSchema Pict where schema = diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs index 5309c4892d2..14458ebe4f9 100644 --- a/libs/wire-api/src/Wire/API/User/RichInfo.hs +++ b/libs/wire-api/src/Wire/API/User/RichInfo.hs @@ -58,6 +58,7 @@ import Data.Schema import Data.Text qualified as Text import Imports import Test.QuickCheck qualified as QC +import Wire.API.PostgresMarshall import Wire.Arbitrary (Arbitrary (arbitrary)) -------------------------------------------------------------------------------- @@ -271,6 +272,7 @@ richInfoAssocListURN = "urn:wire:scim:schemas:profile:1.0" newtype RichInfoAssocList = RichInfoAssocList {unRichInfoAssocList :: [RichField]} deriving stock (Eq, Show, Generic) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema RichInfoAssocList) + deriving (PostgresMarshall A.Value, PostgresUnmarshall A.Value) via (StoreAsJSON RichInfoAssocList) -- | Uses 'normalizeRichInfoAssocList'. mkRichInfoAssocList :: [RichField] -> RichInfoAssocList diff --git a/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql new file mode 100644 index 00000000000..9a5a47acbc7 --- /dev/null +++ b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql @@ -0,0 +1,62 @@ +CREATE TABLE wire_user ( + id uuid PRIMARY KEY, + accent_id integer NOT NULL, + activated boolean NOT NULL, + country text, + email text, + email_unvalidated text, + expires timestamptz, + feature_conference_calling integer, + handle text UNIQUE, + language text, + managed_by integer, + name text NOT NULL, + password text, + picture jsonb, + provider uuid, + service uuid, + searchable boolean, + sso_id jsonb, + account_status integer, + supported_protocols integer, + team uuid, + text_status text, + rich_info jsonb, + created_at timestamptz NOT NULL DEFAULT current_timestamp, + updated_at timestamptz NOT NULL DEFAULT current_timestamp +); + +CREATE INDEX wire_user_service_idx ON wire_user(provider, service); + +CREATE OR REPLACE FUNCTION update_updated_at() + RETURNS TRIGGER AS $$ +BEGIN + NEW.updated_at = now(); + RETURN NEW; +END; +$$ language 'plpgsql'; + +CREATE TRIGGER update_user_updated_at BEFORE UPDATE ON wire_user FOR EACH ROW EXECUTE PROCEDURE update_updated_at(); + +CREATE TABLE asset ( + user_id uuid NOT NULL, + typ integer NOT NULL, + key text NOT NULL, + size integer +); + +CREATE INDEX asset_user_id_idx ON asset (user_id); + +CREATE TABLE bot_conv ( + id uuid PRIMARY KEY, + conv uuid NOT NULL, + conv_team uuid, + FOREIGN KEY (id) REFERENCES wire_user(id) ON DELETE CASCADE +); + +CREATE INDEX bot_conv_conv_idx ON bot_conv (conv); +CREATE INDEX bot_conv_team_idx ON bot_conv (conv_team); + +CREATE TABLE deleted_user ( + id uuid PRIMARY KEY +); diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs index bbc3f68bd52..f66cf80bb63 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs @@ -122,7 +122,7 @@ syncAllUsersWithVersion mkVersion = -- contains User, Maybe Role, UserType, ..., and pass around -- ExtendedUser. this should make the code less convoluted. - let teams :: Map TeamId [IndexUser] = Map.fromListWith (<>) $ mapMaybe (\u -> (,[u]) . value <$> u.teamId) page + let teams :: Map TeamId [IndexUser] = Map.fromListWith (<>) $ mapMaybe (\u -> (,[u]) <$> u.teamId) page teamIds = Map.keys teams visMap <- fmap Map.fromList . unsafePooledForConcurrentlyN 16 teamIds $ \t -> (t,) <$> teamSearchVisibilityInbound t @@ -132,7 +132,7 @@ syncAllUsersWithVersion mkVersion = roles :: Map UserId (WithWritetime Role) <- fmap (Map.fromList . concat) . unsafePooledForConcurrentlyN 16 (Map.toList teams) $ \(t, us) -> do tms <- (.members) <$> selectTeamMemberInfos t (fmap (.userId) us) pure $ mapMaybe mkRoleWithWriteTime tms - let vis indexUser = fromMaybe defaultSearchVisibilityInbound $ (flip Map.lookup visMap . value =<< indexUser.teamId) + let vis indexUser = fromMaybe defaultSearchVisibilityInbound $ (flip Map.lookup visMap =<< indexUser.teamId) mkUserDoc indexUser = indexUserToDoc (vis indexUser) @@ -216,7 +216,7 @@ getUserType :: getUserType iu = case iu.serviceId of Just _ -> pure UserTypeBot Nothing -> do - mmApp <- mapM (getApp iu.userId) (iu.teamId <&> (.value)) + mmApp <- mapM (getApp iu.userId) iu.teamId case join mmApp of Just _ -> pure UserTypeApp Nothing -> pure UserTypeRegular diff --git a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs index df3313ccc76..b24057974a5 100644 --- a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs +++ b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs @@ -41,7 +41,8 @@ instance Exception PostgresMigrationError runAllMigrations :: Pool -> Logger -> IO () runAllMigrations pool logger = do let session = do - Log.info logger $ Log.msg (Log.val "Running migrations") + Log.info logger $ + Log.msg (Log.val "Running migrations") transaction Serializable Write $ do forM_ (MigrationInitialization : allMigrations) $ \migrationCmd -> do mErr <- runMigration migrationCmd diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index a7bc2e9fcdb..ed375a96490 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -19,7 +19,7 @@ module Wire.UserStore where -import Cassandra (PageWithState (..), PagingState) +import Cassandra (GeneralPaginationState, PageWithState (..)) import Data.Default import Data.Handle import Data.Id @@ -72,7 +72,7 @@ data UserStore m a where CreateUser :: NewStoredUser -> Maybe (ConvId, Maybe TeamId) -> UserStore m () GetIndexUser :: UserId -> UserStore m (Maybe IndexUser) DoesUserExist :: UserId -> UserStore m Bool - GetIndexUsersPaginated :: Int32 -> Maybe PagingState -> UserStore m (PageWithState IndexUser) + GetIndexUsersPaginated :: Int32 -> Maybe (GeneralPaginationState UserId) -> UserStore m (PageWithState UserId IndexUser) GetUsers :: [UserId] -> UserStore m [StoredUser] UpdateUser :: UserId -> StoredUserUpdate -> UserStore m () UpdateEmail :: UserId -> EmailAddress -> UserStore m () @@ -112,8 +112,8 @@ data UserStore m a where UpdateFeatureConferenceCalling :: UserId -> Maybe FeatureStatus -> UserStore m () LookupFeatureConferenceCalling :: UserId -> UserStore m (Maybe FeatureStatus) DeleteServiceUser :: ProviderId -> ServiceId -> BotId -> UserStore m () - LookupServiceUsers :: ProviderId -> ServiceId -> Maybe PagingState -> UserStore m (PageWithState (BotId, ConvId, Maybe TeamId)) - LookupServiceUsersForTeam :: ProviderId -> ServiceId -> TeamId -> Maybe PagingState -> UserStore m (PageWithState (BotId, ConvId)) + LookupServiceUsers :: ProviderId -> ServiceId -> Maybe (GeneralPaginationState BotId) -> UserStore m (PageWithState BotId (BotId, ConvId, Maybe TeamId)) + LookupServiceUsersForTeam :: ProviderId -> ServiceId -> TeamId -> Maybe (GeneralPaginationState BotId) -> UserStore m (PageWithState BotId (BotId, ConvId)) makeSem ''UserStore diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index 7a854c4ce23..e0f32afa8ef 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -47,7 +47,7 @@ interpretUserStoreCassandra casClient = GetUsers uids -> getUsersImpl uids DoesUserExist uid -> doesUserExistImpl uid GetIndexUser uid -> getIndexUserImpl uid - GetIndexUsersPaginated pageSize mPagingState -> getIndexUserPaginatedImpl pageSize mPagingState + GetIndexUsersPaginated pageSize mPagingState -> getIndexUserPaginatedImpl pageSize (paginationStateCassandra =<< mPagingState) UpdateUser uid update -> updateUserImpl uid update UpdateEmail uid email -> updateEmailImpl uid email UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid email @@ -77,8 +77,8 @@ interpretUserStoreCassandra casClient = DeleteEmail uid -> deleteEmailImpl uid SetUserSearchable uid searchable -> setUserSearchableImpl uid searchable DeleteServiceUser pid sid bid -> deleteServiceUserImpl pid sid bid - LookupServiceUsers pid sid mPagingState -> lookupServiceUsersImpl pid sid mPagingState - LookupServiceUsersForTeam pid sid tid mPagingState -> lookupServiceUsersForTeamImpl pid sid tid mPagingState + LookupServiceUsers pid sid mPagingState -> lookupServiceUsersImpl pid sid (paginationStateCassandra =<< mPagingState) + LookupServiceUsersForTeam pid sid tid mPagingState -> lookupServiceUsersForTeamImpl pid sid tid (paginationStateCassandra =<< mPagingState) createUserImpl :: NewStoredUser -> Maybe (ConvId, Maybe TeamId) -> Client () createUserImpl new mbConv = retry x5 . batch $ do @@ -117,14 +117,14 @@ doesUserExistImpl uid = getIndexUserImpl :: UserId -> Client (Maybe IndexUser) getIndexUserImpl u = do mIndexUserTuple <- retry x1 $ query1 cql (params LocalQuorum (Identity u)) - pure $ asRecord <$> mIndexUserTuple + pure $ indexUserFromTuple <$> mIndexUserTuple where cql :: PrepQuery R (Identity UserId) (TupleType IndexUser) cql = prepared . QueryString $ getIndexUserBaseQuery <> " WHERE id = ?" -getIndexUserPaginatedImpl :: Int32 -> Maybe PagingState -> Client (PageWithState IndexUser) +getIndexUserPaginatedImpl :: Int32 -> Maybe PagingState -> Client (PageWithState x IndexUser) getIndexUserPaginatedImpl pageSize mPagingState = - asRecord <$$> paginateWithState cql (paramsPagingState LocalQuorum () pageSize mPagingState) x1 + indexUserFromTuple <$$> paginateWithState cql (paramsPagingState LocalQuorum () pageSize mPagingState) x1 where cql :: PrepQuery R () (TupleType IndexUser) cql = prepared $ QueryString getIndexUserBaseQuery @@ -414,7 +414,7 @@ lookupServiceUsersImpl :: ProviderId -> ServiceId -> Maybe PagingState -> - Client (PageWithState (BotId, ConvId, Maybe TeamId)) + Client (PageWithState x (BotId, ConvId, Maybe TeamId)) lookupServiceUsersImpl pid sid mPagingState = paginateWithState cql (paramsPagingState LocalQuorum (pid, sid) 100 mPagingState) x1 where @@ -428,7 +428,7 @@ lookupServiceUsersForTeamImpl :: ServiceId -> TeamId -> Maybe PagingState -> - Client (PageWithState (BotId, ConvId)) + Client (PageWithState x (BotId, ConvId)) lookupServiceUsersForTeamImpl pid sid tid mPagingState = paginateWithState cql (paramsPagingState LocalQuorum (pid, sid, tid) 100 mPagingState) x1 where diff --git a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs index 824fe49e242..ce3d9221f2a 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs @@ -28,6 +28,7 @@ import Data.Json.Util import Data.Text.Encoding qualified as Text import Data.Text.Encoding.Error qualified as Text import Data.Text.ICU.Translit +import Data.Time import Database.CQL.Protocol import Imports import SAML2.WebSSO qualified as SAML @@ -44,19 +45,20 @@ data WithWritetime a = WithWriteTime {value :: a, writetime :: Writetime a} data IndexUser = IndexUser { userId :: UserId, - teamId :: Maybe (WithWritetime TeamId), - name :: WithWritetime Name, - accountStatus :: Maybe (WithWritetime AccountStatus), - handle :: Maybe (WithWritetime Handle), - email :: Maybe (WithWritetime EmailAddress), - colourId :: WithWritetime ColourId, - activated :: WithWritetime Activated, - serviceId :: Maybe (WithWritetime ServiceId), - managedBy :: Maybe (WithWritetime ManagedBy), - ssoId :: Maybe (WithWritetime UserSSOId), - unverifiedEmail :: Maybe (WithWritetime EmailAddress), - searchable :: Maybe (WithWritetime Bool), - writeTimeBumper :: Maybe (Writetime WriteTimeBumper) + teamId :: Maybe TeamId, + name :: Name, + accountStatus :: Maybe AccountStatus, + handle :: Maybe Handle, + email :: Maybe EmailAddress, + colourId :: ColourId, + activated :: Activated, + serviceId :: Maybe ServiceId, + managedBy :: Maybe ManagedBy, + ssoId :: Maybe UserSSOId, + unverifiedEmail :: Maybe EmailAddress, + searchable :: Maybe Bool, + createdAt :: UTCTime, + updatedAt :: UTCTime } deriving (Eq, Show) @@ -79,75 +81,45 @@ type instance Maybe (Writetime WriteTimeBumper) ) -instance Record IndexUser where - asTuple (IndexUser {..}) = +indexUserFromTuple :: TupleType IndexUser -> IndexUser +indexUserFromTuple ( userId, - value <$> teamId, writetime <$> teamId, - name.value, name.writetime, - value <$> accountStatus, writetime <$> accountStatus, - value <$> handle, writetime <$> handle, - value <$> email, writetime <$> email, - colourId.value, colourId.writetime, - activated.value, activated.writetime, - value <$> serviceId, writetime <$> serviceId, - value <$> managedBy, writetime <$> managedBy, - value <$> ssoId, writetime <$> ssoId, - value <$> unverifiedEmail, writetime <$> unverifiedEmail, - value <$> searchable, writetime <$> searchable, - writeTimeBumper - ) - - asRecord - ( u, - mTeam, tTeam, + teamId, tTeam, name, tName, - status, tStatus, + accountStatus, tStatus, handle, tHandle, email, tEmail, - colour, tColour, + colourId, tColour, activated, tActivated, - service, tService, + serviceId, tService, managedBy, tManagedBy, ssoId, tSsoId, - emailUnvalidated, tEmailUnvalidated, + unverifiedEmail, tEmailUnvalidated, searchable, tSearchable, tWriteTimeBumper ) = IndexUser { - userId = u, - teamId = WithWriteTime <$> mTeam <*> tTeam, - name = WithWriteTime name tName, - accountStatus = WithWriteTime <$> status <*> tStatus, - handle = WithWriteTime <$> handle <*> tHandle, - email = WithWriteTime <$> email <*> tEmail, - colourId = WithWriteTime colour tColour, - activated = WithWriteTime activated tActivated, - serviceId = WithWriteTime <$> service <*> tService, - managedBy = WithWriteTime <$> managedBy <*> tManagedBy, - ssoId = WithWriteTime <$> ssoId <*> tSsoId, - unverifiedEmail = WithWriteTime <$> emailUnvalidated <*> tEmailUnvalidated, - searchable = WithWriteTime <$> searchable <*> tSearchable, - writeTimeBumper = tWriteTimeBumper + createdAt = writetimeToUTC tActivated, + updatedAt = maximum $ catMaybes [writetimeToUTC <$> tTeam, + Just $ writetimeToUTC tName, + writetimeToUTC <$> tStatus, + writetimeToUTC <$> tHandle, + writetimeToUTC <$> tEmail, + Just $ writetimeToUTC tColour, + Just $ writetimeToUTC tActivated, + writetimeToUTC <$> tService, + writetimeToUTC <$> tManagedBy, + writetimeToUTC <$> tSsoId, + writetimeToUTC <$> tEmailUnvalidated, + writetimeToUTC <$> tSearchable, + writetimeToUTC <$> tWriteTimeBumper + ], + .. } {- ORMOLU_ENABLE -} indexUserToVersion :: Maybe (WithWritetime Role) -> IndexUser -> IndexVersion -indexUserToVersion role IndexUser {..} = - mkIndexVersion - [ const () <$$> Just name.writetime, - const () <$$> fmap writetime teamId, - const () <$$> fmap writetime accountStatus, - const () <$$> fmap writetime handle, - const () <$$> fmap writetime email, - const () <$$> Just colourId.writetime, - const () <$$> Just activated.writetime, - const () <$$> fmap writetime serviceId, - const () <$$> fmap writetime managedBy, - const () <$$> fmap writetime ssoId, - const () <$$> fmap writetime unverifiedEmail, - const () <$$> fmap writetime role, - const () <$$> fmap writetime searchable, - const () <$$> writeTimeBumper - ] +indexUserToVersion role iu = + mkIndexVersion [Just $ Writetime iu.updatedAt, const () <$$> fmap writetime role] indexUserToDoc :: SearchVisibilityInbound -> Maybe UserType -> Maybe Role -> IndexUser -> UserDoc indexUserToDoc searchVisInbound mUserType mRole IndexUser {..} = @@ -156,22 +128,22 @@ indexUserToDoc searchVisInbound mUserType mRole IndexUser {..} = UserDoc { udId = userId, udType = mUserType, - udSearchable = value <$> searchable, - udEmailUnvalidated = value <$> unverifiedEmail, - udSso = sso . value =<< ssoId, - udScimExternalId = join $ scimExternalId <$> (value <$> managedBy) <*> (value <$> ssoId), + udSearchable = searchable, + udEmailUnvalidated = unverifiedEmail, + udSso = sso =<< ssoId, + udScimExternalId = join $ scimExternalId <$> (managedBy) <*> (ssoId), udSearchVisibilityInbound = Just searchVisInbound, udRole = mRole, - udCreatedAt = Just . toUTCTimeMillis $ writetimeToUTC activated.writetime, - udManagedBy = value <$> managedBy, - udSAMLIdP = idpUrl . value =<< ssoId, - udAccountStatus = value <$> accountStatus, - udColourId = Just colourId.value, - udEmail = value <$> email, - udHandle = value <$> handle, - udNormalized = Just $ normalized name.value.fromName, - udName = Just name.value, - udTeam = value <$> teamId + udCreatedAt = Just . toUTCTimeMillis $ createdAt, + udManagedBy = managedBy, + udSAMLIdP = idpUrl =<< ssoId, + udAccountStatus = accountStatus, + udColourId = Just colourId, + udEmail = email, + udHandle = handle, + udNormalized = Just $ normalized name.fromName, + udName = Just name, + udTeam = teamId } else -- We insert a tombstone-style user here, as it's easier than -- deleting the old one. It's mostly empty, but having the status here @@ -179,7 +151,7 @@ indexUserToDoc searchVisInbound mUserType mRole IndexUser {..} = emptyUserDoc userId where shouldIndex = - ( case value <$> accountStatus of + ( case accountStatus of Nothing -> True Just Active -> True Just Suspended -> True @@ -187,7 +159,7 @@ indexUserToDoc searchVisInbound mUserType mRole IndexUser {..} = Just Ephemeral -> False Just PendingInvitation -> False ) - && activated.value -- FUTUREWORK: how is this adding to the first case? + && activated -- FUTUREWORK: how is this adding to the first case? && isNothing serviceId idpUrl :: UserSSOId -> Maybe Text diff --git a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs new file mode 100644 index 00000000000..00bb0f5d80f --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -0,0 +1,677 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} +{-# OPTIONS_GHC -Wwarn #-} + +module Wire.UserStore.Postgres where + +import Cassandra (GeneralPaginationState (PaginationStatePostgres), PageWithState (..), paginationStatePostgres) +import Control.Error (lastMay) +import Data.Handle +import Data.Id +import Data.Json.Util +import Data.Map qualified as Map +import Data.Qualified (Qualified (qUnqualified)) +import Data.Time +import Data.Tuple.Extra (fst3) +import Data.Vector (Vector) +import Data.Vector qualified as V +import Hasql.Pipeline qualified as Pipeline +import Hasql.Statement qualified as Hasql +import Hasql.TH +import Hasql.Transaction qualified as Transaction +import Hasql.Transaction.Sessions +import Imports +import Polysemy +import Wire.API.Asset hiding (Asset) +import Wire.API.Password +import Wire.API.PostgresMarshall +import Wire.API.Team.Feature (FeatureStatus) +import Wire.API.User hiding (DeleteUser) +import Wire.API.User.RichInfo +import Wire.API.User.Search +import Wire.Postgres +import Wire.StoredUser +import Wire.UserStore +import Wire.UserStore.IndexUser + +interpretUserStoreCassandra :: (PGConstraints r) => InterpreterFor UserStore r +interpretUserStoreCassandra = + interpret $ \case + CreateUser new mbConv -> createUserImpl new mbConv + ActivateUser uid identity -> activateUserImpl uid identity + DeactivateUser uid -> deactivateUserImpl uid + GetUsers uids -> getUsersImpl uids + DoesUserExist uid -> doesUserExistImpl uid + GetIndexUser uid -> getIndexUserImpl uid + GetIndexUsersPaginated pageSize mPagingState -> getIndexUsersPaginatedImpl pageSize (paginationStatePostgres =<< mPagingState) + UpdateUser uid update -> updateUserImpl uid update + UpdateEmail uid email -> updateEmailImpl uid (Just email) + DeleteEmail uid -> updateEmailImpl uid Nothing + UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid (Just email) + DeleteEmailUnvalidated uid -> updateEmailUnvalidatedImpl uid Nothing + LookupName uid -> lookupNameImpl uid + LookupHandle hdl -> lookupHandleImpl hdl + GlimpseHandle hdl -> lookupHandleImpl hdl + UpdateUserHandleEither uid update -> updateUserHandleEitherImpl uid update + UpdateSSOId uid ssoId -> updateSSOIdImpl uid ssoId + UpdateManagedBy uid managedBy -> updateManagedByImpl uid managedBy + UpdateAccountStatus uid accountStatus -> updateAccountStatusImpl uid accountStatus + UpdateRichInfo uid richInfo -> updateRichInfoImpl uid richInfo + UpdateFeatureConferenceCalling uid feat -> updateFeatureConferenceCallingImpl uid feat + LookupFeatureConferenceCalling uid -> lookupFeatureConferenceCallingImpl uid + DeleteUser user -> deleteUserImpl user + LookupStatus uid -> lookupStatusImpl uid + IsActivated uid -> isActivatedImpl uid + LookupLocale uid -> lookupLocaleImpl uid + GetUserTeam uid -> getUserTeamImpl uid + UpdateUserTeam uid tid -> updateUserTeamImpl uid tid + GetActivityTimestamps uid -> getActivityTimestampsImpl uid + GetRichInfo uid -> getRichInfoImpl uid + LookupRichInfos uids -> lookupRichInfosImpl uids + GetUserAuthenticationInfo uid -> getUserAuthenticationInfoImpl uid + SetUserSearchable uid searchable -> setUserSearchableImpl uid searchable + DeleteServiceUser pid sid bid -> deleteServiceUserImpl pid sid bid + LookupServiceUsers pid sid mPagingState -> lookupServiceUsersImpl pid sid (paginationStatePostgres =<< mPagingState) + LookupServiceUsersForTeam pid sid tid mPagingState -> lookupServiceUsersForTeamImpl pid sid tid (paginationStatePostgres =<< mPagingState) + +{- ORMOLU_DISABLE -} +type InsertUserRow = + ( UserId, Name, Maybe TextStatus, Pict, Maybe EmailAddress, + Maybe UserSSOId, ColourId, Maybe Password, Bool, AccountStatus, + Maybe UTCTimeMillis, Language, Maybe Country, Maybe ProviderId, Maybe ServiceId, + Maybe Handle, Maybe TeamId, ManagedBy, Set BaseProtocolTag, Bool + ) +type + SelectUserRow = + ( UserId, Name, Maybe TextStatus, Maybe Pict, Maybe EmailAddress, Maybe EmailAddress, + Maybe UserSSOId, ColourId, Bool, Maybe AccountStatus, + Maybe UTCTimeMillis, Maybe Language, Maybe Country, Maybe ProviderId, Maybe ServiceId, + Maybe Handle, Maybe TeamId, Maybe ManagedBy, Maybe (Set BaseProtocolTag), Maybe Bool + ) + +storedUserFromRow :: SelectUserRow -> StoredUser +storedUserFromRow (id_, name, textStatus, pict, email, emailUnvalidated, + ssoId, accentId, activated, status, + expires, language, country, providerId, serviceId, + handle, teamId, managedBy, supportedProtocols, searchable) + = let assets = Nothing in StoredUser{id = id_, ..} + +type SelectIndexUserRow = + (UserId, Maybe TeamId, Name, Maybe AccountStatus, Maybe Handle, + Maybe EmailAddress, Maybe EmailAddress, ColourId, Bool, Maybe ServiceId, + Maybe ManagedBy, Maybe UserSSOId, Maybe Bool, UTCTime, UTCTime) + +indexUserFromRow :: SelectIndexUserRow -> IndexUser +indexUserFromRow ( uid, teamId, name, accountStatus, handle, + email, unverifiedEmail, colourId, activated, serviceId, + managedBy, ssoId, searchable, createdAt, updatedAt + ) = IndexUser{userId = uid, ..} +{- ORMOLU_ENABLE -} + +createUserImpl :: (PGConstraints r) => NewStoredUser -> Maybe (ConvId, Maybe TeamId) -> Sem r () +createUserImpl new mbConv = + runTransaction Serializable Write $ do + Transaction.statement userRow insertUser + Transaction.statement (mkAssetRows new.id new.assets) insertAssetsStatement + for_ mbConv $ \(convId, mTeamId) -> do + Transaction.statement (new.id, convId, mTeamId) insertBotConv + where + userRow = + ( new.id, + new.name, + new.textStatus, + new.pict, + new.email, + new.ssoId, + new.accentId, + new.password, + new.activated, + new.status, + new.expires, + new.language, + new.country, + new.providerId, + new.serviceId, + new.handle, + new.teamId, + new.managedBy, + new.supportedProtocols, + new.searchable + ) + + insertUser :: Hasql.Statement InsertUserRow () + insertUser = + lmapPG + [resultlessStatement| + INSERT INTO wire_user + (id, name, text_status, picture, email, + sso_id, accent_id, password, activated, account_status, + expires, language, country, provider, service, + handle, team, managed_by, supported_protocols, searchable) + VALUES + ($1 :: uuid, $2 :: text, $3 :: text?, $4 :: jsonb, $5 :: text?, + $6 :: jsonb?, $7 :: integer, $8 :: text?, $9 :: boolean, $10 :: integer, + $11 :: timestamptz?, $12 :: text, $13 :: text?, $14 :: uuid?, $15 :: uuid?, + $16 :: text?, $17 :: uuid?, $18 :: integer, $19 :: integer, $20 :: boolean) + |] + + insertBotConv :: Hasql.Statement (UserId, ConvId, Maybe TeamId) () + insertBotConv = + lmapPG + [resultlessStatement| + INSERT INTO bot_conv + (id, conv, conv_team) + VALUES + ($1 :: uuid, $2 :: uuid, $3 :: uuid?) + |] + +mkAssetRows :: UserId -> [Asset] -> ([UserId], [Int32], [AssetKey], [Maybe AssetSize]) +mkAssetRows uid assets = + unzip4 $ + map (\asset -> (uid, 0, asset.assetKey, asset.assetSize)) assets + +insertAssetsStatement :: Hasql.Statement ([UserId], [Int32], [AssetKey], [Maybe AssetSize]) () +insertAssetsStatement = + lmapPG @(Vector _, Vector _, Vector _, Vector _) + [resultlessStatement| + INSERT INTO asset + (user_id, typ, key, size) + SELECT UNNEST ($1 :: uuid[], $2 :: integer[], $3 :: text[], $4 :: integer?[]) + |] + +getUsersImpl :: (PGConstraints r) => [UserId] -> Sem r [StoredUser] +getUsersImpl uids = do + (userRows, assetRows) <- + runPipeline $ + (,) + <$> Pipeline.statement uids selectUsers + <*> Pipeline.statement uids selectAssets + let assetMap = + foldr + (\(uid, _, key, size) -> Map.insertWith (<>) uid [ImageAsset key size]) + Map.empty + assetRows + pure $ + map + ( \row -> + let storedUser = storedUserFromRow row + in storedUser {assets = Map.lookup storedUser.id assetMap} :: StoredUser + ) + userRows + where + selectUsers :: Hasql.Statement [UserId] [SelectUserRow] + selectUsers = + dimapPG @(Vector _) + [vectorStatement| + SELECT + id :: uuid, name :: text, text_status :: text?, picture :: jsonb?, email :: text?, email_unvalidated :: text?, + sso_id :: jsonb?, accent_id :: integer, activated :: boolean, account_status :: integer?, + expires :: timestamptz?, language :: text?, country :: text?, provider :: uuid?, service :: uuid?, + handle :: text?, team :: uuid?, managed_by :: integer?, supported_protocols :: integer?, searchable :: boolean? + FROM wire_user + WHERE id = ANY($1 :: uuid[]) + |] + + -- TODO: Implement this, but make some test fail before implementing + -- selectDeletedUsers :: Hasql.Statement [UserId] [UserId] + -- selectDeletedUsers = pure [] + + selectAssets :: Hasql.Statement [UserId] [(UserId, Int32, AssetKey, Maybe AssetSize)] + selectAssets = + dimapPG @(Vector _) + [vectorStatement| + SELECT user_id :: uuid, typ :: integer, key :: text, size :: integer? + FROM asset + WHERE id = ANY($1 :: uuid[]) + |] + +doesUserExistImpl :: (PGConstraints r) => UserId -> Sem r Bool +doesUserExistImpl uid = + runStatement uid check + where + check :: Hasql.Statement UserId Bool + check = + lmapPG + [singletonStatement| + SELECT EXISTS ( + SELECT 1 FROM wire_user WHERE id = $1 :: uuid + UNION ALL + SELECT 1 FROM deleted_user WHERE id = $1 :: uuid + ) :: bool + |] + +activateUserImpl :: (PGConstraints r) => UserId -> UserIdentity -> Sem r () +activateUserImpl uid (emailIdentity -> email) = + runStatement (uid, email) update + where + update :: Hasql.Statement (UserId, Maybe EmailAddress) () + update = + lmapPG + [resultlessStatement| + UPDATE wire_user + SET activated = true, + email = $2 :: text? + WHERE id = $1 :: uuid + |] + +deactivateUserImpl :: (PGConstraints r) => UserId -> Sem r () +deactivateUserImpl uid = + runStatement uid update + where + update :: Hasql.Statement UserId () + update = + lmapPG + [resultlessStatement| + UPDATE wire_user + SET activated = false + WHERE id = $1 :: uuid + |] + +getIndexUserImpl :: (PGConstraints r) => UserId -> Sem r (Maybe IndexUser) +getIndexUserImpl uid = do + indexUserFromRow <$$> runStatement uid selectUser + where + selectUser :: Hasql.Statement UserId (Maybe SelectIndexUserRow) + selectUser = + dimapPG + [maybeStatement| + SELECT + id :: uuid, team :: uuid?, name :: text, account_status :: integer?, handle :: text?, + email :: text?, email_unvalidated :: text?, accent_id :: integer, activated :: Bool, serviceId :: uuid?, + managed_by :: integer?, sso_id :: jsonb?, searchable :: boolean?, created_at :: timestamptz, updated_at :: timestamptz + FROM user + WHERE id = $1 :: uuid + |] + +getIndexUsersPaginatedImpl :: (PGConstraints r) => Int32 -> Maybe UserId -> Sem r (PageWithState UserId IndexUser) +getIndexUsersPaginatedImpl lim mState = do + rows <- case mState of + Nothing -> runStatement lim selectStart + Just startId -> runStatement (startId, lim) selectFrom + let results = indexUserFromRow <$> rows + pure + PageWithState + { pwsResults = results, + pwsState = PaginationStatePostgres . (.userId) <$> lastMay results + } + where + selectStart :: Hasql.Statement Int32 [SelectIndexUserRow] + selectStart = + dimapPG + [vectorStatement| + SELECT + id :: uuid, team :: uuid?, name :: text, account_status :: integer?, handle :: text?, + email :: text?, email_unvalidated :: text?, accent_id :: integer, activated :: Bool, serviceId :: uuid?, + managed_by :: integer?, sso_id :: jsonb?, searchable :: boolean?, created_at :: timestamptz, updated_at :: timestamptz + FROM user + ORDER BY id ASC + LIMIT ($1 :: integer) + |] + + selectFrom :: Hasql.Statement (UserId, Int32) [SelectIndexUserRow] + selectFrom = + dimapPG + [vectorStatement| + SELECT + id :: uuid, team :: uuid?, name :: text, account_status :: integer?, handle :: text?, + email :: text?, email_unvalidated :: text?, accent_id :: integer, activated :: Bool, serviceId :: uuid?, + managed_by :: integer?, sso_id :: jsonb?, searchable :: boolean?, created_at :: timestamptz, updated_at :: timestamptz + FROM user + WHERE id > ($1 :: uuid) + ORDER BY id ASC + LIMIT ($2 :: integer) + |] + +updateUserImpl :: (PGConstraints r) => UserId -> StoredUserUpdate -> Sem r () +updateUserImpl uid MkStoredUserUpdate {..} = + runTransaction ReadCommitted Write $ do + Transaction.statement + (uid, name, textStatus, pict, accentId, lLanguage <$> locale, lCountry =<< locale, supportedProtocols) + updateUserFields + for_ assets $ \newAssets -> do + Transaction.statement uid deleteAssets + Transaction.statement (mkAssetRows uid newAssets) insertAssetsStatement + where + updateUserFields :: Hasql.Statement (UserId, Maybe Name, Maybe TextStatus, Maybe Pict, Maybe ColourId, Maybe Language, Maybe Country, Maybe (Set BaseProtocolTag)) () + updateUserFields = + lmapPG + [resultlessStatement| + UPDATE wire_user + SET name = COALESCE($2 :: text?, name), + text_status = COALESCE($3 :: text?, text_status), + picture = COALESCE($4 :: jsonb?, picture), + accent_id = COALESCE($5 :: integer?, accent_id), + language = COALESCE($6 :: text?, language), + country = COALESCE($7 :: text?, country), + supported_protocols = COALESCE($8 :: integer?, supported_protocols) + WHERE id = ($1 :: uuid) + |] + + deleteAssets :: Hasql.Statement UserId () + deleteAssets = + lmapPG + [resultlessStatement|DELETE FROM asset where user_id = $1 :: uuid|] + +updateEmailUnvalidatedImpl :: (PGConstraints r) => UserId -> Maybe EmailAddress -> Sem r () +updateEmailUnvalidatedImpl uid email = + runStatement (uid, email) update + where + update :: Hasql.Statement (UserId, Maybe EmailAddress) () + update = + lmapPG + [resultlessStatement|UPDATE wire_user SET email_unvalidated = ($2 :: text?) WHERE id = ($1 :: uuid)|] + +updateEmailImpl :: (PGConstraints r) => UserId -> Maybe EmailAddress -> Sem r () +updateEmailImpl uid email = + runStatement (uid, email) update + where + update :: Hasql.Statement (UserId, Maybe EmailAddress) () + update = + lmapPG + [resultlessStatement|UPDATE wire_user SET email = ($2 :: text?) WHERE id = ($1 :: uuid)|] + +lookupNameImpl :: (PGConstraints r) => UserId -> Sem r (Maybe Name) +lookupNameImpl uid = runStatement uid select + where + select :: Hasql.Statement UserId (Maybe Name) + select = + dimapPG + [maybeStatement| + SELECT name :: text + FROM wire_user + WHERE id = $1 :: uuid + |] + +lookupHandleImpl :: (PGConstraints r) => Handle -> Sem r (Maybe UserId) +lookupHandleImpl h = runStatement h selectUserIdByHandleStatement + +selectUserIdByHandleStatement :: Hasql.Statement Handle (Maybe UserId) +selectUserIdByHandleStatement = + dimapPG + [maybeStatement| + SELECT id :: uuid + FROM wire_user + WHERE handle = $1 :: text + |] + +updateUserHandleEitherImpl :: (PGConstraints r) => UserId -> StoredUserHandleUpdate -> Sem r (Either StoredUserUpdateError ()) +updateUserHandleEitherImpl uid upd = + runTransaction ReadCommitted Write $ do + mOwner <- Transaction.statement upd.new selectUserIdByHandleStatement + case mOwner of + Just uid' | uid' /= uid -> pure $ Left StoredUserUpdateHandleExists + Just _ -> pure $ Right () + Nothing -> Right <$> Transaction.statement (uid, upd.new) update + where + update :: Hasql.Statement (UserId, Handle) () + update = + lmapPG + [resultlessStatement| + UPDATE wire_user + SET handle = $2 :: text + WHERE id = $1 :: uuid + |] + +deleteUserImpl :: (PGConstraints r) => User -> Sem r () +deleteUserImpl user = + runTransaction ReadCommitted Write $ do + let uid = user.userQualifiedId.qUnqualified + Transaction.statement uid delete + Transaction.statement uid noteDeleted + where + delete :: Hasql.Statement UserId () + delete = + lmapPG + [resultlessStatement| + DELETE FROM wire_user + WHERE id = $1 :: uuid + |] + + noteDeleted :: Hasql.Statement (UserId) () + noteDeleted = + lmapPG + [resultlessStatement| + INSERT INTO deleted_user + (id) + VALUES ($1 :: uuid) + ON CONFLICT (id) DO NOTHING + |] + +-- TODO: This probably needs to work for deleted users +lookupStatusImpl :: (PGConstraints r) => UserId -> Sem r (Maybe AccountStatus) +lookupStatusImpl uid = + join <$> runStatement uid select + where + select :: Hasql.Statement UserId (Maybe (Maybe AccountStatus)) + select = + dimapPG + [maybeStatement|SELECT account_status :: integer? FROM wire_user WHERE id = $1 :: uuid|] + +-- TODO: This probably needs to work for deleted users +isActivatedImpl :: (PGConstraints r) => UserId -> Sem r Bool +isActivatedImpl uid = + fromMaybe False <$> runStatement uid select + where + select :: Hasql.Statement UserId (Maybe Bool) + select = + lmapPG + [maybeStatement|SELECT activated :: bool FROM wire_user WHERE id = $1 :: uuid|] + +lookupLocaleImpl :: (PGConstraints r) => UserId -> Sem r (Maybe (Maybe Language, Maybe Country)) +lookupLocaleImpl uid = + runStatement uid select + where + select :: Hasql.Statement UserId (Maybe (Maybe Language, Maybe Country)) + select = + dimapPG + [maybeStatement|SELECT language :: text?, country :: text? FROM wire_user WHERE id = $1 :: uuid|] + +-- TODO: This probably needs to work for deleted users +getUserTeamImpl :: (PGConstraints r) => UserId -> Sem r (Maybe TeamId) +getUserTeamImpl uid = + join <$> runStatement uid select + where + select :: Hasql.Statement UserId (Maybe (Maybe TeamId)) + select = + dimapPG + [maybeStatement|SELECT team :: uuid? FROM wire_user WHERE id = $1 :: uuid|] + +updateUserTeamImpl :: (PGConstraints r) => UserId -> TeamId -> Sem r () +updateUserTeamImpl uid tid = + runStatement (uid, tid) update + where + update :: Hasql.Statement (UserId, TeamId) () + update = + dimapPG + [resultlessStatement|UPDATE wire_user SET team = $2 :: uuid WHERE id = $1 :: uuid|] + +getActivityTimestampsImpl :: (PGConstraints r) => UserId -> Sem r [Maybe UTCTime] +getActivityTimestampsImpl = todo "getActivityTimestampsImpl: unimplemented" + +-- TODO: This used to work for deleted users, see what breaks if it doesn't, because it really shouldn't. +getRichInfoImpl :: (PGConstraints r) => UserId -> Sem r (Maybe RichInfoAssocList) +getRichInfoImpl uid = + join <$> runStatement (uid) select + where + select :: Hasql.Statement (UserId) (Maybe (Maybe RichInfoAssocList)) + select = + dimapPG + [maybeStatement|SELECT rich_info :: json? FROM wire_user WHERE id = $1 :: uuid|] + +updateRichInfoImpl :: (PGConstraints r) => UserId -> RichInfoAssocList -> Sem r () +updateRichInfoImpl uid richInfo = + runStatement (uid, richInfo) update + where + update :: Hasql.Statement (UserId, RichInfoAssocList) () + update = + dimapPG + [resultlessStatement|UPDATE wire_user SET rich_info = $2 :: jsonb WHERE id = $1 :: uuid|] + +lookupRichInfosImpl :: (PGConstraints r) => [UserId] -> Sem r [(UserId, RichInfo)] +lookupRichInfosImpl uids = + mapMaybe (\(uid, mbRi) -> (uid,) . RichInfo <$> mbRi) <$> runStatement uids select + where + select :: Hasql.Statement [UserId] [(UserId, Maybe RichInfoAssocList)] + select = + dimapPG @(Vector _) + [vectorStatement|SELECT id :: uuid, rich_info :: json? FROM wire_user WHERE id = ANY($1 :: uuid[])|] + +-- TODO: This used to work for deleted users, see what breaks if it doesn't, because it really shouldn't. +getUserAuthenticationInfoImpl :: (PGConstraints r) => UserId -> Sem r (Maybe (Maybe Password, AccountStatus)) +getUserAuthenticationInfoImpl uid = + withDefaultAccountStatus <$$> runStatement (uid) select + where + withDefaultAccountStatus :: (a, Maybe AccountStatus) -> (a, AccountStatus) + withDefaultAccountStatus (a, mStatus) = (a, fromMaybe Active mStatus) + + select :: Hasql.Statement (UserId) (Maybe (Maybe Password, Maybe AccountStatus)) + select = + dimapPG + [maybeStatement|SELECT password :: bytea?, account_status :: integer? FROM wire_user WHERE id = $1 :: uuid|] + +-- TODO: This used to work for deleted users, see what breaks if it doesn't, because it really shouldn't. +setUserSearchableImpl :: (PGConstraints r) => UserId -> SetSearchable -> Sem r () +setUserSearchableImpl uid (SetSearchable searchable) = + runStatement (uid, searchable) update + where + update :: Hasql.Statement (UserId, Bool) () + update = + dimapPG + [resultlessStatement|UPDATE wire_user SET searchable = $2 :: boolean WHERE id = $1 :: uuid|] + +deleteServiceUserImpl :: (PGConstraints r) => ProviderId -> ServiceId -> BotId -> Sem r () +deleteServiceUserImpl _ _ bid = + runStatement (botUserId bid) delete + where + delete :: Hasql.Statement (UserId) () + delete = + lmapPG + [resultlessStatement|DELETE FROM bot_conv where id = $1 :: uuid|] + +lookupServiceUsersImpl :: (PGConstraints r) => ProviderId -> ServiceId -> Maybe BotId -> Sem r (PageWithState BotId (BotId, ConvId, Maybe TeamId)) +lookupServiceUsersImpl _ _ mBotId = do + bots <- case mBotId of + Nothing -> runStatement () selectStart + Just bid -> runStatement bid selectFrom + pure + PageWithState + { pwsState = PaginationStatePostgres . fst3 <$> (bots V.!? (V.length bots - 1)), + pwsResults = V.toList bots + } + where + selectStart :: Hasql.Statement () (Vector (BotId, ConvId, Maybe TeamId)) + selectStart = + dimapPG + [vectorStatement| + SELECT id :: uuid, conv :: uuid, conv_team :: uuid? + FROM bot_conv + ORDER BY id + LIMIT 100 + |] + + selectFrom :: Hasql.Statement (BotId) (Vector (BotId, ConvId, Maybe TeamId)) + selectFrom = + dimapPG + [vectorStatement| + SELECT id :: uuid, conv :: uuid, conv_team :: uuid? + FROM bot_conv + WHERE id > $1 :: uuid + ORDER BY id + LIMIT 100 + |] + +lookupServiceUsersForTeamImpl :: (PGConstraints r) => ProviderId -> ServiceId -> TeamId -> Maybe BotId -> Sem r (PageWithState BotId (BotId, ConvId)) +lookupServiceUsersForTeamImpl _ _ tid mBotId = do + bots <- case mBotId of + Nothing -> runStatement (tid) selectStart + Just bid -> runStatement (tid, bid) selectFrom + pure + PageWithState + { pwsState = PaginationStatePostgres . fst <$> (bots V.!? (V.length bots - 1)), + pwsResults = V.toList bots + } + where + selectStart :: Hasql.Statement (TeamId) (Vector (BotId, ConvId)) + selectStart = + dimapPG + [vectorStatement| + SELECT id :: uuid, conv :: uuid + FROM bot_conv + WHERE conv_team = $1 :: uuid + ORDER BY id + LIMIT 100 + |] + + selectFrom :: Hasql.Statement (TeamId, BotId) (Vector (BotId, ConvId)) + selectFrom = + dimapPG + [vectorStatement| + SELECT id :: uuid, conv :: uuid + FROM bot_conv + WHERE conv_team = $1 :: uuid + AND id > $2 :: uuid + ORDER BY id + LIMIT 100 + |] + +updateSSOIdImpl :: (PGConstraints r) => UserId -> Maybe UserSSOId -> Sem r Bool +updateSSOIdImpl uid ssoid = + isJust . join <$> runStatement (uid, ssoid) update + where + update :: Hasql.Statement (UserId, Maybe UserSSOId) (Maybe (Maybe TeamId)) + update = + dimapPG + [maybeStatement| + UPDATE wire_user + SET sso_id = $2 :: jsonb? + WHERE id = $1 :: uuid + AND team IS NOT NULL + RETURNING team :: uuid? + |] + +updateManagedByImpl :: (PGConstraints r) => UserId -> ManagedBy -> Sem r () +updateManagedByImpl uid managedBy = + runStatement (uid, managedBy) update + where + update :: Hasql.Statement (UserId, ManagedBy) () + update = + lmapPG + [resultlessStatement| + UPDATE wire_user + SET managed_by = $2 :: integer + WHERE id = $1 :: uuid + |] + +updateAccountStatusImpl :: (PGConstraints r) => UserId -> AccountStatus -> Sem r () +updateAccountStatusImpl uid status = + runStatement (uid, status) update + where + update :: Hasql.Statement (UserId, AccountStatus) () + update = + lmapPG + [resultlessStatement| + UPDATE wire_user + SET account_status = $2 :: integer + WHERE id = $1 :: uuid + |] + +updateFeatureConferenceCallingImpl :: (PGConstraints r) => UserId -> Maybe FeatureStatus -> Sem r () +updateFeatureConferenceCallingImpl uid featureStatus = + runStatement (uid, featureStatus) update + where + update :: Hasql.Statement (UserId, Maybe FeatureStatus) () + update = + lmapPG + [resultlessStatement| + UPDATE wire_user + SET feature_conference_calling = $2 :: integer? + WHERE id = $1 :: uuid + |] + +lookupFeatureConferenceCallingImpl :: (PGConstraints r) => UserId -> Sem r (Maybe FeatureStatus) +lookupFeatureConferenceCallingImpl uid = join <$> runStatement uid select + where + select :: Hasql.Statement UserId (Maybe (Maybe FeatureStatus)) + select = + dimapPG + [maybeStatement|SELECT feature_conference_calling :: integer? FROM wire_user WHERE id = $1 :: uuid|] diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index cba59c4fa10..23825ead687 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -728,10 +728,10 @@ syncUserIndex uid = vis <- maybe (pure defaultSearchVisibilityInbound) - (teamSearchVisibilityInbound . value) + teamSearchVisibilityInbound indexUser.teamId - tm <- maybe (pure Nothing) (selectTeamMember . value) indexUser.teamId - userType <- getUserType indexUser.userId (indexUser.teamId <&> (.value)) (indexUser.serviceId <&> (.value)) + tm <- maybe (pure Nothing) selectTeamMember indexUser.teamId + userType <- getUserType indexUser.userId indexUser.teamId indexUser.serviceId let mRole = tm >>= mkRoleWithWriteTime userDoc = indexUserToDoc vis (Just userType) (value <$> mRole) indexUser version = ES.ExternalGT . ES.ExternalDocVersion . docVersion $ indexUserToVersion mRole indexUser diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index 1aa38695158..3711c0a4692 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -19,7 +19,6 @@ module Wire.MockInterpreters.UserStore where -import Cassandra.Util import Data.Handle import Data.Id import Data.Time @@ -150,22 +149,23 @@ storedUserToIndexUser :: StoredUser -> IndexUser storedUserToIndexUser storedUser = -- If we really care about this, we could start storing the writetimes, but we -- don't need it right now - let withDefaultTime x = WithWriteTime x $ Writetime $ UTCTime (YearDay 0 1) 0 + let defaultTime = UTCTime (YearDay 0 1) 0 in IndexUser { userId = storedUser.id, - teamId = withDefaultTime <$> storedUser.teamId, - name = withDefaultTime storedUser.name, - accountStatus = withDefaultTime <$> storedUser.status, - handle = withDefaultTime <$> storedUser.handle, - email = withDefaultTime <$> storedUser.email, - colourId = withDefaultTime storedUser.accentId, - activated = withDefaultTime storedUser.activated, - serviceId = withDefaultTime <$> storedUser.serviceId, - managedBy = withDefaultTime <$> storedUser.managedBy, - ssoId = withDefaultTime <$> storedUser.ssoId, + teamId = storedUser.teamId, + name = storedUser.name, + accountStatus = storedUser.status, + handle = storedUser.handle, + email = storedUser.email, + colourId = storedUser.accentId, + activated = storedUser.activated, + serviceId = storedUser.serviceId, + managedBy = storedUser.managedBy, + ssoId = storedUser.ssoId, unverifiedEmail = Nothing, - searchable = withDefaultTime <$> storedUser.searchable, - writeTimeBumper = Nothing + searchable = storedUser.searchable, + createdAt = defaultTime, + updatedAt = defaultTime } lookupLocaleImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r (Maybe ((Maybe Language, Maybe Country))) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 5dc5e19c770..7efcc5d8c9e 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -359,6 +359,7 @@ library Wire.UserStore Wire.UserStore.Cassandra Wire.UserStore.IndexUser + Wire.UserStore.Postgres Wire.UserStore.Unique Wire.UserSubsystem Wire.UserSubsystem.Error diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 3d37d91d4e5..fb8caee282b 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -1381,14 +1381,14 @@ listConnections uid Public.GetMultiTablePageRequest {..} = do Just (Public.ConnectionPagingState Public.PagingRemotes stateBS) -> remotesOnly self (mkState <$> stateBS) (fromRange gmtprSize) _ -> localsAndRemotes self (fmap mkState . Public.mtpsState =<< gmtprState) gmtprSize where - pageToConnectionsPage :: Public.LocalOrRemoteTable -> Data.PageWithState Public.UserConnection -> Public.ConnectionsPage + pageToConnectionsPage :: Public.LocalOrRemoteTable -> Data.PageWithState Void Public.UserConnection -> Public.ConnectionsPage pageToConnectionsPage table page@Data.PageWithState {..} = Public.MultiTablePage { mtpResults = pwsResults, mtpHasMore = C.pwsHasMore page, -- FUTUREWORK confusingly, using 'ConversationPagingState' instead of 'ConnectionPagingState' doesn't fail any tests. -- Is this type actually useless? Or the tests not good enough? - mtpPagingState = Public.ConnectionPagingState table (LBS.toStrict . C.unPagingState <$> pwsState) + mtpPagingState = Public.ConnectionPagingState table (LBS.toStrict . C.unPagingState <$> (Data.paginationStateCassandra =<< pwsState)) } mkState :: ByteString -> C.PagingState diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index bb13fd60930..41a6f9a8275 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -176,7 +176,7 @@ lookupLocalConnectionsPage :: Local UserId -> Maybe PagingState -> Range 1 1000 Int32 -> - m (PageWithState UserConnection) + m (PageWithState Void UserConnection) lookupLocalConnectionsPage self pagingState (fromRange -> size) = fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) x1 @@ -186,7 +186,7 @@ lookupRemoteConnectionsPage :: Local UserId -> Maybe PagingState -> Int32 -> - m (PageWithState UserConnection) + m (PageWithState Void UserConnection) lookupRemoteConnectionsPage self pagingState size = fmap (toRemoteUserConnection self) <$> paginateWithState diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 2ac49386349..df4c3e996ba 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -418,7 +418,7 @@ getTeamMembers lzusr tid mbMaxResults mbPagingState = do let mLimit = fromMaybe (unsafeRange Public.hardTruncationLimit) mbMaxResults if member `hasPermission` SearchContacts then do - pws :: PageWithState TeamMember <- E.listTeamMembers @CassandraPaging tid mState mLimit + pws :: PageWithState Void TeamMember <- E.listTeamMembers @CassandraPaging tid mState mLimit -- FUTUREWORK: Remove this via-Brig filtering when user and -- team_member tables are migrated to Postgres. We currently -- can't filter in the database because Cassandra doesn't @@ -448,7 +448,7 @@ getTeamMembers lzusr tid mbMaxResults mbPagingState = do let uids = uid : maybeToList invitee TeamSubsystem.internalSelectTeamMembers tid uids <&> toTeamSingleMembersPage member where - toTeamMembersPage :: TeamMember -> C.PageWithState TeamMember -> TeamMembersPage + toTeamMembersPage :: TeamMember -> C.PageWithState Void TeamMember -> TeamMembersPage toTeamMembersPage member p = let withPerms = (member `canSeePermsOf`) in TeamMembersPage $ diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 14d5d68e0a4..5519f0ef176 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -177,7 +177,7 @@ teamMembersPageFrom :: TeamId -> Maybe PagingState -> Range 1 HardTruncationLimit Int32 -> - Client (PageWithState TeamMember) + Client (PageWithState Void TeamMember) teamMembersPageFrom lh tid pagingState (fromRange -> max) = do page <- paginateWithState Cql.selectTeamMembers (paramsPagingState LocalQuorum (Identity tid) max pagingState) x1 members <- mapM (newTeamMember' lh tid) (pwsResults page)