haskell-servant.API.mustache Maven / Gradle / Ivy

Go to download
Show more of this group Show more artifacts with this name
Show all versions of openapi-generator Show documentation
There is a newer version: 7.9.0
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{{#useCustomMonad}}
{-# LANGUAGE RankNTypes                 #-}
{{/useCustomMonad}}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE ViewPatterns               #-}
{-# OPTIONS_GHC
-fno-warn-unused-binds -fno-warn-unused-imports -freduction-depth=328 #-}

module {{title}}.API
  ( -- * Client and Server
    Config(..)
  , {{title}}Backend(..)
  , create{{title}}Client
  , run{{title}}Server
  , run{{title}}MiddlewareServer
  , run{{title}}Client
  , run{{title}}ClientWithManager
  , call{{title}}
  , {{title}}Client
  , {{title}}ClientError(..)
  -- ** Servant
  , {{title}}API
  -- ** Plain WAI Application
  , serverWaiApplication{{title}}
{{#hasAuthMethods}}
  -- ** Authentication
  , {{title}}Auth(..)
  , clientAuth
  , Protected
{{/hasAuthMethods}}
  ) where

import           {{title}}.Types

import           Control.Monad.Catch                (Exception, MonadThrow, throwM)
import           Control.Monad.Except               (ExceptT, runExceptT)
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Reader         (ReaderT (..))
import           Data.Aeson                         (Value)
import qualified Data.Aeson                         as Aeson
{{#authMethods}}
{{#isApiKey}}
import           Data.ByteString                    (ByteString)
{{/isApiKey}}
{{#isBasicBearer}}
import           Data.ByteString                    (ByteString)
{{/isBasicBearer}}
{{/authMethods}}
import qualified Data.ByteString.Lazy               as BSL
import           Data.Coerce                        (coerce)
import           Data.Data                          (Data)
import           Data.Function                      ((&))
import qualified Data.Map                           as Map
import           Data.Monoid                        ((<>))
import           Data.Proxy                         (Proxy (..))
import           Data.Set                           (Set)
import           Data.Text                          (Text)
import qualified Data.Text                          as T
import qualified Data.Text.Encoding                 as T
import           Data.Time
import           Data.UUID                          (UUID)
import           GHC.Exts                           (IsString (..))
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{{#hasAuthMethods}}, Request, requestHeaders{{/hasAuthMethods}})
import qualified Network.Wai.Handler.Warp           as Warp
{{#authMethods}}
{{#isBasicBearer}}
import           Network.Wai.Middleware.HttpAuth    (extractBearerAuth)
{{/isBasicBearer}}
{{#isBasicBasic}}
import           Network.Wai.Middleware.HttpAuth    (extractBasicAuth)
{{/isBasicBasic}}
{{/authMethods}}
import           Servant                            (ServerError, serveWithContextT{{#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{{#authMethods}}{{#isBasicBasic}}, basicAuthReq{{/isBasicBasic}}, AuthClientData, AuthenticatedRequest, addHeader, mkAuthenticatedRequest{{/authMethods}})
import           Servant.Client.Internal.HttpClient (ClientM (..))
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


{{#apiInfo}}{{#apis}}{{#operations}}{{#operation}}{{#hasFormParams}}
data {{vendorExtensions.x-form-name}} = {{vendorExtensions.x-form-name}}
  { {{#formParams}}{{vendorExtensions.x-form-prefix}}{{vendorExtensions.x-form-param-name}} :: {{dataType}}{{^-last}}
  , {{/-last}}{{/formParams}}
  } deriving (Show, Eq, Generic, Data)

instance FromForm {{vendorExtensions.x-form-name}}
instance ToForm {{vendorExtensions.x-form-name}}
{{/hasFormParams}}{{/operation}}{{/operations}}{{/apis}}{{/apiInfo}}

-- | List of elements parsed from a query.
newtype QueryList (p :: CollectionFormat) a = QueryList
  { fromQueryList :: [a]
  } deriving (Functor, Applicative, Monad, Foldable, Traversable)

-- | Formats in which a list can be encoded into a HTTP path.
data CollectionFormat
  = CommaSeparated -- ^ CSV format for multiple parameters.
  | SpaceSeparated -- ^ Also called "SSV"
  | TabSeparated -- ^ Also called "TSV"
  | PipeSeparated -- ^ `value1|value2|value2`
  | MultiParamArray -- ^ Using multiple GET parameters, e.g. `foo=bar&foo=baz`. Only for GET params.

instance FromHttpApiData a => FromHttpApiData (QueryList 'CommaSeparated a) where
  parseQueryParam = parseSeparatedQueryList ','

instance FromHttpApiData a => FromHttpApiData (QueryList 'TabSeparated a) where
  parseQueryParam = parseSeparatedQueryList '\t'

instance FromHttpApiData a => FromHttpApiData (QueryList 'SpaceSeparated a) where
  parseQueryParam = parseSeparatedQueryList ' '

instance FromHttpApiData a => FromHttpApiData (QueryList 'PipeSeparated a) where
  parseQueryParam = parseSeparatedQueryList '|'

instance FromHttpApiData a => FromHttpApiData (QueryList 'MultiParamArray a) where
  parseQueryParam = error "unimplemented FromHttpApiData for MultiParamArray collection format"

parseSeparatedQueryList :: FromHttpApiData a => Char -> Text -> Either Text (QueryList p a)
parseSeparatedQueryList char = fmap QueryList . mapM parseQueryParam . T.split (== char)

instance ToHttpApiData a => ToHttpApiData (QueryList 'CommaSeparated a) where
  toQueryParam = formatSeparatedQueryList ','

instance ToHttpApiData a => ToHttpApiData (QueryList 'TabSeparated a) where
  toQueryParam = formatSeparatedQueryList '\t'

instance ToHttpApiData a => ToHttpApiData (QueryList 'SpaceSeparated a) where
  toQueryParam = formatSeparatedQueryList ' '

instance ToHttpApiData a => ToHttpApiData (QueryList 'PipeSeparated a) where
  toQueryParam = formatSeparatedQueryList '|'

instance ToHttpApiData a => ToHttpApiData (QueryList 'MultiParamArray a) where
  toQueryParam = error "unimplemented ToHttpApiData for MultiParamArray collection format"

formatSeparatedQueryList :: ToHttpApiData a => Char ->  QueryList p a -> Text
formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList

newtype JSONQueryParam a = JSONQueryParam
  { fromJsonQueryParam :: a
  } deriving (Functor, Foldable, Traversable)

instance Aeson.ToJSON a => ToHttpApiData (JSONQueryParam a) where
  toQueryParam = T.decodeUtf8 . BSL.toStrict . Aeson.encode . fromJsonQueryParam

instance Aeson.FromJSON a => FromHttpApiData (JSONQueryParam a) where
  parseQueryParam = either (Left . T.pack) (Right . JSONQueryParam) . Aeson.eitherDecodeStrict . T.encodeUtf8


{{#apiInfo}}
-- | Servant type-level API, generated from the OpenAPI spec for {{title}}.
type {{title}}API
    =    {{#apis}}{{#operations}}{{#operation}}{{#hasAuthMethods}}Protected :> {{/hasAuthMethods}}{{& vendorExtensions.x-route-type}} -- '{{operationId}}' route{{^-last}}
    :<|> {{/-last}}{{/operation}}{{/operations}}{{^-last}}
    :<|> {{/-last}}{{/apis}}{{#serveStatic}}
    :<|> Raw{{/serveStatic}}
{{/apiInfo}}


-- | Server or client configuration, specifying the host and port to query or serve on.
data Config = Config
  { configUrl :: String  -- ^ scheme://hostname:port/path, e.g. "http://localhost:8080/"
  } deriving (Eq, Ord, Show, Read)


-- | Custom exception type for our errors.
newtype {{title}}ClientError = {{title}}ClientError ClientError
  deriving (Show, Exception)
-- | Configuration, specifying the full url of the service.


{{#apiInfo}}
-- | Backend for {{title}}.
-- 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{{#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

instance Applicative {{title}}Client where
  pure x = {{title}}Client (\_ -> pure x)
  ({{title}}Client f) <*> ({{title}}Client x) =
    {{title}}Client (\env -> f env <*> x env)

instance Monad {{title}}Client where
  ({{title}}Client a) >>= f =
    {{title}}Client (\env -> do
      value <- a env
      runClient (f value) env)

instance MonadIO {{title}}Client where
  liftIO io = {{title}}Client (\_ -> liftIO io)
{{/apiInfo}}

{{#apiInfo}}
create{{title}}Client :: {{title}}Backend{{#hasAuthMethods}} AuthClient{{/hasAuthMethods}} {{title}}Client
create{{title}}Client = {{title}}Backend{..}
  where
    ({{#apis}}{{#operations}}{{#operation}}(coerce -> {{operationId}}){{^-last}} :<|>
     {{/-last}}{{/operation}}{{/operations}}{{^-last}} :<|>
     {{/-last}}{{/apis}}{{#serveStatic}} :<|>
     _{{/serveStatic}}) = client (Proxy :: Proxy {{title}}API)

-- | Run requests in the {{title}}Client monad.
run{{title}}Client :: Config -> {{title}}Client a -> ExceptT ClientError IO a
run{{title}}Client clientConfig cl = do
  manager <- liftIO $ newManager tlsManagerSettings
  run{{title}}ClientWithManager manager clientConfig cl

-- | Run requests in the {{title}}Client monad using a custom manager.
run{{title}}ClientWithManager :: Manager -> Config -> {{title}}Client a -> ExceptT ClientError IO a
run{{title}}ClientWithManager manager Config{..} cl = do
  url <- parseBaseUrl configUrl
  runClient cl $ mkClientEnv manager url

-- | Like @runClient@, but returns the response or throws
--   a {{title}}ClientError
call{{title}}
  :: (MonadIO m, MonadThrow m)
  => ClientEnv -> {{title}}Client a -> m a
call{{title}} env f = do
  res <- liftIO $ runExceptT $ runClient f env
  case res of
    Left err       -> throwM ({{title}}ClientError err)
    Right response -> pure response
{{/apiInfo}}


{{#apiInfo}}
requestMiddlewareId :: Application -> Application
requestMiddlewareId a = a

-- | Run the {{title}} server at the provided host and port.
run{{title}}Server
  :: (MonadIO m, MonadThrow m)
  => Config -> {{#useCustomMonad}}(forall x . n x -> Handler x) -> {{/useCustomMonad}}{{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}{{^useCustomMonad}}(ExceptT ServerError IO){{/useCustomMonad}}{{#useCustomMonad}}n{{/useCustomMonad}} -> m ()
run{{title}}Server config {{#useCustomMonad}}nat {{/useCustomMonad}}{{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = run{{title}}MiddlewareServer config requestMiddlewareId {{#useCustomMonad}}nat {{/useCustomMonad}}{{#hasAuthMethods}}auth {{/hasAuthMethods}}backend

-- | Run the {{title}} server at the provided host and port.
run{{title}}MiddlewareServer
  :: (MonadIO m, MonadThrow m)
  => Config -> Middleware -> {{#useCustomMonad}}(forall x . n x -> Handler x) -> {{/useCustomMonad}}{{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend{{#hasAuthMethods}} AuthServer{{/hasAuthMethods}} {{^useCustomMonad}}(ExceptT ServerError IO){{/useCustomMonad}}{{#useCustomMonad}}n{{/useCustomMonad}} -> m ()
run{{title}}MiddlewareServer Config{..} middleware{{#useCustomMonad}} nat{{/useCustomMonad}}{{#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}}{{#useCustomMonad}} nat{{/useCustomMonad}}{{#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}} :: {{#useCustomMonad}}(forall x . n x -> Handler x) -> {{/useCustomMonad}}{{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}{{^useCustomMonad}}(ExceptT ServerError IO){{/useCustomMonad}}{{#useCustomMonad}}n{{/useCustomMonad}} -> Application
serverWaiApplication{{title}} {{#useCustomMonad}}nat {{/useCustomMonad}}{{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = serveWithContextT (Proxy :: Proxy {{title}}API) context {{^useCustomMonad}}id {{/useCustomMonad}}{{#useCustomMonad}}nat {{/useCustomMonad}}(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