diff --git a/api-maker.cabal b/api-maker.cabal --- a/api-maker.cabal +++ b/api-maker.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 6a6fa3f0f379eade6020b6c856c601ee0501ed76dedb9ef47f70a2a62406e38c name: api-maker -version: 0.1.0.0 +version: 0.1.0.6 synopsis: Package to make APIs description: Please see the README on GitHub at category: Web @@ -32,6 +30,7 @@ ApiMaker Network.HTTP.ApiMaker.Class Network.HTTP.ApiMaker.HeaderContent + Network.HTTP.ApiMaker.Logging Network.HTTP.ApiMaker.Ops Network.HTTP.ApiMaker.SessionState other-modules: @@ -44,6 +43,8 @@ , base >=4.7 && <5 , bytestring , containers + , easy-logger >=0.1.0.6 + , http-api-data , http-client , http-client-tls , http-types @@ -58,7 +59,8 @@ ghc-options: -fno-warn-incomplete-patterns cpp-options: -DType=* if impl(ghc >= 8.6) - default-extensions: NoStarIsType + default-extensions: + NoStarIsType default-language: Haskell2010 test-suite api-maker-test @@ -75,6 +77,8 @@ , base >=4.7 && <5 , bytestring , containers + , easy-logger >=0.1.0.6 + , http-api-data , http-client , http-client-tls , http-types diff --git a/src/ApiMaker.hs b/src/ApiMaker.hs --- a/src/ApiMaker.hs +++ b/src/ApiMaker.hs @@ -3,6 +3,7 @@ ) where import Network.HTTP.ApiMaker.Class as R +import Network.HTTP.ApiMaker.Logging as R import Network.HTTP.ApiMaker.Ops as R import Network.HTTP.ApiMaker.HeaderContent as R diff --git a/src/Network/HTTP/ApiMaker/Class.hs b/src/Network/HTTP/ApiMaker/Class.hs --- a/src/Network/HTTP/ApiMaker/Class.hs +++ b/src/Network/HTTP/ApiMaker/Class.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -22,14 +23,19 @@ , SafeReqSt , SafeReq , SafeReqM (..) + , SafeException (..) + , throwUserException ) where +import Control.Exception import Control.Monad.Base import Control.Monad.Except import Control.Monad.Trans.Reader import Control.Monad.Trans.State +import Data.Dynamic import Data.Kind (Type) import Data.Proxy +import qualified Network.HTTP.Client as C import Network.HTTP.Req import Network.HTTP.ApiMaker.SessionState @@ -50,8 +56,10 @@ url :: cfg -> r -> Url 'Https -- (Protocol r) body :: cfg -> r -> Body r response :: cfg -> r -> Proxy (Response r) - option :: cfg -> r -> Option 'Https -- (Protocol r) - process :: (MonadHttp m, SessionState st) => cfg -> r -> Response r -> StateT st m (Output r) + option :: cfg -> r -> IO (Option 'Https) -- (Protocol r) + requestModifier :: cfg -> r -> C.Request -> IO C.Request + requestModifier _ _ = return + process :: (MonadHttp m, MonadError SafeException m, SessionState st) => cfg -> r -> Response r -> StateT st m (Output r) -- Type safe request @@ -63,12 +71,27 @@ , apiConfig :: cfg } +-- | Safe request monad with customized session state `sessionState`, Config `cfg` and result `a`. type SafeReqSt sessionState cfg a = StateT sessionState (SafeReqM cfg) a + +-- | Safe request monad with predetermined @Session@, config `cfg` and result `a`. type SafeReq cfg a = SafeReqSt Session cfg a + +data SafeException + = ReqException HttpException + | forall e. (Typeable e, Exception e) => + SafeUserException e + +instance Exception SafeException +instance Show SafeException where + show (ReqException e) = show e + show (SafeUserException e) = show e + + -- | Safe request, e.g. all errors are caught and tured into exceptions. newtype SafeReqM cfg a = - SafeReqM (ExceptT HttpException (ReaderT (Config cfg) IO) a) + SafeReqM (ExceptT SafeException (ReaderT (Config cfg) IO) a) deriving (Functor, Applicative, Monad, MonadIO) askConfig :: SafeReqM cfg (Config cfg) @@ -81,15 +104,30 @@ liftBase = liftIO instance MonadHttp (SafeReqM cfg) where - handleHttpException = SafeReqM . throwError + handleHttpException = SafeReqM . throwError . ReqException getHttpConfig = httpConfig <$> SafeReqM (lift ask) +instance MonadError SafeException (SafeReqM cfg) where + throwError = SafeReqM . throwError . SafeUserException + catchError c h = do + cfg <- askConfig + res <- runSafeReqM cfg c + case res of + Left ex -> h ex + Right{} -> SafeReqM $ ExceptT $ return res + + +-- | Throw an Exception to the `SafeReqM` Monad. +throwUserException :: (MonadError SafeException m, Exception e) => e -> m a +throwUserException = throwError . SafeUserException + + -- | Safely run the request monad. runSafeReqM :: MonadIO m => Config cfg -- ^ Config including 'HttpConfig' to use -> SafeReqM cfg a -- ^ Computation to run - -> m (Either HttpException a) + -> m (Either SafeException a) runSafeReqM config (SafeReqM m) = liftIO (runReaderT (runExceptT m) config) diff --git a/src/Network/HTTP/ApiMaker/Logging.hs b/src/Network/HTTP/ApiMaker/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/ApiMaker/Logging.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module Network.HTTP.ApiMaker.Logging + ( enableRequestLogging + , disableRequestLogging + ) where + +import EasyLogger + +enableRequestLogging :: LogDestination -> IO () +enableRequestLogging = $(initLogger) + +disableRequestLogging :: IO () +disableRequestLogging = $(finalizeLogger) + + diff --git a/src/Network/HTTP/ApiMaker/Ops.hs b/src/Network/HTTP/ApiMaker/Ops.hs --- a/src/Network/HTTP/ApiMaker/Ops.hs +++ b/src/Network/HTTP/ApiMaker/Ops.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Network.HTTP.ApiMaker.Ops ( mkReq , runRequests @@ -10,6 +12,7 @@ , runReqWithParamsM , runSessReqM , runSessReqWithParamsM + , maybeQueryParam ) where import Control.Lens @@ -17,26 +20,29 @@ import Control.Monad.Trans.State import qualified Data.ByteString.Char8 as B import Data.List (find) +import qualified Data.Text as T +import EasyLogger import qualified Network.HTTP.Client as C import Network.HTTP.Req +import Web.HttpApiData import Network.HTTP.ApiMaker.Class -- | Prepare to run requests. -runReqM :: (MonadIO m) => SafeReqM () a -> m (Either HttpException a) +runReqM :: (MonadIO m) => SafeReqM () a -> m (Either SafeException a) runReqM = runSafeReqM (Config defaultHttpConfig [] ()) -- | Prepare to run requests with addional header options. -runReqWithParamsM :: (MonadIO m) => [Option 'Https] -> SafeReqM () a -> m (Either HttpException a) +runReqWithParamsM :: (MonadIO m) => [Option 'Https] -> SafeReqM () a -> m (Either SafeException a) runReqWithParamsM params = runSafeReqM (Config defaultHttpConfig params ()) -- | Prepare to run request with config. -runSessReqM :: (MonadIO m) => cfg -> SafeReqM cfg a -> m (Either HttpException a) +runSessReqM :: (MonadIO m) => cfg -> SafeReqM cfg a -> m (Either SafeException a) runSessReqM cfg = runSafeReqM (Config defaultHttpConfig [] cfg) -- | Prepare to run request with config and additional header options. -runSessReqWithParamsM :: (MonadIO m) => [Option 'Https] -> cfg -> SafeReqM cfg a -> m (Either HttpException a) +runSessReqWithParamsM :: (MonadIO m) => [Option 'Https] -> cfg -> SafeReqM cfg a -> m (Either SafeException a) runSessReqWithParamsM params cfg = runSafeReqM (Config defaultHttpConfig params cfg) @@ -57,16 +63,20 @@ session <- get cfg <- lift askConfig apiCfg <- lift askApiConfig - - let ops = option apiCfg r <> mkSessionOps session <> mconcat (apiDefaultParameters cfg) - -- liftIO $ putStrLn $ "Running a request to " <> show (url r) - resp <- lift $ req (method apiCfg r) (url apiCfg r) (body apiCfg r) (response apiCfg r) ops + opsReq <- liftIO $ option apiCfg r + let ops = opsReq <> mkSessionOps session <> mconcat (apiDefaultParameters cfg) + let logging request' = do + request <- liftIO $ requestModifier apiCfg r request' + liftIO $ $(logInfo) $ "API Request: " <> T.pack (show request) + return request + resp <- lift $ reqCb (method apiCfg r) (url apiCfg r) (body apiCfg r) (response apiCfg r) ops logging updateSession r resp process apiCfg r resp where mkSessionOps session = maybe mempty cookieJar (session ^. cookieJarData) <> header "Cookie" (B.intercalate ";" (mkSessionCookie session ++ mkCsrfCookie session)) <> mkCsrfHeader session + updateSession :: (Request cfg request, SessionState st) => request -> Response request -> SafeReqSt st cfg () updateSession _ resp = let cookies = C.destroyCookieJar $ responseCookieJar resp @@ -92,3 +102,11 @@ case st ^. csrfToken of Nothing -> mempty Just csrf -> header "X-XSRF-TOKEN" csrf + + +-- | Create a request parameter only if the value is @Just@. For @Nothing@ the parameter is not present at all in the request. +maybeQueryParam :: (Monoid param, QueryParam param, ToHttpApiData a) => T.Text -> Maybe a -> param +maybeQueryParam _ Nothing = mempty +maybeQueryParam n (Just x) = n =: x + +