loafle/openapi-generator
3
0
Fork 0
forked from loafle/openapi-generator-original
Code Pull Requests Activity

Add authentication for haskell-servant (#12470)

Browse Source 
* Add authentication for haskell-servant

* Add BearerToken to HaskellServantCodegen.java
This commit is contained in:
Tom Bärwinkel 2022-05-26 17:44:13 +02:00 committed by GitHub
parent a39d86c1eb
commit 54dca39459
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 308 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
docs/generators/haskell.md
View File

@ -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

1
modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java
View File

@ -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
))

162
modules/openapi-generator/src/main/resources/haskell-servant/API.mustache vendored
View File

@ -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

39
modules/openapi-generator/src/main/resources/haskell-servant/README.mustache vendored
View File

@ -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
```

12
modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache vendored
View File

@ -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

39
samples/server/petstore/haskell-servant/README.md
View File

@ -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
```

102
samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs
View File

@ -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
@ -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

1
samples/server/petstore/haskell-servant/openapi-petstore.cabal
View File

@ -38,4 +38,5 @@ library
, http-types
, swagger2
, uuid
, bytestring
default-language: Haskell2010