[SQSERVICES-1646] Servantify Gundeck (#2769)

Author: battermann

changelog.d/5-internal/pr-2769

@@ -0,0 +1 @@
+Gundeck push token API and notification API is migrated to Servant

libs/wire-api/src/Wire/API/Error/Gundeck.hs

@@ -0,0 +1,46 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
+--
+-- 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 <https://www.gnu.org/licenses/>.
+
+module Wire.API.Error.Gundeck where
+
+import Wire.API.Error
+
+data GundeckError
+  = AddTokenErrorNoBudget
+  | AddTokenErrorNotFound
+  | AddTokenErrorInvalid
+  | AddTokenErrorTooLong
+  | AddTokenErrorMetadataTooLong
+  | TokenNotFound
+  | NotificationNotFound
+
+instance KnownError (MapError e) => IsSwaggerError (e :: GundeckError) where
+  addToSwagger = addStaticErrorToSwagger @(MapError e)
+
+type instance MapError 'AddTokenErrorNoBudget = 'StaticError 413 "sns-thread-budget-reached" "Too many concurrent calls to SNS; is SNS down?"
+
+type instance MapError 'AddTokenErrorNotFound = 'StaticError 404 "app-not-found" "App does not exist"
+
+type instance MapError 'AddTokenErrorInvalid = 'StaticError 404 "invalid-token" "Invalid push token"
+
+type instance MapError 'AddTokenErrorTooLong = 'StaticError 413 "token-too-long" "Push token length must be < 8192 for GCM or 400 for APNS"
+
+type instance MapError 'AddTokenErrorMetadataTooLong = 'StaticError 413 "metadata-too-long" "Tried to add token to endpoint resulting in metadata length > 2048"
+
+type instance MapError 'TokenNotFound = 'StaticError 404 "not-found" "Push token not found"
+
+type instance MapError 'NotificationNotFound = 'StaticError 404 "not-found" "Some notifications not found"

libs/wire-api/src/Wire/API/Notification.hs

@@ -20,6 +20,7 @@
 
 module Wire.API.Notification
   ( NotificationId,
+    RawNotificationId (..),
     Event,
 
     -- * QueuedNotification
@@ -32,6 +33,7 @@ module Wire.API.Notification
     queuedNotifications,
     queuedHasMore,
     queuedTime,
+    GetNotificationsResponse (..),
 
     -- * Swagger
     modelEvent,
@@ -46,11 +48,16 @@ import qualified Data.Aeson.Types as Aeson
 import Data.Id
 import Data.Json.Util
 import Data.List.NonEmpty (NonEmpty)
+import Data.SOP
 import Data.Schema
+import Data.String.Conversions (cs)
+import Data.Swagger (ToParamSchema (..))
 import qualified Data.Swagger as S
 import qualified Data.Swagger.Build.Api as Doc
 import Data.Time.Clock (UTCTime)
 import Imports
+import Servant
+import Wire.API.Routes.MultiVerb
 import Wire.Arbitrary (Arbitrary, GenericUniform (..))
 
 type NotificationId = Id QueuedNotification
@@ -84,8 +91,10 @@ instance ToSchema QueuedNotification where
   schema =
     object "QueuedNotification" $
       QueuedNotification
-        <$> _queuedNotificationId .= field "id" schema
-        <*> _queuedNotificationPayload .= field "payload" (nonEmptyArray jsonObject)
+        <$> _queuedNotificationId
+        .= field "id" schema
+        <*> _queuedNotificationPayload
+        .= field "payload" (nonEmptyArray jsonObject)
 
 makeLenses ''QueuedNotification
 
@@ -121,8 +130,31 @@ instance ToSchema QueuedNotificationList where
   schema =
     object "QueuedNotificationList" $
       QueuedNotificationList
-        <$> _queuedNotifications .= field "notifications" (array schema)
-        <*> _queuedHasMore .= fmap (fromMaybe False) (optField "has_more" schema)
-        <*> _queuedTime .= maybe_ (optField "time" utcTimeSchema)
+        <$> _queuedNotifications
+        .= field "notifications" (array schema)
+        <*> _queuedHasMore
+        .= fmap (fromMaybe False) (optField "has_more" schema)
+        <*> _queuedTime
+        .= maybe_ (optField "time" utcTimeSchema)
 
 makeLenses ''QueuedNotificationList
+
+newtype RawNotificationId = RawNotificationId {unRawNotificationId :: ByteString}
+  deriving stock (Eq, Show, Generic)
+
+instance FromHttpApiData RawNotificationId where
+  parseUrlPiece = pure . RawNotificationId . cs
+
+instance ToParamSchema RawNotificationId where
+  toParamSchema _ = toParamSchema (Proxy @Text)
+
+data GetNotificationsResponse
+  = GetNotificationsWithStatusNotFound QueuedNotificationList
+  | GetNotificationsSuccess QueuedNotificationList
+
+instance AsUnion '[Respond 404 "Notification list" QueuedNotificationList, Respond 200 "Notification list" QueuedNotificationList] GetNotificationsResponse where
+  toUnion (GetNotificationsSuccess xs) = S (Z (I xs))
+  toUnion (GetNotificationsWithStatusNotFound xs) = Z (I xs)
+  fromUnion (S (Z (I xs))) = GetNotificationsSuccess xs
+  fromUnion (Z (I xs)) = GetNotificationsWithStatusNotFound xs
+  fromUnion (S (S x)) = case x of {}

libs/wire-api/src/Wire/API/Push/V2/Token.hs

@@ -34,21 +34,29 @@ module Wire.API.Push.V2.Token
     Token (..),
     AppName (..),
 
-    -- * Swagger
-    modelPushToken,
-    modelPushTokenList,
-    typeTransport,
+    -- * API types
+    AddTokenError (..),
+    AddTokenSuccess (..),
+    AddTokenResponses,
+    DeleteTokenResponses,
   )
 where
 
-import Control.Lens (makeLenses)
-import Data.Aeson
+import Control.Lens (makeLenses, (?~), (^.))
+import qualified Data.Aeson as A
 import Data.Attoparsec.ByteString (takeByteString)
 import Data.ByteString.Conversion
 import Data.Id
-import Data.Json.Util
-import qualified Data.Swagger.Build.Api as Doc
+import Data.SOP
+import Data.Schema
+import Data.Swagger (ToParamSchema)
+import qualified Data.Swagger as S
+import qualified Generics.SOP as GSOP
 import Imports
+import Servant
+import Wire.API.Error
+import qualified Wire.API.Error.Gundeck as E
+import Wire.API.Routes.MultiVerb
 import Wire.Arbitrary (Arbitrary, GenericUniform (..))
 
 --------------------------------------------------------------------------------
@@ -59,19 +67,14 @@ newtype PushTokenList = PushTokenList
   }
   deriving stock (Eq, Show)
   deriving newtype (Arbitrary)
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema PushTokenList)
 
-modelPushTokenList :: Doc.Model
-modelPushTokenList = Doc.defineModel "PushTokenList" $ do
-  Doc.description "List of Native Push Tokens"
-  Doc.property "tokens" (Doc.array (Doc.ref modelPushToken)) $
-    Doc.description "Push tokens"
-
-instance ToJSON PushTokenList where
-  toJSON (PushTokenList t) = object ["tokens" .= t]
-
-instance FromJSON PushTokenList where
-  parseJSON = withObject "PushTokenList" $ \p ->
-    PushTokenList <$> p .: "tokens"
+instance ToSchema PushTokenList where
+  schema =
+    objectWithDocModifier "PushTokenList" (description ?~ "List of Native Push Tokens") $
+      PushTokenList
+        <$> pushTokens
+        .= fieldWithDocModifier "tokens" (description ?~ "Push tokens") (array schema)
 
 data PushToken = PushToken
   { _tokenTransport :: Transport,
@@ -81,39 +84,29 @@ data PushToken = PushToken
   }
   deriving stock (Eq, Ord, Show, Generic)
   deriving (Arbitrary) via (GenericUniform PushToken)
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema PushToken)
 
 pushToken :: Transport -> AppName -> Token -> ClientId -> PushToken
 pushToken = PushToken
 
-modelPushToken :: Doc.Model
-modelPushToken = Doc.defineModel "PushToken" $ do
-  Doc.description "Native Push Token"
-  Doc.property "transport" typeTransport $
-    Doc.description "Transport"
-  Doc.property "app" Doc.string' $
-    Doc.description "Application"
-  Doc.property "token" Doc.bytes' $
-    Doc.description "Access Token"
-  Doc.property "client" Doc.bytes' $ do
-    Doc.description "Client ID"
-    Doc.optional
-
-instance ToJSON PushToken where
-  toJSON p =
-    object $
-      "transport" .= _tokenTransport p
-        # "app" .= _tokenApp p
-        # "token" .= _token p
-        # "client" .= _tokenClient p
-        # []
-
-instance FromJSON PushToken where
-  parseJSON = withObject "PushToken" $ \p ->
-    PushToken
-      <$> p .: "transport"
-      <*> p .: "app"
-      <*> p .: "token"
-      <*> p .: "client"
+instance ToSchema PushToken where
+  schema =
+    objectWithDocModifier "PushToken" desc $
+      PushToken
+        <$> _tokenTransport
+        .= fieldWithDocModifier "transport" transDesc schema
+        <*> _tokenApp
+        .= fieldWithDocModifier "app" appDesc schema
+        <*> _token
+        .= fieldWithDocModifier "token" tokenDesc schema
+        <*> _tokenClient
+        .= fieldWithDocModifier "client" clientIdDesc schema
+    where
+      desc = description ?~ "Native Push Token"
+      transDesc = description ?~ "Transport"
+      appDesc = description ?~ "Application"
+      tokenDesc = description ?~ "Access Token"
+      clientIdDesc = description ?~ "Client ID"
 
 --------------------------------------------------------------------------------
 -- Transport
@@ -126,33 +119,18 @@ data Transport
   | APNSVoIPSandbox
   deriving stock (Eq, Ord, Show, Bounded, Enum, Generic)
   deriving (Arbitrary) via (GenericUniform Transport)
-
-typeTransport :: Doc.DataType
-typeTransport =
-  Doc.string $
-    Doc.enum
-      [ "GCM",
-        "APNS",
-        "APNS_SANDBOX",
-        "APNS_VOIP",
-        "APNS_VOIP_SANDBOX"
-      ]
-
-instance ToJSON Transport where
-  toJSON GCM = "GCM"
-  toJSON APNS = "APNS"
-  toJSON APNSSandbox = "APNS_SANDBOX"
-  toJSON APNSVoIP = "APNS_VOIP"
-  toJSON APNSVoIPSandbox = "APNS_VOIP_SANDBOX"
-
-instance FromJSON Transport where
-  parseJSON = withText "transport" $ \case
-    "GCM" -> pure GCM
-    "APNS" -> pure APNS
-    "APNS_SANDBOX" -> pure APNSSandbox
-    "APNS_VOIP" -> pure APNSVoIP
-    "APNS_VOIP_SANDBOX" -> pure APNSVoIPSandbox
-    x -> fail $ "Invalid push transport: " ++ show x
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Transport)
+
+instance ToSchema Transport where
+  schema =
+    enum @Text "Access" $
+      mconcat
+        [ element "GCM" GCM,
+          element "APNS" APNS,
+          element "APNS_SANDBOX" APNSSandbox,
+          element "APNS_VOIP" APNSVoIP,
+          element "APNS_VOIP_SANDBOX" APNSVoIPSandbox
+        ]
 
 instance FromByteString Transport where
   parser =
@@ -168,12 +146,72 @@ newtype Token = Token
   { tokenText :: Text
   }
   deriving stock (Eq, Ord, Show)
-  deriving newtype (FromJSON, ToJSON, FromByteString, ToByteString, Arbitrary)
+  deriving newtype (FromHttpApiData, ToHttpApiData, FromByteString, ToByteString, Arbitrary)
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Token)
+
+instance ToParamSchema Token where
+  toParamSchema _ = S.toParamSchema (Proxy @Text)
+
+instance ToSchema Token where
+  schema = Token <$> tokenText .= schema
 
 newtype AppName = AppName
   { appNameText :: Text
   }
   deriving stock (Eq, Ord, Show)
-  deriving newtype (FromJSON, ToJSON, IsString, Arbitrary)
+  deriving newtype (IsString, Arbitrary)
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema AppName)
+
+instance ToSchema AppName where
+  schema = AppName <$> appNameText .= schema
 
 makeLenses ''PushToken
+
+--------------------------------------------------------------------------------
+-- Add token types
+
+type AddTokenErrorResponses =
+  '[ ErrorResponse 'E.AddTokenErrorNoBudget,
+     ErrorResponse 'E.AddTokenErrorNotFound,
+     ErrorResponse 'E.AddTokenErrorInvalid,
+     ErrorResponse 'E.AddTokenErrorTooLong,
+     ErrorResponse 'E.AddTokenErrorMetadataTooLong
+   ]
+
+type AddTokenSuccessResponses =
+  WithHeaders
+    '[ Header "Location" Token
+     ]
+    AddTokenSuccess
+    (Respond 201 "Push token registered" PushToken)
+
+type AddTokenResponses = AddTokenErrorResponses .++ '[AddTokenSuccessResponses]
+
+data AddTokenError
+  = AddTokenErrorNoBudget
+  | AddTokenErrorNotFound
+  | AddTokenErrorInvalid
+  | AddTokenErrorTooLong
+  | AddTokenErrorMetadataTooLong
+  deriving (Show, Generic)
+  deriving (AsUnion AddTokenErrorResponses) via GenericAsUnion AddTokenErrorResponses AddTokenError
+
+instance GSOP.Generic AddTokenError
+
+data AddTokenSuccess = AddTokenSuccess PushToken
+
+instance AsHeaders '[Token] PushToken AddTokenSuccess where
+  fromHeaders (I _ :* Nil, t) = AddTokenSuccess t
+  toHeaders (AddTokenSuccess t) = (I (t ^. token) :* Nil, t)
+
+instance (res ~ AddTokenResponses) => AsUnion res (Either AddTokenError AddTokenSuccess) where
+  toUnion = eitherToUnion (toUnion @AddTokenErrorResponses) (Z . I)
+  fromUnion = eitherFromUnion (fromUnion @AddTokenErrorResponses) (unI . unZ)
+
+--------------------------------------------------------------------------------
+-- Delete token types
+
+type DeleteTokenResponses =
+  '[ ErrorResponse 'E.TokenNotFound,
+     RespondEmpty 204 "Push token unregistered"
+   ]