Servantify stern

changelog.d/5-internal/pr-2742

@@ -0,0 +1 @@
+Add swagger2-ui to stern (#2742 ...)

libs/brig-types/brig-types.cabal

@@ -84,6 +84,7 @@ library
     , deriving-swagger2      >=0.1.0
     , imports
     , QuickCheck             >=2.9
+    , schema-profunctor
     , servant-server         >=0.18.2
     , servant-swagger        >=1.1.10
     , string-conversions
@@ -165,6 +166,7 @@ test-suite brig-types-tests
     , QuickCheck             >=2.9
     , swagger2               >=2.5
     , tasty
+    , tasty-hunit
     , tasty-quickcheck
     , text                   >=0.11
     , time                   >=1.1

libs/brig-types/src/Brig/Types/Intra.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- This file is part of the Wire Server implementation.
 --
 -- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
@@ -30,14 +28,16 @@ module Brig.Types.Intra
   )
 where
 
-import Data.Aeson
-import qualified Data.Aeson.KeyMap as KeyMap
+import Data.Aeson as A
 import Data.Code as Code
 import Data.Id (TeamId)
 import Data.Misc (PlainTextPassword (..))
-import qualified Data.Text as Text
+import qualified Data.Schema as Schema
+import qualified Data.Swagger as S
 import Imports
+import Test.QuickCheck (Arbitrary)
 import Wire.API.User
+import Wire.Arbitrary (GenericUniform (..))
 
 -------------------------------------------------------------------------------
 -- AccountStatus
@@ -52,22 +52,19 @@ data AccountStatus
     -- creating via scim.
     PendingInvitation
   deriving (Eq, Show, Generic)
-
-instance FromJSON AccountStatus where
-  parseJSON = withText "account-status" $ \s -> case Text.toLower s of
-    "active" -> pure Active
-    "suspended" -> pure Suspended
-    "deleted" -> pure Deleted
-    "ephemeral" -> pure Ephemeral
-    "pending-invitation" -> pure PendingInvitation
-    _ -> fail $ "Invalid account status: " ++ Text.unpack s
-
-instance ToJSON AccountStatus where
-  toJSON Active = String "active"
-  toJSON Suspended = String "suspended"
-  toJSON Deleted = String "deleted"
-  toJSON Ephemeral = String "ephemeral"
-  toJSON PendingInvitation = String "pending-invitation"
+  deriving (Arbitrary) via (GenericUniform AccountStatus)
+  deriving (ToJSON, FromJSON, S.ToSchema) via Schema.Schema AccountStatus
+
+instance Schema.ToSchema AccountStatus where
+  schema =
+    Schema.enum @Text "AccountStatus" $
+      mconcat
+        [ Schema.element "active" Active,
+          Schema.element "suspended" Suspended,
+          Schema.element "deleted" Deleted,
+          Schema.element "ephemeral" Ephemeral,
+          Schema.element "pending-invitation" PendingInvitation
+        ]
 
 data AccountStatusResp = AccountStatusResp {fromAccountStatusResp :: AccountStatus}
 
@@ -100,21 +97,15 @@ data UserAccount = UserAccount
     accountStatus :: !AccountStatus
   }
   deriving (Eq, Show, Generic)
-
-instance FromJSON UserAccount where
-  parseJSON j@(Object o) = do
-    u <- parseJSON j
-    s <- o .: "status"
-    pure $ UserAccount u s
-  parseJSON _ = mzero
-
-instance ToJSON UserAccount where
-  toJSON (UserAccount u s) =
-    case toJSON u of
-      Object o ->
-        Object $ KeyMap.insert "status" (toJSON s) o
-      other ->
-        error $ "toJSON UserAccount: not an object: " <> show (encode other)
+  deriving (Arbitrary) via (GenericUniform UserAccount)
+  deriving (ToJSON, FromJSON, S.ToSchema) via Schema.Schema UserAccount
+
+instance Schema.ToSchema UserAccount where
+  schema =
+    Schema.object "UserAccount" $
+      UserAccount
+        <$> accountUser Schema..= userObjectSchema
+        <*> accountStatus Schema..= Schema.field "status" Schema.schema
 
 -------------------------------------------------------------------------------
 -- NewUserScimInvitation

libs/brig-types/test/unit/Test/Brig/Types/User.hs

@@ -26,13 +26,15 @@
 module Test.Brig.Types.User where
 
 import Brig.Types.Connection (UpdateConnectionsInternal (..))
-import Brig.Types.Intra (NewUserScimInvitation (..), ReAuthUser (..))
+import Brig.Types.Intra (NewUserScimInvitation (..), ReAuthUser (..), UserAccount (..))
 import Brig.Types.Search (SearchVisibilityInbound (..))
 import Brig.Types.User (ManagedByUpdate (..), RichInfoUpdate (..))
+import Data.Aeson
 import Imports
 import Test.Brig.Roundtrip (testRoundTrip, testRoundTripWithSwagger)
 import Test.QuickCheck (Arbitrary (arbitrary))
 import Test.Tasty
+import Test.Tasty.HUnit
 import Wire.API.Routes.Internal.Brig.EJPD (EJPDRequestBody (..), EJPDResponseBody (..))
 
 tests :: TestTree
@@ -47,7 +49,10 @@ roundtripTests =
     testRoundTripWithSwagger @EJPDRequestBody,
     testRoundTripWithSwagger @EJPDResponseBody,
     testRoundTrip @UpdateConnectionsInternal,
-    testRoundTrip @SearchVisibilityInbound
+    testRoundTrip @SearchVisibilityInbound,
+    testRoundTripWithSwagger @UserAccount,
+    testGroup "golden tests" $
+      [testCaseUserAccount]
   ]
 
 instance Arbitrary ManagedByUpdate where
@@ -61,3 +66,14 @@ instance Arbitrary ReAuthUser where
 
 instance Arbitrary NewUserScimInvitation where
   arbitrary = NewUserScimInvitation <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+testCaseUserAccount :: TestTree
+testCaseUserAccount = testCase "UserAcccount" $ do
+  assertEqual "1" (Just json1) (encode <$> decode @UserAccount json1)
+  assertEqual "2" (Just json2) (encode <$> decode @UserAccount json2)
+  where
+    json1 :: LByteString
+    json1 = "{\"accent_id\":1,\"assets\":[],\"deleted\":true,\"expires_at\":\"1864-05-09T17:20:22.192Z\",\"handle\":\"-ve\",\"id\":\"00000001-0000-0000-0000-000000000001\",\"locale\":\"lu\",\"managed_by\":\"wire\",\"name\":\"bla\",\"phone\":\"+433017355611929\",\"picture\":[],\"qualified_id\":{\"domain\":\"4-o60.j7-i\",\"id\":\"00000000-0000-0001-0000-000100000000\"},\"service\":{\"id\":\"00000000-0000-0001-0000-000000000001\",\"provider\":\"00000001-0000-0001-0000-000000000001\"},\"status\":\"suspended\",\"team\":\"00000000-0000-0001-0000-000100000001\"}"
+
+    json2 :: LByteString
+    json2 = "{\"accent_id\":0,\"assets\":[{\"key\":\"3-4-00000000-0000-0001-0000-000000000000\",\"size\":\"preview\",\"type\":\"image\"}],\"email\":\"@\",\"expires_at\":\"1864-05-10T22:45:44.823Z\",\"handle\":\"b8m\",\"id\":\"00000001-0000-0000-0000-000100000000\",\"locale\":\"tk-KZ\",\"managed_by\":\"wire\",\"name\":\"name2\",\"picture\":[],\"qualified_id\":{\"domain\":\"1-8wq0.b22k1.w5\",\"id\":\"00000000-0000-0000-0000-000000000001\"},\"service\":{\"id\":\"00000000-0000-0001-0000-000000000001\",\"provider\":\"00000001-0000-0001-0000-000100000000\"},\"status\":\"pending-invitation\",\"team\":\"00000000-0000-0001-0000-000000000001\"}"

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

@@ -0,0 +1,47 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
+--
+-- 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.SwaggerHelper where
+
+import Control.Lens
+import Data.Containers.ListUtils (nubOrd)
+import Data.Swagger hiding (Contact, Header, Schema, ToSchema)
+import qualified Data.Swagger as S
+import Imports hiding (head)
+
+cleanupSwagger :: Swagger -> Swagger
+cleanupSwagger =
+  (S.security %~ nub)
+    -- sanitise definitions
+    . (S.definitions . traverse %~ sanitise)
+    -- sanitise general responses
+    . (S.responses . traverse . S.schema . _Just . S._Inline %~ sanitise)
+    -- sanitise all responses of all paths
+    . ( S.allOperations . S.responses . S.responses
+          . traverse
+          . S._Inline
+          . S.schema
+          . _Just
+          . S._Inline
+          %~ sanitise
+      )
+  where
+    sanitise :: S.Schema -> S.Schema
+    sanitise =
+      (S.properties . traverse . S._Inline %~ sanitise)
+        . (S.required %~ nubOrd)
+        . (S.enum_ . _Just %~ nub)

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

@@ -40,6 +40,7 @@ module Wire.API.User
     ssoIssuerAndNameId,
     connectedProfile,
     publicProfile,
+    userObjectSchema,
 
     -- * NewUser
     NewUserPublic (..),
@@ -364,23 +365,25 @@ data User = User
 -- -- FUTUREWORK:
 -- -- disentangle json serializations for 'User', 'NewUser', 'UserIdentity', 'NewUserOrigin'.
 instance ToSchema User where
-  schema =
-    object "User" $
-      User
-        <$> userId .= field "id" schema
-        <*> userQualifiedId .= field "qualified_id" schema
-        <*> userIdentity .= maybeUserIdentityObjectSchema
-        <*> userDisplayName .= field "name" schema
-        <*> userPict .= (fromMaybe noPict <$> optField "picture" schema)
-        <*> userAssets .= (fromMaybe [] <$> optField "assets" (array schema))
-        <*> userAccentId .= field "accent_id" schema
-        <*> (fromMaybe False <$> (\u -> if userDeleted u then Just True else Nothing) .= maybe_ (optField "deleted" schema))
-        <*> userLocale .= field "locale" schema
-        <*> userService .= maybe_ (optField "service" schema)
-        <*> userHandle .= maybe_ (optField "handle" schema)
-        <*> userExpire .= maybe_ (optField "expires_at" schema)
-        <*> userTeam .= maybe_ (optField "team" schema)
-        <*> userManagedBy .= (fromMaybe ManagedByWire <$> optField "managed_by" schema)
+  schema = object "User" userObjectSchema
+
+userObjectSchema :: ObjectSchema SwaggerDoc User
+userObjectSchema =
+  User
+    <$> userId .= field "id" schema
+    <*> userQualifiedId .= field "qualified_id" schema
+    <*> userIdentity .= maybeUserIdentityObjectSchema
+    <*> userDisplayName .= field "name" schema
+    <*> userPict .= (fromMaybe noPict <$> optField "picture" schema)
+    <*> userAssets .= (fromMaybe [] <$> optField "assets" (array schema))
+    <*> userAccentId .= field "accent_id" schema
+    <*> (fromMaybe False <$> (\u -> if userDeleted u then Just True else Nothing) .= maybe_ (optField "deleted" schema))
+    <*> userLocale .= field "locale" schema
+    <*> userService .= maybe_ (optField "service" schema)
+    <*> userHandle .= maybe_ (optField "handle" schema)
+    <*> userExpire .= maybe_ (optField "expires_at" schema)
+    <*> userTeam .= maybe_ (optField "team" schema)
+    <*> userManagedBy .= (fromMaybe ManagedByWire <$> optField "managed_by" schema)
 
 userEmail :: User -> Maybe Email
 userEmail = emailIdentity <=< userIdentity

libs/wire-api/src/Wire/API/User/Identity.hs

@@ -64,6 +64,7 @@ import qualified Data.CaseInsensitive as CI
 import Data.Proxy (Proxy (..))
 import Data.Schema
 import Data.String.Conversions (cs)
+import Data.Swagger (ToParamSchema (..))
 import qualified Data.Swagger as S
 import qualified Data.Text as Text
 import Data.Text.Encoding (decodeUtf8', encodeUtf8)
@@ -163,6 +164,9 @@ data Email = Email
   deriving stock (Eq, Ord, Generic)
   deriving (FromJSON, ToJSON, S.ToSchema) via Schema Email
 
+instance ToParamSchema Email where
+  toParamSchema _ = toParamSchema (Proxy @Text)
+
 instance ToSchema Email where
   schema =
     fromEmail

libs/wire-api/wire-api.cabal

@@ -95,6 +95,7 @@ library
     Wire.API.Routes.WebSocket
     Wire.API.ServantProto
     Wire.API.Swagger
+    Wire.API.SwaggerHelper
     Wire.API.Team
     Wire.API.Team.Conversation
     Wire.API.Team.Export

services/brig/src/Brig/API/Public.hs

@@ -70,14 +70,13 @@ import Brig.User.Phone
 import qualified Cassandra as C
 import qualified Cassandra as Data
 import Control.Error hiding (bool)
-import Control.Lens (view, (%~), (.~), (?~), (^.), _Just)
+import Control.Lens (view, (.~), (?~), (^.))
 import Control.Monad.Catch (throwM)
 import Data.Aeson hiding (json)
 import Data.Bifunctor
 import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import Data.CommaSeparatedList (CommaSeparatedList (fromCommaSeparatedList))
-import Data.Containers.ListUtils (nubOrd)
 import Data.Domain
 import Data.FileEmbed
 import Data.Handle (Handle, parseHandle)
@@ -122,6 +121,7 @@ import qualified Wire.API.Routes.Public.Spar as SparAPI
 import qualified Wire.API.Routes.Public.Util as Public
 import Wire.API.Routes.Version
 import qualified Wire.API.Swagger as Public.Swagger (models)
+import Wire.API.SwaggerHelper (cleanupSwagger)
 import qualified Wire.API.Team as Public
 import Wire.API.Team.LegalHold (LegalholdProtectee (..))
 import Wire.API.User (RegisterError (RegisterErrorWhitelistError))
@@ -152,25 +152,7 @@ swaggerDocsAPI (Just V3) =
     )
       & S.info . S.title .~ "Wire-Server API"
       & S.info . S.description ?~ $(embedText =<< makeRelativeToProject "docs/swagger.md")
-      & S.security %~ nub
-      -- sanitise definitions
-      & S.definitions . traverse %~ sanitise
-      -- sanitise general responses
-      & S.responses . traverse . S.schema . _Just . S._Inline %~ sanitise
-      -- sanitise all responses of all paths
-      & S.allOperations . S.responses . S.responses
-        . traverse
-        . S._Inline
-        . S.schema
-        . _Just
-        . S._Inline
-        %~ sanitise
-  where
-    sanitise :: S.Schema -> S.Schema
-    sanitise =
-      (S.properties . traverse . S._Inline %~ sanitise)
-        . (S.required %~ nubOrd)
-        . (S.enum_ . _Just %~ nub)
+      & cleanupSwagger
 swaggerDocsAPI (Just V0) = swaggerPregenUIServer $(pregenSwagger V0)
 swaggerDocsAPI (Just V1) = swaggerPregenUIServer $(pregenSwagger V1)
 swaggerDocsAPI (Just V2) = swaggerPregenUIServer $(pregenSwagger V2)