Many resources are needed to download a project. Please understand that we have to compensate our server costs. Thank you in advance.
Project price only 1 $
You can buy this project and download/modify it how often you want.
haskell-servant.API.mustache Maven / Gradle / Ivy
{-# 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
