From 38911578cffd99be6a3a1869031f5598f5e6d9b3 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 19 Jan 2026 16:09:10 +0100 Subject: [PATCH 01/13] UserStore.IndexUser: Simplify type by only tracking overall created and updated timestamps This way adapting it for postgresql will be much easier --- .../IndexedUserStore/Bulk/ElasticSearch.hs | 6 +- .../src/Wire/UserStore/Cassandra.hs | 4 +- .../src/Wire/UserStore/IndexUser.hs | 140 +++++++----------- .../src/Wire/UserSubsystem/Interpreter.hs | 6 +- .../unit/Wire/MockInterpreters/UserStore.hs | 28 ++-- 5 files changed, 78 insertions(+), 106 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs index bbc3f68bd5..f66cf80bb6 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/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index 7a854c4ce2..f47e8da56b 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -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 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 diff --git a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs index 824fe49e24..ce3d9221f2 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/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index cba59c4fa1..23825ead68 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 1aa3869515..3711c0a469 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))) From a964c1804840f25bfad8b8365065206b73876f75 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Jan 2026 11:41:17 +0100 Subject: [PATCH 02/13] Introduce GeneralPaginationState type to be able to paginate over cassandra or postgres --- libs/cassandra-util/src/Cassandra.hs | 3 ++ libs/cassandra-util/src/Cassandra/Exec.hs | 35 ++++++++++++++----- .../src/Wire/Sem/Paging/Cassandra.hs | 2 +- libs/wire-api/src/Wire/API/Team/Member.hs | 9 +++-- libs/wire-subsystems/src/Wire/UserStore.hs | 8 ++--- .../src/Wire/UserStore/Cassandra.hs | 12 +++---- services/brig/src/Brig/API/Public.hs | 4 +-- services/brig/src/Brig/Data/Connection.hs | 4 +-- services/galley/src/Galley/API/Teams.hs | 4 +-- services/galley/src/Galley/Cassandra/Team.hs | 2 +- 10 files changed, 54 insertions(+), 29 deletions(-) diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 74dcdfc45f..2440633481 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 57fdf3ff2b..9d5c7a03d5 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 12210c3c8a..a775a56beb 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/Team/Member.hs b/libs/wire-api/src/Wire/API/Team/Member.hs index 2d75ce2e04..55453872d7 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-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index a7bc2e9fcd..df314e5fb0 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 Void) -> UserStore m (PageWithState Void 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 Void) -> UserStore m (PageWithState Void (BotId, ConvId, Maybe TeamId)) + LookupServiceUsersForTeam :: ProviderId -> ServiceId -> TeamId -> Maybe (GeneralPaginationState Void) -> UserStore m (PageWithState Void (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 f47e8da56b..61f12ac5f5 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 @@ -122,7 +122,7 @@ getIndexUserImpl u = do 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 = indexUserFromTuple <$$> paginateWithState cql (paramsPagingState LocalQuorum () pageSize mPagingState) x1 where @@ -414,7 +414,7 @@ lookupServiceUsersImpl :: ProviderId -> ServiceId -> Maybe PagingState -> - Client (PageWithState (BotId, ConvId, Maybe TeamId)) + Client (PageWithState Void (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 Void (BotId, ConvId)) lookupServiceUsersForTeamImpl pid sid tid mPagingState = paginateWithState cql (paramsPagingState LocalQuorum (pid, sid, tid) 100 mPagingState) x1 where diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 3d37d91d4e..fb8caee282 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 bb13fd6093..41a6f9a827 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 2ac4938634..df4c3e996b 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 14d5d68e0a..5519f0ef17 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) From 702f6bab35dc39d7e158e2bfe6489a943231ce24 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 13 Jan 2026 17:10:57 +0100 Subject: [PATCH 03/13] UserStore.Postgres: Implement createUser --- libs/wire-api/src/Wire/API/Asset.hs | 7 + libs/wire-api/src/Wire/API/Locale.hs | 17 ++ libs/wire-api/src/Wire/API/Password.hs | 14 +- .../wire-api/src/Wire/API/PostgresMarshall.hs | 29 +++ libs/wire-api/src/Wire/API/User.hs | 41 +++- .../src/Wire/API/User/EmailAddress.hs | 9 + libs/wire-api/src/Wire/API/User/Identity.hs | 2 + libs/wire-api/src/Wire/API/User/Profile.hs | 31 ++- .../20260113140936-create-user-tables.sql | 45 ++++ .../src/Wire/PostgresMigrations.hs | 3 +- .../src/Wire/UserStore/Postgres.hs | 228 ++++++++++++++++++ libs/wire-subsystems/wire-subsystems.cabal | 1 + 12 files changed, 401 insertions(+), 26 deletions(-) create mode 100644 libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql create mode 100644 libs/wire-subsystems/src/Wire/UserStore/Postgres.hs diff --git a/libs/wire-api/src/Wire/API/Asset.hs b/libs/wire-api/src/Wire/API/Asset.hs index ac51bde02f..d822626e0e 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 576c7eeeb1..a9005d0c54 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 dfb16d1d25..03f0bc972e 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 666b5b78c4..c69bb8f39a 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/User.hs b/libs/wire-api/src/Wire/API/User.hs index defa322a59..4bef9277cc 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 1b3a58554e..9bde18007e 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 97a3c503e5..edcc3c3d84 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 d3634799df..36cc322af0 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-subsystems/postgres-migrations/20260113140936-create-user-tables.sql b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql new file mode 100644 index 0000000000..b5d11bba29 --- /dev/null +++ b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql @@ -0,0 +1,45 @@ +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, + 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, + write_time_bumper integer +); + +CREATE INDEX wire_user_service_idx ON wire_user(provider, service); + +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 +); + +CREATE INDEX bot_conv_conv_idx ON bot_conv (conv); +CREATE INDEX bot_conv_team_idx ON bot_conv (conv_team); diff --git a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs index df3313ccc7..b24057974a 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/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs new file mode 100644 index 0000000000..07970bb182 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -0,0 +1,228 @@ +{-# OPTIONS_GHC -Wwarn #-} + +module Wire.UserStore.Postgres where + +import Cassandra (PageWithState, paginationStatePostgres) +import Data.Handle +import Data.Id +import Data.Json.Util +import Data.Time +import Data.Vector (Vector) +import Hasql.Statement qualified as Hasql +import Hasql.TH (resultlessStatement) +import Hasql.Transaction qualified as Transaction +import Hasql.Transaction.Sessions +import Imports +import Polysemy +import Wire.API.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 + GetUsers uids -> getUsersImpl uids + GetIndexUser uid -> getIndexUserImpl uid + GetIndexUsersPaginated pageSize mPagingState -> getIndexUsersPaginatedImpl pageSize (paginationStatePostgres =<< mPagingState) + UpdateUser uid update -> updateUserImpl uid update + UpdateEmail uid email -> updateEmailImpl uid email + UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid email + DeleteEmailUnvalidated uid -> deleteEmailUnvalidatedImpl uid + 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 + DeleteUser user -> deleteUserImpl user + LookupHandle hdl -> lookupHandleImpl hdl + GlimpseHandle hdl -> lookupHandleImpl hdl + 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 + GetUserAuthenticationInfo uid -> getUserAuthenticationInfoImpl uid + 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 (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 + ) +{- 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 assetRows insertAssets + 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) + |] + + assetRows :: ([UserId], [Int32], [AssetKey], [Maybe AssetSize]) + assetRows = + unzip4 $ + map (\asset -> (new.id, 0, asset.assetKey, asset.assetSize)) new.assets + + insertAssets :: Hasql.Statement ([UserId], [Int32], [AssetKey], [Maybe AssetSize]) () + insertAssets = + lmapPG @(Vector _, Vector _, Vector _, Vector _) + [resultlessStatement| + INSERT INTO asset + (user_id, typ, key, size) + SELECT UNNEST ($1 :: uuid[], $2 :: integer[], $3 :: text[], $4 :: integer?[]) + |] + + 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?) + |] + +getIndexUserImpl :: (PGConstraints r) => UserId -> Sem r (Maybe IndexUser) +getIndexUserImpl = todo "getIndexUserImpl: unimplemented" + +getIndexUsersPaginatedImpl :: (PGConstraints r) => Int32 -> Maybe Void -> Sem r (PageWithState Void IndexUser) +getIndexUsersPaginatedImpl = todo "getIndexUsersPaginatedImpl: unimplemented" + +getUsersImpl :: (PGConstraints r) => [UserId] -> Sem r [StoredUser] +getUsersImpl = todo "getUsersImpl: unimplemented" + +updateUserImpl :: (PGConstraints r) => UserId -> StoredUserUpdate -> Sem r () +updateUserImpl = todo "updateUserImpl: unimplemented" + +updateEmailUnvalidatedImpl :: (PGConstraints r) => UserId -> EmailAddress -> Sem r () +updateEmailUnvalidatedImpl = todo "updateEmailUnvalidatedImpl: unimplemented" + +updateUserHandleEitherImpl :: (PGConstraints r) => UserId -> StoredUserHandleUpdate -> Sem r (Either StoredUserUpdateError ()) +updateUserHandleEitherImpl = todo "updateUserHandleEitherImpl: unimplemented" + +deleteUserImpl :: (PGConstraints r) => User -> Sem r () +deleteUserImpl = todo "deleteUserImpl: unimplemented" + +lookupHandleImpl :: (PGConstraints r) => Handle -> Sem r (Maybe UserId) +lookupHandleImpl = todo "lookupHandleImpl: unimplemented" + +glimpseHandleImpl :: (PGConstraints r) => Handle -> Sem r (Maybe UserId) +glimpseHandleImpl = todo "glimpseHandleImpl: unimplemented" + +lookupStatusImpl :: (PGConstraints r) => UserId -> Sem r (Maybe AccountStatus) +lookupStatusImpl = todo "lookupStatusImpl: unimplemented" + +isActivatedImpl :: (PGConstraints r) => UserId -> Sem r Bool +isActivatedImpl = todo "isActivatedImpl: unimplemented" + +lookupLocaleImpl :: (PGConstraints r) => UserId -> Sem r (Maybe (Maybe Language, Maybe Country)) +lookupLocaleImpl = todo "lookupLocaleImpl: unimplemented" + +getUserTeamImpl :: (PGConstraints r) => UserId -> Sem r (Maybe TeamId) +getUserTeamImpl = todo "getUserTeamImpl: unimplemented" + +updateUserTeamImpl :: (PGConstraints r) => UserId -> TeamId -> Sem r () +updateUserTeamImpl = todo "updateUserTeamImpl: unimplemented" + +getActivityTimestampsImpl :: (PGConstraints r) => UserId -> Sem r [Maybe UTCTime] +getActivityTimestampsImpl = todo "getActivityTimestampsImpl: unimplemented" + +getRichInfoImpl :: (PGConstraints r) => UserId -> Sem r (Maybe RichInfoAssocList) +getRichInfoImpl = todo "getRichInfoImpl: unimplemented" + +getUserAuthenticationInfoImpl :: (PGConstraints r) => UserId -> Sem r (Maybe (Maybe Password, AccountStatus)) +getUserAuthenticationInfoImpl = todo "getUserAuthenticationInfoImpl: unimplemented" + +deleteEmailImpl :: (PGConstraints r) => UserId -> Sem r () +deleteEmailImpl = todo "deleteEmailImpl: unimplemented" + +setUserSearchableImpl :: (PGConstraints r) => UserId -> SetSearchable -> Sem r () +setUserSearchableImpl = todo "setUserSearchableImpl: unimplemented" + +deleteServiceUserImpl :: ProviderId -> ServiceId -> BotId -> Sem r () +deleteServiceUserImpl = todo "deleteServiceUserImpl: unimplemented" + +lookupServiceUsersImpl :: ProviderId -> ServiceId -> Maybe Void -> Sem r (PageWithState Void (BotId, ConvId, Maybe TeamId)) +lookupServiceUsersImpl = todo "lookupServiceUsersImpl: unimplemented" + +lookupServiceUsersForTeamImpl :: ProviderId -> ServiceId -> TeamId -> Maybe Void -> Sem r (PageWithState Void (BotId, ConvId)) +lookupServiceUsersForTeamImpl = todo "lookupServiceUsersForTeamImpl: unimplemented" + +updateEmailImpl :: (PGConstraints r) => UserId -> EmailAddress -> Sem r () +updateEmailImpl = todo "updateEmailImpl: unimplemented" + +deleteEmailUnvalidatedImpl :: (PGConstraints r) => UserId -> Sem r () +deleteEmailUnvalidatedImpl = todo "deleteEmailUnvalidatedImpl: unimplemented" + +updateSSOIdImpl :: (PGConstraints r) => UserId -> Maybe UserSSOId -> Sem r Bool +updateSSOIdImpl = todo "updateSSOIdImpl: unimplemented" + +updateManagedByImpl :: (PGConstraints r) => UserId -> ManagedBy -> Sem r () +updateManagedByImpl = todo "updateManagedByImpl: unimplemented" + +updateAccountStatusImpl :: (PGConstraints r) => UserId -> AccountStatus -> Sem r () +updateAccountStatusImpl = todo "updateAccountStatusImpl: unimplemented" + +updateRichInfoImpl :: (PGConstraints r) => UserId -> RichInfoAssocList -> Sem r () +updateRichInfoImpl = todo "updateRichInfoImpl: unimplemented" + +updateFeatureConferenceCallingImpl :: (PGConstraints r) => UserId -> Maybe FeatureStatus -> Sem r () +updateFeatureConferenceCallingImpl = todo "updateFeatureConferenceCallingImpl: unimplemented" diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 5dc5e19c77..7efcc5d8c9 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 From 0d7e181837fea8b256cf612d6e740f5a9d84c62d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 19 Jan 2026 14:15:23 +0100 Subject: [PATCH 04/13] UserStore.Postgres: Implement getUsers --- .../src/Wire/UserStore/Postgres.hs | 65 +++++++++++++++++-- 1 file changed, 61 insertions(+), 4 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index 07970bb182..078040b496 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} {-# OPTIONS_GHC -Wwarn #-} module Wire.UserStore.Postgres where @@ -6,10 +8,12 @@ import Cassandra (PageWithState, paginationStatePostgres) import Data.Handle import Data.Id import Data.Json.Util +import Data.Map qualified as Map import Data.Time import Data.Vector (Vector) +import Hasql.Pipeline qualified as Pipeline import Hasql.Statement qualified as Hasql -import Hasql.TH (resultlessStatement) +import Hasql.TH (resultlessStatement, vectorStatement) import Hasql.Transaction qualified as Transaction import Hasql.Transaction.Sessions import Imports @@ -67,6 +71,20 @@ type InsertUserRow = 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_, ..} {- ORMOLU_ENABLE -} createUserImpl :: (PGConstraints r) => NewStoredUser -> Maybe (ConvId, Maybe TeamId) -> Sem r () @@ -140,15 +158,54 @@ createUserImpl new mbConv = ($1 :: uuid, $2 :: uuid, $3 :: uuid?) |] +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[]) + |] + + 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[]) + |] + getIndexUserImpl :: (PGConstraints r) => UserId -> Sem r (Maybe IndexUser) getIndexUserImpl = todo "getIndexUserImpl: unimplemented" getIndexUsersPaginatedImpl :: (PGConstraints r) => Int32 -> Maybe Void -> Sem r (PageWithState Void IndexUser) getIndexUsersPaginatedImpl = todo "getIndexUsersPaginatedImpl: unimplemented" -getUsersImpl :: (PGConstraints r) => [UserId] -> Sem r [StoredUser] -getUsersImpl = todo "getUsersImpl: unimplemented" - updateUserImpl :: (PGConstraints r) => UserId -> StoredUserUpdate -> Sem r () updateUserImpl = todo "updateUserImpl: unimplemented" From f81fe8fa8e260499c37561339743bade28cc52a1 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 19 Jan 2026 16:10:22 +0100 Subject: [PATCH 05/13] UserStore.Postgres: Implement getIndexUser --- .../20260113140936-create-user-tables.sql | 13 ++++++++- .../src/Wire/UserStore/Postgres.hs | 28 +++++++++++++++++-- 2 files changed, 38 insertions(+), 3 deletions(-) diff --git a/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql index b5d11bba29..4e510d0a83 100644 --- a/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql +++ b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql @@ -21,11 +21,22 @@ CREATE TABLE wire_user ( supported_protocols integer, team uuid, text_status text, - write_time_bumper integer + 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, diff --git a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index 078040b496..be3a7a31b8 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -13,7 +13,7 @@ import Data.Time import Data.Vector (Vector) import Hasql.Pipeline qualified as Pipeline import Hasql.Statement qualified as Hasql -import Hasql.TH (resultlessStatement, vectorStatement) +import Hasql.TH import Hasql.Transaction qualified as Transaction import Hasql.Transaction.Sessions import Imports @@ -85,6 +85,17 @@ storedUserFromRow (id_, name, textStatus, pict, email, emailUnvalidated, 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 () @@ -201,7 +212,20 @@ getUsersImpl uids = do |] getIndexUserImpl :: (PGConstraints r) => UserId -> Sem r (Maybe IndexUser) -getIndexUserImpl = todo "getIndexUserImpl: unimplemented" +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 Void -> Sem r (PageWithState Void IndexUser) getIndexUsersPaginatedImpl = todo "getIndexUsersPaginatedImpl: unimplemented" From 5adaf79505cb117725ab25fc2455b17c3b5fc6a0 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Jan 2026 15:18:44 +0100 Subject: [PATCH 06/13] UserStore.Postgres: Implement getIndexUsersPaginated --- libs/wire-subsystems/src/Wire/UserStore.hs | 2 +- .../src/Wire/UserStore/Postgres.hs | 43 +++++++++++++++++-- 2 files changed, 41 insertions(+), 4 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index df314e5fb0..12f6804f0d 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -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 (GeneralPaginationState Void) -> UserStore m (PageWithState Void 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 () diff --git a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index be3a7a31b8..f5af31bc34 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -4,7 +4,8 @@ module Wire.UserStore.Postgres where -import Cassandra (PageWithState, paginationStatePostgres) +import Cassandra (GeneralPaginationState (PaginationStatePostgres), PageWithState (..), paginationStatePostgres) +import Control.Error (lastMay) import Data.Handle import Data.Id import Data.Json.Util @@ -227,8 +228,44 @@ getIndexUserImpl uid = do WHERE id = $1 :: uuid |] -getIndexUsersPaginatedImpl :: (PGConstraints r) => Int32 -> Maybe Void -> Sem r (PageWithState Void IndexUser) -getIndexUsersPaginatedImpl = todo "getIndexUsersPaginatedImpl: unimplemented" +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 = todo "updateUserImpl: unimplemented" From 357ced6e4048828ee456062a06b60ff45398911f Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Jan 2026 15:52:16 +0100 Subject: [PATCH 07/13] UserStore.Postgres: Implement updateUser --- .../src/Wire/UserStore/Postgres.hs | 61 +++++++++++++------ 1 file changed, 44 insertions(+), 17 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index f5af31bc34..cb48850634 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -19,7 +19,7 @@ import Hasql.Transaction qualified as Transaction import Hasql.Transaction.Sessions import Imports import Polysemy -import Wire.API.Asset +import Wire.API.Asset hiding (Asset) import Wire.API.Password import Wire.API.PostgresMarshall import Wire.API.Team.Feature (FeatureStatus) @@ -103,7 +103,7 @@ createUserImpl :: (PGConstraints r) => NewStoredUser -> Maybe (ConvId, Maybe Tea createUserImpl new mbConv = runTransaction Serializable Write $ do Transaction.statement userRow insertUser - Transaction.statement assetRows insertAssets + Transaction.statement (mkAssetRows new.id new.assets) insertAssetsStatement for_ mbConv $ \(convId, mTeamId) -> do Transaction.statement (new.id, convId, mTeamId) insertBotConv where @@ -146,20 +146,6 @@ createUserImpl new mbConv = $16 :: text?, $17 :: uuid?, $18 :: integer, $19 :: integer, $20 :: boolean) |] - assetRows :: ([UserId], [Int32], [AssetKey], [Maybe AssetSize]) - assetRows = - unzip4 $ - map (\asset -> (new.id, 0, asset.assetKey, asset.assetSize)) new.assets - - insertAssets :: Hasql.Statement ([UserId], [Int32], [AssetKey], [Maybe AssetSize]) () - insertAssets = - lmapPG @(Vector _, Vector _, Vector _, Vector _) - [resultlessStatement| - INSERT INTO asset - (user_id, typ, key, size) - SELECT UNNEST ($1 :: uuid[], $2 :: integer[], $3 :: text[], $4 :: integer?[]) - |] - insertBotConv :: Hasql.Statement (UserId, ConvId, Maybe TeamId) () insertBotConv = lmapPG @@ -170,6 +156,20 @@ createUserImpl new mbConv = ($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) <- @@ -268,7 +268,34 @@ getIndexUsersPaginatedImpl lim mState = do |] updateUserImpl :: (PGConstraints r) => UserId -> StoredUserUpdate -> Sem r () -updateUserImpl = todo "updateUserImpl: unimplemented" +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 -> EmailAddress -> Sem r () updateEmailUnvalidatedImpl = todo "updateEmailUnvalidatedImpl: unimplemented" From d77e74d6ecc6d9ea7f204f7f05ba13c73192f242 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Jan 2026 16:05:45 +0100 Subject: [PATCH 08/13] UserStore.Postgres: Implement {update,delete}Email{,unvalidated} --- .../src/Wire/UserStore/Postgres.hs | 46 ++++++++++++++----- 1 file changed, 35 insertions(+), 11 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index cb48850634..7f71e2bee2 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -40,6 +40,7 @@ interpretUserStoreCassandra = GetIndexUsersPaginated pageSize mPagingState -> getIndexUsersPaginatedImpl pageSize (paginationStatePostgres =<< mPagingState) UpdateUser uid update -> updateUserImpl uid update UpdateEmail uid email -> updateEmailImpl uid email + DeleteEmail uid -> deleteEmailImpl uid UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid email DeleteEmailUnvalidated uid -> deleteEmailUnvalidatedImpl uid UpdateUserHandleEither uid update -> updateUserHandleEitherImpl uid update @@ -59,7 +60,6 @@ interpretUserStoreCassandra = GetActivityTimestamps uid -> getActivityTimestampsImpl uid GetRichInfo uid -> getRichInfoImpl uid GetUserAuthenticationInfo uid -> getUserAuthenticationInfoImpl uid - 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 (paginationStatePostgres =<< mPagingState) @@ -298,7 +298,40 @@ updateUserImpl uid MkStoredUserUpdate {..} = [resultlessStatement|DELETE FROM asset where user_id = $1 :: uuid|] updateEmailUnvalidatedImpl :: (PGConstraints r) => UserId -> EmailAddress -> Sem r () -updateEmailUnvalidatedImpl = todo "updateEmailUnvalidatedImpl: unimplemented" +updateEmailUnvalidatedImpl uid email = + runStatement (uid, email) update + where + update :: Hasql.Statement (UserId, EmailAddress) () + update = + lmapPG + [resultlessStatement|UPDATE wire_user SET email_unvalidated = ($2 :: text) WHERE id = ($1 :: uuid)|] + +deleteEmailUnvalidatedImpl :: (PGConstraints r) => UserId -> Sem r () +deleteEmailUnvalidatedImpl uid = + runStatement uid del + where + del :: Hasql.Statement UserId () + del = + lmapPG + [resultlessStatement|UPDATE wire_user SET email_unvalidated = NULL WHERE id = ($1 :: uuid)|] + +updateEmailImpl :: (PGConstraints r) => UserId -> EmailAddress -> Sem r () +updateEmailImpl uid email = + runStatement (uid, email) update + where + update :: Hasql.Statement (UserId, EmailAddress) () + update = + lmapPG + [resultlessStatement|UPDATE wire_user SET email = ($2 :: text) WHERE id = ($1 :: uuid)|] + +deleteEmailImpl :: (PGConstraints r) => UserId -> Sem r () +deleteEmailImpl uid = + runStatement uid del + where + del :: Hasql.Statement UserId () + del = + lmapPG + [resultlessStatement|UPDATE wire_user SET email = NULL WHERE id = ($1 :: uuid)|] updateUserHandleEitherImpl :: (PGConstraints r) => UserId -> StoredUserHandleUpdate -> Sem r (Either StoredUserUpdateError ()) updateUserHandleEitherImpl = todo "updateUserHandleEitherImpl: unimplemented" @@ -336,9 +369,6 @@ getRichInfoImpl = todo "getRichInfoImpl: unimplemented" getUserAuthenticationInfoImpl :: (PGConstraints r) => UserId -> Sem r (Maybe (Maybe Password, AccountStatus)) getUserAuthenticationInfoImpl = todo "getUserAuthenticationInfoImpl: unimplemented" -deleteEmailImpl :: (PGConstraints r) => UserId -> Sem r () -deleteEmailImpl = todo "deleteEmailImpl: unimplemented" - setUserSearchableImpl :: (PGConstraints r) => UserId -> SetSearchable -> Sem r () setUserSearchableImpl = todo "setUserSearchableImpl: unimplemented" @@ -351,12 +381,6 @@ lookupServiceUsersImpl = todo "lookupServiceUsersImpl: unimplemented" lookupServiceUsersForTeamImpl :: ProviderId -> ServiceId -> TeamId -> Maybe Void -> Sem r (PageWithState Void (BotId, ConvId)) lookupServiceUsersForTeamImpl = todo "lookupServiceUsersForTeamImpl: unimplemented" -updateEmailImpl :: (PGConstraints r) => UserId -> EmailAddress -> Sem r () -updateEmailImpl = todo "updateEmailImpl: unimplemented" - -deleteEmailUnvalidatedImpl :: (PGConstraints r) => UserId -> Sem r () -deleteEmailUnvalidatedImpl = todo "deleteEmailUnvalidatedImpl: unimplemented" - updateSSOIdImpl :: (PGConstraints r) => UserId -> Maybe UserSSOId -> Sem r Bool updateSSOIdImpl = todo "updateSSOIdImpl: unimplemented" From 13a3754b417c9d68e5c21450bebd04d8064c8eff Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Jan 2026 16:08:22 +0100 Subject: [PATCH 09/13] UserStore.Postgres: Simplify {update,delete}Email{,unvalidated} --- .../src/Wire/UserStore/Postgres.hs | 38 +++++-------------- 1 file changed, 10 insertions(+), 28 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index 7f71e2bee2..3e20ae47ac 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -39,10 +39,10 @@ interpretUserStoreCassandra = GetIndexUser uid -> getIndexUserImpl uid GetIndexUsersPaginated pageSize mPagingState -> getIndexUsersPaginatedImpl pageSize (paginationStatePostgres =<< mPagingState) UpdateUser uid update -> updateUserImpl uid update - UpdateEmail uid email -> updateEmailImpl uid email - DeleteEmail uid -> deleteEmailImpl uid - UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid email - DeleteEmailUnvalidated uid -> deleteEmailUnvalidatedImpl uid + UpdateEmail uid email -> updateEmailImpl uid (Just email) + DeleteEmail uid -> updateEmailImpl uid Nothing + UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid (Just email) + DeleteEmailUnvalidated uid -> updateEmailUnvalidatedImpl uid Nothing UpdateUserHandleEither uid update -> updateUserHandleEitherImpl uid update UpdateSSOId uid ssoId -> updateSSOIdImpl uid ssoId UpdateManagedBy uid managedBy -> updateManagedByImpl uid managedBy @@ -297,41 +297,23 @@ updateUserImpl uid MkStoredUserUpdate {..} = lmapPG [resultlessStatement|DELETE FROM asset where user_id = $1 :: uuid|] -updateEmailUnvalidatedImpl :: (PGConstraints r) => UserId -> EmailAddress -> Sem r () +updateEmailUnvalidatedImpl :: (PGConstraints r) => UserId -> Maybe EmailAddress -> Sem r () updateEmailUnvalidatedImpl uid email = runStatement (uid, email) update where - update :: Hasql.Statement (UserId, EmailAddress) () + update :: Hasql.Statement (UserId, Maybe EmailAddress) () update = lmapPG - [resultlessStatement|UPDATE wire_user SET email_unvalidated = ($2 :: text) WHERE id = ($1 :: uuid)|] + [resultlessStatement|UPDATE wire_user SET email_unvalidated = ($2 :: text?) WHERE id = ($1 :: uuid)|] -deleteEmailUnvalidatedImpl :: (PGConstraints r) => UserId -> Sem r () -deleteEmailUnvalidatedImpl uid = - runStatement uid del - where - del :: Hasql.Statement UserId () - del = - lmapPG - [resultlessStatement|UPDATE wire_user SET email_unvalidated = NULL WHERE id = ($1 :: uuid)|] - -updateEmailImpl :: (PGConstraints r) => UserId -> EmailAddress -> Sem r () +updateEmailImpl :: (PGConstraints r) => UserId -> Maybe EmailAddress -> Sem r () updateEmailImpl uid email = runStatement (uid, email) update where - update :: Hasql.Statement (UserId, EmailAddress) () + update :: Hasql.Statement (UserId, Maybe EmailAddress) () update = lmapPG - [resultlessStatement|UPDATE wire_user SET email = ($2 :: text) WHERE id = ($1 :: uuid)|] - -deleteEmailImpl :: (PGConstraints r) => UserId -> Sem r () -deleteEmailImpl uid = - runStatement uid del - where - del :: Hasql.Statement UserId () - del = - lmapPG - [resultlessStatement|UPDATE wire_user SET email = NULL WHERE id = ($1 :: uuid)|] + [resultlessStatement|UPDATE wire_user SET email = ($2 :: text?) WHERE id = ($1 :: uuid)|] updateUserHandleEitherImpl :: (PGConstraints r) => UserId -> StoredUserHandleUpdate -> Sem r (Either StoredUserUpdateError ()) updateUserHandleEitherImpl = todo "updateUserHandleEitherImpl: unimplemented" From 272456fbfbad8c5967e6354977e81e55856c05f1 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Jan 2026 16:28:42 +0100 Subject: [PATCH 10/13] UserStore.Postgres: Implement {lookup,glimpse}Handle and updateUserHandleEither --- .../20260113140936-create-user-tables.sql | 2 +- .../src/Wire/UserStore/Postgres.hs | 39 ++++++++++++++----- 2 files changed, 31 insertions(+), 10 deletions(-) diff --git a/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql index 4e510d0a83..fce6678985 100644 --- a/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql +++ b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql @@ -7,7 +7,7 @@ CREATE TABLE wire_user ( email_unvalidated text, expires timestamptz, feature_conference_calling integer, - handle text, + handle text UNIQUE, language text, managed_by integer, name text NOT NULL, diff --git a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index 3e20ae47ac..c379265b23 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -43,6 +43,8 @@ interpretUserStoreCassandra = DeleteEmail uid -> updateEmailImpl uid Nothing UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid (Just email) DeleteEmailUnvalidated uid -> updateEmailUnvalidatedImpl uid Nothing + 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 @@ -50,8 +52,6 @@ interpretUserStoreCassandra = UpdateRichInfo uid richInfo -> updateRichInfoImpl uid richInfo UpdateFeatureConferenceCalling uid feat -> updateFeatureConferenceCallingImpl uid feat DeleteUser user -> deleteUserImpl user - LookupHandle hdl -> lookupHandleImpl hdl - GlimpseHandle hdl -> lookupHandleImpl hdl LookupStatus uid -> lookupStatusImpl uid IsActivated uid -> isActivatedImpl uid LookupLocale uid -> lookupLocaleImpl uid @@ -315,18 +315,39 @@ updateEmailImpl uid email = lmapPG [resultlessStatement|UPDATE wire_user SET email = ($2 :: text?) 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 = todo "updateUserHandleEitherImpl: unimplemented" +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 = todo "deleteUserImpl: unimplemented" -lookupHandleImpl :: (PGConstraints r) => Handle -> Sem r (Maybe UserId) -lookupHandleImpl = todo "lookupHandleImpl: unimplemented" - -glimpseHandleImpl :: (PGConstraints r) => Handle -> Sem r (Maybe UserId) -glimpseHandleImpl = todo "glimpseHandleImpl: unimplemented" - lookupStatusImpl :: (PGConstraints r) => UserId -> Sem r (Maybe AccountStatus) lookupStatusImpl = todo "lookupStatusImpl: unimplemented" From 6aea2fc6b6c419061a7943bab3bf231bcce77cde Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 26 Jan 2026 15:41:34 +0100 Subject: [PATCH 11/13] UserStore.Postgres: Implement deleteUser --- .../20260113140936-create-user-tables.sql | 4 +++ .../src/Wire/UserStore/Postgres.hs | 30 ++++++++++++++++++- 2 files changed, 33 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql index fce6678985..52d9ccf658 100644 --- a/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql +++ b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql @@ -54,3 +54,7 @@ CREATE TABLE bot_conv ( 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/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index c379265b23..2abcdb3547 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -10,8 +10,10 @@ 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.Vector (Vector) +import Hasql.Decoders (uuid) import Hasql.Pipeline qualified as Pipeline import Hasql.Statement qualified as Hasql import Hasql.TH @@ -203,6 +205,10 @@ getUsersImpl uids = do 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 _) @@ -346,7 +352,29 @@ updateUserHandleEitherImpl uid upd = |] deleteUserImpl :: (PGConstraints r) => User -> Sem r () -deleteUserImpl = todo "deleteUserImpl: unimplemented" +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 + |] lookupStatusImpl :: (PGConstraints r) => UserId -> Sem r (Maybe AccountStatus) lookupStatusImpl = todo "lookupStatusImpl: unimplemented" From 178bc16fb3e7a4e88d56ff4525771d472faaa03b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 26 Jan 2026 16:58:13 +0100 Subject: [PATCH 12/13] UserStore.Postgres: Implement more things --- libs/wire-api/src/Wire/API/User/RichInfo.hs | 2 + .../20260113140936-create-user-tables.sql | 1 + .../src/Wire/UserStore/Postgres.hs | 92 ++++++++++++++++--- 3 files changed, 83 insertions(+), 12 deletions(-) diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs index 5309c4892d..14458ebe4f 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 index 52d9ccf658..d11ef3956e 100644 --- a/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql +++ b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql @@ -21,6 +21,7 @@ CREATE TABLE wire_user ( 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 ); diff --git a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index 2abcdb3547..d59d425fc8 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -13,7 +13,6 @@ import Data.Map qualified as Map import Data.Qualified (Qualified (qUnqualified)) import Data.Time import Data.Vector (Vector) -import Hasql.Decoders (uuid) import Hasql.Pipeline qualified as Pipeline import Hasql.Statement qualified as Hasql import Hasql.TH @@ -376,32 +375,104 @@ deleteUserImpl user = ON CONFLICT (id) DO NOTHING |] +-- TODO: This probably needs to work for deleted users lookupStatusImpl :: (PGConstraints r) => UserId -> Sem r (Maybe AccountStatus) -lookupStatusImpl = todo "lookupStatusImpl: unimplemented" +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 = todo "isActivatedImpl: unimplemented" +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 = todo "lookupLocaleImpl: unimplemented" +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 = todo "getUserTeamImpl: unimplemented" +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 = todo "updateUserTeamImpl: unimplemented" +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 = todo "getRichInfoImpl: unimplemented" +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|] + +-- 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 = todo "getUserAuthenticationInfoImpl: unimplemented" +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 = todo "setUserSearchableImpl: unimplemented" +setUserSearchableImpl = + todo + "setUserSearchableImpl: unimplemented" + 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|] deleteServiceUserImpl :: ProviderId -> ServiceId -> BotId -> Sem r () deleteServiceUserImpl = todo "deleteServiceUserImpl: unimplemented" @@ -421,8 +492,5 @@ updateManagedByImpl = todo "updateManagedByImpl: unimplemented" updateAccountStatusImpl :: (PGConstraints r) => UserId -> AccountStatus -> Sem r () updateAccountStatusImpl = todo "updateAccountStatusImpl: unimplemented" -updateRichInfoImpl :: (PGConstraints r) => UserId -> RichInfoAssocList -> Sem r () -updateRichInfoImpl = todo "updateRichInfoImpl: unimplemented" - updateFeatureConferenceCallingImpl :: (PGConstraints r) => UserId -> Maybe FeatureStatus -> Sem r () updateFeatureConferenceCallingImpl = todo "updateFeatureConferenceCallingImpl: unimplemented" From c996d6ba429c4e527951f8a9b3ae2e4b87ca42b0 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Jan 2026 11:13:42 +0100 Subject: [PATCH 13/13] UserStore.Postgres: Implement Everything --- libs/wire-api/src/Wire/API/Team/Feature.hs | 20 +- .../20260113140936-create-user-tables.sql | 3 +- libs/wire-subsystems/src/Wire/UserStore.hs | 4 +- .../src/Wire/UserStore/Cassandra.hs | 4 +- .../src/Wire/UserStore/Postgres.hs | 221 ++++++++++++++++-- 5 files changed, 221 insertions(+), 31 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 37d226b9b1..ea3057dfd5 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-subsystems/postgres-migrations/20260113140936-create-user-tables.sql b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql index d11ef3956e..9a5a47acbc 100644 --- a/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql +++ b/libs/wire-subsystems/postgres-migrations/20260113140936-create-user-tables.sql @@ -50,7 +50,8 @@ 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 + conv_team uuid, + FOREIGN KEY (id) REFERENCES wire_user(id) ON DELETE CASCADE ); CREATE INDEX bot_conv_conv_idx ON bot_conv (conv); diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 12f6804f0d..ed375a9649 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -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 (GeneralPaginationState Void) -> UserStore m (PageWithState Void (BotId, ConvId, Maybe TeamId)) - LookupServiceUsersForTeam :: ProviderId -> ServiceId -> TeamId -> Maybe (GeneralPaginationState Void) -> UserStore m (PageWithState Void (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 61f12ac5f5..e0f32afa8e 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -414,7 +414,7 @@ lookupServiceUsersImpl :: ProviderId -> ServiceId -> Maybe PagingState -> - Client (PageWithState Void (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 Void (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/Postgres.hs b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs index d59d425fc8..00bb0f5d80 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Postgres.hs @@ -12,7 +12,9 @@ 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 @@ -36,7 +38,10 @@ 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 @@ -44,6 +49,7 @@ interpretUserStoreCassandra = 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 @@ -52,6 +58,7 @@ interpretUserStoreCassandra = 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 @@ -60,6 +67,7 @@ interpretUserStoreCassandra = 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 @@ -217,6 +225,48 @@ getUsersImpl uids = do 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 @@ -320,6 +370,18 @@ updateEmailImpl uid email = 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 @@ -445,6 +507,15 @@ updateRichInfoImpl uid richInfo = 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 = @@ -460,37 +531,147 @@ getUserAuthenticationInfoImpl uid = -- 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 = - todo - "setUserSearchableImpl: unimplemented" - withDefaultAccountStatus - <$$> runStatement (uid) select +setUserSearchableImpl uid (SetSearchable searchable) = + runStatement (uid, searchable) update where - withDefaultAccountStatus :: (a, Maybe AccountStatus) -> (a, AccountStatus) - withDefaultAccountStatus (a, mStatus) = (a, fromMaybe Active mStatus) + update :: Hasql.Statement (UserId, Bool) () + update = + dimapPG + [resultlessStatement|UPDATE wire_user SET searchable = $2 :: boolean WHERE id = $1 :: uuid|] - select :: Hasql.Statement (UserId) (Maybe (Maybe Password, Maybe AccountStatus)) - select = +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 - [maybeStatement|SELECT password :: bytea?, account_status :: integer? FROM wire_user WHERE id = $1 :: uuid|] + [vectorStatement| + SELECT id :: uuid, conv :: uuid, conv_team :: uuid? + FROM bot_conv + ORDER BY id + LIMIT 100 + |] -deleteServiceUserImpl :: ProviderId -> ServiceId -> BotId -> Sem r () -deleteServiceUserImpl = todo "deleteServiceUserImpl: unimplemented" + 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 + |] -lookupServiceUsersImpl :: ProviderId -> ServiceId -> Maybe Void -> Sem r (PageWithState Void (BotId, ConvId, Maybe TeamId)) -lookupServiceUsersImpl = todo "lookupServiceUsersImpl: unimplemented" +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 + |] -lookupServiceUsersForTeamImpl :: ProviderId -> ServiceId -> TeamId -> Maybe Void -> Sem r (PageWithState Void (BotId, ConvId)) -lookupServiceUsersForTeamImpl = todo "lookupServiceUsersForTeamImpl: unimplemented" + 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 = todo "updateSSOIdImpl: unimplemented" +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 = todo "updateManagedByImpl: unimplemented" +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 = todo "updateAccountStatusImpl: unimplemented" +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 = todo "updateFeatureConferenceCallingImpl: unimplemented" +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|]