From 54dca39459207c76427400faced5339b3c8d89d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=20B=C3=A4rwinkel?= Date: Thu, 26 May 2022 17:44:13 +0200 Subject: [PATCH] Add authentication for haskell-servant (#12470) * Add authentication for haskell-servant * Add BearerToken to HaskellServantCodegen.java --- docs/generators/haskell.md | 2 +- .../languages/HaskellServantCodegen.java | 1 + .../resources/haskell-servant/API.mustache | 162 ++++++++++++++++-- .../resources/haskell-servant/README.mustache | 39 +++++ .../haskell-servant-codegen.mustache | 12 ++ .../server/petstore/haskell-servant/README.md | 39 +++++ .../lib/OpenAPIPetstore/API.hs | 104 +++++++---- .../haskell-servant/openapi-petstore.cabal | 1 + 8 files changed, 308 insertions(+), 52 deletions(-) diff --git a/docs/generators/haskell.md b/docs/generators/haskell.md index 1b1e3e68c13..47b891a1eb2 100644 --- a/docs/generators/haskell.md +++ b/docs/generators/haskell.md @@ -195,7 +195,7 @@ These options may be applied as additional-properties (cli) or configOptions (pl |BasicAuth|✓|OAS2,OAS3 |ApiKey|✓|OAS2,OAS3 |OpenIDConnect|✗|OAS3 -|BearerToken|✗|OAS3 +|BearerToken|✓|OAS3 |OAuth2_Implicit|✓|OAS2,OAS3 |OAuth2_Password|✗|OAS2,OAS3 |OAuth2_ClientCredentials|✗|OAS2,OAS3 diff --git a/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java b/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java index 477df471507..97c1cbf77a2 100644 --- a/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java +++ b/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java @@ -86,6 +86,7 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf .wireFormatFeatures(EnumSet.of(WireFormatFeature.JSON, WireFormatFeature.XML)) .securityFeatures(EnumSet.of( SecurityFeature.BasicAuth, + SecurityFeature.BearerToken, SecurityFeature.ApiKey, SecurityFeature.OAuth2_Implicit )) diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache index f352eba419e..84f19738f9d 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache +++ b/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache @@ -29,6 +29,12 @@ module {{title}}.API , {{title}}API -- ** Plain WAI Application , serverWaiApplication{{title}} +{{#hasAuthMethods}} + -- ** Authentication + , {{title}}Auth(..) + , clientAuth + , Protected +{{/hasAuthMethods}} ) where import {{title}}.Types @@ -38,6 +44,14 @@ import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT (..)) import Data.Aeson (Value) +{{#authMethods}} +{{#isApiKey}} +import Data.ByteString (ByteString) +{{/isApiKey}} +{{#isBasicBearer}} +import Data.ByteString (ByteString) +{{/isBasicBearer}} +{{/authMethods}} import Data.Coerce (coerce) import Data.Data (Data) import Data.Function ((&)) @@ -54,17 +68,38 @@ import GHC.Generics (Generic) import Network.HTTP.Client (Manager, newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Method (methodOptions) -import Network.Wai (Middleware) +import Network.Wai (Middleware{{#hasAuthMethods}}, Request, requestHeaders{{/hasAuthMethods}}) import qualified Network.Wai.Handler.Warp as Warp -import Servant (ServerError, serve) -import Servant.API +{{#authMethods}} +{{#isBasicBearer}} +import Network.Wai.Middleware.HttpAuth (extractBearerAuth) +{{/isBasicBearer}} +{{#isBasicBasic}} +import Network.Wai.Middleware.HttpAuth (extractBasicAuth) +{{/isBasicBasic}} +{{/authMethods}} +import Servant (ServerError, serveWithContext{{#hasAuthMethods}}, throwError{{/hasAuthMethods}}) +import Servant.API hiding (addHeader) +{{#authMethods}} +{{#isBasicBasic}} +import Servant.API.BasicAuth (BasicAuthData (..)) +{{/isBasicBasic}} +{{/authMethods}} import Servant.API.Verbs (StdMethod (..), Verb) +{{#hasAuthMethods}} +import Servant.API.Experimental.Auth (AuthProtect) +{{/hasAuthMethods}} import Servant.Client (ClientEnv, Scheme (Http), ClientError, client, mkClientEnv, parseBaseUrl) -import Servant.Client.Core (baseUrlPort, baseUrlHost) +import Servant.Client.Core (baseUrlPort, baseUrlHost{{#authMethods}}{{#isBasicBasic}}, basicAuthReq{{/isBasicBasic}}, AuthClientData, AuthenticatedRequest, addHeader, mkAuthenticatedRequest{{/authMethods}}) import Servant.Client.Internal.HttpClient (ClientM (..)) -import Servant.Server (Handler (..), Application){{#serveStatic}} -import Servant.Server.StaticFiles (serveDirectoryFileServer){{/serveStatic}} +import Servant.Server (Handler (..), Application, Context ({{#hasAuthMethods}}(:.), {{/hasAuthMethods}}EmptyContext)) +{{#hasAuthMethods}} +import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) +{{/hasAuthMethods}} +{{#serveStatic}} +import Servant.Server.StaticFiles (serveDirectoryFileServer) +{{/serveStatic}} import Web.FormUrlEncoded import Web.HttpApiData @@ -132,10 +167,10 @@ formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryPa {{#apiInfo}} -- | Servant type-level API, generated from the OpenAPI spec for {{title}}. type {{title}}API - = {{#apis}}{{#operations}}{{#operation}}{{& vendorExtensions.x-route-type}} -- '{{operationId}}' route{{^-last}} + = {{#apis}}{{#operations}}{{#operation}}{{#hasAuthMethods}}Protected :> {{/hasAuthMethods}}{{& vendorExtensions.x-route-type}} -- '{{operationId}}' route{{^-last}} :<|> {{/-last}}{{/operation}}{{/operations}}{{^-last}} :<|> {{/-last}}{{/apis}}{{#serveStatic}} - :<|> Raw {{/serveStatic}} + :<|> Raw{{/serveStatic}} {{/apiInfo}} @@ -156,12 +191,39 @@ newtype {{title}}ClientError = {{title}}ClientError ClientError -- The backend can be used both for the client and the server. The client generated from the {{title}} OpenAPI spec -- is a backend that executes actions by sending HTTP requests (see @create{{title}}Client@). Alternatively, provided -- a backend, the API can be served using @run{{title}}MiddlewareServer@. -data {{title}}Backend m = {{title}}Backend - { {{#apis}}{{#operations}}{{#operation}}{{operationId}} :: {{& vendorExtensions.x-client-type}}{- ^ {{& notes}} -}{{^-last}} +data {{title}}Backend{{#hasAuthMethods}} a{{/hasAuthMethods}} m = {{title}}Backend + { {{#apis}}{{#operations}}{{#operation}}{{operationId}} :: {{#hasAuthMethods}}a -> {{/hasAuthMethods}}{{& vendorExtensions.x-client-type}}{- ^ {{& notes}} -}{{^-last}} , {{/-last}}{{/operation}}{{/operations}}{{^-last}} , {{/-last}}{{/apis}} } +{{#authMethods}} +{{^isOAuth}} +-- | Authentication settings for {{title}}. +-- lookupUser is used to retrieve a user given a header value. The data type can be specified by providing an +-- type instance for AuthServerData. authError is a function that given a request returns a custom error that +-- is returned when the header is not found. +{{/isOAuth}} +{{#isApiKey}} +data {{title}}Auth = {{title}}Auth + { lookupUser :: ByteString -> Handler AuthServer + , authError :: Request -> ServerError + } +{{/isApiKey}} +{{#isBasicBearer}} +data {{title}}Auth = {{title}}Auth + { lookupUser :: ByteString -> Handler AuthServer + , authError :: Request -> ServerError + } +{{/isBasicBearer}} +{{#isBasicBasic}} +data {{title}}Auth = {{title}}Auth + { lookupUser :: BasicAuthData -> Handler AuthServer + , authError :: Request -> ServerError + } +{{/isBasicBasic}} +{{/authMethods}} + newtype {{title}}Client a = {{title}}Client { runClient :: ClientEnv -> ExceptT ClientError IO a } deriving Functor @@ -182,7 +244,7 @@ instance MonadIO {{title}}Client where {{/apiInfo}} {{#apiInfo}} -create{{title}}Client :: {{title}}Backend {{title}}Client +create{{title}}Client :: {{title}}Backend{{#hasAuthMethods}} AuthClient{{/hasAuthMethods}} {{title}}Client create{{title}}Client = {{title}}Backend{..} where ({{#apis}}{{#operations}}{{#operation}}(coerce -> {{operationId}}){{^-last}} :<|> @@ -222,29 +284,93 @@ requestMiddlewareId a = a -- | Run the {{title}} server at the provided host and port. run{{title}}Server :: (MonadIO m, MonadThrow m) - => Config -> {{title}}Backend (ExceptT ServerError IO) -> m () -run{{title}}Server config backend = run{{title}}MiddlewareServer config requestMiddlewareId backend + => Config -> {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}(ExceptT ServerError IO) -> m () +run{{title}}Server config {{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = run{{title}}MiddlewareServer config requestMiddlewareId {{#hasAuthMethods}}auth {{/hasAuthMethods}}backend -- | Run the {{title}} server at the provided host and port. run{{title}}MiddlewareServer :: (MonadIO m, MonadThrow m) - => Config -> Middleware -> {{title}}Backend (ExceptT ServerError IO) -> m () -run{{title}}MiddlewareServer Config{..} middleware backend = do + => Config -> Middleware -> {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend{{#hasAuthMethods}} AuthServer{{/hasAuthMethods}} (ExceptT ServerError IO) -> m () +run{{title}}MiddlewareServer Config{..} middleware{{#hasAuthMethods}} auth{{/hasAuthMethods}} backend = do url <- parseBaseUrl configUrl let warpSettings = Warp.defaultSettings & Warp.setPort (baseUrlPort url) & Warp.setHost (fromString $ baseUrlHost url) - liftIO $ Warp.runSettings warpSettings $ middleware $ serverWaiApplication{{title}} backend + liftIO $ Warp.runSettings warpSettings $ middleware $ serverWaiApplication{{title}}{{#hasAuthMethods}} auth{{/hasAuthMethods}} backend -- | Plain "Network.Wai" Application for the {{title}} server. -- -- Can be used to implement e.g. tests that call the API without a full webserver. -serverWaiApplication{{title}} :: {{title}}Backend (ExceptT ServerError IO) -> Application -serverWaiApplication{{title}} backend = serve (Proxy :: Proxy {{title}}API) (serverFromBackend backend) +serverWaiApplication{{title}} :: {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}(ExceptT ServerError IO) -> Application +serverWaiApplication{{title}} {{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = serveWithContext (Proxy :: Proxy {{title}}API) context (serverFromBackend backend) where + context = serverContext{{#hasAuthMethods}} auth{{/hasAuthMethods}} serverFromBackend {{title}}Backend{..} = ({{#apis}}{{#operations}}{{#operation}}coerce {{operationId}}{{^-last}} :<|> {{/-last}}{{/operation}}{{/operations}}{{^-last}} :<|> {{/-last}}{{/apis}}{{#serveStatic}} :<|> serveDirectoryFileServer "static"{{/serveStatic}}) {{/apiInfo}} + +{{#authMethods}} +{{^isOAuth}} +-- Authentication is implemented with servants generalized authentication: +-- https://docs.servant.dev/en/stable/tutorial/Authentication.html#generalized-authentication + +{{/isOAuth}} +{{#isApiKey}} +authHandler :: {{title}}Auth -> AuthHandler Request AuthServer +authHandler {{title}}Auth{..} = mkAuthHandler handler + where + handler req = case lookup "{{keyParamName}}" (requestHeaders req) of + Just header -> lookupUser header + Nothing -> throwError (authError req) + +type Protected = AuthProtect "apikey" +type AuthServer = AuthServerData Protected +type AuthClient = AuthenticatedRequest Protected +type instance AuthClientData Protected = Text + +clientAuth :: Text -> AuthClient +clientAuth key = mkAuthenticatedRequest key (addHeader "{{keyParamName}}") +{{/isApiKey}} +{{#isBasicBearer}} +authHandler :: {{title}}Auth -> AuthHandler Request AuthServer +authHandler {{title}}Auth{..} = mkAuthHandler handler + where + handler req = case lookup "Authorization" (requestHeaders req) of + Just header -> case extractBearerAuth header of + Just key -> lookupUser key + Nothing -> throwError (authError req) + Nothing -> throwError (authError req) + +type Protected = AuthProtect "bearer" +type AuthServer = AuthServerData Protected +type AuthClient = AuthenticatedRequest Protected +type instance AuthClientData Protected = Text + +clientAuth :: Text -> AuthClient +clientAuth key = mkAuthenticatedRequest ("Bearer " <> key) (addHeader "Authorization") +{{/isBasicBearer}} +{{#isBasicBasic}} +authHandler :: {{title}}Auth -> AuthHandler Request AuthServer +authHandler {{title}}Auth{..} = mkAuthHandler handler + where + handler req = case lookup "Authorization" (requestHeaders req) of + Just header -> case extractBasicAuth header of + Just (user, password) -> lookupUser (BasicAuthData user password) + Nothing -> throwError (authError req) + Nothing -> throwError (authError req) + +type Protected = AuthProtect "basic" +type AuthServer = AuthServerData Protected +type AuthClient = AuthenticatedRequest Protected +type instance AuthClientData Protected = BasicAuthData + +clientAuth :: BasicAuthData -> AuthClient +clientAuth key = mkAuthenticatedRequest key basicAuthReq +{{/isBasicBasic}} +{{/authMethods}} + +serverContext :: {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}Context ({{#hasAuthMethods}}AuthHandler Request AuthServer ': {{/hasAuthMethods}}'[]) +serverContext {{#hasAuthMethods}}auth {{/hasAuthMethods}}= {{#hasAuthMethods}}authHandler auth :. {{/hasAuthMethods}}EmptyContext diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/README.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/README.mustache index 4dac568315c..359ba55c0f9 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/README.mustache +++ b/modules/openapi-generator/src/main/resources/haskell-servant/README.mustache @@ -87,3 +87,42 @@ main = do config = Config "http://localhost:8080/" run{{title}}MiddlewareServer config requestMiddlewares server ``` + +## Authentication + +Currently basic, bearer and API key authentication is supported. The API key must be provided +in the request header. + +For clients authentication the function `clientAuth` is generated automatically. For basic +authentication the argument is of type `BasicAuthData` provided by `Servant.API.BasicAuth`. +For bearer and API key authentication the argument is the key/token and is of type `Text`. +Protected endpoints on the client will receive an extra argument. The value returned by +`clientAuth keyTokenOrBasic` can then be used to make authenticated requests. + +For the server you are free to choose a custom data type. After you specified an instance of +`AuthServerData` it is automatically added as a first argument to protected endpoints: + +``` +newtype Account = Account {unAccount :: Text} +type instance AuthServerData Protected = Account +``` + +Additionally, you have to provide value for the `{{title}}Auth` type provided by the +`{{title}}.API` module: + +``` +auth :: {{title}}Auth +auth = + {{title}}Auth + { lookupUser = lookupAccount, + authError = \request -> err401 {errBody = "Missing header"} + } +``` + +`lookupAccount` is a user defined function used to verify the key, token or basic auth data. +`authError` takes a `Request` and returns a `ServerError`. The value is used by the server +functions: + +``` +run{{title}}MiddlewareServer config requestMiddlewares auth server +``` diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache index f41a28b41f2..a55ed07ed2c 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache +++ b/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache @@ -38,4 +38,16 @@ library , http-types , swagger2 , uuid +{{#authMethods}} +{{#isApiKey}} + , bytestring +{{/isApiKey}} +{{#isBasicBearer}} + , bytestring + , wai-extra +{{/isBasicBearer}} +{{#isBasicBasic}} + , wai-extra +{{/isBasicBasic}} +{{/authMethods}} default-language: Haskell2010 diff --git a/samples/server/petstore/haskell-servant/README.md b/samples/server/petstore/haskell-servant/README.md index 5a5258926ee..0b315e40a84 100644 --- a/samples/server/petstore/haskell-servant/README.md +++ b/samples/server/petstore/haskell-servant/README.md @@ -87,3 +87,42 @@ main = do config = Config "http://localhost:8080/" runOpenAPIPetstoreMiddlewareServer config requestMiddlewares server ``` + +## Authentication + +Currently basic, bearer and API key authentication is supported. The API key must be provided +in the request header. + +For clients authentication the function `clientAuth` is generated automatically. For basic +authentication the argument is of type `BasicAuthData` provided by `Servant.API.BasicAuth`. +For bearer and API key authentication the argument is the key/token and is of type `Text`. +Protected endpoints on the client will receive an extra argument. The value returned by +`clientAuth keyTokenOrBasic` can then be used to make authenticated requests. + +For the server you are free to choose a custom data type. After you specified an instance of +`AuthServerData` it is automatically added as a first argument to protected endpoints: + +``` +newtype Account = Account {unAccount :: Text} +type instance AuthServerData Protected = Account +``` + +Additionally, you have to provide value for the `OpenAPIPetstoreAuth` type provided by the +`OpenAPIPetstore.API` module: + +``` +auth :: OpenAPIPetstoreAuth +auth = + OpenAPIPetstoreAuth + { lookupUser = lookupAccount, + authError = \request -> err401 {errBody = "Missing header"} + } +``` + +`lookupAccount` is a user defined function used to verify the key, token or basic auth data. +`authError` takes a `Request` and returns a `ServerError`. The value is used by the server +functions: + +``` +runOpenAPIPetstoreMiddlewareServer config requestMiddlewares auth server +``` diff --git a/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs b/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs index e06ac16b307..bdb61723535 100644 --- a/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs +++ b/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs @@ -29,6 +29,10 @@ module OpenAPIPetstore.API , OpenAPIPetstoreAPI -- ** Plain WAI Application , serverWaiApplicationOpenAPIPetstore + -- ** Authentication + , OpenAPIPetstoreAuth(..) + , clientAuth + , Protected ) where import OpenAPIPetstore.Types @@ -38,6 +42,7 @@ import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT (..)) import Data.Aeson (Value) +import Data.ByteString (ByteString) import Data.Coerce (coerce) import Data.Data (Data) import Data.Function ((&)) @@ -54,16 +59,18 @@ import GHC.Generics (Generic) import Network.HTTP.Client (Manager, newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Method (methodOptions) -import Network.Wai (Middleware) +import Network.Wai (Middleware, Request, requestHeaders) import qualified Network.Wai.Handler.Warp as Warp -import Servant (ServerError, serve) -import Servant.API +import Servant (ServerError, serveWithContext, throwError) +import Servant.API hiding (addHeader) import Servant.API.Verbs (StdMethod (..), Verb) +import Servant.API.Experimental.Auth (AuthProtect) import Servant.Client (ClientEnv, Scheme (Http), ClientError, client, mkClientEnv, parseBaseUrl) -import Servant.Client.Core (baseUrlPort, baseUrlHost) +import Servant.Client.Core (baseUrlPort, baseUrlHost, AuthClientData, AuthenticatedRequest, addHeader, mkAuthenticatedRequest, AuthClientData, AuthenticatedRequest, addHeader, mkAuthenticatedRequest) import Servant.Client.Internal.HttpClient (ClientM (..)) -import Servant.Server (Handler (..), Application) +import Servant.Server (Handler (..), Application, Context ((:.), EmptyContext)) +import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) import Servant.Server.StaticFiles (serveDirectoryFileServer) import Web.FormUrlEncoded import Web.HttpApiData @@ -139,16 +146,16 @@ formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryPa -- | Servant type-level API, generated from the OpenAPI spec for OpenAPIPetstore. type OpenAPIPetstoreAPI - = "pet" :> ReqBody '[JSON] Pet :> Verb 'POST 200 '[JSON] NoContent -- 'addPet' route - :<|> "pet" :> Capture "petId" Integer :> Header "api_key" Text :> Verb 'DELETE 200 '[JSON] NoContent -- 'deletePet' route - :<|> "pet" :> "findByStatus" :> QueryParam "status" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByStatus' route - :<|> "pet" :> "findByTags" :> QueryParam "tags" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByTags' route - :<|> "pet" :> Capture "petId" Integer :> Verb 'GET 200 '[JSON] Pet -- 'getPetById' route - :<|> "pet" :> ReqBody '[JSON] Pet :> Verb 'PUT 200 '[JSON] NoContent -- 'updatePet' route - :<|> "pet" :> Capture "petId" Integer :> ReqBody '[FormUrlEncoded] FormUpdatePetWithForm :> Verb 'POST 200 '[JSON] NoContent -- 'updatePetWithForm' route - :<|> "pet" :> Capture "petId" Integer :> "uploadImage" :> ReqBody '[FormUrlEncoded] FormUploadFile :> Verb 'POST 200 '[JSON] ApiResponse -- 'uploadFile' route + = Protected :> "pet" :> ReqBody '[JSON] Pet :> Verb 'POST 200 '[JSON] NoContent -- 'addPet' route + :<|> Protected :> "pet" :> Capture "petId" Integer :> Header "api_key" Text :> Verb 'DELETE 200 '[JSON] NoContent -- 'deletePet' route + :<|> Protected :> "pet" :> "findByStatus" :> QueryParam "status" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByStatus' route + :<|> Protected :> "pet" :> "findByTags" :> QueryParam "tags" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByTags' route + :<|> Protected :> "pet" :> Capture "petId" Integer :> Verb 'GET 200 '[JSON] Pet -- 'getPetById' route + :<|> Protected :> "pet" :> ReqBody '[JSON] Pet :> Verb 'PUT 200 '[JSON] NoContent -- 'updatePet' route + :<|> Protected :> "pet" :> Capture "petId" Integer :> ReqBody '[FormUrlEncoded] FormUpdatePetWithForm :> Verb 'POST 200 '[JSON] NoContent -- 'updatePetWithForm' route + :<|> Protected :> "pet" :> Capture "petId" Integer :> "uploadImage" :> ReqBody '[FormUrlEncoded] FormUploadFile :> Verb 'POST 200 '[JSON] ApiResponse -- 'uploadFile' route :<|> "store" :> "order" :> Capture "orderId" Text :> Verb 'DELETE 200 '[JSON] NoContent -- 'deleteOrder' route - :<|> "store" :> "inventory" :> Verb 'GET 200 '[JSON] ((Map.Map String Int)) -- 'getInventory' route + :<|> Protected :> "store" :> "inventory" :> Verb 'GET 200 '[JSON] ((Map.Map String Int)) -- 'getInventory' route :<|> "store" :> "order" :> Capture "orderId" Integer :> Verb 'GET 200 '[JSON] Order -- 'getOrderById' route :<|> "store" :> "order" :> ReqBody '[JSON] Order :> Verb 'POST 200 '[JSON] Order -- 'placeOrder' route :<|> "user" :> ReqBody '[JSON] User :> Verb 'POST 200 '[JSON] NoContent -- 'createUser' route @@ -159,7 +166,7 @@ type OpenAPIPetstoreAPI :<|> "user" :> "login" :> QueryParam "username" Text :> QueryParam "password" Text :> Verb 'GET 200 '[JSON] Text -- 'loginUser' route :<|> "user" :> "logout" :> Verb 'GET 200 '[JSON] NoContent -- 'logoutUser' route :<|> "user" :> Capture "username" Text :> ReqBody '[JSON] User :> Verb 'PUT 200 '[JSON] NoContent -- 'updateUser' route - :<|> Raw + :<|> Raw -- | Server or client configuration, specifying the host and port to query or serve on. @@ -178,17 +185,17 @@ newtype OpenAPIPetstoreClientError = OpenAPIPetstoreClientError ClientError -- The backend can be used both for the client and the server. The client generated from the OpenAPIPetstore OpenAPI spec -- is a backend that executes actions by sending HTTP requests (see @createOpenAPIPetstoreClient@). Alternatively, provided -- a backend, the API can be served using @runOpenAPIPetstoreMiddlewareServer@. -data OpenAPIPetstoreBackend m = OpenAPIPetstoreBackend - { addPet :: Pet -> m NoContent{- ^ -} - , deletePet :: Integer -> Maybe Text -> m NoContent{- ^ -} - , findPetsByStatus :: Maybe [Text] -> m [Pet]{- ^ Multiple status values can be provided with comma separated strings -} - , findPetsByTags :: Maybe [Text] -> m [Pet]{- ^ Multiple tags can be provided with comma separated strings. Use tag1, tag2, tag3 for testing. -} - , getPetById :: Integer -> m Pet{- ^ Returns a single pet -} - , updatePet :: Pet -> m NoContent{- ^ -} - , updatePetWithForm :: Integer -> FormUpdatePetWithForm -> m NoContent{- ^ -} - , uploadFile :: Integer -> FormUploadFile -> m ApiResponse{- ^ -} +data OpenAPIPetstoreBackend a m = OpenAPIPetstoreBackend + { addPet :: a -> Pet -> m NoContent{- ^ -} + , deletePet :: a -> Integer -> Maybe Text -> m NoContent{- ^ -} + , findPetsByStatus :: a -> Maybe [Text] -> m [Pet]{- ^ Multiple status values can be provided with comma separated strings -} + , findPetsByTags :: a -> Maybe [Text] -> m [Pet]{- ^ Multiple tags can be provided with comma separated strings. Use tag1, tag2, tag3 for testing. -} + , getPetById :: a -> Integer -> m Pet{- ^ Returns a single pet -} + , updatePet :: a -> Pet -> m NoContent{- ^ -} + , updatePetWithForm :: a -> Integer -> FormUpdatePetWithForm -> m NoContent{- ^ -} + , uploadFile :: a -> Integer -> FormUploadFile -> m ApiResponse{- ^ -} , deleteOrder :: Text -> m NoContent{- ^ For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors -} - , getInventory :: m ((Map.Map String Int)){- ^ Returns a map of status codes to quantities -} + , getInventory :: a -> m ((Map.Map String Int)){- ^ Returns a map of status codes to quantities -} , getOrderById :: Integer -> m Order{- ^ For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions -} , placeOrder :: Order -> m Order{- ^ -} , createUser :: User -> m NoContent{- ^ This can only be done by the logged in user. -} @@ -201,6 +208,15 @@ data OpenAPIPetstoreBackend m = OpenAPIPetstoreBackend , updateUser :: Text -> User -> m NoContent{- ^ This can only be done by the logged in user. -} } +-- | Authentication settings for OpenAPIPetstore. +-- lookupUser is used to retrieve a user given a header value. The data type can be specified by providing an +-- type instance for AuthServerData. authError is a function that given a request returns a custom error that +-- is returned when the header is not found. +data OpenAPIPetstoreAuth = OpenAPIPetstoreAuth + { lookupUser :: ByteString -> Handler AuthServer + , authError :: Request -> ServerError + } + newtype OpenAPIPetstoreClient a = OpenAPIPetstoreClient { runClient :: ClientEnv -> ExceptT ClientError IO a } deriving Functor @@ -219,7 +235,7 @@ instance Monad OpenAPIPetstoreClient where instance MonadIO OpenAPIPetstoreClient where liftIO io = OpenAPIPetstoreClient (\_ -> liftIO io) -createOpenAPIPetstoreClient :: OpenAPIPetstoreBackend OpenAPIPetstoreClient +createOpenAPIPetstoreClient :: OpenAPIPetstoreBackend AuthClient OpenAPIPetstoreClient createOpenAPIPetstoreClient = OpenAPIPetstoreBackend{..} where ((coerce -> addPet) :<|> @@ -274,26 +290,27 @@ requestMiddlewareId a = a -- | Run the OpenAPIPetstore server at the provided host and port. runOpenAPIPetstoreServer :: (MonadIO m, MonadThrow m) - => Config -> OpenAPIPetstoreBackend (ExceptT ServerError IO) -> m () -runOpenAPIPetstoreServer config backend = runOpenAPIPetstoreMiddlewareServer config requestMiddlewareId backend + => Config -> OpenAPIPetstoreAuth -> OpenAPIPetstoreBackend AuthServer (ExceptT ServerError IO) -> m () +runOpenAPIPetstoreServer config auth backend = runOpenAPIPetstoreMiddlewareServer config requestMiddlewareId auth backend -- | Run the OpenAPIPetstore server at the provided host and port. runOpenAPIPetstoreMiddlewareServer :: (MonadIO m, MonadThrow m) - => Config -> Middleware -> OpenAPIPetstoreBackend (ExceptT ServerError IO) -> m () -runOpenAPIPetstoreMiddlewareServer Config{..} middleware backend = do + => Config -> Middleware -> OpenAPIPetstoreAuth -> OpenAPIPetstoreBackend AuthServer (ExceptT ServerError IO) -> m () +runOpenAPIPetstoreMiddlewareServer Config{..} middleware auth backend = do url <- parseBaseUrl configUrl let warpSettings = Warp.defaultSettings & Warp.setPort (baseUrlPort url) & Warp.setHost (fromString $ baseUrlHost url) - liftIO $ Warp.runSettings warpSettings $ middleware $ serverWaiApplicationOpenAPIPetstore backend + liftIO $ Warp.runSettings warpSettings $ middleware $ serverWaiApplicationOpenAPIPetstore auth backend -- | Plain "Network.Wai" Application for the OpenAPIPetstore server. -- -- Can be used to implement e.g. tests that call the API without a full webserver. -serverWaiApplicationOpenAPIPetstore :: OpenAPIPetstoreBackend (ExceptT ServerError IO) -> Application -serverWaiApplicationOpenAPIPetstore backend = serve (Proxy :: Proxy OpenAPIPetstoreAPI) (serverFromBackend backend) +serverWaiApplicationOpenAPIPetstore :: OpenAPIPetstoreAuth -> OpenAPIPetstoreBackend AuthServer (ExceptT ServerError IO) -> Application +serverWaiApplicationOpenAPIPetstore auth backend = serveWithContext (Proxy :: Proxy OpenAPIPetstoreAPI) context (serverFromBackend backend) where + context = serverContext auth serverFromBackend OpenAPIPetstoreBackend{..} = (coerce addPet :<|> coerce deletePet :<|> @@ -316,3 +333,24 @@ serverWaiApplicationOpenAPIPetstore backend = serve (Proxy :: Proxy OpenAPIPetst coerce logoutUser :<|> coerce updateUser :<|> serveDirectoryFileServer "static") + +-- Authentication is implemented with servants generalized authentication: +-- https://docs.servant.dev/en/stable/tutorial/Authentication.html#generalized-authentication + +authHandler :: OpenAPIPetstoreAuth -> AuthHandler Request AuthServer +authHandler OpenAPIPetstoreAuth{..} = mkAuthHandler handler + where + handler req = case lookup "api_key" (requestHeaders req) of + Just header -> lookupUser header + Nothing -> throwError (authError req) + +type Protected = AuthProtect "apikey" +type AuthServer = AuthServerData Protected +type AuthClient = AuthenticatedRequest Protected +type instance AuthClientData Protected = Text + +clientAuth :: Text -> AuthClient +clientAuth key = mkAuthenticatedRequest key (addHeader "api_key") + +serverContext :: OpenAPIPetstoreAuth -> Context (AuthHandler Request AuthServer ': '[]) +serverContext auth = authHandler auth :. EmptyContext diff --git a/samples/server/petstore/haskell-servant/openapi-petstore.cabal b/samples/server/petstore/haskell-servant/openapi-petstore.cabal index 50f4dfcc258..c1a44b71baa 100644 --- a/samples/server/petstore/haskell-servant/openapi-petstore.cabal +++ b/samples/server/petstore/haskell-servant/openapi-petstore.cabal @@ -38,4 +38,5 @@ library , http-types , swagger2 , uuid + , bytestring default-language: Haskell2010