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

Go to download
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# 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
  ) 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           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           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)
import qualified Network.Wai.Handler.Warp           as Warp
import           Servant                            (ServerError, serve)
import           Servant.API
import           Servant.API.Verbs                  (StdMethod (..), Verb)
import           Servant.Client                     (ClientEnv, Scheme (Http), ClientError, client,
                                                     mkClientEnv, parseBaseUrl)
import           Servant.Client.Core                (baseUrlPort, baseUrlHost)
import           Servant.Client.Internal.HttpClient (ClientM (..))
import           Servant.Server                     (Handler (..), Application){{#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}}{{#hasMore}}
  , {{/hasMore}}{{/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


{{#apiInfo}}
-- | Servant type-level API, generated from the OpenAPI spec for {{title}}.
type {{title}}API
    =    {{#apis}}{{#operations}}{{#operation}}{{& vendorExtensions.x-route-type}} -- '{{operationId}}' route{{#hasMore}}
    :<|> {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}}
    :<|> {{/hasMore}}{{/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 m = {{title}}Backend
  { {{#apis}}{{#operations}}{{#operation}}{{operationId}} :: {{& vendorExtensions.x-client-type}}{- ^ {{& notes}} -}{{#hasMore}}
  , {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}}
  , {{/hasMore}}{{/apis}}
  }

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 {{title}}Client
create{{title}}Client = {{title}}Backend{..}
  where
    ({{#apis}}{{#operations}}{{#operation}}(coerce -> {{operationId}}){{#hasMore}} :<|>
     {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}} :<|>
     {{/hasMore}}{{/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 -> {{title}}Backend (ExceptT ServerError IO) -> m ()
run{{title}}Server config backend = run{{title}}MiddlewareServer config requestMiddlewareId 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
  url <- parseBaseUrl configUrl
  let warpSettings = Warp.defaultSettings
        & Warp.setPort (baseUrlPort url)
        & Warp.setHost (fromString $ baseUrlHost url)
  liftIO $ Warp.runSettings warpSettings $ middleware $ serve (Proxy :: Proxy {{title}}API) (serverFromBackend backend)
  where
    serverFromBackend {{title}}Backend{..} =
      ({{#apis}}{{#operations}}{{#operation}}coerce {{operationId}}{{#hasMore}} :<|>
       {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}} :<|>
       {{/hasMore}}{{/apis}}{{#serveStatic}} :<|>
       serveDirectoryFileServer "static"{{/serveStatic}})
{{/apiInfo}}