Servantify own client API

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.

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 <hidden>"
 
-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

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"

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

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}