diff --git a/changelog.d/5-internal/pr-2742 b/changelog.d/5-internal/pr-2742 new file mode 100644 index 0000000000..b62f0db100 --- /dev/null +++ b/changelog.d/5-internal/pr-2742 @@ -0,0 +1 @@ +Add swagger2-ui to stern (#2742 ...) \ No newline at end of file diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal index 4b3cbd43fa..3220d58a2d 100644 --- a/libs/brig-types/brig-types.cabal +++ b/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 diff --git a/libs/brig-types/src/Brig/Types/Intra.hs b/libs/brig-types/src/Brig/Types/Intra.hs index 5fcb18e631..0fafba46c2 100644 --- a/libs/brig-types/src/Brig/Types/Intra.hs +++ b/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 @@ -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 diff --git a/libs/brig-types/test/unit/Test/Brig/Types/User.hs b/libs/brig-types/test/unit/Test/Brig/Types/User.hs index a3c2002bc9..e54ed41c01 100644 --- a/libs/brig-types/test/unit/Test/Brig/Types/User.hs +++ b/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\"}" diff --git a/libs/wire-api/src/Wire/API/SwaggerHelper.hs b/libs/wire-api/src/Wire/API/SwaggerHelper.hs new file mode 100644 index 0000000000..7d43382521 --- /dev/null +++ b/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 +-- +-- 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 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) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 5dae1dfd9a..53e44cac01 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/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 diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 9c1f0ae55c..0b7b626d5e 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/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 diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 26d7c0f2ac..126ac7d697 100644 --- a/libs/wire-api/wire-api.cabal +++ b/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 diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 3f553e40cc..d94c6747b7 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/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) diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index af93fae30e..2cdd03873a 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -37,6 +37,7 @@ import Data.ByteString.Lazy (fromStrict) import Data.Handle (Handle) import Data.Id import Data.Predicate +import Data.Proxy (Proxy (..)) import Data.Range import qualified Data.Schema as S import Data.Swagger.Build.Api hiding (Response, def, min, response) @@ -55,7 +56,10 @@ import Network.Wai.Routing hiding (trace) import Network.Wai.Utilities import qualified Network.Wai.Utilities.Server as Server import Network.Wai.Utilities.Swagger (document, mkSwaggerApi) +import Servant (ServerT, (:<|>) (..)) +import qualified Servant import Stern.API.Predicates +import Stern.API.Routes import Stern.App import qualified Stern.Intra as Intra import Stern.Options @@ -64,6 +68,7 @@ import Stern.Types import System.Logger.Class hiding (Error, name, trace, (.=)) import Util.Options import Wire.API.Connection +import Wire.API.Routes.Named (Named (Named)) import Wire.API.Team.Feature hiding (setStatus) import qualified Wire.API.Team.Feature as Public import Wire.API.Team.SearchVisibility @@ -77,17 +82,47 @@ start :: Opts -> IO () start o = do e <- newEnv o s <- Server.newSettings (server e) - Server.runSettingsWithShutdown s (pipeline e) Nothing + Server.runSettingsWithShutdown s (servantApp e) Nothing where + server :: Env -> Server.Server server e = Server.defaultServer (unpack $ stern o ^. epHost) (stern o ^. epPort) (e ^. applog) (e ^. metrics) + + pipeline :: Env -> Application pipeline e = GZip.gzip GZip.def $ serve e + + serve :: Env -> Request -> Continue IO -> IO ResponseReceived serve e r k = runHandler e r (Server.route (Server.compile sitemap) r k) k + -- WIP: the servant app wraps the old wai-routes api + -- todo: remove wai-route api and replace with servant api when fully servantified + -- currently the servant app only contains the swagger docs + -- and is served with stern: http://localhost:8091/backoffice/api/swagger-ui/ + -- swagger ui is functional and can execute requests against stern + -- however there is a servant value that implements the servant api and uses the same handlers as the wai-route api + -- to make sure it type checks + servantApp :: Env -> Application + servantApp e = + Servant.serve + (Proxy @(SwaggerDocsAPI :<|> Servant.Raw)) + (swaggerDocsAPI :<|> Servant.Tagged (pipeline e)) + sitemap :: Routes Doc.ApiBuilder Handler () sitemap = do routes apiDocs +------------------------------------------------------------------------------- +-- servant API + +-- | The stern API implemented with servant +-- currently not yet in use, replace wai-route api with this, when fully servantified +-- primarily used for type checking +_servantSitemap :: ServerT SternAPI Handler +_servantSitemap = Named @"get-users-by-email" usersByEmail + +------------------------------------------------------------------------------- +-- wai-routes API + data SupportsTtl = TtlEnabled | TtlDisabled routes :: Routes Doc.ApiBuilder Handler () @@ -119,7 +154,7 @@ routes = do Doc.response 400 "Bad request" (Doc.model Doc.errorModel) Doc.response 404 "Account not found" (Doc.model Doc.errorModel) - get "/users" (continue usersByEmail) $ + get "/users" (continue usersByEmail') $ param "email" document "GET" "users" $ do Doc.summary "Displays user's info given an email address" @@ -523,8 +558,11 @@ suspendUser uid = do unsuspendUser :: UserId -> Handler Response unsuspendUser uid = Intra.putUserStatus Active uid >> pure empty -usersByEmail :: Email -> Handler Response -usersByEmail = fmap json . Intra.getUserProfilesByIdentity . Left +usersByEmail' :: Email -> Handler Response +usersByEmail' = fmap json . usersByEmail + +usersByEmail :: Email -> Handler [UserAccount] +usersByEmail = Intra.getUserProfilesByIdentity . Left usersByPhone :: Phone -> Handler Response usersByPhone = fmap json . Intra.getUserProfilesByIdentity . Right diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs new file mode 100644 index 0000000000..f48ca484d2 --- /dev/null +++ b/tools/stern/src/Stern/API/Routes.hs @@ -0,0 +1,57 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 Stern.API.Routes + ( SternAPI, + SwaggerDocsAPI, + swaggerDocsAPI, + ) +where + +import Brig.Types.Intra (UserAccount) +import Control.Lens +import qualified Data.Swagger as S +import Imports hiding (head) +import Servant (JSON) +import Servant hiding (Handler, JSON, addHeader, respond) +import Servant.Swagger (HasSwagger (toSwagger)) +import Servant.Swagger.Internal.Orphans () +import Servant.Swagger.UI +import Wire.API.Routes.Named +import Wire.API.SwaggerHelper (cleanupSwagger) +import Wire.API.User (Email) + +type SternAPI = + Named + "get-users-by-email" + ( Summary "Displays user's info given an email address" + :> "users" + :> QueryParam' [Required, Strict, Description "Email address"] "email" Email + :> Get '[JSON] [UserAccount] + ) + +------------------------------------------------------------------------------- +-- Swagger + +type SwaggerDocsAPI = "backoffice" :> "api" :> SwaggerSchemaUI "swagger-ui" "swagger.json" + +swaggerDocsAPI :: Servant.Server SwaggerDocsAPI +swaggerDocsAPI = + swaggerSchemaUIServer $ + (toSwagger (Proxy @SternAPI)) + & S.info . S.title .~ "Stern API" + & cleanupSwagger diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index f0e6e5cffb..3ba2ef6abd 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -19,6 +19,7 @@ library Main Stern.API Stern.API.Predicates + Stern.API.Routes Stern.App Stern.Intra Stern.Options @@ -93,9 +94,14 @@ library , metrics-wai >=0.3 , mtl >=2.1 , schema-profunctor + , servant + , servant-server + , servant-swagger + , servant-swagger-ui , split >=0.2 , string-conversions - , swagger >=0.3 + , swagger + , swagger2 , text >=1.1 , tinylog >=0.10 , transformers >=0.3