Add authentication for haskell-servant (#12470)

* Add authentication for haskell-servant

* Add BearerToken to HaskellServantCodegen.java

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

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

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)
+{{#authMethods}}
-import           Servant.API
+{{#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                     (Handler (..), Application, Context ({{#hasAuthMethods}}(:.), {{/hasAuthMethods}}EmptyContext))
-import           Servant.Server.StaticFiles         (serveDirectoryFileServer){{/serveStatic}}
+{{#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
+data {{title}}Backend{{#hasAuthMethods}} a{{/hasAuthMethods}} m = {{title}}Backend
-  { {{#apis}}{{#operations}}{{#operation}}{{operationId}} :: {{& vendorExtensions.x-client-type}}{- ^ {{& notes}} -}{{^-last}}
+  { {{#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 ()
+  => Config -> {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}(ExceptT ServerError IO) -> m ()
-run{{title}}Server config backend = run{{title}}MiddlewareServer config requestMiddlewareId backend
+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 ()
+  => Config -> Middleware -> {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend{{#hasAuthMethods}} AuthServer{{/hasAuthMethods}} (ExceptT ServerError IO) -> m ()
-run{{title}}MiddlewareServer Config{..} middleware backend = do
+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}} :: {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}(ExceptT ServerError IO) -> Application
-serverWaiApplication{{title}} backend = serve (Proxy :: Proxy {{title}}API) (serverFromBackend backend)
+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

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

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

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

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                            (ServerError, serveWithContext, throwError)
-import           Servant.API
+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
+    =    Protected :> "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
+    :<|> Protected :> "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
+    :<|> Protected :> "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
+    :<|> Protected :> "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
+    :<|> Protected :> "pet" :> Capture "petId" Integer :> Verb 'GET 200 '[JSON] Pet -- 'getPetById' route
-    :<|> "pet" :> ReqBody '[JSON] Pet :> Verb 'PUT 200 '[JSON] NoContent -- 'updatePet' route
+    :<|> Protected :> "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
+    :<|> Protected :> "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" :> 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
+data OpenAPIPetstoreBackend a m = OpenAPIPetstoreBackend
-  { addPet :: Pet -> m NoContent{- ^  -}
+  { addPet :: a -> Pet -> m NoContent{- ^  -}
-  , deletePet :: Integer -> Maybe Text -> m NoContent{- ^  -}
+  , deletePet :: a -> Integer -> Maybe Text -> m NoContent{- ^  -}
-  , findPetsByStatus :: Maybe [Text] -> m [Pet]{- ^ Multiple status values can be provided with comma separated strings -}
+  , findPetsByStatus :: a -> 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. -}
+  , findPetsByTags :: a -> 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 -}
+  , getPetById :: a -> Integer -> m Pet{- ^ Returns a single pet -}
-  , updatePet :: Pet -> m NoContent{- ^  -}
+  , updatePet :: a -> Pet -> m NoContent{- ^  -}
-  , updatePetWithForm :: Integer -> FormUpdatePetWithForm -> m NoContent{- ^  -}
+  , updatePetWithForm :: a -> Integer -> FormUpdatePetWithForm -> m NoContent{- ^  -}
-  , uploadFile :: Integer -> FormUploadFile -> m ApiResponse{- ^  -}
+  , 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 ()
+  => Config -> OpenAPIPetstoreAuth -> OpenAPIPetstoreBackend AuthServer (ExceptT ServerError IO) -> m ()
-runOpenAPIPetstoreServer config backend = runOpenAPIPetstoreMiddlewareServer config requestMiddlewareId backend
+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 ()
+  => Config -> Middleware -> OpenAPIPetstoreAuth -> OpenAPIPetstoreBackend AuthServer (ExceptT ServerError IO) -> m ()
-runOpenAPIPetstoreMiddlewareServer Config{..} middleware backend = do
+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 :: OpenAPIPetstoreAuth -> OpenAPIPetstoreBackend AuthServer (ExceptT ServerError IO) -> Application
-serverWaiApplicationOpenAPIPetstore backend = serve (Proxy :: Proxy OpenAPIPetstoreAPI) (serverFromBackend backend)
+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

samples/server/petstore/haskell-servant/openapi-petstore.cabal

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