Servantify stern

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

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 <[email protected]>
@@ -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,7 +26,7 @@
 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 Imports
@@ -47,7 +47,8 @@ roundtripTests =
     testRoundTripWithSwagger @EJPDRequestBody,
     testRoundTripWithSwagger @EJPDResponseBody,
     testRoundTrip @UpdateConnectionsInternal,
-    testRoundTrip @SearchVisibilityInbound
+    testRoundTrip @SearchVisibilityInbound,
+    testRoundTripWithSwagger @UserAccount
   ]
 
 instance Arbitrary ManagedByUpdate where

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

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,49 @@ 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.serveWithContext
+        (Proxy @(SwaggerDocsAPI :<|> Servant.Raw))
+        Servant.EmptyContext
+        ( 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 +156,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 +560,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

tools/stern/src/Stern/API/Routes.hs

@@ -0,0 +1,74 @@
+-- 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 Stern.API.Routes where
+
+import Brig.Types.Intra (UserAccount)
+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)
+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.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
+
+sternSwagger :: Swagger
+sternSwagger = toSwagger (Proxy @SternAPI)
+
+type SwaggerDocsAPI = "backoffice" :> "api" :> SwaggerSchemaUI "swagger-ui" "swagger.json"
+
+swaggerDocsAPI :: Servant.Server SwaggerDocsAPI
+swaggerDocsAPI =
+  swaggerSchemaUIServer $
+    sternSwagger
+      & S.info . S.title .~ "Stern API"
+      & 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)

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