2017-09-06 00:33:48 +08:00

318 lines
12 KiB
Plaintext

{-|
Module : {{title}}.Client
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
module {{title}}.Client where
import {{title}}.Model
import {{title}}.API
import {{title}}.MimeTypes
import qualified Control.Monad.IO.Class as P
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import qualified Data.Proxy as P (Proxy(..))
import Data.Function ((&))
import Data.Monoid ((<>))
import Data.Text (Text)
import GHC.Exts (IsString(..))
import Web.FormUrlEncoded as WH
import Web.HttpApiData as WH
import Control.Monad.Catch (MonadThrow)
import qualified Control.Monad.Logger as LG
import qualified Data.Time as TI
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Text.Printf as T
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as BCL
import qualified Data.ByteString.Builder as BB
import qualified Network.HTTP.Client as NH
import qualified Network.HTTP.Client.TLS as NH
import qualified Network.HTTP.Client.MultipartFormData as NH
import qualified Network.HTTP.Types.Method as NH
import qualified Network.HTTP.Types as NH
import qualified Network.HTTP.Types.URI as NH
import qualified Control.Exception.Safe as E
-- * Config
-- |
data {{configType}} = {{configType}}
{ configHost :: BCL.ByteString -- ^ host supplied in the Request
, configUserAgent :: Text -- ^ user-agent supplied in the Request
, configExecLoggingT :: ExecLoggingT -- ^ Run a block using a MonadLogger instance
, configLoggingFilter :: LG.LogSource -> LG.LogLevel -> Bool -- ^ Only log messages passing the given predicate function.
}
-- | display the config
instance Show {{configType}} where
show c =
T.printf
"{ configHost = %v, configUserAgent = %v, ..}"
(show (configHost c))
(show (configUserAgent c))
-- | constructs a default {{configType}}
--
-- configHost:
--
-- @{{basePath}}@
--
-- configUserAgent:
--
-- @"{{#httpUserAgent}}{{{.}}}{{/httpUserAgent}}{{^httpUserAgent}}{{{artifactId}}}/{{{artifactVersion}}}{{/httpUserAgent}}"@
--
-- configExecLoggingT: 'runNullLoggingT'
--
-- configLoggingFilter: 'infoLevelFilter'
newConfig :: {{configType}}
newConfig =
{{configType}}
{ configHost = "{{basePath}}"
, configUserAgent = "{{#httpUserAgent}}{{{.}}}{{/httpUserAgent}}{{^httpUserAgent}}{{{artifactId}}}/{{{artifactVersion}}}{{/httpUserAgent}}"
, configExecLoggingT = runNullLoggingT
, configLoggingFilter = infoLevelFilter
}
-- | updates the config to use a MonadLogger instance which prints to stdout.
withStdoutLogging :: {{configType}} -> {{configType}}
withStdoutLogging p = p { configExecLoggingT = LG.runStdoutLoggingT}
-- | updates the config to use a MonadLogger instance which prints to stderr.
withStderrLogging :: {{configType}} -> {{configType}}
withStderrLogging p = p { configExecLoggingT = LG.runStderrLoggingT}
-- | updates the config to disable logging
withNoLogging :: {{configType}} -> {{configType}}
withNoLogging p = p { configExecLoggingT = runNullLoggingT}
-- * Dispatch
-- ** Lbs
-- | send a request returning the raw http response
dispatchLbs
:: (Produces req accept, MimeType contentType)
=> NH.Manager -- ^ http-client Connection manager
-> {{configType}} -- ^ config
-> {{requestType}} req contentType res -- ^ request
-> accept -- ^ "accept" 'MimeType'
-> IO (NH.Response BCL.ByteString) -- ^ response
dispatchLbs manager config request accept = do
initReq <- _toInitRequest config request accept
dispatchInitUnsafe manager config initReq
-- ** Mime
-- | pair of decoded http body and http response
data MimeResult res =
MimeResult { mimeResult :: Either MimeError res -- ^ decoded http body
, mimeResultResponse :: NH.Response BCL.ByteString -- ^ http response
}
deriving (Show, Functor, Foldable, Traversable)
-- | pair of unrender/parser error and http response
data MimeError =
MimeError {
mimeError :: String -- ^ unrender/parser error
, mimeErrorResponse :: NH.Response BCL.ByteString -- ^ http response
} deriving (Eq, Show)
-- | send a request returning the 'MimeResult'
dispatchMime
:: (Produces req accept, MimeUnrender accept res, MimeType contentType)
=> NH.Manager -- ^ http-client Connection manager
-> {{configType}} -- ^ config
-> {{requestType}} req contentType res -- ^ request
-> accept -- ^ "accept" 'MimeType'
-> IO (MimeResult res) -- ^ response
dispatchMime manager config request accept = do
httpResponse <- dispatchLbs manager config request accept
parsedResult <-
runExceptionLoggingT "Client" config $
do case mimeUnrender' accept (NH.responseBody httpResponse) of
Left s -> do
logNST LG.LevelError "Client" (T.pack s)
pure (Left (MimeError s httpResponse))
Right r -> pure (Right r)
return (MimeResult parsedResult httpResponse)
-- | like 'dispatchMime', but only returns the decoded http body
dispatchMime'
:: (Produces req accept, MimeUnrender accept res, MimeType contentType)
=> NH.Manager -- ^ http-client Connection manager
-> {{configType}} -- ^ config
-> {{requestType}} req contentType res -- ^ request
-> accept -- ^ "accept" 'MimeType'
-> IO (Either MimeError res) -- ^ response
dispatchMime' manager config request accept = do
MimeResult parsedResult _ <- dispatchMime manager config request accept
return parsedResult
-- ** Unsafe
-- | like 'dispatchReqLbs', but does not validate the operation is a 'Producer' of the "accept" 'MimeType'. (Useful if the server's response is undocumented)
dispatchLbsUnsafe
:: (MimeType accept, MimeType contentType)
=> NH.Manager -- ^ http-client Connection manager
-> {{configType}} -- ^ config
-> {{requestType}} req contentType res -- ^ request
-> accept -- ^ "accept" 'MimeType'
-> IO (NH.Response BCL.ByteString) -- ^ response
dispatchLbsUnsafe manager config request accept = do
initReq <- _toInitRequest config request accept
dispatchInitUnsafe manager config initReq
-- | dispatch an InitRequest
dispatchInitUnsafe
:: NH.Manager -- ^ http-client Connection manager
-> {{configType}} -- ^ config
-> InitRequest req contentType res accept -- ^ init request
-> IO (NH.Response BCL.ByteString) -- ^ response
dispatchInitUnsafe manager config (InitRequest req) = do
runExceptionLoggingT logSrc config $
do logNST LG.LevelInfo logSrc requestLogMsg
logNST LG.LevelDebug logSrc requestDbgLogMsg
res <- P.liftIO $ NH.httpLbs req manager
logNST LG.LevelInfo logSrc (responseLogMsg res)
logNST LG.LevelDebug logSrc ((T.pack . show) res)
return res
where
logSrc = "Client"
endpoint =
T.pack $
BC.unpack $
NH.method req <> " " <> NH.host req <> NH.path req <> NH.queryString req
requestLogMsg = "REQ:" <> endpoint
requestDbgLogMsg =
"Headers=" <> (T.pack . show) (NH.requestHeaders req) <> " Body=" <>
(case NH.requestBody req of
NH.RequestBodyLBS xs -> T.decodeUtf8 (BL.toStrict xs)
_ -> "<RequestBody>")
responseStatusCode = (T.pack . show) . NH.statusCode . NH.responseStatus
responseLogMsg res =
"RES:statusCode=" <> responseStatusCode res <> " (" <> endpoint <> ")"
-- * InitRequest
-- | wraps an http-client 'Request' with request/response type parameters
newtype InitRequest req contentType res accept = InitRequest
{ unInitRequest :: NH.Request
} deriving (Show)
-- | Build an http-client 'Request' record from the supplied config and request
_toInitRequest
:: (MimeType accept, MimeType contentType)
=> {{configType}} -- ^ config
-> {{requestType}} req contentType res -- ^ request
-> accept -- ^ "accept" 'MimeType'
-> IO (InitRequest req contentType res accept) -- ^ initialized request
_toInitRequest config req0 accept = do
parsedReq <- NH.parseRequest $ BCL.unpack $ BCL.append (configHost config) (BCL.concat (urlPath req0))
let req1 = _setAcceptHeader req0 accept & _setContentTypeHeader
reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders (params req1)
reqQuery = NH.renderQuery True (paramsQuery (params req1))
pReq = parsedReq { NH.method = (rMethod req1)
, NH.requestHeaders = reqHeaders
, NH.queryString = reqQuery
}
outReq <- case paramsBody (params req1) of
ParamBodyNone -> pure (pReq { NH.requestBody = mempty })
ParamBodyB bs -> pure (pReq { NH.requestBody = NH.RequestBodyBS bs })
ParamBodyBL bl -> pure (pReq { NH.requestBody = NH.RequestBodyLBS bl })
ParamBodyFormUrlEncoded form -> pure (pReq { NH.requestBody = NH.RequestBodyLBS (WH.urlEncodeForm form) })
ParamBodyMultipartFormData parts -> NH.formDataBody parts pReq
pure (InitRequest outReq)
-- | modify the underlying Request
modifyInitRequest :: InitRequest req contentType res accept -> (NH.Request -> NH.Request) -> InitRequest req contentType res accept
modifyInitRequest (InitRequest req) f = InitRequest (f req)
-- | modify the underlying Request (monadic)
modifyInitRequestM :: Monad m => InitRequest req contentType res accept -> (NH.Request -> m NH.Request) -> m (InitRequest req contentType res accept)
modifyInitRequestM (InitRequest req) f = fmap InitRequest (f req)
-- * Logging
-- | A block using a MonadLogger instance
type ExecLoggingT = forall m. P.MonadIO m =>
forall a. LG.LoggingT m a -> m a
-- ** Null Logger
-- | a logger which disables logging
nullLogger :: LG.Loc -> LG.LogSource -> LG.LogLevel -> LG.LogStr -> IO ()
nullLogger _ _ _ _ = return ()
-- | run the monad transformer that disables logging
runNullLoggingT :: LG.LoggingT m a -> m a
runNullLoggingT = (`LG.runLoggingT` nullLogger)
-- ** Logging Filters
-- | a log filter that uses 'LevelError' as the minimum logging level
errorLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool
errorLevelFilter = minLevelFilter LG.LevelError
-- | a log filter that uses 'LevelInfo' as the minimum logging level
infoLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool
infoLevelFilter = minLevelFilter LG.LevelInfo
-- | a log filter that uses 'LevelDebug' as the minimum logging level
debugLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool
debugLevelFilter = minLevelFilter LG.LevelDebug
minLevelFilter :: LG.LogLevel -> LG.LogSource -> LG.LogLevel -> Bool
minLevelFilter l _ l' = l' >= l
-- ** Logging
-- | Log a message using the current time
logNST :: (P.MonadIO m, LG.MonadLogger m) => LG.LogLevel -> Text -> Text -> m ()
logNST level src msg = do
now <- P.liftIO (formatTimeLog <$> TI.getCurrentTime)
LG.logOtherNS sourceLog level (now <> " " <> msg)
where
sourceLog = "{{title}}/" <> src
formatTimeLog =
T.pack . TI.formatTime TI.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Z"
-- | re-throws exceptions after logging them
logExceptions
:: (LG.MonadLogger m, E.MonadCatch m, P.MonadIO m)
=> Text -> m a -> m a
logExceptions src =
E.handle
(\(e :: E.SomeException) -> do
logNST LG.LevelError src ((T.pack . show) e)
E.throw e)
-- | Run a block using the configured MonadLogger instance
runLoggingT :: {{configType}} -> ExecLoggingT
runLoggingT config =
configExecLoggingT config . LG.filterLogger (configLoggingFilter config)
-- | Run a block using the configured MonadLogger instance (logs exceptions)
runExceptionLoggingT
:: (E.MonadCatch m, P.MonadIO m)
=> T.Text -> {{configType}} -> LG.LoggingT m a -> m a
runExceptionLoggingT logSrc config = runLoggingT config . logExceptions logSrc