diff --git a/libs/schema-profunctor/src/Data/Schema.hs b/libs/schema-profunctor/src/Data/Schema.hs index 10466cb5520..94d4f87744d 100644 --- a/libs/schema-profunctor/src/Data/Schema.hs +++ b/libs/schema-profunctor/src/Data/Schema.hs @@ -258,7 +258,6 @@ schemaOut (SchemaP _ _ (SchemaOut o)) = o -- | A schema for a one-field JSON object. field :: - forall doc' doc a b. HasField doc' doc => Text -> SchemaP doc' A.Value A.Value a b -> @@ -293,8 +292,8 @@ fieldWithDocModifier :: HasField doc' doc => Text -> (doc' -> doc') -> - ValueSchema doc' a -> - ObjectSchema doc a + SchemaP doc' A.Value A.Value a b -> + SchemaP doc A.Object [A.Pair] a b fieldWithDocModifier name modify sch = field name (over doc modify sch) -- | Change the input type of a schema. diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index c6bda616225..cb0214a7102 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -64,7 +64,6 @@ import Cassandra import Control.Lens (makeLenses, (.~), (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A import qualified Data.Attoparsec.ByteString.Char8 as Chars import Data.Bifunctor (Bifunctor (first)) import qualified Data.ByteString.Base64 as B64 @@ -81,6 +80,7 @@ import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Imports +import Servant (FromHttpApiData (..)) import Test.QuickCheck (Arbitrary (arbitrary), chooseInteger) import qualified Test.QuickCheck as QC import Text.Read (Read (..)) @@ -93,6 +93,12 @@ import qualified URI.ByteString.QQ as URI.QQ newtype IpAddr = IpAddr {ipAddr :: IP} deriving stock (Eq, Ord, Show, Generic) +instance S.ToParamSchema IpAddr where + toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString + +instance FromHttpApiData IpAddr where + parseQueryParam p = first Text.pack (runParser parser (encodeUtf8 p)) + instance FromByteString IpAddr where parser = do s <- Chars.takeWhile1 (not . isSpace) @@ -147,6 +153,14 @@ data Location = Location _longitude :: !Double } deriving stock (Eq, Ord, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema Location + +instance ToSchema Location where + schema = + object "Location" $ + Location + <$> _latitude .= field "lat" genericToSchema + <*> _longitude .= field "lon" genericToSchema instance Show Location where show p = @@ -177,28 +191,6 @@ modelLocation = Doc.defineModel "Location" $ do Doc.property "lon" Doc.double' $ Doc.description "Longitude" -instance ToJSON Location where - toJSON p = A.object ["lat" A..= (p ^. latitude), "lon" A..= (p ^. longitude)] - -instance FromJSON Location where - parseJSON = A.withObject "Location" $ \o -> - location - <$> (Latitude <$> o A..: "lat") - <*> (Longitude <$> o A..: "lon") - -instance S.ToSchema Location where - declareNamedSchema _ = do - doubleSchema <- S.declareSchemaRef (Proxy @Double) - return $ - S.NamedSchema (Just "Location") $ - mempty - & S.type_ ?~ S.SwaggerObject - & S.properties - .~ [ ("lat", doubleSchema), - ("lon", doubleSchema) - ] - & S.required .~ ["lat", "lon"] - instance Arbitrary Location where arbitrary = Location <$> arbitrary <*> arbitrary @@ -338,15 +330,15 @@ instance Arbitrary (Fingerprint Rsa) where newtype PlainTextPassword = PlainTextPassword {fromPlainTextPassword :: Text} deriving stock (Eq, Generic) - deriving newtype (ToJSON) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema PlainTextPassword instance Show PlainTextPassword where show _ = "PlainTextPassword " -instance FromJSON PlainTextPassword where - parseJSON x = - PlainTextPassword . fromRange - <$> (parseJSON x :: A.Parser (Range 6 1024 Text)) +instance ToSchema PlainTextPassword where + schema = + PlainTextPassword + <$> fromPlainTextPassword .= untypedRangedSchema 6 1024 schema instance Arbitrary PlainTextPassword where -- TODO: why 6..1024? For tests we might want invalid passwords as well, e.g. 3 chars diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index e4a394d48cf..89a1a3ca295 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -84,3 +84,8 @@ type UnknownClient = ErrorDescription 403 "Unknown Client" unknownClient :: UnknownClient unknownClient = ErrorDescription "unknown-client" "Sending client not known" + +type ClientNotFound = ErrorDescription 404 "Client not found" + +clientNotFound :: ClientNotFound +clientNotFound = ErrorDescription "client-not-found" "client not found" 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 6ff6fe4c7a0..5717583382d 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -23,16 +23,18 @@ import Data.CommaSeparatedList (CommaSeparatedList) import Data.Domain import Data.Handle import Data.Id as Id +import Data.Misc (IpAddr) import Data.Qualified (Qualified (..)) import Data.Range -import Data.Swagger hiding (Contact) +import Data.Swagger hiding (Contact, Header) import Imports hiding (head) import Servant (JSON) import Servant hiding (Handler, JSON, addHeader, respond) import Servant.API.Generic import Servant.Swagger (HasSwagger (toSwagger)) import Servant.Swagger.Internal.Orphans () -import Wire.API.Routes.Public (EmptyResult, ZUser) +import Wire.API.ErrorDescription (ClientNotFound) +import Wire.API.Routes.Public (EmptyResult, ZConn, ZUser) import Wire.API.User import Wire.API.User.Client import Wire.API.User.Client.Prekey @@ -48,6 +50,10 @@ type CaptureUserId name = Capture' '[Description "User Id"] name UserId type CaptureClientId name = Capture' '[Description "ClientId"] name ClientId +type NewClientResponse = Headers '[Header "Location" ClientId] Client + +type GetClientResponse = [WithStatus 200 Client, ClientNotFound] + data Api routes = Api { -- Note [document responses] -- @@ -268,6 +274,65 @@ data Api routes = Api :> "list-prekeys" :> ReqBody '[JSON] QualifiedUserClients :> Post '[JSON] QualifiedUserClientPrekeyMap, + -- User Client API ---------------------------------------------------- + + -- This endpoint can lead to the following events being sent: + -- - ClientAdded event to self + -- - ClientRemoved event to self, if removing old clients due to max number + -- Doc.errorResponse tooManyClients + -- Doc.errorResponse missingAuthError + -- Doc.errorResponse malformedPrekeys + addClient :: + routes :- Summary "Register a new client" + :> ZUser + :> ZConn + :> "clients" + :> Header "X-Forwarded-For" IpAddr + :> ReqBody '[JSON] NewClient + :> Verb 'POST 201 '[JSON] NewClientResponse, + -- Doc.errorResponse malformedPrekeys + updateClient :: + routes :- Summary "Update a registered client" + :> ZUser + :> "clients" + :> CaptureClientId "client" + :> ReqBody '[JSON] UpdateClient + :> Put '[] (EmptyResult 200), + -- This endpoint can lead to the following events being sent: + -- - ClientRemoved event to self + deleteClient :: + routes :- Summary "Delete an existing client" + :> ZUser + :> ZConn + :> "clients" + :> CaptureClientId "client" + :> ReqBody '[JSON] RmClient + :> Delete '[] (EmptyResult 200), + listClients :: + routes :- Summary "List the registered clients" + :> ZUser + :> "clients" + :> Get '[JSON] [Client], + getClient :: + routes :- Summary "Get a register client by ID" + :> ZUser + :> "clients" + :> CaptureClientId "client" + :> UVerb 'GET '[JSON] GetClientResponse, + getClientCapabilities :: + routes :- Summary "Read back what the client has been posting about itself" + :> ZUser + :> "clients" + :> CaptureClientId "client" + :> "capabilities" + :> Get '[JSON] ClientCapabilityList, + getClientPrekeys :: + routes :- Summary "List the remaining prekey IDs of a client" + :> ZUser + :> "clients" + :> CaptureClientId "client" + :> "prekeys" + :> Get '[JSON] [PrekeyId], searchContacts :: routes :- Summary "Search for users" :> ZUser diff --git a/libs/wire-api/src/Wire/API/User/Auth.hs b/libs/wire-api/src/Wire/API/User/Auth.hs index 7935f88ee9e..42eaf096224 100644 --- a/libs/wire-api/src/Wire/API/User/Auth.hs +++ b/libs/wire-api/src/Wire/API/User/Auth.hs @@ -59,7 +59,8 @@ import qualified Data.Code as Code import Data.Handle (Handle) import Data.Id (UserId) import Data.Misc (PlainTextPassword (..)) -import Data.Swagger (ToSchema) +import Data.Schema (ToSchema) +import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import Data.Time.Clock (UTCTime) @@ -320,7 +321,16 @@ instance FromJSON (Cookie ()) where newtype CookieLabel = CookieLabel {cookieLabelText :: Text} deriving stock (Eq, Ord, Show, Generic) - deriving newtype (FromJSON, ToJSON, FromByteString, ToByteString, IsString, Arbitrary, ToSchema) + deriving newtype + ( FromJSON, + ToJSON, + FromByteString, + ToByteString, + IsString, + Arbitrary, + S.ToSchema, + ToSchema + ) newtype CookieId = CookieId {cookieIdNum :: Word32} diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index c887ed8dd47..7b92acfbc7e 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -92,15 +92,10 @@ import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text.Encoding as Text.E import Data.UUID (toASCIIBytes) import Deriving.Swagger - ( CamelToSnake, - ConstructorTagModifier, - CustomSwagger, + ( CustomSwagger, FieldLabelModifier, - LabelMapping ((:->)), - LabelMappings, LowerCase, StripPrefix, - StripSuffix, ) import Imports import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..), generateExample, mapOf', setOf') @@ -174,23 +169,30 @@ instance Cql.Cql ClientCapability where fromCql _ = Left "ClientCapability value: int expected" -- FUTUREWORK: add golden tests for this? -data ClientCapabilityList = ClientCapabilityList {fromClientCapabilityList :: Set ClientCapability} +newtype ClientCapabilityList = ClientCapabilityList {fromClientCapabilityList :: Set ClientCapability} deriving stock (Eq, Ord, Show, Generic) + deriving newtype (Semigroup, Monoid) deriving (Arbitrary) via (GenericUniform ClientCapabilityList) deriving (ToJSON, FromJSON, Swagger.ToSchema) via (Schema ClientCapabilityList) instance ToSchema ClientCapabilityList where schema = - objectWithDocModifier "ClientCapabilityList" mods $ - ClientCapabilityList - <$> (Set.toList . fromClientCapabilityList) - .= field "capabilities" (Set.fromList <$> array schema) - where - mods = description ?~ ("Hints provided by the client for the backend so it can behavior in a backwards-compatible way." :: Text) + object "ClientCapabilityList" $ + ClientCapabilityList <$> fromClientCapabilityList .= capabilitiesFieldSchema + +capabilitiesFieldSchema :: ObjectSchema SwaggerDoc (Set ClientCapability) +capabilitiesFieldSchema = + Set.toList + .= fieldWithDocModifier "capabilities" mods (Set.fromList <$> array schema) + where + mods = + description + ?~ "Hints provided by the client for the backend so it can \ + \behave in a backwards-compatible way." modelClientCapabilityList :: Doc.Model modelClientCapabilityList = Doc.defineModel "ClientCapabilityList" $ do - Doc.description "Hints provided by the client for the backend so it can behavior in a backwards-compatible way." + Doc.description "Hints provided by the client for the backend so it can behave in a backwards-compatible way." Doc.property "capabilities" (Doc.array typeClientCapability) $ do Doc.description "Array containing all capabilities supported by a client." @@ -407,7 +409,21 @@ data Client = Client } deriving stock (Eq, Show, Generic, Ord) deriving (Arbitrary) via (GenericUniform Client) - deriving (Swagger.ToSchema) via (CustomSwagger '[FieldLabelModifier (StripPrefix "client", LowerCase)] Client) + deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema Client + +instance ToSchema Client where + schema = + object "Client" $ + Client + <$> clientId .= field "id" schema + <*> clientType .= field "type" schema + <*> clientTime .= field "time" schema + <*> clientClass .= opt (field "class" schema) + <*> clientLabel .= opt (field "label" schema) + <*> clientCookie .= opt (field "cookie" schema) + <*> clientLocation .= opt (field "location" schema) + <*> clientModel .= opt (field "model" schema) + <*> clientCapabilities .= (field "capabilities" schema <|> pure mempty) modelClient :: Doc.Model modelClient = Doc.defineModel "Client" $ do @@ -435,33 +451,6 @@ modelClient = Doc.defineModel "Client" $ do Doc.description "Optional model information of this client" Doc.optional -instance ToJSON Client where - toJSON c = - A.object $ - "id" A..= clientId c - # "type" A..= clientType c - # "label" A..= clientLabel c - # "class" A..= clientClass c - # "time" A..= clientTime c - # "cookie" A..= clientCookie c - # "location" A..= clientLocation c - # "model" A..= clientModel c - # "capabilities" A..= clientCapabilities c - # [] - -instance FromJSON Client where - parseJSON = A.withObject "Client" $ \o -> - Client - <$> o A..: "id" - <*> o A..: "type" - <*> o A..: "time" - <*> o A..:? "class" - <*> o A..:? "label" - <*> o A..:? "cookie" - <*> o A..:? "location" - <*> o A..:? "model" - <*> (o A..:? "capabilities" A..!= ClientCapabilityList mempty) - -------------------------------------------------------------------------------- -- PubClient @@ -506,25 +495,20 @@ instance FromJSON PubClient where -- interaction, and on an ongoing basis see a visual indication in all -- conversations where such a device is active. --- | Strategy to translate enums in this module to schema. -type EnumToSchemaStrategy suffix ty = - ( CustomSwagger - '[ ConstructorTagModifier - ( StripSuffix suffix, - CamelToSnake, - LabelMappings '["legal_hold" ':-> "legalhold"] - ) - ] - ty - ) - data ClientType = TemporaryClientType | PermanentClientType | LegalHoldClientType -- see Note [LegalHold] deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform ClientType) - deriving (Swagger.ToSchema) via EnumToSchemaStrategy "ClientType" ClientType + deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema ClientType + +instance ToSchema ClientType where + schema = + enum @Text "ClientType" $ + element "temporary" TemporaryClientType + <> element "permanent" PermanentClientType + <> element "legalhold" LegalHoldClientType typeClientType :: Doc.DataType typeClientType = @@ -535,18 +519,6 @@ typeClientType = "legalhold" ] -instance ToJSON ClientType where - toJSON TemporaryClientType = A.String "temporary" - toJSON PermanentClientType = A.String "permanent" - toJSON LegalHoldClientType = A.String "legalhold" - -instance FromJSON ClientType where - parseJSON = A.withText "ClientType" $ \txt -> case txt of - "temporary" -> return TemporaryClientType - "permanent" -> return PermanentClientType - "legalhold" -> return LegalHoldClientType - _ -> fail "Must be one of {'temporary', 'permanent', 'legalhold'}." - data ClientClass = PhoneClient | TabletClient @@ -554,7 +526,15 @@ data ClientClass | LegalHoldClient -- see Note [LegalHold] deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform ClientClass) - deriving (Swagger.ToSchema) via EnumToSchemaStrategy "Client" ClientClass + deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema ClientClass + +instance ToSchema ClientClass where + schema = + enum @Text "ClientClass" $ + element "phone" PhoneClient + <> element "tablet" TabletClient + <> element "desktop" DesktopClient + <> element "legalhold" LegalHoldClient typeClientClass :: Doc.DataType typeClientClass = @@ -566,20 +546,6 @@ typeClientClass = "legalhold" ] -instance ToJSON ClientClass where - toJSON PhoneClient = A.String "phone" - toJSON TabletClient = A.String "tablet" - toJSON DesktopClient = A.String "desktop" - toJSON LegalHoldClient = A.String "legalhold" - -instance FromJSON ClientClass where - parseJSON = A.withText "ClientClass" $ \txt -> case txt of - "phone" -> return PhoneClient - "tablet" -> return TabletClient - "desktop" -> return DesktopClient - "legalhold" -> return LegalHoldClient - _ -> fail "Must be one of {'phone', 'tablet', 'desktop', 'legalhold'}." - -------------------------------------------------------------------------------- -- NewClient @@ -596,6 +562,7 @@ data NewClient = NewClient } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform NewClient) + deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema NewClient modelNewClient :: Doc.Model modelNewClient = Doc.defineModel "NewClient" $ do @@ -636,6 +603,64 @@ modelNewClient = Doc.defineModel "NewClient" $ do Doc.description "Hints for the backend so it can behave in a backwards-compatible way." Doc.optional +instance ToSchema NewClient where + schema = + object "NewClient" $ + NewClient + <$> newClientPrekeys + .= fieldWithDocModifier + "prekeys" + (description ?~ "Prekeys for other clients to establish OTR sessions.") + (array schema) + <*> newClientLastKey + .= fieldWithDocModifier + "lastkey" + ( description + ?~ "The last resort prekey for other clients to establish OTR sessions. \ + \This key must have the ID 0xFFFF and is never deleted." + ) + schema + <*> newClientType + .= fieldWithDocModifier + "type" + ( description + ?~ "The type of client to register. A user may have no more than \ + \7 (seven) permanent clients and 1 (one) temporary client. When the \ + \limit of permanent clients is reached, an error is returned. \ + \When a temporary client already exists, it is replaced." + ) + schema + <*> newClientLabel .= opt (field "label" schema) + <*> newClientClass + .= opt + ( fieldWithDocModifier + "class" + ( description + ?~ "The device class this client belongs to. \ + \Either 'phone', 'tablet', or 'desktop'." + ) + schema + ) + <*> newClientCookie + .= opt + ( fieldWithDocModifier + "cookie" + (description ?~ "The cookie label, i.e. the label used when logging in.") + schema + ) + <*> newClientPassword + .= opt + ( fieldWithDocModifier + "password" + ( description + ?~ "The password of the authenticated user for verification. \ + \Note: Required for registration of the 2nd, 3rd, ... client." + ) + schema + ) + <*> newClientModel .= opt (field "model" schema) + <*> newClientCapabilities .= opt capabilitiesFieldSchema + newClient :: ClientType -> LastPrekey -> NewClient newClient t k = NewClient @@ -650,33 +675,6 @@ newClient t k = newClientCapabilities = Nothing } -instance ToJSON NewClient where - toJSON c = - A.object $ - "type" A..= newClientType c - # "prekeys" A..= newClientPrekeys c - # "lastkey" A..= newClientLastKey c - # "label" A..= newClientLabel c - # "class" A..= newClientClass c - # "cookie" A..= newClientCookie c - # "password" A..= newClientPassword c - # "model" A..= newClientModel c - # "capabilities" A..= newClientCapabilities c - # [] - -instance FromJSON NewClient where - parseJSON = A.withObject "NewClient" $ \o -> - NewClient - <$> o A..: "prekeys" - <*> o A..: "lastkey" - <*> o A..: "type" - <*> o A..:? "label" - <*> o A..:? "class" - <*> o A..:? "cookie" - <*> o A..:? "password" - <*> o A..:? "model" - <*> o A..:? "capabilities" - -------------------------------------------------------------------------------- -- UpdateClient @@ -689,6 +687,36 @@ data UpdateClient = UpdateClient } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UpdateClient) + deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema UpdateClient + +instance ToSchema UpdateClient where + schema = + object "UpdateClient" $ + UpdateClient + <$> (Just . updateClientPrekeys) + .= ( fromMaybe [] + <$> opt + ( fieldWithDocModifier + "prekeys" + (description ?~ "New prekeys for other clients to establish OTR sessions.") + (array schema) + ) + ) + <*> updateClientLastKey + .= opt + ( fieldWithDocModifier + "lastkey" + (description ?~ "New last-resort prekey.") + schema + ) + <*> updateClientLabel + .= opt + ( fieldWithDocModifier + "label" + (description ?~ "A new name for this client.") + schema + ) + <*> updateClientCapabilities .= opt capabilitiesFieldSchema modelUpdateClient :: Doc.Model modelUpdateClient = Doc.defineModel "UpdateClient" $ do @@ -712,23 +740,6 @@ modelUpdateClient = Doc.defineModel "UpdateClient" $ do Doc.description "Hints for the backend so it can behave in a backwards-compatible way." Doc.optional -instance ToJSON UpdateClient where - toJSON c = - A.object $ - "prekeys" A..= updateClientPrekeys c - # "lastkey" A..= updateClientLastKey c - # "label" A..= updateClientLabel c - # "capabilities" A..= updateClientCapabilities c - # [] - -instance FromJSON UpdateClient where - parseJSON = A.withObject "RefreshClient" $ \o -> - UpdateClient - <$> o A..:? "prekeys" A..!= [] - <*> o A..:? "lastkey" - <*> o A..:? "label" - <*> o A..:? "capabilities" - -------------------------------------------------------------------------------- -- RmClient @@ -737,6 +748,20 @@ newtype RmClient = RmClient } deriving stock (Eq, Show, Generic) deriving newtype (Arbitrary) + deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema RmClient + +instance ToSchema RmClient where + schema = + object "DeleteClient" $ + RmClient + <$> rmPassword + .= fieldWithDocModifier + "password" + ( description + ?~ "The password of the authenticated user for verification. \ + \The password is not required for deleting temporary clients." + ) + (optWithDefault A.Null schema) modelDeleteClient :: Doc.Model modelDeleteClient = Doc.defineModel "DeleteClient" $ do @@ -747,13 +772,6 @@ modelDeleteClient = Doc.defineModel "DeleteClient" $ do \The password is not required for deleting temporary clients." Doc.optional -instance ToJSON RmClient where - toJSON (RmClient pw) = A.object ["password" A..= pw] - -instance FromJSON RmClient where - parseJSON = A.withObject "RmClient" $ \o -> - RmClient <$> o A..:? "password" - -------------------------------------------------------------------------------- -- other models diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index e54724c578b..60f1202a748 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -91,6 +91,7 @@ import Servant.Swagger.UI import qualified System.Logger.Class as Log import Util.Logging (logFunction, logHandle, logTeam, logUser) import qualified Wire.API.Connection as Public +import qualified Wire.API.ErrorDescription as ErrorDescription import qualified Wire.API.Properties as Public import Wire.API.Routes.Public (EmptyResult (..)) import qualified Wire.API.Routes.Public.Brig as BrigAPI @@ -184,6 +185,13 @@ servantSitemap = BrigAPI.getUsersPrekeyBundleQualified = getPrekeyBundleH, BrigAPI.getMultiUserPrekeyBundleUnqualified = getMultiUserPrekeyBundleUnqualifiedH, BrigAPI.getMultiUserPrekeyBundleQualified = getMultiUserPrekeyBundleH, + BrigAPI.addClient = addClient, + BrigAPI.updateClient = updateClient, + BrigAPI.deleteClient = deleteClient, + BrigAPI.listClients = listClients, + BrigAPI.getClient = getClient, + BrigAPI.getClientCapabilities = getClientCapabilities, + BrigAPI.getClientPrekeys = getClientPrekeys, BrigAPI.searchContacts = Search.search } @@ -477,99 +485,6 @@ sitemap o = do Doc.returns (Doc.ref Public.modelConnection) Doc.response 200 "Connection" Doc.end - -- User Client API ---------------------------------------------------- - -- TODO: another one? - - -- This endpoint can lead to the following events being sent: - -- - ClientAdded event to self - -- - ClientRemoved event to self, if removing old clients due to max number - post "/clients" (continue addClientH) $ - jsonRequest @Public.NewClient - .&. zauthUserId - .&. zauthConnId - .&. opt (header "X-Forwarded-For") - .&. accept "application" "json" - document "POST" "registerClient" $ do - Doc.summary "Register a new client." - Doc.body (Doc.ref Public.modelNewClient) $ - Doc.description "JSON body" - Doc.returns (Doc.ref Public.modelClient) - Doc.response 200 "Client" Doc.end - Doc.errorResponse tooManyClients - Doc.errorResponse missingAuthError - Doc.errorResponse malformedPrekeys - - put "/clients/:client" (continue updateClientH) $ - jsonRequest @Public.UpdateClient - .&. zauthUserId - .&. capture "client" - .&. accept "application" "json" - document "PUT" "updateClient" $ do - Doc.summary "Update a registered client." - Doc.parameter Doc.Path "client" Doc.bytes' $ - Doc.description "Client ID" - Doc.body (Doc.ref Public.modelUpdateClient) $ - Doc.description "JSON body" - Doc.response 200 "Client updated." Doc.end - Doc.errorResponse malformedPrekeys - - -- This endpoint can lead to the following events being sent: - -- - ClientRemoved event to self - delete "/clients/:client" (continue rmClientH) $ - jsonRequest @Public.RmClient - .&. zauthUserId - .&. zauthConnId - .&. capture "client" - .&. accept "application" "json" - document "DELETE" "deleteClient" $ do - Doc.summary "Delete an existing client." - Doc.parameter Doc.Path "client" Doc.bytes' $ - Doc.description "Client ID" - Doc.body (Doc.ref Public.modelDeleteClient) $ - Doc.description "JSON body" - Doc.response 200 "Client deleted." Doc.end - - get "/clients" (continue listClientsH) $ - zauthUserId - .&. accept "application" "json" - document "GET" "listClients" $ do - Doc.summary "List the registered clients." - Doc.returns (Doc.array (Doc.ref Public.modelClient)) - Doc.response 200 "List of clients" Doc.end - - get "/clients/:client" (continue getClientH) $ - zauthUserId - .&. capture "client" - .&. accept "application" "json" - document "GET" "getClients" $ do - Doc.summary "Get a registered client by ID." - Doc.parameter Doc.Path "client" Doc.bytes' $ - Doc.description "Client ID" - Doc.returns (Doc.ref Public.modelClient) - Doc.response 200 "Client" Doc.end - - get "/clients/:client/capabilities" (continue getClientCapabilitiesH) $ - zauthUserId - .&. capture "client" - .&. accept "application" "json" - document "GET" "getClientCapabilities" $ do - Doc.summary "Read back what the client has been posting about itself." - Doc.parameter Doc.Path "client" Doc.bytes' $ - Doc.description "Client ID" - Doc.returns (Doc.ref Public.modelClientCapabilityList) - Doc.response 200 "Client" Doc.end - - get "/clients/:client/prekeys" (continue listPrekeyIdsH) $ - zauthUserId - .&. capture "client" - .&. accept "application" "json" - document "GET" "listPrekeyIds" $ do - Doc.summary "List the remaining prekey IDs of a client." - Doc.parameter Doc.Path "client" Doc.bytes' $ - Doc.description "Client ID" - Doc.returns (Doc.array Doc.string') - Doc.response 200 "List of remaining prekey IDs." Doc.end - -- Properties API ----------------------------------------------------- -- This endpoint can lead to the following events being sent: @@ -868,51 +783,36 @@ getMultiUserPrekeyBundleH zusr qualUserClients = do throwStd tooManyClients API.claimMultiPrekeyBundles (ProtectedUser zusr) qualUserClients !>> clientError -addClientH :: JsonRequest Public.NewClient ::: UserId ::: ConnId ::: Maybe IpAddr ::: JSON -> Handler Response -addClientH (req ::: usr ::: con ::: ip ::: _) = do - new <- parseJsonBody req - clt <- addClient new usr con ip - let loc = toByteString' $ Public.clientId clt - pure . setStatus status201 . addHeader "Location" loc . json $ clt - -addClient :: Public.NewClient -> UserId -> ConnId -> Maybe IpAddr -> Handler Public.Client -addClient new usr con ip = do +addClient :: UserId -> ConnId -> Maybe IpAddr -> Public.NewClient -> Handler BrigAPI.NewClientResponse +addClient usr con ip new = do -- Users can't add legal hold clients when (Public.newClientType new == Public.LegalHoldClientType) $ throwE (clientError ClientLegalHoldCannotBeAdded) - API.addClient usr (Just con) (ipAddr <$> ip) new !>> clientError - -rmClientH :: JsonRequest Public.RmClient ::: UserId ::: ConnId ::: ClientId ::: JSON -> Handler Response -rmClientH (req ::: usr ::: con ::: clt ::: _) = do - body <- parseJsonBody req - empty <$ rmClient body usr con clt + clientResponse <$> API.addClient usr (Just con) (ipAddr <$> ip) new !>> clientError + where + clientResponse :: Public.Client -> BrigAPI.NewClientResponse + clientResponse client = Servant.addHeader (Public.clientId client) client -rmClient :: Public.RmClient -> UserId -> ConnId -> ClientId -> Handler () -rmClient body usr con clt = +deleteClient :: UserId -> ConnId -> ClientId -> Public.RmClient -> Handler (EmptyResult 200) +deleteClient usr con clt body = do API.rmClient usr con clt (Public.rmPassword body) !>> clientError + pure EmptyResult -updateClientH :: JsonRequest Public.UpdateClient ::: UserId ::: ClientId ::: JSON -> Handler Response -updateClientH (req ::: usr ::: clt ::: _) = do - body <- parseJsonBody req - empty <$ updateClient body usr clt - -updateClient :: Public.UpdateClient -> UserId -> ClientId -> Handler () -updateClient body usr clt = - API.updateClient usr clt body !>> clientError - -listClientsH :: UserId ::: JSON -> Handler Response -listClientsH (zusr ::: _) = - json <$> listClients zusr +updateClient :: UserId -> ClientId -> Public.UpdateClient -> Handler (EmptyResult 200) +updateClient usr clt upd = do + API.updateClient usr clt upd !>> clientError + pure EmptyResult listClients :: UserId -> Handler [Public.Client] listClients zusr = lift $ API.lookupLocalClients zusr -getClientH :: UserId ::: ClientId ::: JSON -> Handler Response -getClientH (zusr ::: clt ::: _) = - getClient zusr clt <&> \case - Just c -> json c - Nothing -> setStatus status404 empty +getClient :: UserId -> ClientId -> Handler (Union BrigAPI.GetClientResponse) +getClient zusr clientId = do + mc <- lift $ API.lookupLocalClient zusr clientId + case mc of + Nothing -> Servant.respond ErrorDescription.clientNotFound + Just c -> Servant.respond (WithStatus @200 c) getUserClientsUnqualified :: UserId -> Handler [Public.PubClient] getUserClientsUnqualified uid = do @@ -941,13 +841,6 @@ getUserClientQualified domain uid cid = do x <- API.lookupPubClient (Qualified uid domain) cid !>> clientError ifNothing (notFound "client not found") x -getClient :: UserId -> ClientId -> Handler (Maybe Public.Client) -getClient zusr clientId = do - lift $ API.lookupLocalClient zusr clientId - -getClientCapabilitiesH :: UserId ::: ClientId ::: JSON -> Handler Response -getClientCapabilitiesH (uid ::: cid ::: _) = json <$> getClientCapabilities uid cid - getClientCapabilities :: UserId -> ClientId -> Handler Public.ClientCapabilityList getClientCapabilities uid cid = do mclient <- lift (API.lookupLocalClient uid cid) @@ -969,10 +862,8 @@ getRichInfo self user = do -- Query rich info fromMaybe Public.emptyRichInfoAssocList <$> lift (API.lookupRichInfo user) -listPrekeyIdsH :: UserId ::: ClientId ::: JSON -> Handler Response -listPrekeyIdsH (usr ::: clt ::: _) = do - prekeyIds <- lift (API.lookupPrekeyIds usr clt) - pure $ json (prekeyIds :: [Public.PrekeyId]) +getClientPrekeys :: UserId -> ClientId -> Handler [Public.PrekeyId] +getClientPrekeys usr clt = lift (API.lookupPrekeyIds usr clt) -- docs/reference/user/registration.md {#RefRegistration} createUserH :: JSON ::: JsonRequest Public.NewUserPublic -> Handler Response