diff --git a/CHANGELOG.md b/CHANGELOG.md index 53628a556b..33b9e77494 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,6 +38,41 @@ ## Internal changes +# [2021-08-16] + +## Release Notes + +This is a routine release requiring only the routine upgrade steps. + +## API Changes + +* Add `POST /conversations/list-ids` (#1686) +* Deprecate `GET /converstations/ids` (#1686) + +## Features + +* Client functions for the hscim library (#1694, #1699, #1702, https://hackage.haskell.org/package/hscim) + +## Bug fixes and other updates + +* Change http response code for `missing-legalhold-consent`. (#1688) +* Remove old end-point for changing email + +## Federation changes (alpha feature, do not use yet) + +* Add new API to list paginated qualified conversation ids (#1686) + +## Documentation + +* Fix swagger: mark name in UserUpdate as optional (#1691, #1692) + +## Internal changes + +* Replaced uses of `UVerb` and `EmptyResult` with `MultiVerb` (#1693) +* Added a mechanism to derive `AsUnion` instances automatically (#1693) +* Integration test coverage (#1696, #1704) + + # [2021-08-02] ## Release Notes @@ -65,6 +100,7 @@ Upgrade nginz (#1658) * New, hardened end-point for changing email (68b4db08) * Fix: CSV export is missing SCIM external id when SAML is also used (#1608) * Fix: sso_id field in user record (brig) was not always filled correctly in cassandra (#1334) +* Change http response code for `missing-legalhold-consent` from 412 to 403 (#1688) ## Documentation diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 31b9c4ed85..2b166cc9b4 100644 --- a/libs/cassandra-util/src/Cassandra.hs +++ b/libs/cassandra-util/src/Cassandra.hs @@ -30,6 +30,7 @@ import Cassandra.CQL as C Consistency (All, One, Quorum), Cql, Keyspace (Keyspace), + PagingState (..), QueryParams (QueryParams), QueryString (QueryString), R, @@ -58,6 +59,7 @@ import Cassandra.Exec as C ClientState, MonadClient, Page (..), + PageWithState (..), PrepQuery, Row, addPrepQuery, @@ -70,8 +72,11 @@ import Cassandra.Exec as C nextPage, paginate, paginateC, + paginateWithState, params, paramsP, + paramsPagingState, + pwsHasMore, query, query1, result, diff --git a/libs/cassandra-util/src/Cassandra/CQL.hs b/libs/cassandra-util/src/Cassandra/CQL.hs index 3680166d0d..058b6a5bd4 100644 --- a/libs/cassandra-util/src/Cassandra/CQL.hs +++ b/libs/cassandra-util/src/Cassandra/CQL.hs @@ -29,6 +29,7 @@ import Database.CQL.Protocol as C Consistency (All, One, Quorum), Cql, Keyspace (Keyspace), + PagingState (..), QueryParams (QueryParams), QueryString (QueryString), R, diff --git a/libs/cassandra-util/src/Cassandra/Exec.hs b/libs/cassandra-util/src/Cassandra/Exec.hs index bfe15af27f..d39188bc03 100644 --- a/libs/cassandra-util/src/Cassandra/Exec.hs +++ b/libs/cassandra-util/src/Cassandra/Exec.hs @@ -26,6 +26,10 @@ module Cassandra.Exec x1, syncCassandra, paginateC, + PageWithState (..), + paginateWithState, + paramsPagingState, + pwsHasMore, module C, ) where @@ -34,10 +38,11 @@ import Cassandra.CQL (Consistency, R) import Control.Monad.Catch import Data.Conduit -- We only use these locally. -import Database.CQL.IO (RetrySettings, RunQ, defRetrySettings, eagerRetrySettings) +import Database.CQL.IO (ProtocolError (UnexpectedResponse), RetrySettings, RunQ, defRetrySettings, eagerRetrySettings, getResult, hrHost, hrResponse, runQ) -- Things we just import and re-export. import Database.CQL.IO as C (BatchM, Client, ClientState, MonadClient, Page (..), PrepQuery, Row, addPrepQuery, addQuery, adjustConsistency, adjustResponseTimeout, adjustSendTimeout, batch, emptyPage, init, liftClient, localState, paginate, prepared, query, query1, queryString, retry, runClient, schema, setConsistency, setSerialConsistency, setType, shutdown, trans, write) -import Database.CQL.Protocol (Error, QueryParams (QueryParams), Tuple) +import Database.CQL.Protocol (Error, QueryParams (QueryParams), Tuple, pagingState) +import qualified Database.CQL.Protocol as Protocol import Imports hiding (init) params :: Tuple a => Consistency -> a -> QueryParams a @@ -100,3 +105,29 @@ paginateC q p r = go =<< lift (retry r (paginate q p)) yield (result page) when (hasMore page) $ go =<< lift (retry r (liftClient (nextPage page))) + +data PageWithState a = PageWithState + { pwsResults :: [a], + pwsState :: Maybe Protocol.PagingState + } + deriving (Functor) + +-- | Like 'paginate' but exposes the paging state. This paging state can be +-- 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 -> m (PageWithState b) +paginateWithState q p = do + let p' = p {Protocol.pageSize = Protocol.pageSize p <|> Just 10000} + r <- runQ q p' + getResult r >>= \case + Protocol.RowsResult m b -> + return $ PageWithState b (pagingState m) + _ -> throwM $ UnexpectedResponse (hrHost r) (hrResponse r) + +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 = isJust . pwsState diff --git a/libs/hscim/CHANGELOG b/libs/hscim/CHANGELOG new file mode 100644 index 0000000000..24ba090e43 --- /dev/null +++ b/libs/hscim/CHANGELOG @@ -0,0 +1,2 @@ +0.3.4: + - initial version diff --git a/libs/hscim/hscim.cabal b/libs/hscim/hscim.cabal index d79f9817ce..870c476dbc 100644 --- a/libs/hscim/hscim.cabal +++ b/libs/hscim/hscim.cabal @@ -4,15 +4,15 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 427354dd7819ba82a24149dd338a58c577aa8b4ba3a1682d80de4c8f3c459049 +-- hash: b8d0589f22bc168d16fa3a2b2800d9cc3b14b4d94bb911fe973ccf2a2025e5e5 name: hscim -version: 0.3.4 -synopsis: ... -description: ... +version: 0.3.5 +synopsis: hscim json schema and server implementation +description: The README file will answer all the questions you might have category: Web -homepage: https://github.com/wireapp/hscim/README.md -bug-reports: https://github.com/wireapp/hscim/issues +homepage: https://github.com/wireapp/wire-server/libs/hscim/README.md +bug-reports: https://github.com/wireapp/wire-server/issues author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2018 Wire Swiss GmbH @@ -21,10 +21,12 @@ license-file: LICENSE build-type: Simple extra-source-files: README.md + CHANGELOG source-repository head type: git - location: https://github.com/wireapp/hscim + location: https://github.com/wireapp/wire-server + subdir: hscim library exposed-modules: @@ -38,6 +40,7 @@ library Web.Scim.Class.Auth Web.Scim.Class.Group Web.Scim.Class.User + Web.Scim.Client Web.Scim.ContentType Web.Scim.Filter Web.Scim.Handler @@ -72,7 +75,7 @@ library aeson >=1.4.5 && <1.5 , aeson-qq >=0.8.2 && <0.9 , attoparsec >=0.13.2 && <0.14 - , base >=4.12 && <4.14 + , base >=4.12 && <4.15 , bytestring >=0.10.8 && <0.11 , case-insensitive >=1.2.1.0 && <1.3 , email-validate >=2.3.2 && <2.4 @@ -93,11 +96,13 @@ library , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.19 + , servant-client >=0.16.2 && <0.19 + , servant-client-core >=0.16.2 && <0.19 , servant-server >=0.16.2 && <0.19 , stm >=2.5.0 && <2.6 , stm-containers >=1.1.0 && <1.2 , string-conversions >=0.4.0 && <0.5 - , template-haskell >=2.14.0 && <2.16 + , template-haskell >=2.14.0 && <2.17 , text >=1.2.3 && <1.3 , time >=1.8.0 && <1.10 , unordered-containers >=0.2.10 && <0.3 @@ -119,7 +124,7 @@ executable hscim-server aeson >=1.4.5 && <1.5 , aeson-qq >=0.8.2 && <0.9 , attoparsec >=0.13.2 && <0.14 - , base >=4.12 && <4.14 + , base >=4.12 && <4.15 , bytestring >=0.10.8 && <0.11 , case-insensitive >=1.2.1.0 && <1.3 , email-validate >=2.3.2 && <2.4 @@ -141,11 +146,13 @@ executable hscim-server , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.19 + , servant-client >=0.16.2 && <0.19 + , servant-client-core >=0.16.2 && <0.19 , servant-server >=0.16.2 && <0.19 , stm >=2.5.0 && <2.6 , stm-containers >=1.1.0 && <1.2 , string-conversions >=0.4.0 && <0.5 - , template-haskell >=2.14.0 && <2.16 + , template-haskell >=2.14.0 && <2.17 , text >=1.2.3 && <1.3 , time >=1.8.0 && <1.10 , unordered-containers >=0.2.10 && <0.3 @@ -166,6 +173,7 @@ test-suite spec Test.Class.UserSpec Test.FilterSpec Test.MiscSpec + Test.Schema.MetaSchemaSpec Test.Schema.PatchOpSpec Test.Schema.UserSpec Paths_hscim @@ -179,7 +187,7 @@ test-suite spec aeson >=1.4.5 && <1.5 , aeson-qq >=0.8.2 && <0.9 , attoparsec >=0.13.2 && <0.14 - , base >=4.12 && <4.14 + , base >=4.12 && <4.15 , bytestring >=0.10.8 && <0.11 , case-insensitive >=1.2.1.0 && <1.3 , email-validate >=2.3.2 && <2.4 @@ -201,11 +209,13 @@ test-suite spec , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.19 + , servant-client >=0.16.2 && <0.19 + , servant-client-core >=0.16.2 && <0.19 , servant-server >=0.16.2 && <0.19 , stm >=2.5.0 && <2.6 , stm-containers >=1.1.0 && <1.2 , string-conversions >=0.4.0 && <0.5 - , template-haskell >=2.14.0 && <2.16 + , template-haskell >=2.14.0 && <2.17 , text >=1.2.3 && <1.3 , time >=1.8.0 && <1.10 , unordered-containers >=0.2.10 && <0.3 diff --git a/libs/hscim/package.yaml b/libs/hscim/package.yaml index b8e70e4c50..1bd19369ca 100644 --- a/libs/hscim/package.yaml +++ b/libs/hscim/package.yaml @@ -1,8 +1,8 @@ name: hscim -version: 0.3.4 -synopsis: ... -description: ... -homepage: https://github.com/wireapp/hscim/README.md +version: 0.3.5 +synopsis: hscim json schema and server implementation +description: The README file will answer all the questions you might have +homepage: https://github.com/wireapp/wire-server/libs/hscim/README.md license: AGPL-3 license-file: LICENSE author: Wire Swiss GmbH @@ -10,7 +10,10 @@ maintainer: Wire Swiss GmbH copyright: (c) 2018 Wire Swiss GmbH category: Web build-type: Simple -github: wireapp/hscim +github: wireapp/wire-server/hscim +# TODO: should be `github: wireapp/wire-server/libs/hscim`, but hpack +# 0.33.0 doesn't allow that: https://github.com/sol/hpack/pull/451. +# (i think we should just move back to writing cabal files by hand.) default-extensions: - ConstraintKinds @@ -32,19 +35,19 @@ default-extensions: extra-source-files: - README.md - + - CHANGELOG dependencies: - aeson >= 1.4.5 && < 1.5 - attoparsec >= 0.13.2 && < 0.14 - bytestring >= 0.10.8 && < 0.11 - - base >= 4.12 && < 4.14 + - base >= 4.12 && < 4.15 - case-insensitive >= 1.2.1.0 && < 1.3 - scientific >= 0.3.6 && < 0.4 - hashable >= 1.2.7 && < 1.4 - text >= 1.2.3 && < 1.3 - time >= 1.8.0 && < 1.10 - - template-haskell >= 2.14.0 && < 2.16 + - template-haskell >= 2.14.0 && < 2.17 - unordered-containers >= 0.2.10 && < 0.3 - aeson-qq >= 0.8.2 && < 0.9 - mtl >= 2.2.2 && < 2.3 @@ -66,6 +69,8 @@ dependencies: - network-uri >= 2.6.2 && < 2.7 - servant >= 0.16.2 && < 0.19 - servant-server >= 0.16.2 && < 0.19 + - servant-client >= 0.16.2 && < 0.19 + - servant-client-core >= 0.16.2 && < 0.19 - warp >= 3.2.28 && < 3.4 - stm-containers >= 1.1.0 && < 1.2 - string-conversions >= 0.4.0 && < 0.5 diff --git a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index d7fa8b40d4..600a6d69c4 100644 --- a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs @@ -29,6 +29,7 @@ where import Data.Aeson import qualified Data.HashMap.Lazy as HML import Data.Text (Text) +import Data.Typeable (Typeable, cast) import Servant hiding (URI) import Servant.API.Generic import Servant.Server.Generic @@ -39,7 +40,7 @@ import Web.Scim.Capabilities.MetaSchema.Schema import Web.Scim.Capabilities.MetaSchema.User import Web.Scim.ContentType import Web.Scim.Handler -import Web.Scim.Schema.AuthenticationScheme +import qualified Web.Scim.Schema.AuthenticationScheme as AuthScheme import Web.Scim.Schema.Common import Web.Scim.Schema.Error hiding (schemas) import Web.Scim.Schema.ListResponse as ListResponse hiding (schemas) @@ -58,6 +59,18 @@ instance ToJSON a => ToJSON (Supported a) where (Object o) -> Object $ HML.insert "supported" (Bool b) o _ -> Object $ HML.fromList [("supported", Bool b)] +-- | See module "Test.Schema.MetaSchemaSpec" for golden tests that explain this instance +-- better. +instance (Typeable a, FromJSON a) => FromJSON (Supported a) where + parseJSON val = do + Supported + <$> withObject "Supported a" (.: "supported") val + <*> let -- allow special case for empty subConfig (`()` does not parse from json objects) + val' = case cast @() @a () of + Just _ -> Array mempty + Nothing -> val + in parseJSON @a val' + data BulkConfig = BulkConfig { maxOperations :: Int, maxPayloadSize :: Int @@ -67,6 +80,9 @@ data BulkConfig = BulkConfig instance ToJSON BulkConfig where toJSON = genericToJSON serializeOptions +instance FromJSON BulkConfig where + parseJSON = genericParseJSON serializeOptions + data FilterConfig = FilterConfig { maxResults :: Int } @@ -75,6 +91,9 @@ data FilterConfig = FilterConfig instance ToJSON FilterConfig where toJSON = genericToJSON serializeOptions +instance FromJSON FilterConfig where + parseJSON = genericParseJSON serializeOptions + data Configuration = Configuration { documentationUri :: Maybe URI, schemas :: [Schema], @@ -84,13 +103,16 @@ data Configuration = Configuration changePassword :: Supported (), sort :: Supported (), etag :: Supported (), - authenticationSchemes :: [AuthenticationSchemeEncoding] + authenticationSchemes :: [AuthScheme.AuthenticationSchemeEncoding] } deriving (Show, Eq, Generic) instance ToJSON Configuration where toJSON = genericToJSON serializeOptions +instance FromJSON Configuration where + parseJSON = genericParseJSON serializeOptions + empty :: Configuration empty = Configuration @@ -108,7 +130,7 @@ empty = changePassword = Supported (ScimBool False) (), sort = Supported (ScimBool False) (), etag = Supported (ScimBool False) (), - authenticationSchemes = [authHttpBasicEncoding] + authenticationSchemes = [AuthScheme.authHttpBasicEncoding] } configServer :: diff --git a/libs/hscim/src/Web/Scim/Client.hs b/libs/hscim/src/Web/Scim/Client.hs new file mode 100644 index 0000000000..4cf0dfdc50 --- /dev/null +++ b/libs/hscim/src/Web/Scim/Client.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Web.Scim.Client + ( HasScimClient, + + -- * config + spConfig, + getSchemas, + schema, + resourceTypes, + + -- * user + scimClients, + getUsers, + getUser, + postUser, + putUser, + patchUser, + deleteUser, + + -- * group + getGroups, + getGroup, + postGroup, + putGroup, + patchGroup, + deleteGroup, + ) +where + +import Control.Exception +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Text +import Servant.API +import Servant.Client +import Servant.Client.Generic +import qualified Web.Scim.Capabilities.MetaSchema as MetaSchema +import Web.Scim.Class.Auth +import Web.Scim.Class.Group (Group, GroupId, StoredGroup) +import Web.Scim.Class.User (StoredUser) +import Web.Scim.Filter (Filter) +import Web.Scim.Schema.ListResponse (ListResponse) +import Web.Scim.Schema.PatchOp (PatchOp) +import qualified Web.Scim.Schema.ResourceType as ResourceType +import Web.Scim.Schema.User (User) +import Web.Scim.Schema.UserTypes (UserExtra, UserId) +import Web.Scim.Server + +type HasScimClient tag = + ( AuthTypes tag, + ToJSON (UserExtra tag), + FromJSON (UserExtra tag), + FromJSON (UserId tag), + FromJSON (GroupId tag), + ToHttpApiData (AuthData tag), + ToHttpApiData (UserId tag), + ToHttpApiData (GroupId tag) + ) + +scimClients :: HasScimClient tag => ClientEnv -> Site tag (AsClientT IO) +scimClients env = genericClientHoist $ \x -> runClientM x env >>= either throwIO return + +-- config + +spConfig :: + forall tag. + HasScimClient tag => + ClientEnv -> + IO MetaSchema.Configuration +spConfig env = case config @tag (scimClients env) of ((r :<|> _) :<|> (_ :<|> _)) -> r + +getSchemas :: + forall tag. + HasScimClient tag => + ClientEnv -> + IO (ListResponse Value) +getSchemas env = case config @tag (scimClients env) of ((_ :<|> r) :<|> (_ :<|> _)) -> r + +schema :: + forall tag. + HasScimClient tag => + ClientEnv -> + Text -> + IO Value +schema env = case config @tag (scimClients env) of ((_ :<|> _) :<|> (r :<|> _)) -> r + +resourceTypes :: + forall tag. + HasScimClient tag => + ClientEnv -> + IO (ListResponse ResourceType.Resource) +resourceTypes env = case config @tag (scimClients env) of ((_ :<|> _) :<|> (_ :<|> r)) -> r + +-- users + +getUsers :: + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + Maybe Filter -> + IO (ListResponse (StoredUser tag)) +getUsers env tok = case users (scimClients env) tok of ((r :<|> (_ :<|> _)) :<|> (_ :<|> (_ :<|> _))) -> r + +getUser :: + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + UserId tag -> + IO (StoredUser tag) +getUser env tok = case users (scimClients env) tok of ((_ :<|> (r :<|> _)) :<|> (_ :<|> (_ :<|> _))) -> r + +postUser :: + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + (User tag) -> + IO (StoredUser tag) +postUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> r)) :<|> (_ :<|> (_ :<|> _))) -> r + +putUser :: + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + UserId tag -> + (User tag) -> + IO (StoredUser tag) +putUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (r :<|> (_ :<|> _))) -> r + +patchUser :: + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + UserId tag -> + PatchOp tag -> + IO (StoredUser tag) +patchUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (_ :<|> (r :<|> _))) -> r + +deleteUser :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + UserId tag -> + IO NoContent +deleteUser env tok = case users @tag (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (_ :<|> (_ :<|> r))) -> r + +-- groups + +getGroups :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + IO (ListResponse (StoredGroup tag)) +getGroups = error "groups are not authenticated at the moment; implement that first!" + +getGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + GroupId tag -> + IO (StoredGroup tag) +getGroup = error "groups are not authenticated at the moment; implement that first!" + +postGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + Group -> + IO (StoredGroup tag) +postGroup = error "groups are not authenticated at the moment; implement that first!" + +putGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + GroupId tag -> + IO (StoredGroup tag) +putGroup = error "groups are not authenticated at the moment; implement that first!" + +patchGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + GroupId tag -> + IO (StoredGroup tag) +patchGroup = error "groups are not authenticated at the moment; implement that first!" + +deleteGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + GroupId tag -> + IO DeleteNoContent +deleteGroup = error "groups are not authenticated at the moment; implement that first!" diff --git a/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs b/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs index b6baae5bc2..24ec013f20 100644 --- a/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs +++ b/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs @@ -19,7 +19,7 @@ module Web.Scim.Schema.AuthenticationScheme ( AuthenticationScheme (..), - AuthenticationSchemeEncoding, + AuthenticationSchemeEncoding (..), authHttpBasicEncoding, ) where @@ -65,6 +65,9 @@ data AuthenticationSchemeEncoding = AuthenticationSchemeEncoding instance ToJSON AuthenticationSchemeEncoding where toJSON = genericToJSON serializeOptions +instance FromJSON AuthenticationSchemeEncoding where + parseJSON = genericParseJSON serializeOptions + -- NB: "typ" will be converted to "type" thanks to 'serializeOptions' ---------------------------------------------------------------------------- diff --git a/libs/hscim/src/Web/Scim/Server.hs b/libs/hscim/src/Web/Scim/Server.hs index cc726506ca..4ee886ffd5 100644 --- a/libs/hscim/src/Web/Scim/Server.hs +++ b/libs/hscim/src/Web/Scim/Server.hs @@ -25,6 +25,7 @@ module Web.Scim.Server -- * API tree SiteAPI, + Site (..), siteServer, -- ** API subtrees, useful for tests diff --git a/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs new file mode 100644 index 0000000000..8432858082 --- /dev/null +++ b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Schema.MetaSchemaSpec + ( spec, + ) +where + +import Data.Aeson +import Data.Text (Text) +import HaskellWorks.Hspec.Hedgehog (require) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Network.URI.Static (uri) +import Test.Hspec +import Web.Scim.Capabilities.MetaSchema +import Web.Scim.Schema.AuthenticationScheme +import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..)) +import Web.Scim.Schema.Schema (Schema (..)) +import Prelude hiding (filter) + +prop_roundtrip :: (ToJSON a, FromJSON a, Show a, Eq a) => Gen a -> Property +prop_roundtrip gen = property $ do + config <- forAll gen + tripping config toJSON fromJSON + +spec :: Spec +spec = do + describe "MetaSchema" $ do + -- the extra 'decode' in the golden tests is to make attribute order not count for Eq. + it "`Supported ()` golden test" $ do + decode @Value (encode (Supported (ScimBool True) ())) `shouldBe` decode @Value ("{\"supported\":true}") + it "`Supported a` golden test" $ do + decode @Value (encode (Supported (ScimBool True) (FilterConfig 3))) `shouldBe` decode @Value "{\"supported\":true,\"maxResults\":3}" + it "`Supported ()` roundtrips" $ do + require (prop_roundtrip (genSupported (pure ()))) + it "`BulkConfig` roundtrips" $ do + require (prop_roundtrip genBulkConfig) + it "`FilterConfig` roundtrips" $ do + require (prop_roundtrip genFilterConfig) + it "`AuthenticationSchemeEncoding` roundtrips" $ do + require (prop_roundtrip genAuthenticationSchemeEncoding) + it "`Configuration` roundtrips" $ do + require (prop_roundtrip genConfiguration) + +genConfiguration :: Gen Configuration +genConfiguration = do + Configuration + <$> Gen.maybe genUri + <*> pure [User20] + <*> genSupported (pure ()) + <*> genSupported genBulkConfig + <*> genSupported genFilterConfig + <*> genSupported (pure ()) + <*> genSupported (pure ()) + <*> genSupported (pure ()) + <*> Gen.list (Range.linear 0 100) genAuthenticationSchemeEncoding + +genBulkConfig :: Gen BulkConfig +genBulkConfig = do + BulkConfig + <$> Gen.int (Range.linear 0 100) + <*> Gen.int (Range.linear 0 100) + +genFilterConfig :: Gen FilterConfig +genFilterConfig = do + FilterConfig <$> Gen.int (Range.linear 0 100) + +genAuthenticationSchemeEncoding :: Gen AuthenticationSchemeEncoding +genAuthenticationSchemeEncoding = do + AuthenticationSchemeEncoding + <$> genSimpleText + <*> genSimpleText + <*> genSimpleText + <*> Gen.maybe genUri + <*> Gen.maybe genUri + +genSupported :: forall a. Gen a -> Gen (Supported a) +genSupported gen = do + Supported <$> (ScimBool <$> Gen.bool) + <*> gen + +genUri :: Gen URI +genUri = Gen.element [URI [uri|https://example.com|], URI [uri|gopher://glab.io|], URI [uri|ssh://nothing/blorg|]] + +genSimpleText :: Gen Text +genSimpleText = Gen.element ["one", "green", "sharp"] diff --git a/libs/hscim/test/Test/Schema/UserSpec.hs b/libs/hscim/test/Test/Schema/UserSpec.hs index 651f7ebedd..0cefaa4fae 100644 --- a/libs/hscim/test/Test/Schema/UserSpec.hs +++ b/libs/hscim/test/Test/Schema/UserSpec.hs @@ -160,7 +160,7 @@ genName = <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) genUri :: Gen URI -genUri = Gen.element [URI [uri|https://example.com|]] +genUri = Gen.element [URI [uri|https://example.com|], URI [uri|gopher://glab.io|], URI [uri|ssh://nothing/blorg|]] -- TODO(arianvp) Generate the lists too, but first need better support for SCIM -- lists in the first place diff --git a/libs/types-common/src/Data/Json/Util.hs b/libs/types-common/src/Data/Json/Util.hs index 21e1e9b709..bed1399f7f 100644 --- a/libs/types-common/src/Data/Json/Util.hs +++ b/libs/types-common/src/Data/Json/Util.hs @@ -37,6 +37,7 @@ module Data.Json.Util -- * Base64 Base64ByteString (..), fromBase64TextLenient, + fromBase64Text, toBase64Text, ) where @@ -200,5 +201,8 @@ instance Arbitrary Base64ByteString where fromBase64TextLenient :: Text -> ByteString fromBase64TextLenient = B64.decodeLenient . Text.encodeUtf8 +fromBase64Text :: Text -> Either String ByteString +fromBase64Text = B64.decode . Text.encodeUtf8 + toBase64Text :: ByteString -> Text toBase64Text = Text.decodeUtf8 . B64.encode diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index c374cf1bbd..d8ad5bf815 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -38,7 +38,7 @@ import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) import Wire.API.Federation.Domain (OriginDomainHeader) import qualified Wire.API.Federation.GRPC.Types as Proto import Wire.API.Federation.Util.Aeson (CustomEncoded (..)) -import Wire.API.Message (MessageSendingStatus, Priority) +import Wire.API.Message (MessageNotSent, MessageSendingStatus, PostOtrResponse, Priority) import Wire.API.User.Client (UserClientMap) -- FUTUREWORK: data types, json instances, more endpoints. See @@ -171,7 +171,7 @@ data RemoteMessage conv = RemoteMessage deriving (ToJSON, FromJSON) via (CustomEncoded (RemoteMessage conv)) data MessageSendRequest = MessageSendRequest - { -- | Converastion is assumed to be owned by the target domain, this allows + { -- | Conversation is assumed to be owned by the target domain, this allows -- us to protect against relay attacks msrConvId :: ConvId, -- | Sender is assumed to be owned by the origin domain, this allows us to @@ -184,17 +184,14 @@ data MessageSendRequest = MessageSendRequest deriving (ToJSON, FromJSON) via (CustomEncoded MessageSendRequest) newtype MessageSendResponse = MessageSendResponse - {msResponse :: Either MessageNotSent MessageSendingStatus} + {msResponse :: PostOtrResponse MessageSendingStatus} deriving stock (Eq, Show) - deriving newtype (ToJSON, FromJSON) - -data MessageNotSent - = MessageNotSentLegalhold - | MessageNotSentClientMissing MessageSendingStatus - | MessageNotSentConversationNotFound - | MessageNotSentUnknownClient - deriving stock (Eq, Show, Generic) - deriving (ToJSON, FromJSON) via (CustomEncoded MessageNotSent) + deriving + (ToJSON, FromJSON) + via ( Either + (CustomEncoded (MessageNotSent MessageSendingStatus)) + MessageSendingStatus + ) clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Galley m)) clientRoutes = genericClient diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MessageSendResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MessageSendResponse.hs index b1c5a15c80..abf1b572b8 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MessageSendResponse.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MessageSendResponse.hs @@ -23,7 +23,7 @@ import Data.Json.Util (toUTCTimeMillis) import Data.UUID as UUID import GHC.Exts (IsList (fromList)) import Imports -import Wire.API.Federation.API.Galley (MessageNotSent (..), MessageSendResponse (..)) +import Wire.API.Federation.API.Galley (MessageSendResponse (..)) import Wire.API.Message import Wire.API.User.Client (QualifiedUserClients (..)) diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index 53dd3dbfec..82cc58a66f 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -36,6 +36,7 @@ library: - extended - extra - generic-random >=1.2 + - generics-sop - ghc-prim - hashable - hostname-validate diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index c4b8b627f7..55e9c50fa7 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. @@ -18,14 +19,18 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . --- FUTUREWORK: --- There's still a lot of stuff we should factor out into separate modules. +-- FUTUREWORK: There's still a lot of stuff we should factor out into separate +-- modules. module Wire.API.Conversation ( -- * Conversation Conversation (..), ConversationCoverView (..), ConversationList (..), ListConversations (..), + GetPaginatedConversationIds (..), + ConversationPagingState (..), + ConversationPagingTable (..), + ConvIdsPage (..), -- * Conversation properties Access (..), @@ -73,13 +78,16 @@ import Control.Applicative import Control.Lens (at, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A +import qualified Data.Attoparsec.ByteString as AB +import qualified Data.ByteString as BS import Data.Id +import Data.Json.Util (fromBase64Text, toBase64Text) import Data.List.NonEmpty (NonEmpty) import Data.List1 import Data.Misc import Data.Proxy (Proxy (Proxy)) import Data.Qualified (Qualified (qUnqualified), deprecatedSchema) -import Data.Range (Range) +import Data.Range (Range, toRange) import Data.Schema import qualified Data.Set as Set import Data.String.Conversions (cs) @@ -225,6 +233,9 @@ instance ConversationListItem ConvId where instance ConversationListItem Conversation where convListItemName _ = "conversations" +instance ConversationListItem (Qualified ConvId) where + convListItemName _ = "qualified Conversation IDs" + instance (ConversationListItem a, S.ToSchema a) => S.ToSchema (ConversationList a) where declareNamedSchema _ = do listSchema <- S.declareSchemaRef (Proxy @[a]) @@ -252,6 +263,85 @@ instance FromJSON a => FromJSON (ConversationList a) where <$> o A..: "conversations" <*> o A..: "has_more" +data ConvIdsPage = ConvIdsPage + { pageConvIds :: [Qualified ConvId], + pageHasMore :: Bool, + pagePagingState :: ConversationPagingState + } + deriving (Show, Eq, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema ConvIdsPage + +instance ToSchema ConvIdsPage where + schema = + object "ConvIdsPage" $ + ConvIdsPage + <$> pageConvIds .= field "qualified_conversations" (array schema) + <*> pageHasMore .= field "has_more" schema + <*> pagePagingState .= field "paging_state" schema + +data ConversationPagingState = ConversationPagingState + { cpsTable :: ConversationPagingTable, + cpsPagingState :: Maybe ByteString + } + deriving (Show, Eq) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema ConversationPagingState + +instance ToSchema ConversationPagingState where + schema = + (toBase64Text . encodeConversationPagingState) + .= parsedText "ConversationPagingState" (parseConvesationPagingState <=< fromBase64Text) + +parseConvesationPagingState :: ByteString -> Either String ConversationPagingState +parseConvesationPagingState = AB.parseOnly conversationPagingStateParser + +conversationPagingStateParser :: AB.Parser ConversationPagingState +conversationPagingStateParser = do + cpsTable <- tableParser + cpsPagingState <- (AB.endOfInput $> Nothing) <|> (Just <$> AB.takeByteString <* AB.endOfInput) + pure ConversationPagingState {..} + where + tableParser :: AB.Parser ConversationPagingTable + tableParser = + (AB.word8 0 $> PagingLocals) + <|> (AB.word8 1 $> PagingRemotes) + +encodeConversationPagingState :: ConversationPagingState -> ByteString +encodeConversationPagingState ConversationPagingState {..} = + let table = encodeConversationPagingTable cpsTable + state = fromMaybe "" cpsPagingState + in BS.cons table state + +encodeConversationPagingTable :: ConversationPagingTable -> Word8 +encodeConversationPagingTable = \case + PagingLocals -> 0 + PagingRemotes -> 1 + +data ConversationPagingTable + = PagingLocals + | PagingRemotes + deriving (Show, Eq) + +data GetPaginatedConversationIds = GetPaginatedConversationIds + { gpciPagingState :: Maybe ConversationPagingState, + gpciSize :: Range 1 1000 Int32 + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema GetPaginatedConversationIds + +instance ToSchema GetPaginatedConversationIds where + schema = + let addPagingStateDoc = + description + ?~ "optional, when not specified first page of the conversation ids will be returned.\ + \Every returned page contains a paging_state, this should be supplied to retrieve the next page." + addSizeDoc = description ?~ "optional, must be <= 1000, defaults to 1000." + in objectWithDocModifier + "GetPaginatedConversationIds" + (description ?~ "A request to list some or all of a user's conversation ids, including remote ones") + $ GetPaginatedConversationIds + <$> gpciPagingState .= optFieldWithDocModifier "paging_state" Nothing addPagingStateDoc schema + <*> gpciSize .= (fieldWithDocModifier "size" addSizeDoc schema <|> pure (toRange (Proxy @1000))) + -- | Used on the POST /list-conversations endpoint -- FUTUREWORK: add to golden tests (how to generate them?) data ListConversations = ListConversations diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 92dae6a966..9856e050ca 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -4,7 +4,7 @@ import Control.Lens (at, ix, over, (%~), (.~), (<>~), (?~)) import Control.Lens.Combinators (_Just) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as LBS -import Data.SOP (I (..), NS (..)) +import Data.SOP (I (..), NP (..), NS (..)) import Data.Schema import Data.Swagger (Swagger) import qualified Data.Swagger as Swagger @@ -117,45 +117,6 @@ instance (KnownStatus statusCode, KnownSymbol label, KnownSymbol desc) => ToSche codeSchema :: ValueSchema SwaggerDoc Integer codeSchema = unnamed $ enum @Integer "Status" (element code code) --- | This instance works with 'UVerb' only because of the following overlapping --- instance for 'UVerb method cs (ErrorDescription status label desc ': rest))' -instance - (KnownStatus statusCode, KnownSymbol label, KnownSymbol desc, AllAccept cs, SwaggerMethod method) => - HasSwagger (Verb method statusCode cs (ErrorDescription statusCode label desc)) - where - toSwagger _ = - mempty - & Swagger.paths . at "/" - ?~ ( mempty & method - ?~ ( mempty - & Swagger.produces ?~ Swagger.MimeList responseContentTypes - & at code - ?~ Swagger.Inline - ( mempty - & Swagger.description .~ desc - & Swagger.schema ?~ schemaRef - ) - ) - ) - where - method = swaggerMethod (Proxy @method) - responseContentTypes = allContentType (Proxy @cs) - code = fromIntegral (natVal (Proxy @statusCode)) - desc = Text.pack (symbolVal (Proxy @desc)) - schemaRef = Swagger.Inline $ Swagger.toSchema (Proxy @(ErrorDescription statusCode label desc)) - --- | This is a copy of instance for 'UVerb method cs (a:as)', but without this --- things don't work because the instance defined in the library is already --- compiled with the now overlapped version of `Verb method cs a` and won't --- pickup the above instance. -instance - (KnownStatus status, KnownSymbol label, KnownSymbol desc, AllAccept cs, SwaggerMethod method, HasSwagger (UVerb method cs rest)) => - HasSwagger (UVerb method cs (ErrorDescription status label desc ': rest)) - where - toSwagger _ = - toSwagger (Proxy @(Verb method status cs (ErrorDescription status label desc))) - `combineSwagger` toSwagger (Proxy @(UVerb method cs rest)) - instance KnownStatus status => HasStatus (ErrorDescription status label desc) where type StatusOf (ErrorDescription status label desc) = status @@ -164,6 +125,8 @@ instance KnownStatus status => HasStatus (ErrorDescription status label desc) wh type RespondWithErrorDescription s label desc = Respond s desc (ErrorDescription s label desc) +type instance ResponseType (ErrorDescription s label desc) = ErrorDescription s label desc + instance ( AllMimeRender cs (ErrorDescription s label desc), AllMimeUnrender cs (ErrorDescription s label desc), @@ -173,12 +136,15 @@ instance ) => IsResponse cs (ErrorDescription s label desc) where - type ResponseType (ErrorDescription s label desc) = ErrorDescription s label desc type ResponseStatus (ErrorDescription s label desc) = s responseRender = responseRender @cs @(RespondWithErrorDescription s label desc) responseUnrender = responseUnrender @cs @(RespondWithErrorDescription s label desc) +instance KnownSymbol desc => AsConstructor '[] (ErrorDescription s label desc) where + toConstructor _ = Nil + fromConstructor _ = mkErrorDescription + instance (KnownStatus s, KnownSymbol label, KnownSymbol desc) => IsSwaggerResponse (ErrorDescription s label desc) @@ -201,11 +167,12 @@ instance data EmptyErrorForLegacyReasons s desc +type instance ResponseType (EmptyErrorForLegacyReasons s desc) = () + instance KnownStatus s => IsResponse cs (EmptyErrorForLegacyReasons s desc) where - type ResponseType (EmptyErrorForLegacyReasons s desc) = () type ResponseStatus (EmptyErrorForLegacyReasons s desc) = s responseRender _ () = @@ -332,3 +299,13 @@ type MalformedPrekeys = ErrorDescription 400 "bad-request" "Malformed prekeys up malformedPrekeys :: MalformedPrekeys malformedPrekeys = mkErrorDescription + +type MissingLegalholdConsent = + ErrorDescription + 403 + "missing-legalhold-consent" + "Failed to connect to a user or to invite a user to a group because somebody \ + \is under legalhold and somebody else has not granted consent." + +missingLegalholdConsent :: MissingLegalholdConsent +missingLegalholdConsent = mkErrorDescription diff --git a/libs/wire-api/src/Wire/API/Message.hs b/libs/wire-api/src/Wire/API/Message.hs index a6c55b6c57..b9ee8acf81 100644 --- a/libs/wire-api/src/Wire/API/Message.hs +++ b/libs/wire-api/src/Wire/API/Message.hs @@ -51,6 +51,9 @@ module Wire.API.Message ClientMismatch (..), ClientMismatchStrategy (..), MessageSendingStatus (..), + PostOtrResponses, + PostOtrResponse, + MessageNotSent (..), UserClients (..), ReportMissing (..), IgnoreMissing (..), @@ -75,6 +78,7 @@ import qualified Data.ProtoLens as ProtoLens import qualified Data.ProtoLens.Field as ProtoLens import qualified Data.ProtocolBuffers as Protobuf import Data.Qualified (Qualified (..)) +import Data.SOP (I (..), NS (..), unI, unZ) import Data.Schema import Data.Serialize (runGetLazy) import qualified Data.Set as Set @@ -82,12 +86,16 @@ import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text.Read as Reader import qualified Data.UUID as UUID +import qualified Generics.SOP as GSOP import Imports import qualified Proto.Otr import qualified Proto.Otr_Fields as Proto.Otr import Servant (FromHttpApiData (..)) +import Servant.Server (type (.++)) import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..)) +import Wire.API.ErrorDescription import qualified Wire.API.Message.Proto as Proto +import Wire.API.Routes.MultiVerb import Wire.API.ServantProto (FromProto (..), ToProto (..)) import Wire.API.User.Client (QualifiedUserClientMap (QualifiedUserClientMap), QualifiedUserClients, UserClientMap (..), UserClients (..), modelOtrClientMap, modelUserClients) @@ -553,6 +561,47 @@ instance ToSchema MessageSendingStatus where ) schema +data MessageNotSent a + = MessageNotSentConversationNotFound + | MessageNotSentUnknownClient + | MessageNotSentLegalhold + | MessageNotSentClientMissing a + deriving stock (Eq, Show, Generic, Functor) + deriving + (AsUnion (MessageNotSentResponses a)) + via (GenericAsUnion (MessageNotSentResponses a) (MessageNotSent a)) + +instance GSOP.Generic (MessageNotSent a) + +type MessageNotSentResponses a = + '[ ConvNotFound, + UnknownClient, + MissingLegalholdConsent, + Respond 412 "Missing clients" a + ] + +type PostOtrResponses a = + MessageNotSentResponses a + .++ '[Respond 201 "Message sent" a] + +type PostOtrResponse a = Either (MessageNotSent a) a + +instance + ( rs ~ (MessageNotSentResponses a .++ '[r]), + a ~ ResponseType r + ) => + AsUnion rs (PostOtrResponse a) + where + toUnion = + eitherToUnion + (toUnion @(MessageNotSentResponses a)) + (Z . I) + + fromUnion = + eitherFromUnion + (fromUnion @(MessageNotSentResponses a)) + (unI . unZ) + -- QueryParams data IgnoreMissing diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 4728fdb9ba..44d3e7a28f 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -24,12 +24,19 @@ module Wire.API.Routes.MultiVerb DescHeader, AsHeaders (..), AsUnion (..), + eitherToUnion, + eitherFromUnion, + AsConstructor (..), + GenericAsConstructor (..), + GenericAsUnion (..), + ResponseType, IsResponse (..), IsSwaggerResponse (..), RenderOutput (..), roAddContentType, roResponse, ResponseSwagger (..), + ResponseTypes, IsResponseList (..), ) where @@ -46,6 +53,7 @@ import qualified Data.Swagger as S import qualified Data.Swagger.Declare as S import qualified Data.Text as Text import GHC.TypeLits +import Generics.SOP as GSOP import Imports import qualified Network.HTTP.Media as M import Network.HTTP.Types (HeaderName, hContentType) @@ -125,15 +133,17 @@ instance MonadPlus UnrenderResult where class IsSwaggerResponse a where responseSwagger :: Declare ResponseSwagger +type family ResponseType a :: * + class IsResponse cs a where - type ResponseType a :: * type ResponseStatus a :: Nat responseRender :: AcceptHeader -> ResponseType a -> Maybe RenderOutput responseUnrender :: M.MediaType -> RenderOutput -> UnrenderResult (ResponseType a) +type instance ResponseType (Respond s desc a) = a + instance (AllMimeRender cs a, AllMimeUnrender cs a, KnownStatus s) => IsResponse cs (Respond s desc a) where - type ResponseType (Respond s desc a) = a type ResponseStatus (Respond s desc a) = s -- Note: here it seems like we are rendering for all possible content types, @@ -170,8 +180,9 @@ instance desc = Text.pack (symbolVal (Proxy @desc)) status = statusVal (Proxy @s) +type instance ResponseType (RespondEmpty s desc) = () + instance KnownStatus s => IsResponse cs (RespondEmpty s desc) where - type ResponseType (RespondEmpty s desc) = () type ResponseStatus (RespondEmpty s desc) = s responseRender _ _ = @@ -237,6 +248,8 @@ instance desc = Text.pack (symbolVal (Proxy @desc)) sch = S.toParamSchema (Proxy @a) +type instance ResponseType (WithHeaders hs a r) = a + instance ( AsHeaders (ServantHeaders hs) (ResponseType r) a, GetHeaders' (ServantHeaders hs), @@ -246,7 +259,6 @@ instance ) => IsResponse cs (WithHeaders hs a r) where - type ResponseType (WithHeaders hs a r) = a type ResponseStatus (WithHeaders hs a r) = ResponseStatus r responseRender acc x = @@ -275,17 +287,17 @@ instance class IsSwaggerResponseList as where responseListSwagger :: Declare [ResponseSwagger] -class IsResponseList cs as where - type ResponseTypes as :: [*] +type family ResponseTypes (as :: [*]) where + ResponseTypes '[] = '[] + ResponseTypes (a ': as) = ResponseType a ': ResponseTypes as +class IsResponseList cs as where responseListRender :: AcceptHeader -> Union (ResponseTypes as) -> Maybe RenderOutput responseListUnrender :: M.MediaType -> RenderOutput -> UnrenderResult (Union (ResponseTypes as)) responseListStatuses :: [Status] instance IsResponseList cs '[] where - type ResponseTypes '[] = '[] - responseListRender _ x = case x of responseListUnrender _ _ = empty responseListStatuses = [] @@ -300,8 +312,6 @@ instance ) => IsResponseList cs (a ': as) where - type ResponseTypes (a ': as) = ResponseType a ': ResponseTypes as - responseListRender acc (Z (I x)) = responseRender @cs @a acc x responseListRender acc (S x) = responseListRender @cs @as acc x @@ -347,6 +357,126 @@ instance rs ~ ResponseTypes as => AsUnion as (Union rs) where toUnion = id fromUnion = id +instance AsUnion '[RespondEmpty code desc] () where + toUnion () = Z (I ()) + fromUnion (Z (I ())) = () + fromUnion (S x) = case x of + +class InjectAfter as bs where + injectAfter :: Union bs -> Union (as .++ bs) + +instance InjectAfter '[] bs where + injectAfter = id + +instance InjectAfter as bs => InjectAfter (a ': as) bs where + injectAfter = S . injectAfter @as @bs + +class InjectBefore as bs where + injectBefore :: Union as -> Union (as .++ bs) + +instance InjectBefore '[] bs where + injectBefore x = case x of + +instance InjectBefore as bs => InjectBefore (a ': as) bs where + injectBefore (Z x) = Z x + injectBefore (S x) = S (injectBefore @as @bs x) + +eitherToUnion :: + forall as bs a b. + (InjectAfter as bs, InjectBefore as bs) => + (a -> Union as) -> + (b -> Union bs) -> + (Either a b -> Union (as .++ bs)) +eitherToUnion f _ (Left a) = injectBefore @as @bs (f a) +eitherToUnion _ g (Right b) = injectAfter @as @bs (g b) + +class EitherFromUnion as bs where + eitherFromUnion :: + (Union as -> a) -> + (Union bs -> b) -> + (Union (as .++ bs) -> Either a b) + +instance EitherFromUnion '[] bs where + eitherFromUnion _ g = Right . g + +instance EitherFromUnion as bs => EitherFromUnion (a ': as) bs where + eitherFromUnion f _ (Z x) = Left (f (Z x)) + eitherFromUnion f g (S x) = eitherFromUnion @as @bs (f . S) g x + +-- | This class can be instantiated to get automatic derivation of 'AsUnion' +-- instances via 'GenericAsUnion'. The idea is that one has to make sure that for +-- each response @r@ in a 'MultiVerb' endpoint, there is an instance of +-- @AsConstructor xs r@ for some @xs@, and that the list @xss@ of all the +-- corresponding @xs@ is equal to 'GSOP.Code' of the handler type. Then one can +-- write: +-- @ +-- type Responses = ... +-- data Result = ... +-- deriving stock (Generic) +-- deriving (AsUnion Responses) via (GenericAsUnion Responses Result) +-- +-- instance GSOP.Generic Result +-- @ +-- and get an 'AsUnion' instance for free. +-- +-- There are a few predefined instances for constructors taking a single type +-- corresponding to a simple response, and for empty responses, but in more +-- general cases one either has to define an 'AsConstructor' instance by hand, +-- or derive it via 'GenericAsConstructor'. +class AsConstructor xs r where + toConstructor :: ResponseType r -> NP I xs + fromConstructor :: NP I xs -> ResponseType r + +class AsConstructors xss rs where + toSOP :: Union (ResponseTypes rs) -> SOP I xss + fromSOP :: SOP I xss -> Union (ResponseTypes rs) + +instance AsConstructors '[] '[] where + toSOP x = case x of + fromSOP x = case x of + +instance AsConstructor '[a] (Respond code desc a) where + toConstructor x = I x :* Nil + fromConstructor = unI . hd + +instance AsConstructor '[] (RespondEmpty code desc) where + toConstructor _ = Nil + fromConstructor _ = () + +newtype GenericAsConstructor r = GenericAsConstructor r + +type instance ResponseType (GenericAsConstructor r) = ResponseType r + +instance + (GSOP.Code (ResponseType r) ~ '[xs], GSOP.Generic (ResponseType r)) => + AsConstructor xs (GenericAsConstructor r) + where + toConstructor = unZ . unSOP . GSOP.from + fromConstructor = GSOP.to . SOP . Z + +instance + (AsConstructor xs r, AsConstructors xss rs) => + AsConstructors (xs ': xss) (r ': rs) + where + toSOP (Z (I x)) = SOP . Z $ toConstructor @xs @r x + toSOP (S x) = SOP . S . unSOP $ toSOP @xss @rs x + + fromSOP (SOP (Z x)) = Z (I (fromConstructor @xs @r x)) + fromSOP (SOP (S x)) = S (fromSOP @xss @rs (SOP x)) + +-- | This type is meant to be used with @deriving via@ in order to automatically +-- generate an 'AsUnion' instance using 'Generics.SOP'. +-- +-- See 'AsConstructor' for more information and examples. +newtype GenericAsUnion rs a = GenericAsUnion a + +instance + (GSOP.Code a ~ xss, GSOP.Generic a, AsConstructors xss rs) => + AsUnion rs (GenericAsUnion rs a) + where + toUnion (GenericAsUnion x) = fromSOP @xss @rs (GSOP.from x) + fromUnion = GenericAsUnion . GSOP.to . toSOP @xss @rs + -- | A handler for a pair of empty responses can be implemented simply by -- returning a boolean value. The convention is that the "failure" case, normally -- represented by 'False', corresponds to the /first/ response. @@ -435,7 +565,7 @@ instance let acc = getAcceptHeader req action' = action `addMethodCheck` methodCheck method req - `addMethodCheck` acceptCheck (Proxy @cs) acc + `addAcceptCheck` acceptCheck (Proxy @cs) acc runAction action' env req k $ \output -> do let mresp = responseListRender @cs @as acc (toUnion @as output) resp' <- case mresp of diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs index 71f24d1243..c893f0b0bb 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public.hs @@ -23,31 +23,13 @@ module Wire.API.Routes.Public where import Control.Lens ((<>~)) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Id as Id -import Data.SOP.Constraint (All) import Data.Swagger import GHC.Base (Symbol) -import GHC.TypeLits (KnownNat, KnownSymbol, natVal) +import GHC.TypeLits (KnownSymbol) import Imports hiding (All, head) -import Network.HTTP.Types (Status) -import Network.Wai (responseLBS) import Servant hiding (Handler, JSON, addHeader, respond) import Servant.API.Modifiers (FoldLenient, FoldRequired) -import Servant.API.Status (KnownStatus, statusVal) -import Servant.API.UVerb.Union (foldMapUnion) -import Servant.Server.Internal - ( Delayed, - Handler, - RouteResult (..), - Router, - addMethodCheck, - leafRouter, - methodCheck, - noContentRouter, - runAction, - ) import Servant.Swagger (HasSwagger (toSwagger)) -import Servant.Swagger.Internal (SwaggerMethod, combineSwagger) -import Servant.Swagger.Internal.Orphans () -- This type exists for the special 'HasSwagger' and 'HasServer' instances. It -- shows the "Authorization" header in the swagger docs, but expects the @@ -114,82 +96,6 @@ instance instance ToSchema a => ToSchema (Headers ls a) where declareNamedSchema _ = declareNamedSchema (Proxy @a) ---- | Return type of an endpoint with an empty response. ---- ---- In principle we could use 'WithStatus n NoContent' instead, but ---- Servant does not support it, so we would need orphan instances. -data EmptyResult n = EmptyResult - -instance - (SwaggerMethod method, KnownNat n) => - HasSwagger (Verb method n '[] (EmptyResult n)) - where - toSwagger _ = toSwagger (Proxy @(Verb method n '[] NoContent)) - -instance - ( SwaggerMethod method, - KnownNat n, - HasSwagger (UVerb method '[] as) - ) => - HasSwagger (UVerb method '[] (EmptyResult n ': as)) - where - toSwagger _ = - combineSwagger - (toSwagger (Proxy @(Verb method n '[] NoContent))) - (toSwagger (Proxy @(UVerb method '[] as))) - -instance - (ReflectMethod method, KnownNat n) => - HasServer (Verb method n '[] (EmptyResult n)) context - where - type ServerT (Verb method n '[] (EmptyResult n)) m = m (EmptyResult n) - hoistServerWithContext _ _ nt s = nt s - - route Proxy _ = noContentRouter method status - where - method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy @n) - -class HasStatus a => IsEmptyResponse a - -instance KnownStatus n => HasStatus (EmptyResult n) where - type StatusOf (EmptyResult n) = n - -instance KnownStatus n => IsEmptyResponse (EmptyResult n) - --- FUTUREWORK: submit this to Servant -instance - {-# OVERLAPPING #-} - ( ReflectMethod method, - All IsEmptyResponse as, - Unique (Statuses as) - ) => - HasServer (UVerb method '[] as) context - where - type ServerT (UVerb method '[] as) m = m (Union as) - hoistServerWithContext _ _ nt s = nt s - - route :: - forall env. - Proxy (UVerb method '[] as) -> - Context context -> - Delayed env (Server (UVerb method '[] as)) -> - Router env - route _proxy _ctx action = leafRouter route' - where - pickStatus :: All IsEmptyResponse as => Union as -> Status - pickStatus = foldMapUnion (Proxy @IsEmptyResponse) getStatus - - getStatus :: forall a. IsEmptyResponse a => a -> Status - getStatus _ = statusVal (Proxy @(StatusOf a)) - - method = reflectMethod (Proxy @method) - route' env request cont = do - let action' :: Delayed env (Handler (Union as)) - action' = addMethodCheck action (methodCheck method request) - runAction action' env request cont $ \(output :: Union as) -> do - Route $ responseLBS (pickStatus output) mempty mempty - -- | A type-level tag that lets us omit any branch from Swagger docs. -- -- Those are likely to be: diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 6fde7614cb..933362d46e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -43,7 +43,7 @@ import Wire.API.ErrorDescription UserNotFound, ) import Wire.API.Routes.MultiVerb -import Wire.API.Routes.Public (EmptyResult, ZConn, ZUser) +import Wire.API.Routes.Public (ZConn, ZUser) import Wire.API.Routes.QualifiedCapture import Wire.API.User import Wire.API.User.Client @@ -267,7 +267,7 @@ data Api routes = Api :> "clients" :> CaptureClientId "client" :> ReqBody '[JSON] UpdateClient - :> Put '[] (EmptyResult 200), + :> MultiVerb 'PUT '[JSON] '[RespondEmpty 200 "Client updated"] (), -- This endpoint can lead to the following events being sent: -- - ClientRemoved event to self deleteClient :: @@ -277,7 +277,7 @@ data Api routes = Api :> "clients" :> CaptureClientId "client" :> ReqBody '[JSON] RmClient - :> Delete '[] (EmptyResult 200), + :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 200 "Client deleted"] (), listClients :: routes :- Summary "List the registered clients" :> ZUser diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index b28d04f27f..e93b561e20 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -37,9 +37,9 @@ import Wire.API.Conversation as Public import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription import qualified Wire.API.Event.Conversation as Public -import qualified Wire.API.Message as Public +import Wire.API.Message import Wire.API.Routes.MultiVerb -import Wire.API.Routes.Public (EmptyResult, ZConn, ZUser) +import Wire.API.Routes.Public (ZConn, ZUser) import Wire.API.Routes.QualifiedCapture import Wire.API.ServantProto (Proto, RawProto) import qualified Wire.API.Team.Conversation as Public @@ -101,20 +101,6 @@ instance AsUnion UpdateResponses UpdateResult where fromUnion (S (Z (I e))) = Updated e fromUnion (S (S x)) = case x of -type PostOtrResponsesUnqualified = - '[ WithStatus 201 Public.ClientMismatch, - WithStatus 412 Public.ClientMismatch, - ConvNotFound, - UnknownClient - ] - -type PostOtrResponses = - '[ WithStatus 201 Public.MessageSendingStatus, - WithStatus 412 Public.MessageSendingStatus, - ConvNotFound, - UnknownClient - ] - data Api routes = Api { -- Conversations @@ -140,9 +126,9 @@ data Api routes = Api :> Capture "cnv" ConvId :> "roles" :> Get '[Servant.JSON] Public.ConversationRolesList, - getConversationIds :: + listConversationIdsUnqualified :: routes - :- Summary "Get all conversation IDs." + :- Summary "[deprecated] Get all local conversation IDs." -- FUTUREWORK: add bounds to swagger schema for Range :> ZUser :> "conversations" @@ -162,6 +148,15 @@ data Api routes = Api "size" (Range 1 1000 Int32) :> Get '[Servant.JSON] (Public.ConversationList ConvId), + listConversationIds :: + routes + :- Summary "Get all conversation IDs." + :> Description "To retrieve the next page, a client must pass the paging_state returned by the previous page." + :> ZUser + :> "conversations" + :> "list-ids" + :> ReqBody '[Servant.JSON] Public.GetPaginatedConversationIds + :> Post '[Servant.JSON] Public.ConvIdsPage, getConversations :: routes :- Summary "Get all *local* conversations." @@ -297,7 +292,7 @@ data Api routes = Api :> Capture "tid" TeamId :> "conversations" :> Capture "cid" ConvId - :> Delete '[] (EmptyResult 200), + :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 200 "Conversation deleted"] (), postOtrMessageUnqualified :: routes :- Summary "Post an encrypted message to a conversation (accepts JSON or Protobuf)" @@ -306,12 +301,16 @@ data Api routes = Api :> ZConn :> "conversations" :> Capture "cnv" ConvId - :> QueryParam "ignore_missing" Public.IgnoreMissing - :> QueryParam "report_missing" Public.ReportMissing + :> QueryParam "ignore_missing" IgnoreMissing + :> QueryParam "report_missing" ReportMissing :> "otr" :> "messages" - :> ReqBody '[Servant.JSON, Proto] Public.NewOtrMessage - :> UVerb 'POST '[Servant.JSON] PostOtrResponsesUnqualified, + :> ReqBody '[Servant.JSON, Proto] NewOtrMessage + :> MultiVerb + 'POST + '[Servant.JSON] + (PostOtrResponses ClientMismatch) + (Either (MessageNotSent ClientMismatch) ClientMismatch), postProteusMessage :: routes :- Summary "Post an encrypted message to a conversation (accepts only Protobuf)" @@ -322,8 +321,12 @@ data Api routes = Api :> QualifiedCapture "cnv" ConvId :> "proteus" :> "messages" - :> ReqBody '[Proto] (RawProto Public.QualifiedNewOtrMessage) - :> UVerb 'POST '[Servant.JSON] PostOtrResponses, + :> ReqBody '[Proto] (RawProto QualifiedNewOtrMessage) + :> MultiVerb + 'POST + '[Servant.JSON] + (PostOtrResponses MessageSendingStatus) + (Either (MessageNotSent MessageSendingStatus) MessageSendingStatus), teamFeatureStatusSSOGet :: routes :- FeatureStatusGet 'TeamFeatureSSO, diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 0e6032927c..e7095dcd09 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -812,8 +812,9 @@ data UserUpdate = UserUpdate modelUserUpdate :: Doc.Model modelUserUpdate = Doc.defineModel "UserUpdate" $ do Doc.description "User Update Data" - Doc.property "name" Doc.string' $ + Doc.property "name" Doc.string' $ do Doc.description "Name (1 - 128 characters)" + Doc.optional Doc.property "assets" (Doc.array (Doc.ref modelAsset)) $ do Doc.description "Profile assets" Doc.optional diff --git a/libs/wire-api/test/golden/testObject_ConvIdsPage_1.json b/libs/wire-api/test/golden/testObject_ConvIdsPage_1.json new file mode 100644 index 0000000000..e56981dcc2 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_ConvIdsPage_1.json @@ -0,0 +1,5 @@ +{ + "has_more": false, + "paging_state": "AA==", + "qualified_conversations": [] +} \ No newline at end of file diff --git a/libs/wire-api/test/golden/testObject_ConvIdsPage_2.json b/libs/wire-api/test/golden/testObject_ConvIdsPage_2.json new file mode 100644 index 0000000000..54491bffe9 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_ConvIdsPage_2.json @@ -0,0 +1,10 @@ +{ + "has_more": true, + "paging_state": "AA==", + "qualified_conversations": [ + { + "domain": "domain.example.com", + "id": "00000018-0000-0020-0000-000e00000002" + } + ] +} \ No newline at end of file diff --git a/libs/wire-api/test/golden/testObject_ConversationPagingState_1.json b/libs/wire-api/test/golden/testObject_ConversationPagingState_1.json new file mode 100644 index 0000000000..12ccb495be --- /dev/null +++ b/libs/wire-api/test/golden/testObject_ConversationPagingState_1.json @@ -0,0 +1 @@ +"AA==" \ No newline at end of file diff --git a/libs/wire-api/test/golden/testObject_ConversationPagingState_2.json b/libs/wire-api/test/golden/testObject_ConversationPagingState_2.json new file mode 100644 index 0000000000..400bef583c --- /dev/null +++ b/libs/wire-api/test/golden/testObject_ConversationPagingState_2.json @@ -0,0 +1 @@ +"AAABWGN9WA==" \ No newline at end of file diff --git a/libs/wire-api/test/golden/testObject_ConversationPagingState_3.json b/libs/wire-api/test/golden/testObject_ConversationPagingState_3.json new file mode 100644 index 0000000000..3ca82884d8 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_ConversationPagingState_3.json @@ -0,0 +1 @@ +"AQ==" \ No newline at end of file diff --git a/libs/wire-api/test/golden/testObject_ConversationPagingState_4.json b/libs/wire-api/test/golden/testObject_ConversationPagingState_4.json new file mode 100644 index 0000000000..f04aaae71e --- /dev/null +++ b/libs/wire-api/test/golden/testObject_ConversationPagingState_4.json @@ -0,0 +1 @@ +"AVgMFw==" \ No newline at end of file diff --git a/libs/wire-api/test/golden/testObject_GetPaginatedConversationIds_1.json b/libs/wire-api/test/golden/testObject_GetPaginatedConversationIds_1.json new file mode 100644 index 0000000000..57dfcf1da0 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_GetPaginatedConversationIds_1.json @@ -0,0 +1,3 @@ +{ + "size": 50 +} \ No newline at end of file diff --git a/libs/wire-api/test/golden/testObject_GetPaginatedConversationIds_2.json b/libs/wire-api/test/golden/testObject_GetPaginatedConversationIds_2.json new file mode 100644 index 0000000000..5de0d4bea9 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_GetPaginatedConversationIds_2.json @@ -0,0 +1,4 @@ +{ + "size": 1000, + "paging_state": "AA==" +} \ No newline at end of file diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs index 8ba523d2d0..bd7fd0d8b0 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs @@ -22,8 +22,11 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Wire.API.Golden.Manual.ClientCapability import Test.Wire.API.Golden.Manual.ClientCapabilityList +import Test.Wire.API.Golden.Manual.ConvIdsPage import Test.Wire.API.Golden.Manual.ConversationCoverView +import Test.Wire.API.Golden.Manual.ConversationPagingState import Test.Wire.API.Golden.Manual.FeatureConfigEvent +import Test.Wire.API.Golden.Manual.GetPaginatedConversationIds import Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap import Test.Wire.API.Golden.Manual.UserClientPrekeyMap import Test.Wire.API.Golden.Runner @@ -54,6 +57,23 @@ tests = (testObject_ConversationCoverView_2, "testObject_ConversationCoverView_2.json"), (testObject_ConversationCoverView_3, "testObject_ConversationCoverView_3.json") ], + testCase "GetPaginatedConversationIds" $ + testObjects + [ (testObject_GetPaginatedConversationIds_1, "testObject_GetPaginatedConversationIds_1.json"), + (testObject_GetPaginatedConversationIds_2, "testObject_GetPaginatedConversationIds_2.json") + ], + testCase "ConversationPagingState" $ + testObjects + [ (testObject_ConversationPagingState_1, "testObject_ConversationPagingState_1.json"), + (testObject_ConversationPagingState_2, "testObject_ConversationPagingState_2.json"), + (testObject_ConversationPagingState_3, "testObject_ConversationPagingState_3.json"), + (testObject_ConversationPagingState_4, "testObject_ConversationPagingState_4.json") + ], + testCase "ConvIdsPage" $ + testObjects + [ (testObject_ConvIdsPage_1, "testObject_ConvIdsPage_1.json"), + (testObject_ConvIdsPage_2, "testObject_ConvIdsPage_2.json") + ], testCase "ClientCapability" $ testObjects [(testObject_ClientCapability_1, "testObject_ClientCapability_1.json")], diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConvIdsPage.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConvIdsPage.hs new file mode 100644 index 0000000000..e81ba68814 --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConvIdsPage.hs @@ -0,0 +1,15 @@ +module Test.Wire.API.Golden.Manual.ConvIdsPage where + +import Data.Domain (Domain (Domain)) +import Data.Id (Id (Id)) +import Data.Qualified +import qualified Data.UUID as UUID +import Imports +import Test.Wire.API.Golden.Manual.ConversationPagingState (testObject_ConversationPagingState_1) +import Wire.API.Conversation + +testObject_ConvIdsPage_1 :: ConvIdsPage +testObject_ConvIdsPage_1 = ConvIdsPage [] False testObject_ConversationPagingState_1 + +testObject_ConvIdsPage_2 :: ConvIdsPage +testObject_ConvIdsPage_2 = ConvIdsPage [Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-000e00000002"))) (Domain "domain.example.com")] True testObject_ConversationPagingState_1 diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationPagingState.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationPagingState.hs new file mode 100644 index 0000000000..bcf75ee423 --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationPagingState.hs @@ -0,0 +1,17 @@ +module Test.Wire.API.Golden.Manual.ConversationPagingState where + +import qualified Data.ByteString as BS +import Imports +import Wire.API.Conversation + +testObject_ConversationPagingState_1 :: ConversationPagingState +testObject_ConversationPagingState_1 = ConversationPagingState PagingLocals Nothing + +testObject_ConversationPagingState_2 :: ConversationPagingState +testObject_ConversationPagingState_2 = ConversationPagingState PagingLocals (Just (BS.pack [0, 1, 88, 99, 125, 88])) + +testObject_ConversationPagingState_3 :: ConversationPagingState +testObject_ConversationPagingState_3 = ConversationPagingState PagingRemotes Nothing + +testObject_ConversationPagingState_4 :: ConversationPagingState +testObject_ConversationPagingState_4 = ConversationPagingState PagingRemotes (Just (BS.pack [88, 12, 23])) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/GetPaginatedConversationIds.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/GetPaginatedConversationIds.hs new file mode 100644 index 0000000000..5848a8b0fb --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/GetPaginatedConversationIds.hs @@ -0,0 +1,12 @@ +module Test.Wire.API.Golden.Manual.GetPaginatedConversationIds where + +import Data.Proxy +import Data.Range +import Imports +import Wire.API.Conversation + +testObject_GetPaginatedConversationIds_1 :: GetPaginatedConversationIds +testObject_GetPaginatedConversationIds_1 = GetPaginatedConversationIds Nothing (toRange (Proxy @50)) + +testObject_GetPaginatedConversationIds_2 :: GetPaginatedConversationIds +testObject_GetPaginatedConversationIds_2 = GetPaginatedConversationIds (Just $ ConversationPagingState PagingLocals Nothing) (toRange (Proxy @1000)) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 534853d76f..76a60c2955 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 51eb96bf37999a61021ffce3cf4fdb0ac87752f9fe570564d30a06530ec1e844 +-- hash: 9152de17654638a8439538e5d42de1b136055ce828561a44f3ca3e3b3d28fdba name: wire-api version: 0.1.0 @@ -116,6 +116,7 @@ library , extended , extra , generic-random >=1.2 + , generics-sop , ghc-prim , hashable , hostname-validate @@ -398,7 +399,10 @@ test-suite wire-api-tests Test.Wire.API.Golden.Manual.ClientCapability Test.Wire.API.Golden.Manual.ClientCapabilityList Test.Wire.API.Golden.Manual.ConversationCoverView + Test.Wire.API.Golden.Manual.ConversationPagingState + Test.Wire.API.Golden.Manual.ConvIdsPage Test.Wire.API.Golden.Manual.FeatureConfigEvent + Test.Wire.API.Golden.Manual.GetPaginatedConversationIds Test.Wire.API.Golden.Manual.ListConversations Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap Test.Wire.API.Golden.Manual.UserClientPrekeyMap diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index f6c40d5483..af50a8a7f1 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -94,7 +94,7 @@ connError (ConnectBlacklistedUserKey k) = StdError $ foldKey (const blacklistedE connError (ConnectInvalidEmail _ _) = StdError invalidEmail connError ConnectInvalidPhone {} = StdError invalidPhone connError ConnectSameBindingTeamUsers = StdError sameBindingTeamUsers -connError ConnectMissingLegalholdConsent = StdError missingLegalholdConsent +connError ConnectMissingLegalholdConsent = StdError (errorDescriptionToWai missingLegalholdConsent) actError :: ActivationError -> Error actError (UserKeyExists _) = StdError userKeyExists @@ -203,7 +203,7 @@ clientError ClientLegalHoldCannotBeRemoved = StdError can'tDeleteLegalHoldClient clientError ClientLegalHoldCannotBeAdded = StdError can'tAddLegalHoldClient clientError (ClientFederationError e) = fedError e clientError ClientCapabilitiesCannotBeRemoved = StdError clientCapabilitiesCannotBeRemoved -clientError ClientMissingLegalholdConsent = StdError missingLegalholdConsent +clientError ClientMissingLegalholdConsent = StdError (errorDescriptionToWai missingLegalholdConsent) fedError :: FederationError -> Error fedError = StdError . federationErrorToWai @@ -456,9 +456,6 @@ propertyManagedByScim prop = Wai.mkError status403 "managed-by-scim" $ "Updating sameBindingTeamUsers :: Wai.Error sameBindingTeamUsers = Wai.mkError status403 "same-binding-team-users" "Operation not allowed to binding team users." -missingLegalholdConsent :: Wai.Error -missingLegalholdConsent = Wai.mkError status412 "missing-legalhold-consent" "Failed to connect to a user or to invite a user to a group because somebody is under legalhold and somebody else has not granted consent." - ownerDeletingSelf :: Wai.Error ownerDeletingSelf = Wai.mkError diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index a9ed769bf0..e5cb99a908 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -94,7 +94,6 @@ import Util.Logging (logFunction, logHandle, logTeam, logUser) import qualified Wire.API.Connection as Public import Wire.API.ErrorDescription import qualified Wire.API.Properties as Public -import Wire.API.Routes.Public (EmptyResult (..)) import qualified Wire.API.Routes.Public.Brig as BrigAPI import qualified Wire.API.Routes.Public.Galley as GalleyAPI import qualified Wire.API.Routes.Public.LegalHold as LegalHoldAPI @@ -268,21 +267,6 @@ sitemap o = do Doc.returns (Doc.ref Public.modelUserDisplayName) Doc.response 200 "Profile name found." Doc.end - put "/self/email" (continue changeSelfEmailH) $ - zauthUserId - .&. zauthConnId - .&. jsonRequest @Public.EmailUpdate - document "PUT" "changeEmail" $ do - Doc.summary "Change your email address" - Doc.body (Doc.ref Public.modelEmailUpdate) $ - Doc.description "JSON body" - Doc.response 202 "Update accepted and pending activation of the new email." Doc.end - Doc.response 204 "No update, current and new email address are the same." Doc.end - Doc.errorResponse invalidEmail - Doc.errorResponse userKeyExists - Doc.errorResponse blacklistedEmail - Doc.errorResponse blacklistedPhone - put "/self/phone" (continue changePhoneH) $ zauthUserId .&. zauthConnId @@ -796,15 +780,12 @@ addClient usr con ip new = do clientResponse :: Public.Client -> BrigAPI.NewClientResponse clientResponse client = Servant.addHeader (Public.clientId client) client -deleteClient :: UserId -> ConnId -> ClientId -> Public.RmClient -> Handler (EmptyResult 200) -deleteClient usr con clt body = do +deleteClient :: UserId -> ConnId -> ClientId -> Public.RmClient -> Handler () +deleteClient usr con clt body = API.rmClient usr con clt (Public.rmPassword body) !>> clientError - pure EmptyResult -updateClient :: UserId -> ClientId -> Public.UpdateClient -> Handler (EmptyResult 200) -updateClient usr clt upd = do - API.updateClient usr clt upd !>> clientError - pure EmptyResult +updateClient :: UserId -> ClientId -> Public.UpdateClient -> Handler () +updateClient usr clt upd = API.updateClient usr clt upd !>> clientError listClients :: UserId -> Handler [Public.Client] listClients zusr = @@ -1134,13 +1115,6 @@ customerExtensionCheckBlockedDomains email = do when (domain `elem` blockedDomains) $ throwM $ customerExtensionBlockedDomain domain -changeSelfEmailH :: UserId ::: ConnId ::: JsonRequest Public.EmailUpdate -> Handler Response -changeSelfEmailH (u ::: _ ::: req) = do - email <- Public.euEmail <$> parseJsonBody req - API.changeSelfEmail u email API.ForbidSCIMUpdates >>= \case - ChangeEmailResponseIdempotent -> pure (setStatus status204 empty) - ChangeEmailResponseNeedsActivation -> pure (setStatus status202 empty) - createConnectionH :: JSON ::: UserId ::: ConnId ::: JsonRequest Public.ConnectionRequest -> Handler Response createConnectionH (_ ::: self ::: conn ::: req) = do cr <- parseJsonBody req diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index f0bcc91927..536e7c9a85 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -898,7 +898,7 @@ guardLegalhold protectee userClients = do res <- lift $ galleyRequest PUT req case Bilge.statusCode res of 200 -> pure () - 412 -> throwE ClientMissingLegalholdConsent + 403 -> throwE ClientMissingLegalholdConsent 404 -> pure () -- allow for galley not to be ready, so the set of valid deployment orders is non-empty. _ -> throwM internalServerError where diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 865c6e06b0..f1583b7cc5 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -311,7 +311,7 @@ logInvitationRequest context action = Log.warn $ context . Log.msg @Text ("Failed to create invitation, label: " <> (cs . errorLabel) err') pure (Left err') Right result@(_, code) -> do - Log.info $ (context . logInvitationCode code) . Log.msg @Text "Succesfully created invitation" + Log.info $ (context . logInvitationCode code) . Log.msg @Text "Successfully created invitation" pure (Right result) createInvitation' :: TeamId -> Public.Role -> Maybe UserId -> Email -> Public.InvitationRequest -> Handler (Public.Invitation, Public.InvitationCode) diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index aa4ac383c3..f687f1b3de 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -103,7 +103,7 @@ tests _ at opts p b c ch g aws = test' aws p "head /users/:domain/:uid - 404" $ testUserDoesNotExist b, test' aws p "post /list-users - 200" $ testMultipleUsers b, test' aws p "put /self - 200" $ testUserUpdate b c aws, - test' aws p "put /self/email - 2xx" $ testEmailUpdate b aws, + test' aws p "put /access/self/email - 2xx" $ testEmailUpdate b aws, test' aws p "put /self/phone - 202" $ testPhoneUpdate b, test' aws p "head /self/password - 200/404" $ testPasswordSet b, test' aws p "put /self/password - 200" $ testPasswordChange b, @@ -280,9 +280,10 @@ testCreateUserNoEmailNoPassword brig = do responseJsonMaybe rs e <- randomEmail - let setEmail = RequestBodyLBS . encode $ EmailUpdate e - put (brig . path "/self/email" . contentJson . zUser uid . zConn "conn" . body setEmail) - !!! const 202 === statusCode + Just code <- do + sendLoginCode brig p LoginCodeSMS False !!! const 200 === statusCode + getPhoneLoginCode brig p + initiateEmailUpdateLogin brig e (SmsLogin p code Nothing) uid !!! (const 202 === statusCode) -- | email address must not be taken on @/register@. testCreateUserConflict :: Opt.Opts -> Brig -> Http () @@ -717,13 +718,14 @@ testEmailUpdate brig aws = do let uid = userId usr eml <- randomEmail -- update email - initiateEmailUpdate brig eml uid !!! const 202 === statusCode + let Just oldeml = userEmail usr + initiateEmailUpdateLogin brig eml (emailLogin oldeml defPassword Nothing) uid !!! const 202 === statusCode -- activate activateEmail brig eml checkEmail brig uid eml liftIO $ Util.assertUserJournalQueue "user update" aws (userEmailUpdateJournaled uid eml) - -- update email, which is exactly the same as before - initiateEmailUpdate brig eml uid !!! const 204 === statusCode + -- update email, which is exactly the same as before (idempotency) + initiateEmailUpdateLogin brig eml (emailLogin eml defPassword Nothing) uid !!! const 204 === statusCode -- ensure no other user has "test+@example.com" -- if there is such a user, let's delete it first. otherwise -- this test fails since there can be only one user with "test+...@example.com" @@ -996,6 +998,11 @@ testEmailPhoneDelete brig cannon = do user <- randomUser brig let uid = userId user let Just email = userEmail user + (cky, tok) <- do + rsp <- + login brig (emailLogin email defPassword Nothing) PersistentCookie + liftIO $ assertFailure "missing activation key/code" @@ -1060,9 +1065,8 @@ testDeleteUserByPassword brig cannon aws = do -- Initiate a change of email address, to verify that activation -- does not work after the account has been deleted. eml <- randomEmail - let emailUpdate = RequestBodyLBS . encode $ EmailUpdate eml - put (brig . path "/self/email" . contentJson . zUser uid1 . zConn "c" . body emailUpdate) - !!! const 202 === statusCode + let Just oldeml = userEmail u + initiateEmailUpdateLogin brig eml (emailLogin oldeml defPassword Nothing) uid1 !!! (const 202 === statusCode) -- Establish some connections usr2 <- randomUser brig let uid2 = userId usr2 diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 7189626686..37e803e54b 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -372,33 +372,6 @@ testLoginFailure brig = do let badmail = Email "wrong" "wire.com" login brig (PasswordLogin (LoginByEmail badmail) defPassword Nothing) PersistentCookie !!! const 403 === statusCode - -- Create user with only phone number - p <- randomPhone - let newUser = - RequestBodyLBS . encode $ - object - [ "name" .= ("Alice" :: Text), - "phone" .= fromPhone p - ] - res <- - post (brig . path "/i/users" . contentJson . Http.body newUser) - responseJsonError res - eml <- randomEmail - -- Add email - let emailUpdate = RequestBodyLBS . encode $ EmailUpdate eml - put (brig . path "/self/email" . contentJson . zUser uid . zConn "c" . Http.body emailUpdate) - !!! (const 202 === statusCode) - -- Activate - act <- getActivationCode brig (Left eml) - case act of - Nothing -> liftIO $ assertFailure "missing activation key/code" - Just kc -> do - activate brig kc !!! const 200 === statusCode - -- Attempt to log in without having set a password - login brig (defEmailLogin eml) PersistentCookie !!! do - const 403 === statusCode - const (Just "invalid-credentials") === errorLabel testThrottleLogins :: Opts.Opts -> Brig -> Http () testThrottleLogins conf b = do @@ -670,6 +643,7 @@ testTokenMismatchLegalhold z brig galley = do -- | This only tests access; the logic is tested in 'testEmailUpdate' in `Account.hs`. testAccessSelfEmailAllowed :: Nginz -> Brig -> Http () testAccessSelfEmailAllowed nginz brig = do + -- this test duplicates some of 'initiateEmailUpdateLogin' intentionally. forM_ [True, False] $ \withCookie -> do usr <- randomUser brig let Just email = userEmail usr @@ -694,6 +668,7 @@ testAccessSelfEmailAllowed nginz brig = do testAccessSelfEmailDenied :: ZAuth.Env -> Nginz -> Brig -> Http () testAccessSelfEmailDenied zenv nginz brig = do + -- this test duplicates some of 'initiateEmailUpdateLogin' intentionally. forM_ [True, False] $ \withCookie -> do mbCky <- if withCookie diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index fa5351856e..7737a86c73 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -38,7 +38,7 @@ tests _cl _at _conf p b _c _g = testGroup "password-reset" [ test p "post /password-reset[/complete] - 201[/200]" $ testPasswordReset b, - test p "post /password-reset & put /self/email - 400" $ testPasswordResetAfterEmailUpdate b + test p "post /password-reset after put /access/self/email - 400" $ testPasswordResetAfterEmailUpdate b ] testPasswordReset :: Brig -> Http () @@ -69,7 +69,7 @@ testPasswordResetAfterEmailUpdate brig = do let uid = userId u let Just email = userEmail u eml <- randomEmail - initiateEmailUpdate brig eml uid !!! const 202 === statusCode + initiateEmailUpdateLogin brig eml (emailLogin email defPassword Nothing) uid !!! const 202 === statusCode initiatePasswordReset brig email !!! const 201 === statusCode passwordResetData <- preparePasswordReset brig email uid (PlainTextPassword "newsecret") -- activate new email diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 65989fb847..a74cdf8145 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -26,6 +26,7 @@ import Brig.Types import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User.Auth hiding (user) +import qualified Brig.ZAuth import qualified CargoHold.Types.V3 as CHV3 import qualified Codec.MIME.Type as MIME import Control.Lens (preview, (^?)) @@ -149,10 +150,24 @@ checkEmail brig uid expectedEmail = const 200 === statusCode const (Just expectedEmail) === (userEmail <=< responseJsonMaybe) -initiateEmailUpdate :: Brig -> Email -> UserId -> (MonadIO m, MonadHttp m) => m ResponseLBS -initiateEmailUpdate brig email uid = - let emailUpdate = RequestBodyLBS . encode $ EmailUpdate email - in put (brig . path "/self/email" . contentJson . zUser uid . zConn "c" . body emailUpdate) +initiateEmailUpdateLogin :: Brig -> Email -> Login -> UserId -> (MonadIO m, MonadCatch m, MonadHttp m) => m ResponseLBS +initiateEmailUpdateLogin brig email loginCreds uid = do + (cky, tok) <- do + rsp <- + login brig loginCreds PersistentCookie + Email -> (Bilge.Cookie, Brig.ZAuth.AccessToken) -> UserId -> (MonadIO m, MonadCatch m, MonadHttp m) => m ResponseLBS +initiateEmailUpdateCreds brig email (cky, tok) uid = do + put $ + brig + . path "/access/self/email" + . cookie cky + . header "Authorization" ("Bearer " <> toByteString' tok) + . zUser uid + . Bilge.json (EmailUpdate email) initiateEmailUpdateNoSend :: Brig -> Email -> UserId -> (MonadIO m, MonadHttp m) => m ResponseLBS initiateEmailUpdateNoSend brig email uid = diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index f26ca3ea20..6e2679fd43 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -37,7 +37,7 @@ import Brig.Types.User import Brig.Types.User.Auth import qualified Brig.ZAuth as ZAuth import Control.Lens ((^.), (^?), (^?!)) -import Control.Monad.Catch (MonadCatch) +import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Retry import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _Integral, _JSON, _String) @@ -801,6 +801,12 @@ retryWhileN n f m = (const (return . f)) (const m) +recoverN :: (MonadIO m, MonadMask m) => Int -> m a -> m a +recoverN n m = + recoverAll + (constantDelay 1000000 <> limitRetries n) + (const m) + -- | This allows you to run requests against a brig instantiated using the given options. -- Note that ONLY 'brig' calls should occur within the provided action, calls to other -- services will fail. diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 45dac5801c..08b4c97575 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -49,6 +49,7 @@ import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities import qualified Wire.API.Conversation as Public +import Wire.API.ErrorDescription (missingLegalholdConsent) import Wire.API.Routes.Public.Galley ( ConversationResponse, ConversationResponseFor (..), @@ -89,7 +90,7 @@ ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ unlessM (allLegalholdConsentGiven locals) $ - throwM missingLegalholdConsent + throwErrorDescription missingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 8d9c4f1b00..27572d52a8 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -209,9 +209,6 @@ noLegalHoldDeviceAllocated = mkError status404 "legalhold-no-device-allocated" " legalHoldCouldNotBlockConnections :: Error legalHoldCouldNotBlockConnections = mkError status500 "legalhold-internal" "legal hold service: could not block connections when resolving policy conflicts." -missingLegalholdConsent :: Error -missingLegalholdConsent = mkError status412 "missing-legalhold-consent" "Failed to connect to a user or to invite a user to a group because somebody is under legalhold and somebody else has not granted consent." - disableSsoNotImplemented :: Error disableSsoNotImplemented = mkError diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index f01d0cd1be..0e596c588e 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -28,7 +28,7 @@ where import qualified Cassandra as Cql import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) -import Control.Monad.Catch (MonadCatch, MonadThrow (throwM)) +import Control.Monad.Catch (MonadCatch) import Data.Id as Id import Data.List1 (List1, list1, maybeList1) import Data.Range @@ -37,7 +37,7 @@ import GHC.TypeLits (AppendSymbol) import qualified Galley.API.Clients as Clients import qualified Galley.API.Create as Create import qualified Galley.API.CustomBackend as CustomBackend -import Galley.API.Error (missingLegalholdConsent) +import Galley.API.Error (throwErrorDescription) import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) import qualified Galley.API.Query as Query @@ -71,6 +71,7 @@ import Servant.API.Generic import Servant.Server import Servant.Server.Generic (genericServerT) import System.Logger.Class hiding (Path, name) +import Wire.API.ErrorDescription (missingLegalholdConsent) import qualified Wire.API.Team.Feature as Public data InternalApi routes = InternalApi @@ -491,5 +492,5 @@ guardLegalholdPolicyConflictsH :: (JsonRequest GuardLegalholdPolicyConflicts ::: guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) - >>= either (const (throwM missingLegalholdConsent)) pure + >>= either (const (throwErrorDescription missingLegalholdConsent)) pure pure $ Network.Wai.Utilities.setStatus status200 empty diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 069545b9f5..058142bce0 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -1,7 +1,6 @@ module Galley.API.Message where import Control.Lens -import Control.Monad.Catch (throwM) import Control.Monad.Except (throwError) import Control.Monad.Extra (eitherM) import Control.Monad.Trans.Except (runExceptT) @@ -18,14 +17,11 @@ import Data.Json.Util import Data.List1 (singleton) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) -import Data.Proxy import Data.Qualified (Qualified (..), partitionRemote) -import Data.SOP (I (..), htrans, unI) import qualified Data.Set as Set import Data.Set.Lens import Data.Tagged (unTagged) import Data.Time.Clock (UTCTime, getCurrentTime) -import Galley.API.Error (missingLegalholdConsent) import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) import Galley.API.Util ( runFederatedBrig, @@ -44,19 +40,14 @@ import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports -import qualified Servant -import Servant.API (Union, WithStatus (..)) import qualified System.Logger.Class as Log import UnliftIO.Async -import Wire.API.ErrorDescription as ErrorDescription import Wire.API.Event.Conversation import qualified Wire.API.Federation.API.Brig as FederatedBrig import qualified Wire.API.Federation.API.Galley as FederatedGalley import Wire.API.Federation.Client (FederationError, executeFederated) import Wire.API.Federation.Error (federationErrorToWai) import Wire.API.Message -import qualified Wire.API.Message as Public -import Wire.API.Routes.Public.Galley as Public import Wire.API.Team.LegalHold import Wire.API.User.Client import Wire.API.UserMap (UserMap (..)) @@ -206,7 +197,7 @@ postRemoteOtrMessage :: Qualified UserId -> Qualified ConvId -> LByteString -> - Galley (Union Public.PostOtrResponses) + Galley (PostOtrResponse MessageSendingStatus) postRemoteOtrMessage sender conv rawMsg = do let msr = FederatedGalley.MessageSendRequest @@ -215,17 +206,9 @@ postRemoteOtrMessage sender conv rawMsg = do FederatedGalley.msrRawMessage = Base64ByteString rawMsg } rpc = FederatedGalley.sendMessage FederatedGalley.clientRoutes (qDomain sender) msr - mkPostOtrResponsesUnion . FederatedGalley.msResponse =<< runFederatedGalley (qDomain conv) rpc + FederatedGalley.msResponse <$> runFederatedGalley (qDomain conv) rpc -mkPostOtrResponsesUnion :: Either FederatedGalley.MessageNotSent MessageSendingStatus -> Galley (Union Public.PostOtrResponses) -mkPostOtrResponsesUnion (Right mss) = Servant.respond (WithStatus @201 mss) -mkPostOtrResponsesUnion (Left reason) = case reason of - FederatedGalley.MessageNotSentClientMissing mss -> Servant.respond (WithStatus @412 mss) - FederatedGalley.MessageNotSentUnknownClient -> Servant.respond ErrorDescription.unknownClient - FederatedGalley.MessageNotSentConversationNotFound -> Servant.respond ErrorDescription.convNotFound - FederatedGalley.MessageNotSentLegalhold -> throwM missingLegalholdConsent - -postQualifiedOtrMessage :: UserType -> Qualified UserId -> Maybe ConnId -> ConvId -> Public.QualifiedNewOtrMessage -> Galley (Either FederatedGalley.MessageNotSent Public.MessageSendingStatus) +postQualifiedOtrMessage :: UserType -> Qualified UserId -> Maybe ConnId -> ConvId -> QualifiedNewOtrMessage -> Galley (PostOtrResponse MessageSendingStatus) postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do alive <- Data.isConvAlive convId localDomain <- viewFederationDomain @@ -236,7 +219,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do let senderClient = qualifiedNewOtrSender msg unless alive $ do lift $ Data.deleteConversation convId - throwError FederatedGalley.MessageNotSentConversationNotFound + throwError MessageNotSentConversationNotFound -- conversation members localMembers <- lift $ Data.members convId @@ -253,7 +236,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- check if the sender is part of the conversation unless (Set.member sender members) $ - throwError FederatedGalley.MessageNotSentConversationNotFound + throwError MessageNotSentConversationNotFound -- get local clients localClients <- @@ -277,7 +260,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do senderClient (Map.findWithDefault mempty (senderDomain, senderUser) qualifiedClients) ) - $ throwError FederatedGalley.MessageNotSentUnknownClient + $ throwError MessageNotSentUnknownClient let (sendMessage, validMessages, mismatch) = checkMessageClients @@ -289,8 +272,8 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do unless sendMessage $ do let lhProtectee = qualifiedUserToProtectee localDomain senderType sender missingClients = qmMissing mismatch - legalholdErr = pure FederatedGalley.MessageNotSentLegalhold - clientMissingErr = pure $ FederatedGalley.MessageNotSentClientMissing otrResult + legalholdErr = pure MessageNotSentLegalhold + clientMissingErr = pure $ MessageNotSentClientMissing otrResult guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients & eitherM (const legalholdErr) (const clientMissingErr) & lift @@ -487,18 +470,18 @@ data MessageMetadata = MessageMetadata } deriving (Eq, Ord, Show) -qualifiedNewOtrMetadata :: Public.QualifiedNewOtrMessage -> MessageMetadata +qualifiedNewOtrMetadata :: QualifiedNewOtrMessage -> MessageMetadata qualifiedNewOtrMetadata msg = MessageMetadata - { mmNativePush = Public.qualifiedNewOtrNativePush msg, - mmTransient = Public.qualifiedNewOtrTransient msg, - mmNativePriority = Public.qualifiedNewOtrNativePriority msg, - mmData = Public.qualifiedNewOtrData msg + { mmNativePush = qualifiedNewOtrNativePush msg, + mmTransient = qualifiedNewOtrTransient msg, + mmNativePriority = qualifiedNewOtrNativePriority msg, + mmData = qualifiedNewOtrData msg } -- unqualified -legacyClientMismatchStrategy :: Domain -> Maybe [UserId] -> Maybe Public.IgnoreMissing -> Maybe Public.ReportMissing -> ClientMismatchStrategy +legacyClientMismatchStrategy :: Domain -> Maybe [UserId] -> Maybe IgnoreMissing -> Maybe ReportMissing -> ClientMismatchStrategy legacyClientMismatchStrategy localDomain (Just uids) _ _ = MismatchReportOnly (Set.fromList (map (`Qualified` localDomain) uids)) legacyClientMismatchStrategy _ Nothing (Just IgnoreMissingAll) _ = MismatchIgnoreAll @@ -515,12 +498,6 @@ class Unqualify a b where instance Unqualify a a where unqualify _ = id -instance - Unqualify a b => - Unqualify (WithStatus c a) (WithStatus c b) - where - unqualify domain (WithStatus x) = WithStatus (unqualify domain x) - instance Unqualify MessageSendingStatus ClientMismatch where unqualify domain status = ClientMismatch @@ -536,5 +513,6 @@ instance Unqualify QualifiedUserClients UserClients where . Map.findWithDefault mempty domain . qualifiedUserClients -instance Unqualify (Union PostOtrResponses) (Union PostOtrResponsesUnqualified) where - unqualify domain = htrans (Proxy @Unqualify) $ I . unqualify domain . unI +instance Unqualify a b => Unqualify (PostOtrResponse a) (PostOtrResponse b) where + unqualify domain (Left a) = Left (unqualify domain <$> a) + unqualify domain (Right a) = Right (unqualify domain a) diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index b2b5ffb147..b256288b0a 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -80,7 +80,8 @@ servantSitemap = { GalleyAPI.getUnqualifiedConversation = Query.getUnqualifiedConversation, GalleyAPI.getConversation = Query.getConversation, GalleyAPI.getConversationRoles = Query.getConversationRoles, - GalleyAPI.getConversationIds = Query.getConversationIds, + GalleyAPI.listConversationIdsUnqualified = Query.conversationIdsPageFromUnqualified, + GalleyAPI.listConversationIds = Query.conversationIdsPageFrom, GalleyAPI.getConversations = Query.getConversations, GalleyAPI.getConversationByReusableCode = Query.getConversationByReusableCode, GalleyAPI.listConversations = Query.listConversations, diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index eafebb6728..d401ed4730 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -14,13 +14,15 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE RecordWildCards #-} module Galley.API.Query ( getBotConversationH, getUnqualifiedConversation, getConversation, getConversationRoles, - getConversationIds, + conversationIdsPageFromUnqualified, + conversationIdsPageFrom, getConversations, listConversations, iterateConversations, @@ -31,7 +33,9 @@ module Galley.API.Query ) where +import qualified Cassandra as C import Control.Monad.Catch (throwM) +import qualified Data.ByteString.Lazy as LBS import Data.Code import Data.CommaSeparatedList import Data.Domain (Domain) @@ -118,8 +122,8 @@ getConversationRoles zusr cnv = do -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles -getConversationIds :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley (Public.ConversationList ConvId) -getConversationIds zusr start msize = do +conversationIdsPageFromUnqualified :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley (Public.ConversationList ConvId) +conversationIdsPageFromUnqualified zusr start msize = do let size = fromMaybe (toRange (Proxy @1000)) msize ids <- Data.conversationIdsFrom zusr start size pure $ @@ -127,6 +131,50 @@ getConversationIds zusr start msize = do (Data.resultSetResult ids) (Data.resultSetType ids == Data.ResultSetTruncated) +-- | Lists conversation ids for the logged in user in a paginated way. +-- +-- Pagination requires an order, in this case the order is defined as: +-- +-- - First all the local conversations are listed ordered by their id +-- +-- - After local conversations, remote conversations are listed ordered +-- - lexicographically by their domain and then by their id. +conversationIdsPageFrom :: UserId -> Public.GetPaginatedConversationIds -> Galley Public.ConvIdsPage +conversationIdsPageFrom zusr Public.GetPaginatedConversationIds {..} = do + localDomain <- viewFederationDomain + case gpciPagingState of + Just (Public.ConversationPagingState Public.PagingRemotes stateBS) -> remotesOnly (mkState <$> stateBS) (fromRange gpciSize) + _ -> localsAndRemotes localDomain (fmap mkState . Public.cpsPagingState =<< gpciPagingState) gpciSize + where + mkState :: ByteString -> C.PagingState + mkState = C.PagingState . LBS.fromStrict + + localsAndRemotes :: Domain -> Maybe C.PagingState -> Range 1 1000 Int32 -> Galley Public.ConvIdsPage + localsAndRemotes localDomain pagingState size = do + localPage <- pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) <$> Data.localConversationIdsPageFrom zusr pagingState size + let remainingSize = fromRange size - fromIntegral (length (Public.pageConvIds localPage)) + if Public.pageHasMore localPage || remainingSize <= 0 + then pure localPage {Public.pageHasMore = True} -- We haven't check the remotes yet, so has_more must always be True here. + else do + remotePage <- remotesOnly Nothing remainingSize + pure $ remotePage {Public.pageConvIds = Public.pageConvIds localPage <> Public.pageConvIds remotePage} + + remotesOnly :: Maybe C.PagingState -> Int32 -> Galley Public.ConvIdsPage + remotesOnly pagingState size = + pageToConvIdPage Public.PagingRemotes <$> Data.remoteConversationIdsPageFrom zusr pagingState size + + pageToConvIdPage :: Public.ConversationPagingTable -> Data.PageWithState (Qualified ConvId) -> Public.ConvIdsPage + pageToConvIdPage table page@Data.PageWithState {..} = + Public.ConvIdsPage + { pageConvIds = pwsResults, + pageHasMore = C.pwsHasMore page, + pagePagingState = + Public.ConversationPagingState + { cpsTable = table, + cpsPagingState = LBS.toStrict . C.unPagingState <$> pwsState + } + } + getConversations :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Public.Conversation) getConversations user mids mstart msize = do ConversationList cs more <- getConversationsInternal user mids mstart msize diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 7e73e773c8..8dfbc7476f 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -116,7 +116,6 @@ import UnliftIO (mapConcurrently) import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription (convNotFound, notATeamMember, operationDenied) import qualified Wire.API.Notification as Public -import Wire.API.Routes.Public (EmptyResult (..)) import qualified Wire.API.Team as Public import qualified Wire.API.Team.Conversation as Public import Wire.API.Team.Export (TeamExportUser (..)) @@ -761,7 +760,7 @@ getTeamConversation zusr tid cid = do throwErrorDescription (operationDenied GetTeamConversations) Data.teamConversation tid cid >>= maybe (throwErrorDescription convNotFound) pure -deleteTeamConversation :: UserId -> ConnId -> TeamId -> ConvId -> Galley (EmptyResult 200) +deleteTeamConversation :: UserId -> ConnId -> TeamId -> ConvId -> Galley () deleteTeamConversation zusr zcon tid cid = do localDomain <- viewFederationDomain let qconvId = Qualified cid localDomain @@ -778,7 +777,6 @@ deleteTeamConversation zusr zcon tid cid = do -- TODO: we don't delete bots here, but we should do that, since every -- bot user can only be in a single conversation Data.removeTeamConv tid cid - pure EmptyResult getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley Response getSearchVisibilityH (uid ::: tid ::: _) = do diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 0fefd9a184..9da41f6fe8 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -103,19 +103,22 @@ import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (and, failure, setStatus, _1, _2) import Network.Wai.Utilities -import Servant.API.UVerb import qualified System.Logger.Class as Log import Wire.API.Conversation (InviteQualified (invQRoleName)) import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public import Wire.API.Conversation.Role (roleNameWireAdmin) -import Wire.API.ErrorDescription (codeNotFound, convNotFound, unknownClient) +import Wire.API.ErrorDescription + ( codeNotFound, + convNotFound, + missingLegalholdConsent, + unknownClient, + ) import qualified Wire.API.ErrorDescription as Public import qualified Wire.API.Event.Conversation as Public import Wire.API.Federation.API.Galley (RemoteMessage (..)) import qualified Wire.API.Message as Public import Wire.API.Routes.Public.Galley (UpdateResult (..)) -import qualified Wire.API.Routes.Public.Galley as GalleyAPI import Wire.API.ServantProto (RawProto (..)) import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client @@ -520,11 +523,11 @@ addMembers zusr zcon convId invite = do whenM (anyLegalholdActivated (memId <$> convUsers)) $ unless allNewUsersGaveConsent $ - throwM missingLegalholdConsent + throwErrorDescription missingLegalholdConsent whenM (anyLegalholdActivated newUsers) $ do unless allNewUsersGaveConsent $ - throwM missingLegalholdConsent + throwErrorDescription missingLegalholdConsent convUsersLHStatus <- do uidsStatus <- getLHStatusForUsers (memId <$> convUsers) @@ -541,7 +544,7 @@ addMembers zusr zcon convId invite = do when (consentGiven status == ConsentNotGiven) $ void $ removeMember (memId mem) Nothing (Data.convId conv) (memId mem) else do - throwM missingLegalholdConsent + throwErrorDescription missingLegalholdConsent checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley () checkLHPolicyConflictsRemote _remotes = pure () @@ -641,15 +644,15 @@ postBotMessage zbot zcnv val message = do -- | FUTUREWORK: Send message to remote users, as of now this function fails if -- the conversation is not hosted on current backend. If the conversation is -- hosted on current backend, it completely ignores remote users. -postProteusMessage :: UserId -> ConnId -> Qualified ConvId -> RawProto Public.QualifiedNewOtrMessage -> Galley (Union GalleyAPI.PostOtrResponses) +postProteusMessage :: UserId -> ConnId -> Qualified ConvId -> RawProto Public.QualifiedNewOtrMessage -> Galley (Public.PostOtrResponse Public.MessageSendingStatus) postProteusMessage zusr zcon conv msg = do localDomain <- viewFederationDomain let sender = Qualified zusr localDomain if localDomain /= qDomain conv then postRemoteOtrMessage sender conv (rpRaw msg) - else mkPostOtrResponsesUnion =<< postQualifiedOtrMessage User sender (Just zcon) (qUnqualified conv) (rpValue msg) + else postQualifiedOtrMessage User sender (Just zcon) (qUnqualified conv) (rpValue msg) -postOtrMessageUnqualified :: UserId -> ConnId -> ConvId -> Maybe Public.IgnoreMissing -> Maybe Public.ReportMissing -> Public.NewOtrMessage -> Galley (Union GalleyAPI.PostOtrResponsesUnqualified) +postOtrMessageUnqualified :: UserId -> ConnId -> ConvId -> Maybe Public.IgnoreMissing -> Maybe Public.ReportMissing -> Public.NewOtrMessage -> Galley (Public.PostOtrResponse Public.ClientMismatch) postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do localDomain <- viewFederationDomain let sender = Qualified zusr localDomain @@ -674,9 +677,7 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do Public.qualifiedNewOtrClientMismatchStrategy = clientMismatchStrategy } unqualify localDomain - <$> ( mkPostOtrResponsesUnion - =<< postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage - ) + <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage postProtoOtrBroadcastH :: UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do @@ -1130,7 +1131,7 @@ handleOtrResponse utype usr clt rcps membs clts val now go = case checkOtrRecipi ValidOtrRecipients m r -> go r >> pure (OtrSent m) MissingOtrRecipients m -> do guardLegalholdPolicyConflicts (userToProtectee utype usr) (missingClients m) - >>= either (const (throwM missingLegalholdConsent)) pure + >>= either (const (throwErrorDescription missingLegalholdConsent)) pure pure (OtrMissingRecipients m) InvalidOtrSenderUser -> pure $ OtrConversationNotFound convNotFound InvalidOtrSenderClient -> pure $ OtrUnknownClient unknownClient diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 8417571105..2e14434e5d 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -20,6 +20,7 @@ module Galley.Data ( ResultSet, ResultSetType (..), + PageWithState (..), mkResultSet, resultSetType, resultSetResult, @@ -59,6 +60,7 @@ module Galley.Data acceptConnect, conversation, conversationIdsFrom, + localConversationIdsPageFrom, conversationIdRowsForPagination, conversationIdsOf, conversationMeta, @@ -75,6 +77,7 @@ module Galley.Data updateConversationMessageTimer, deleteConversation, lookupReceiptMode, + remoteConversationIdsPageFrom, -- * Conversation Members addMember, @@ -538,8 +541,9 @@ conversationMeta conv = where toConvMeta (t, c, a, r, n, i, _, mt, rm) = ConversationMeta conv t c (defAccess t a) (maybeRole t r) n i mt rm +-- | Deprecated, use 'localConversationIdsPageFrom' conversationIdsFrom :: - (MonadClient m, Log.MonadLogger m, MonadThrow m) => + (MonadClient m) => UserId -> Maybe ConvId -> Range 1 1000 Int32 -> @@ -551,6 +555,19 @@ conversationIdsFrom usr start (fromRange -> max) = where strip p = p {result = take (fromIntegral max) (result p)} +localConversationIdsPageFrom :: + (MonadClient m) => + UserId -> + Maybe PagingState -> + Range 1 1000 Int32 -> + m (PageWithState ConvId) +localConversationIdsPageFrom usr pagingState (fromRange -> max) = + fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState Quorum (Identity usr) max pagingState) + +remoteConversationIdsPageFrom :: (MonadClient m) => UserId -> Maybe PagingState -> Int32 -> m (PageWithState (Qualified ConvId)) +remoteConversationIdsPageFrom usr pagingState max = + uncurry (flip Qualified) <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState Quorum (Identity usr) max pagingState) + conversationIdRowsForPagination :: MonadClient m => UserId -> Maybe ConvId -> Range 1 1000 Int32 -> m (Page ConvId) conversationIdRowsForPagination usr start (fromRange -> max) = runIdentity diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Data/Queries.hs index 6af659366b..bd8cdd6277 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Data/Queries.hs @@ -305,7 +305,7 @@ insertUserRemoteConv :: PrepQuery W (UserId, Domain, ConvId) () insertUserRemoteConv = "insert into user_remote_conv (user, conv_remote_domain, conv_remote_id) values (?, ?, ?)" selectUserRemoteConvs :: PrepQuery R (Identity UserId) (Domain, ConvId) -selectUserRemoteConvs = "select conv_remote_domain, conv_remote_id from user_remote_conv where user = ? order by conv_remote_domain" +selectUserRemoteConvs = "select conv_remote_domain, conv_remote_id from user_remote_conv where user = ?" selectRemoteConvMembership :: PrepQuery R (UserId, Domain, ConvId) (Identity UserId) selectRemoteConvMembership = "select user from user_remote_conv where user = ? and conv_remote_domain = ? and conv_remote_id = ?" diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index d950cf252c..28b6471eb9 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -50,6 +50,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.List1 import qualified Data.List1 as List1 import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) import Data.Qualified import Data.Range import qualified Data.Set as Set @@ -116,7 +117,10 @@ tests s = test s "list-conversations by ids" listConvsOk2, test s "fail to get >500 conversations" getConvsFailMaxSize, test s "get conversation ids" getConvIdsOk, + test s "get conversation ids v2" listConvIdsOk, test s "paginate through conversation ids" paginateConvIds, + test s "paginate through /conversations/list-ids" paginateConvListIds, + test s "paginate through /conversations/list-ids - page ending at locals and remote domain" paginateConvListIdsPageEndingAtLocalsAndDomain, test s "fail to get >1000 conversation ids" getConvIdsFailMaxSize, test s "page through conversations" getConvsPagingOk, test s "page through list-conversations (local conversations only)" listConvsPagingOk, @@ -667,12 +671,12 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do let expectedRedundant = QualifiedUserClients . Map.fromList $ [ ( owningDomain, - Map.fromList $ + Map.fromList [ (nonMemberUnqualified, Set.singleton nonMemberOwningDomainClient) ] ), ( remoteDomain, - Map.fromList $ + Map.fromList [ (nonMemberRemoteUnqualified, Set.singleton nonMemberRemoteClient) ] ) @@ -1220,17 +1224,27 @@ paginateConvIds = do [alice, bob, eve] <- randomUsers 3 connectUsers alice (singleton bob) connectUsers alice (singleton eve) - replicateM_ 256 $ + replicateM_ 253 $ postConv alice [bob, eve] (Just "gossip") [] Nothing Nothing !!! const 201 === statusCode - foldM_ (getChunk 16 alice) Nothing [15 .. 0 :: Int] + -- 1 self conv, 2 convs with bob and eve, 253 gossips = 256 convs + foldM_ (getChunk 16 alice) Nothing [15, 14 .. 0 :: Int] where getChunk size alice start n = do resp <- getConvIds alice start (Just size) 0 + -- This is because of the way this test is setup, we always get 16 + -- convs, even on the last one + assertEqual + ("Number of convs should match the requested size, " <> show n <> " more gets to go") + (fromIntegral size) + (length (convList c)) + + if n > 0 + then assertEqual "hasMore should be True" True (convHasMore c) + else assertEqual ("hasMore should be False, " <> show n <> " more chunks to go") False (convHasMore c) + return (Just (Right (last (convList c)))) getConvIdsFailMaxSize :: TestM () @@ -1239,6 +1253,148 @@ getConvIdsFailMaxSize = do getConvIds usr Nothing (Just 1001) !!! const 400 === statusCode +listConvIdsOk :: TestM () +listConvIdsOk = do + [alice, bob] <- randomUsers 2 + connectUsers alice (singleton bob) + void $ postO2OConv alice bob (Just "gossip") + let paginationOpts = GetPaginatedConversationIds Nothing (toRange (Proxy @5)) + listConvIds alice paginationOpts !!! do + const 200 === statusCode + const (Right 2) === fmap length . decodeQualifiedConvIdList + listConvIds bob paginationOpts !!! do + const 200 === statusCode + const (Right 2) === fmap length . decodeQualifiedConvIdList + +paginateConvListIds :: TestM () +paginateConvListIds = do + [alice, bob, eve] <- randomUsers 3 + connectUsers alice (list1 bob [eve]) + localDomain <- viewFederationDomain + let qAlice = Qualified alice localDomain + now <- liftIO getCurrentTime + fedGalleyClient <- view tsFedGalleyClient + + replicateM_ 197 $ + postConv alice [bob, eve] (Just "gossip") [] Nothing Nothing + !!! const 201 === statusCode + + remoteChad <- randomId + let chadDomain = Domain "chad.example.com" + qChad = Qualified remoteChad chadDomain + replicateM_ 25 $ do + conv <- randomId + let cmu = + FederatedGalley.ConversationMemberUpdate + { FederatedGalley.cmuTime = now, + FederatedGalley.cmuOrigUserId = qChad, + FederatedGalley.cmuConvId = Qualified conv chadDomain, + FederatedGalley.cmuAlreadyPresentUsers = [], + FederatedGalley.cmuUsersAdd = [(qAlice, roleNameWireMember)], + FederatedGalley.cmuUsersRemove = [] + } + FederatedGalley.updateConversationMemberships fedGalleyClient cmu + + remoteDee <- randomId + let deeDomain = Domain "dee.example.com" + qDee = Qualified remoteDee deeDomain + replicateM_ 31 $ do + conv <- randomId + let cmu = + FederatedGalley.ConversationMemberUpdate + { FederatedGalley.cmuTime = now, + FederatedGalley.cmuOrigUserId = qDee, + FederatedGalley.cmuConvId = Qualified conv deeDomain, + FederatedGalley.cmuAlreadyPresentUsers = [], + FederatedGalley.cmuUsersAdd = [(qAlice, roleNameWireMember)], + FederatedGalley.cmuUsersRemove = [] + } + FederatedGalley.updateConversationMemberships fedGalleyClient cmu + + -- 1 self conv + 2 convs with bob and eve + 197 local convs + 25 convs on + -- chad.example.com + 31 on dee.example = 256 convs. Getting them 16 at a time + -- should get all them in 16 times. + foldM_ (getChunkedConvs 16 0 alice) Nothing [16, 15 .. 0 :: Int] + +-- This test ensures to setup conversations so that a page would end exactly +-- when local convs are exhausted and then exactly when another remote domain's +-- convs are exhausted. As the local convs and remote convs are stored in two +-- different tables, this is an important edge case to test. +paginateConvListIdsPageEndingAtLocalsAndDomain :: TestM () +paginateConvListIdsPageEndingAtLocalsAndDomain = do + [alice, bob, eve] <- randomUsers 3 + connectUsers alice (list1 bob [eve]) + localDomain <- viewFederationDomain + let qAlice = Qualified alice localDomain + now <- liftIO getCurrentTime + fedGalleyClient <- view tsFedGalleyClient + + -- With page size 16, 29 group convs + 2 one-to-one convs + 1 self conv, we + -- get 32 convs. The 2nd page should end here. + replicateM_ 29 $ + postConv alice [bob, eve] (Just "gossip") [] Nothing Nothing + !!! const 201 === statusCode + + -- We should be able to page through current state in 2 pages exactly + foldM_ (getChunkedConvs 16 0 alice) Nothing [2, 1, 0 :: Int] + + remoteChad <- randomId + let chadDomain = Domain "chad.example.com" + qChad = Qualified remoteChad chadDomain + -- The 3rd page will end with this domain + replicateM_ 16 $ do + conv <- randomId + let cmu = + FederatedGalley.ConversationMemberUpdate + { FederatedGalley.cmuTime = now, + FederatedGalley.cmuOrigUserId = qChad, + FederatedGalley.cmuConvId = Qualified conv chadDomain, + FederatedGalley.cmuAlreadyPresentUsers = [], + FederatedGalley.cmuUsersAdd = [(qAlice, roleNameWireMember)], + FederatedGalley.cmuUsersRemove = [] + } + FederatedGalley.updateConversationMemberships fedGalleyClient cmu + + remoteDee <- randomId + let deeDomain = Domain "dee.example.com" + qDee = Qualified remoteDee deeDomain + -- The 4th and last page will end with this domain + replicateM_ 16 $ do + conv <- randomId + let cmu = + FederatedGalley.ConversationMemberUpdate + { FederatedGalley.cmuTime = now, + FederatedGalley.cmuOrigUserId = qDee, + FederatedGalley.cmuConvId = Qualified conv deeDomain, + FederatedGalley.cmuAlreadyPresentUsers = [], + FederatedGalley.cmuUsersAdd = [(qAlice, roleNameWireMember)], + FederatedGalley.cmuUsersRemove = [] + } + FederatedGalley.updateConversationMemberships fedGalleyClient cmu + + foldM_ (getChunkedConvs 16 0 alice) Nothing [4, 3, 2, 1, 0 :: Int] + +-- | Gets chunked conversation ids given size of each chunk, size of the last +-- chunk, requesting user and @n@ which represents how many chunks are remaining +-- to go, when this is 0, it is assumed that this chunk is last and the response +-- must set @has_more@ to 'False' and the number of conv ids returned should +-- match @lastSize@. +getChunkedConvs :: HasCallStack => Int32 -> Int -> UserId -> Maybe ConversationPagingState -> Int -> TestM (Maybe ConversationPagingState) +getChunkedConvs size lastSize alice pagingState n = do + let paginationOpts = GetPaginatedConversationIds pagingState (unsafeRange size) + resp <- listConvIds alice paginationOpts 0 + then assertEqual ("Number of convs should match the requested size, " <> show n <> " more chunks to go") (fromIntegral size) (length (pageConvIds c)) + else assertEqual "Number of convs should match the last size, no more chunks to go" lastSize (length (pageConvIds c)) + + if n > 0 + then assertEqual ("hasMore should be True, " <> show n <> " more chunk(s) to go") True (pageHasMore c) + else assertEqual "hasMore should be False, no more chunks to go" False (pageHasMore c) + + return . Just $ pagePagingState c + getConvsPagingOk :: TestM () getConvsPagingOk = do [ally, bill, carl] <- randomUsers 3 @@ -1312,7 +1468,7 @@ postConvFailNumMembers :: TestM () postConvFailNumMembers = do n <- fromIntegral <$> view tsMaxConvSize alice <- randomUser - bob : others <- replicateM n (randomUser) + bob : others <- replicateM n randomUser connectUsers alice (list1 bob others) postConv alice (bob : others) Nothing [] Nothing Nothing !!! do const 400 === statusCode @@ -1504,7 +1660,7 @@ postRepeatConnectConvCancel = do let cnv = responseJsonUnsafeWithMsg "conversation" rsp1 liftIO $ do ConnectConv @=? cnvType cnv - (Just "A") @=? cnvName cnv + Just "A" @=? cnvName cnv [] @=? cmOthers (cnvMembers cnv) privateAccess @=? cnvAccess cnv -- Alice blocks / cancels @@ -1514,7 +1670,7 @@ postRepeatConnectConvCancel = do let cnv2 = responseJsonUnsafeWithMsg "conversation" rsp2 liftIO $ do ConnectConv @=? cnvType cnv2 - (Just "A2") @=? cnvName cnv2 + Just "A2" @=? cnvName cnv2 [] @=? cmOthers (cnvMembers cnv2) privateAccess @=? cnvAccess cnv2 -- Alice blocks / cancels again @@ -1524,7 +1680,7 @@ postRepeatConnectConvCancel = do let cnv3 = responseJsonUnsafeWithMsg "conversation" rsp3 liftIO $ do ConnectConv @=? cnvType cnv3 - (Just "B") @=? cnvName cnv3 + Just "B" @=? cnvName cnv3 privateAccess @=? cnvAccess cnv3 -- Bob accepting is a no-op, since he is already a member let convId = qUnqualified . cnvQualifiedId $ cnv @@ -1532,14 +1688,14 @@ postRepeatConnectConvCancel = do cnvX <- responseJsonUnsafeWithMsg "conversation" <$> getConv bob convId liftIO $ do ConnectConv @=? cnvType cnvX - (Just "B") @=? cnvName cnvX + Just "B" @=? cnvName cnvX privateAccess @=? cnvAccess cnvX -- Alice accepts, finally turning it into a 1-1 putConvAccept alice convId !!! const 200 === statusCode cnv4 <- responseJsonUnsafeWithMsg "conversation" <$> getConv alice convId liftIO $ do One2OneConv @=? cnvType cnv4 - (Just "B") @=? cnvName cnv4 + Just "B" @=? cnvName cnv4 privateAccess @=? cnvAccess cnv4 where cancel u c = do @@ -1620,7 +1776,7 @@ leaveConnectConversation = do alice <- randomUser bob <- randomUser bdy <- postConnectConv alice bob "alice" "ni" Nothing responseJsonUnsafe bdy) + let c = maybe (error "invalid connect conversation") (qUnqualified . cnvQualifiedId) (responseJsonUnsafe bdy) deleteMember alice alice c !!! const 403 === statusCode -- FUTUREWORK: Add more tests for scenarios of federation. @@ -1806,7 +1962,7 @@ testAddRemoteMemberFederationDisabled = do -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing - withSettingsOverrides federatorNotConfigured $ do + withSettingsOverrides federatorNotConfigured $ postQualifiedMembers' g alice (remoteBob :| []) convId !!! do const 400 === statusCode const (Just "federation-not-enabled") === fmap label . responseJsonUnsafe @@ -1815,7 +1971,7 @@ testAddRemoteMemberFederationDisabled = do -- misconfiguration of federator. That should give a 500. -- Port 1 should always be wrong hopefully. let federatorUnavailable :: Opts = opts & optFederator ?~ Endpoint "127.0.0.1" 1 - withSettingsOverrides federatorUnavailable $ do + withSettingsOverrides federatorUnavailable $ postQualifiedMembers' g alice (remoteBob :| []) convId !!! do const 500 === statusCode const (Just "federation-not-available") === fmap label . responseJsonUnsafe @@ -2002,12 +2158,12 @@ putMemberOk update = do Member { memId = bob, memService = Nothing, - memOtrMuted = fromMaybe False (mupOtrMute update), + memOtrMuted = Just True == mupOtrMute update, memOtrMutedStatus = mupOtrMuteStatus update, memOtrMutedRef = mupOtrMuteRef update, - memOtrArchived = fromMaybe False (mupOtrArchive update), + memOtrArchived = Just True == mupOtrArchive update, memOtrArchivedRef = mupOtrArchiveRef update, - memHidden = fromMaybe False (mupHidden update), + memHidden = Just True == mupHidden update, memHiddenRef = mupHiddenRef update, memConvRoleName = fromMaybe roleNameWireAdmin (mupConvRoleName update) } diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 638d98655a..14a5e0fbd1 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -169,7 +169,7 @@ addLocalUser = do Cql.runClient cassState . Cql.query Cql.selectUserRemoteConvs $ Cql.params Cql.Quorum (Identity alice) - liftIO $ [(dom, conv)] @?= convs + liftIO $ convs @?= [(dom, conv)] notifyLocalUser :: TestM () notifyLocalUser = do diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 0010e85d76..a5faeabfe3 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -377,12 +377,20 @@ testSimpleFlag defaultValue = do setFlagInternal defaultValue getFlag defaultValue --- | Call 'GET /teams/:tid/features' and check if all features are there +-- | Call 'GET /teams/:tid/features' and 'GET /feature-configs', and check if all +-- features are there. testAllFeatures :: TestM () testAllFeatures = do (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 - let res = Util.getAllTeamFeatures member tid - res !!! do + Util.getAllTeamFeatures member tid !!! do + statusCode === const 200 + responseJsonMaybe === const (Just expected) + Util.getAllTeamFeaturesPersonal member !!! do + statusCode === const 200 + responseJsonMaybe === const (Just expected) + + randomPersonalUser <- Util.randomUser + Util.getAllTeamFeaturesPersonal randomPersonalUser !!! do statusCode === const 200 responseJsonMaybe === const (Just expected) where diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 5287d88392..f58a5740d3 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -806,7 +806,7 @@ testOldClientsBlockDeviceHandshake = do -- If user has a client without the ClientSupportsLegalholdImplicitConsent -- capability then message sending is prevented to legalhold devices. peerClient <- randomClient peer (someLastPrekeys !! 2) - runit peer peerClient >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") + runit peer peerClient >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") upgradeClientToLH peer peerClient runit peer peerClient >>= errWith 412 (\(_ :: Msg.ClientMismatch) -> True) @@ -928,8 +928,8 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect const 201 === statusCode else do void doEnableLH - postConnection legalholder peer !!! do testResponse 412 (Just "missing-legalhold-consent") - postConnection peer legalholder !!! do testResponse 412 (Just "missing-legalhold-consent") + postConnection legalholder peer !!! do testResponse 403 (Just "missing-legalhold-consent") + postConnection peer legalholder !!! do testResponse 403 (Just "missing-legalhold-consent") data GroupConvAdmin = LegalholderIsAdmin @@ -1044,7 +1044,7 @@ testGroupConvInvitationHandlesLHConflicts inviteCase = do assertNotConvMember peer convId InviteAlsoNonConsenters -> do API.Util.postMembers userWithConsent (List1.list1 legalholder [peer2]) convId - >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") + >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") testNoConsentCannotBeInvited :: HasCallStack => TestM () testNoConsentCannotBeInvited = do @@ -1081,11 +1081,11 @@ testNoConsentCannotBeInvited = do liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus API.Util.postMembers userLHNotActivated (List1.list1 peer2 []) convId - >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") + >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") localdomain <- viewFederationDomain API.Util.postQualifiedMembers userLHNotActivated ((Qualified peer2 localdomain) :| []) convId - >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") + >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") testCannotCreateGroupWithUsersInConflict :: HasCallStack => TestM () testCannotCreateGroupWithUsersInConflict = do @@ -1120,7 +1120,7 @@ testCannotCreateGroupWithUsersInConflict = do liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus createTeamConvAccessRaw userLHNotActivated tid [peer2, legalholder] (Just "corp + us") Nothing Nothing Nothing (Just roleNameWireMember) - >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") + >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") data TestClaimKeys = TCKConsentMissing @@ -1169,7 +1169,7 @@ testClaimKeys testcase = do TCKConsentAndNewClients -> good where good = testResponse 200 Nothing - bad = testResponse 412 (Just "missing-legalhold-consent") + bad = testResponse 403 (Just "missing-legalhold-consent") let fetchKeys :: ClientId -> TestM () fetchKeys legalholderLHDevice = do diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index e9b75dfa80..b023b3abf5 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -752,7 +752,7 @@ testOldClientsBlockDeviceHandshake = do -- If user has a client without the ClientSupportsLegalholdImplicitConsent -- capability then message sending is prevented to legalhold devices. peerClient <- randomClient peer (someLastPrekeys !! 2) - runit peer peerClient >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") + runit peer peerClient >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") upgradeClientToLH peer peerClient runit peer peerClient >>= errWith 412 (\(_ :: Msg.ClientMismatch) -> True) @@ -803,7 +803,7 @@ testClaimKeys testcase = do TCKConsentAndNewClients -> good where good = testResponse 200 Nothing - bad = testResponse 412 (Just "missing-legalhold-consent") + bad = testResponse 403 (Just "missing-legalhold-consent") let fetchKeys :: ClientId -> TestM () fetchKeys legalholderLHDevice = do diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index f52b2b2fdb..fd7a8cebb8 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -834,6 +834,15 @@ getConvIds u r s = do . zType "access" . convRange r s +listConvIds :: UserId -> Public.GetPaginatedConversationIds -> TestM ResponseLBS +listConvIds u paginationOpts = do + g <- view tsGalley + post $ + g + . path "/conversations/list-ids" + . zUser u + . json paginationOpts + postQualifiedMembers :: UserId -> NonEmpty (Qualified UserId) -> ConvId -> TestM ResponseLBS postQualifiedMembers zusr invitees conv = do g <- view tsGalley @@ -1286,6 +1295,9 @@ decodeConvList = convList . responseJsonUnsafeWithMsg "conversations" decodeConvIdList :: Response (Maybe Lazy.ByteString) -> [ConvId] decodeConvIdList = convList . responseJsonUnsafeWithMsg "conversation-ids" +decodeQualifiedConvIdList :: Response (Maybe Lazy.ByteString) -> Either String [Qualified ConvId] +decodeQualifiedConvIdList = fmap pageConvIds . responseJsonEither + zUser :: UserId -> Request -> Request zUser = header "Z-User" . toByteString' diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 353f67b4d7..ccdb769477 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -106,6 +106,17 @@ getAllTeamFeatures uid tid = do . paths ["teams", toByteString' tid, "features"] . zUser uid +getAllTeamFeaturesPersonal :: + (HasCallStack, HasGalley m, MonadIO m, MonadHttp m) => + UserId -> + m ResponseLBS +getAllTeamFeaturesPersonal uid = do + g <- viewGalley + get $ + g + . paths ["feature-configs"] + . zUser uid + getTeamFeatureFlagWithGalley :: (MonadIO m, MonadHttp m, HasCallStack) => Public.TeamFeatureName -> (Request -> Request) -> UserId -> TeamId -> m ResponseLBS getTeamFeatureFlagWithGalley feature galley uid tid = do get $