servant-util 0.1.0.2 → 0.2
raw patch · 12 files changed
+440/−80 lines, 12 filesdep +constraints
Dependencies added: constraints
Files
- CHANGES.md +8/−0
- examples/Books.hs +1/−1
- servant-util.cabal +6/−2
- src/Servant/Util/Combinators/ErrorResponses.hs +3/−3
- src/Servant/Util/Combinators/Filtering/Logging.hs +3/−3
- src/Servant/Util/Combinators/Logging.hs +210/−58
- src/Servant/Util/Combinators/Pagination.hs +3/−3
- src/Servant/Util/Combinators/Sorting/Logging.hs +3/−3
- src/Servant/Util/Combinators/Tag.hs +6/−6
- src/Servant/Util/Common/PolyKinds.hs +41/−0
- tests/Test/Servant/Helpers.hs +24/−1
- tests/Test/Servant/Logging/ImplSpec.hs +132/−0
CHANGES.md view
@@ -1,6 +1,14 @@ Unreleased ===== +0.2+=====++* Added logging modifiers to API.+ In log config, printing function now accepts one more argument+ (feel free to ignore it by default).+ `HasLoggingServer` obtained `lcontext` type argument, constraints has changed in some instances.+ 0.1.0 =====
examples/Books.hs view
@@ -101,4 +101,4 @@ serve @(SwaggerSchemaUI "swagger-ui" "swagger.json" :<|> api) Proxy (swaggerSchemaUIServer swagger :<|> booksHandlers) where- loggingConfig = ServantLogConfig putTextLn+ loggingConfig = ServantLogConfig $ \_ -> putTextLn
servant-util.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 162d0c665afc7e688062cc1007aa9fbc6aa2a300ac096144fffd1cd576b6fee1+-- hash: 936cf3a2b61cfa35f3cca3316f3946e3e890066234f3e915b0190b1b41bb84a6 name: servant-util-version: 0.1.0.2+version: 0.2 synopsis: Servant servers utilities. description: Basement for common Servant combinators like filtering, sorting, pagination and semantical logging. category: Servant, Web@@ -79,6 +79,7 @@ QuickCheck , aeson , base >=4.7 && <5+ , constraints , containers , data-default , fmt@@ -119,6 +120,7 @@ QuickCheck , aeson , base >=4.7 && <5+ , constraints , containers , data-default , fmt@@ -158,6 +160,7 @@ Test.Servant.Filtering.ImplSpec Test.Servant.Filtering.LikeSpec Test.Servant.Helpers+ Test.Servant.Logging.ImplSpec Test.Servant.Pagination.ImplSpec Test.Servant.Sorting.ImplSpec Paths_servant_util@@ -171,6 +174,7 @@ QuickCheck , aeson , base >=4.7 && <5+ , constraints , containers , data-default , fmt
src/Servant/Util/Combinators/ErrorResponses.hs view
@@ -82,9 +82,9 @@ clientWithRoute pm _ = clientWithRoute pm (Proxy @subApi) hoistClientMonad pm _ hst = hoistClientMonad pm (Proxy @subApi) hst -instance HasLoggingServer config subApi ctx =>- HasLoggingServer config (ErrorResponses errors :> subApi) ctx where- routeWithLog = inRouteServer @(ErrorResponses errors :> LoggingApiRec config subApi) route id+instance HasLoggingServer config lcontext subApi ctx =>+ HasLoggingServer config lcontext (ErrorResponses errors :> subApi) ctx where+ routeWithLog = inRouteServer @(ErrorResponses errors :> LoggingApiRec config lcontext subApi) route id class KnownErrorCodes (errors :: [ErrorDesc]) where
src/Servant/Util/Combinators/Filtering/Logging.hs view
@@ -59,14 +59,14 @@ buildSomeFilter :: BuildSomeFilter params => SomeFilter params -> Builder buildSomeFilter sf = buildSomeFilter' sf ?: error "Failed to build some filter" -instance ( HasLoggingServer config subApi ctx+instance ( HasLoggingServer config lcontext subApi ctx , AreFilteringParams params , ReifyParamsNames params , BuildSomeFilter params ) =>- HasLoggingServer config (FilteringParams params :> subApi) ctx where+ HasLoggingServer config lcontext (FilteringParams params :> subApi) ctx where routeWithLog =- inRouteServer @(FilteringParams params :> LoggingApiRec config subApi) route $+ inRouteServer @(FilteringParams params :> LoggingApiRec config lcontext subApi) route $ \(paramsInfo, handler) filtering@(FilteringSpec params) -> let paramLog | null params = "no filters"
src/Servant/Util/Combinators/Logging.hs view
@@ -5,9 +5,18 @@ ( -- * Automatic requests logging LoggingApi , LoggingApiRec+ , LoggingMod+ , LoggingLevel+ , LoggingRequestsEnabled+ , LoggingRequestsDisabled+ , LoggingResponsesEnabled+ , LoggingResponsesDisabled+ , LoggingDisabled+ , LogContext (..) , HasLoggingServer (..) , ServantLogConfig (..) , ForResponseLog (..)+ , BuildableForResponseIfNecessary , buildListForResponse , buildForResponse , ApiHasArgClass (..)@@ -20,6 +29,7 @@ import Universum import Control.Monad.Error.Class (catchError, throwError)+import Data.Constraint (Dict (..)) import Data.Default (Default (..)) import Data.Reflection (Reifies (..), reify) import Data.Swagger (Swagger)@@ -30,7 +40,9 @@ import Servant.API (Capture, Description, NoContent, NoContentVerb, QueryFlag, QueryParam', Raw, ReflectMethod (..), ReqBody, SBoolI, Summary, Verb, (:<|>) (..), (:>)) import Servant.API.Modifiers (FoldRequired, foldRequiredArgument)+import Servant.Client (HasClient (..)) import Servant.Server (Handler (..), HasServer (..), Server, ServerError (..))+import Servant.Swagger (HasSwagger (..)) import Servant.Swagger.UI.Core (SwaggerUiHtml) import System.Console.Pretty (Color (..), Style (..), color, style) @@ -58,10 +70,108 @@ data LoggingApi config api -- | Helper to traverse servant api and apply logging.-data LoggingApiRec config api+data LoggingApiRec config (lcontext :: LoggingContext) api +-- | Logging context at type-level, accumulates all the 'LoggingMod' modifiers.+data LoggingContext = LoggingContext+ (Maybe Nat) -- ^ Recommended logging level.+ Bool -- ^ Whether requests are logged.+ Bool -- ^ Whether responses are logged.++type family EmptyLoggingContext :: LoggingContext where+ EmptyLoggingContext = 'LoggingContext 'Nothing 'True 'True++type family LcResponsesEnabled (lcontext :: LoggingContext) :: Bool where+ LcResponsesEnabled ('LoggingContext _ _ flag) = flag++-- | Require 'Buildable' for the response type, but only if logging context+-- assumes that the response will indeed be built.+type BuildableForResponseIfNecessary lcontext resp =+ ( If (LcResponsesEnabled lcontext)+ (Buildable (ForResponseLog resp))+ (() :: Constraint)+ , Demote (LcResponsesEnabled lcontext)+ )++-- | Servant combinator that changes how the logs will be printed for the+-- affected endpoints.+--+-- This is an internal thing, we export aliases.+data LoggingMod (mod :: LoggingModKind)++-- | How to change the logging of the endpoints.+data LoggingModKind+ = LMLoggingLevel Nat+ | LMRequestsLogged Bool+ | LMResponsesLogged Bool+ | LMLoggingDisabled++-- | Combinator to set the logging level within the endpoints.+type LoggingLevel lvl = LoggingMod ('LMLoggingLevel lvl)++-- | Combinator to disable logging of requests.+type LoggingRequestsDisabled = LoggingMod ('LMRequestsLogged 'False)++-- | Combinator to enable logging of requests back for a narrower+-- set of entrypoints.+type LoggingRequestsEnabled = LoggingMod ('LMRequestsLogged 'True)++-- | Combinator to disable logging of responses.+type LoggingResponsesDisabled = LoggingMod ('LMResponsesLogged 'False)++-- | Combinator to enable logging of responses.+type LoggingResponsesEnabled = LoggingMod ('LMResponsesLogged 'True)++-- | Combinator to disable all the logging.+--+-- This works similarly to other similar combinators and can be partially+-- or fully reverted with 'LoggingRequestsDisabled' or 'LoggingResponsesDisabled'.+type LoggingDisabled = LoggingMod 'LMLoggingDisabled++-- | Full context of the logging action.+data LogFullContext = LogFullContext+ { lcRecommendedLevel :: Maybe Natural+ -- ^ Logging level specified by 'LoggingLevel' combinator.+ -- Will be provided to the user.+ , lcRequestsEnabled :: Bool+ -- ^ Whether to log requests.+ -- Accounted automatically.+ , lcResponsesEnabled :: Bool+ -- ^ Whether to log responses.+ -- Accounted automatically.+ } deriving (Show)++type instance Demoted LoggingContext = LogFullContext+instance ( ctx ~ 'LoggingContext lvl req resp+ , Demote lvl+ , Demote req+ , Demote resp+ ) => Demote ctx where+ demote _ = LogFullContext+ { lcRecommendedLevel = demote (Proxy @lvl)+ , lcRequestsEnabled = demote (Proxy @req)+ , lcResponsesEnabled = demote (Proxy @resp)+ }++type family ApplyLoggingMod (lcontext :: LoggingContext) (mod :: LoggingModKind) where+ ApplyLoggingMod ('LoggingContext _ req resp) ('LMLoggingLevel lvl) =+ 'LoggingContext ('Just lvl) req resp+ ApplyLoggingMod ('LoggingContext mlvl _ resp) ('LMRequestsLogged req) =+ 'LoggingContext mlvl req resp+ ApplyLoggingMod ('LoggingContext mlvl req _) ('LMResponsesLogged resp) =+ 'LoggingContext mlvl req resp+ ApplyLoggingMod ('LoggingContext mlvl _ _) 'LMLoggingDisabled =+ 'LoggingContext mlvl 'False 'False++-- | Logging context that will be supplied to the user.+newtype LogContext = LogContext+ { lecRecommendedLevel :: Maybe Natural+ -- ^ Logging level specified by 'LoggingLevel' combinator.+ } deriving (Show, Eq)++-- | Logging configuration specified at server start. newtype ServantLogConfig = ServantLogConfig- { clcLog :: Text -> IO ()+ { clcLog :: LogContext -> Text -> IO () } dullColor :: Color -> Text -> Text@@ -115,13 +225,13 @@ buildForResponse :: Buildable a => ForResponseLog a -> Builder buildForResponse = build . unForResponseLog -instance ( HasServer (LoggingApiRec config api) ctx+instance ( HasServer (LoggingApiRec config EmptyLoggingContext api) ctx , HasServer api ctx ) => HasServer (LoggingApi config api) ctx where type ServerT (LoggingApi config api) m = ServerT api m - route = inRouteServer @(LoggingApiRec config api) route+ route = inRouteServer @(LoggingApiRec config EmptyLoggingContext api) route (def, ) hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)@@ -129,16 +239,16 @@ -- | Version of 'HasServer' which is assumed to perform logging. -- It's helpful because 'ServerT (LoggingApi ...)' is already defined for us -- in actual 'HasServer' instance once and forever.-class HasServer api ctx => HasLoggingServer config api ctx where+class HasServer api ctx => HasLoggingServer config (lcontext :: LoggingContext) api ctx where routeWithLog- :: Proxy (LoggingApiRec config api)+ :: Proxy (LoggingApiRec config lcontext api) -> SI.Context ctx- -> SI.Delayed env (Server (LoggingApiRec config api))+ -> SI.Delayed env (Server (LoggingApiRec config lcontext api)) -> SI.Router env -instance HasLoggingServer config api ctx =>- HasServer (LoggingApiRec config api) ctx where- type ServerT (LoggingApiRec config api) m =+instance HasLoggingServer config lcontext api ctx =>+ HasServer (LoggingApiRec config lcontext api) ctx where+ type ServerT (LoggingApiRec config lcontext api) m = (ApiParamsLogInfo, ServerT api m) route = routeWithLog@@ -146,24 +256,24 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt <$> s -instance ( HasLoggingServer config api1 ctx- , HasLoggingServer config api2 ctx+instance ( HasLoggingServer config lcontext api1 ctx+ , HasLoggingServer config lcontext api2 ctx ) =>- HasLoggingServer config (api1 :<|> api2) ctx where+ HasLoggingServer config lcontext (api1 :<|> api2) ctx where routeWithLog = inRouteServer- @(LoggingApiRec config api1 :<|> LoggingApiRec config api2)+ @(LoggingApiRec config lcontext api1 :<|> LoggingApiRec config lcontext api2) route $ \(paramsInfo, f1 :<|> f2) -> let paramsInfo' = setInPrefix paramsInfo in (paramsInfo', f1) :<|> (paramsInfo', f2) instance ( KnownSymbol path- , HasLoggingServer config res ctx+ , HasLoggingServer config lcontext res ctx ) =>- HasLoggingServer config (path :> res) ctx where+ HasLoggingServer config lcontext (path :> res) ctx where routeWithLog =- inRouteServer @(path :> LoggingApiRec config res) route $+ inRouteServer @(path :> LoggingApiRec config lcontext res) route $ first updateParamsInfo where updateParamsInfo =@@ -205,20 +315,20 @@ type ApiArgToLog (QueryFlag cs) = Bool paramRouteWithLog- :: forall config api subApi res ctx env.+ :: forall config lcontext api subApi res ctx env. ( api ~ (subApi :> res)- , HasServer (subApi :> LoggingApiRec config res) ctx+ , HasServer (subApi :> LoggingApiRec config lcontext res) ctx , ApiHasArg subApi res- , ApiHasArg subApi (LoggingApiRec config res)+ , ApiHasArg subApi (LoggingApiRec config lcontext res) , ApiCanLogArg subApi , Buildable (ApiArgToLog subApi) )- => Proxy (LoggingApiRec config api)+ => Proxy (LoggingApiRec config lcontext api) -> SI.Context ctx- -> SI.Delayed env (Server (LoggingApiRec config api))+ -> SI.Delayed env (Server (LoggingApiRec config lcontext api)) -> SI.Router env paramRouteWithLog =- inRouteServer @(subApi :> LoggingApiRec config res) route $+ inRouteServer @(subApi :> LoggingApiRec config lcontext res) route $ \(paramsInfo, f) a -> (a `updateParamsInfo` paramsInfo, f a) where updateParamsInfo a =@@ -228,30 +338,35 @@ in addParamLogInfo paramInfo . setInPrefix instance ( HasServer (subApi :> res) ctx- , HasServer (subApi :> LoggingApiRec config res) ctx+ , HasServer (subApi :> LoggingApiRec config lcontext res) ctx , ApiHasArg subApi res- , ApiHasArg subApi (LoggingApiRec config res)+ , ApiHasArg subApi (LoggingApiRec config lcontext res) , ApiCanLogArg subApi , Buildable (ApiArgToLog subApi) , subApi ~ apiType (a :: Type) ) =>- HasLoggingServer config (apiType a :> res) ctx where+ HasLoggingServer config lcontext (apiType a :> res) ctx where routeWithLog = paramRouteWithLog -instance ( HasLoggingServer config res ctx+instance ( HasLoggingServer config lcontext res ctx , KnownSymbol s ) =>- HasLoggingServer config (QueryFlag s :> res) ctx where+ HasLoggingServer config lcontext (QueryFlag s :> res) ctx where routeWithLog = paramRouteWithLog -instance HasLoggingServer config res ctx =>- HasLoggingServer config (Summary s :> res) ctx where- routeWithLog = inRouteServer @(Summary s :> LoggingApiRec config res) route id+instance HasLoggingServer config lcontext res ctx =>+ HasLoggingServer config lcontext (Summary s :> res) ctx where+ routeWithLog = inRouteServer @(Summary s :> LoggingApiRec config lcontext res) route id -instance HasLoggingServer config res ctx =>- HasLoggingServer config (Description d :> res) ctx where- routeWithLog = inRouteServer @(Description d :> LoggingApiRec config res) route id+instance HasLoggingServer config lcontext res ctx =>+ HasLoggingServer config lcontext (Description d :> res) ctx where+ routeWithLog = inRouteServer @(Description d :> LoggingApiRec config lcontext res) route id +instance ( HasLoggingServer config (ApplyLoggingMod lcontext mod) res ctx+ , HasServer res ctx+ ) =>+ HasLoggingServer config lcontext (LoggingMod mod :> res) ctx where+ routeWithLog = inRouteServer @(LoggingApiRec config (ApplyLoggingMod lcontext mod) res) route id -- | Unique identifier for request-response pair. newtype RequestId = RequestId Integer@@ -273,15 +388,18 @@ -- | Modify an action so that it performs all the required logging. applyServantLogging :: ( Reifies config ServantLogConfig+ , Demote (lcontext :: LoggingContext)+ , Demote (LcResponsesEnabled lcontext) , ReflectMethod (method :: k) ) => Proxy config+ -> Proxy lcontext -> Proxy method -> ApiParamsLogInfo- -> (a -> Text)+ -> If (LcResponsesEnabled lcontext) (a -> Text) () -> Handler a -> Handler a-applyServantLogging configP methodP paramsInfo showResponse action = do+applyServantLogging configP (contextP :: Proxy lcontext) methodP paramsInfo showResponse action = do timer <- mkTimer reqId <- nextRequestId catchErrors reqId timer $ do@@ -305,8 +423,12 @@ return $ do endTime <- liftIO getPOSIXTime return . show $ endTime - startTime+ logContext = demote contextP+ logEntryContext = LogContext+ { lecRecommendedLevel = lcRecommendedLevel logContext+ } log :: Text -> Handler ()- log = liftIO ... clcLog $ reflect configP+ log txt = liftIO $ clcLog (reflect configP) logEntryContext txt eParamLogs :: Either Text Text eParamLogs = case paramsInfo of ApiParamsLogInfo _ path infos -> Right $@@ -320,6 +442,7 @@ ApiNoParamsLogInfo why -> Left why reportRequest :: RequestId -> Handler () reportRequest reqId =+ when (lcRequestsEnabled logContext) $ case eParamLogs of Left e -> log $ "\n" +| dullColor Red "Unexecuted request due to error"@@ -330,15 +453,18 @@ |+ " " +| gray ("Request " <> pretty reqId) |+ "\n" +| paramLogs |+ "" responseTag reqId = "Response " <> pretty reqId- reportResponse reqId timer resp = do- durationText <- timer- log $- "\n " +| gray (responseTag reqId)- |+ " " +| (dullColor Green "OK")- |+ " " +| durationText- |+ " " +| gray ">"- |+ " " +| showResponse resp- |+ ""+ reportResponse reqId timer resp =+ case tyBoolCase (Proxy @(LcResponsesEnabled lcontext)) of+ Left _ -> pass+ Right Dict -> do+ durationText <- timer+ log $+ "\n " +| gray (responseTag reqId)+ |+ " " +| dullColor Green "OK"+ |+ " " +| durationText+ |+ " " +| gray ">"+ |+ " " +| showResponse resp+ |+ "" catchErrors reqId st = flip catchError (servantErrHandler reqId st) . handleAny (exceptionsHandler reqId st)@@ -362,38 +488,48 @@ throwM e applyLoggingToHandler- :: forall k config method a.- ( Buildable (ForResponseLog a)- , Reifies config ServantLogConfig+ :: forall k config lcontext method a.+ ( Reifies config ServantLogConfig+ , Demote lcontext+ , BuildableForResponseIfNecessary lcontext a+ , Demote lcontext , ReflectMethod method )- => Proxy config -> Proxy (method :: k) -> (ApiParamsLogInfo, Handler a) -> Handler a-applyLoggingToHandler configP methodP (paramsInfo, handler) = do- applyServantLogging configP methodP paramsInfo (pretty . ForResponseLog) handler+ => Proxy config -> Proxy (lcontext :: LoggingContext) -> Proxy (method :: k)+ -> (ApiParamsLogInfo, Handler a) -> Handler a+applyLoggingToHandler configP contextP methodP (paramsInfo, handler) = do+ let apply format =+ applyServantLogging configP contextP methodP paramsInfo format handler+ case tyBoolCase $ Proxy @(LcResponsesEnabled lcontext) of+ Right Dict -> apply (pretty . ForResponseLog)+ Left Dict -> apply () skipLogging :: (ApiParamsLogInfo, action) -> action skipLogging = snd instance ( HasServer (Verb mt st ct a) ctx , Reifies config ServantLogConfig+ , Demote lcontext , ReflectMethod mt- , Buildable (ForResponseLog a)+ , BuildableForResponseIfNecessary lcontext a ) =>- HasLoggingServer config (Verb (mt :: k) (st :: Nat) (ct :: [Type]) a) ctx where+ HasLoggingServer config lcontext (Verb (mt :: k) (st :: Nat) (ct :: [Type]) a) ctx where routeWithLog = inRouteServer @(Verb mt st ct a) route $- applyLoggingToHandler (Proxy @config) (Proxy @mt)+ applyLoggingToHandler (Proxy @config) (Proxy @lcontext) (Proxy @mt) instance ( HasServer (NoContentVerb mt) ctx , Reifies config ServantLogConfig+ , Demote lcontext , ReflectMethod mt+ , BuildableForResponseIfNecessary lcontext NoContent ) =>- HasLoggingServer config (NoContentVerb (mt :: k)) ctx where+ HasLoggingServer config lcontext (NoContentVerb (mt :: k)) ctx where routeWithLog = inRouteServer @(NoContentVerb mt) route $- applyLoggingToHandler (Proxy @config) (Proxy @mt)+ applyLoggingToHandler (Proxy @config) (Proxy @lcontext) (Proxy @mt) -instance HasLoggingServer config Raw ctx where+instance HasLoggingServer config lcontext Raw ctx where routeWithLog = inRouteServer @Raw route skipLogging instance Buildable (ForResponseLog NoContent) where@@ -410,6 +546,22 @@ instance Buildable (ForResponseLog (SwaggerUiHtml dir api)) where build _ = "Accessed documentation UI"++instance HasServer api ctx =>+ HasServer (LoggingMod mod :> api) ctx where+ type ServerT (LoggingMod mod :> api) m = ServerT api m+ route = inRouteServer @api route id+ hoistServerWithContext _ = hoistServerWithContext (Proxy @api)++instance HasClient m api =>+ HasClient m (LoggingMod mod :> api) where+ type Client m (LoggingMod mod :> api) = Client m api+ clientWithRoute mp _ = clientWithRoute mp (Proxy @api)+ hoistClientMonad mp _ = hoistClientMonad mp (Proxy @api)++instance HasSwagger api =>+ HasSwagger (LoggingMod mod :> api) where+ toSwagger _ = toSwagger (Proxy @api) -- | Apply logging to the given server. serverWithLogging
src/Servant/Util/Combinators/Pagination.hs view
@@ -86,13 +86,13 @@ hoistServerWithContext (Proxy @subApi) pc nt . s instance- ( HasLoggingServer config subApi ctx+ ( HasLoggingServer config lcontext subApi ctx , KnownPaginationPageSize settings , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters ) =>- HasLoggingServer config (PaginationParams settings :> subApi) ctx where+ HasLoggingServer config lcontext (PaginationParams settings :> subApi) ctx where routeWithLog =- inRouteServer @(PaginationParams settings :> LoggingApiRec config subApi) route $+ inRouteServer @(PaginationParams settings :> LoggingApiRec config lcontext subApi) route $ \(paramsInfo, handler) pagination@PaginationSpec{..} -> let text = merge . catMaybes $ [ guard (psOffset > 0) $> ("offset " <> show psOffset)
src/Servant/Util/Combinators/Sorting/Logging.hs view
@@ -15,14 +15,14 @@ import Servant.Util.Combinators.Sorting.Server () import Servant.Util.Common -instance ( HasLoggingServer config subApi ctx+instance ( HasLoggingServer config lcontext subApi ctx , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters , ReifySortingItems base , ReifyParamsNames provided ) =>- HasLoggingServer config (SortingParams provided base :> subApi) ctx where+ HasLoggingServer config lcontext (SortingParams provided base :> subApi) ctx where routeWithLog =- inRouteServer @(SortingParams provided base :> LoggingApiRec config subApi) route $+ inRouteServer @(SortingParams provided base :> LoggingApiRec config lcontext subApi) route $ \(paramsInfo, handler) sorting@(SortingSpec provided) -> let paramLog | null provided = "no sorting"
src/Servant/Util/Combinators/Tag.hs view
@@ -31,9 +31,9 @@ clientWithRoute pm _ = clientWithRoute pm (Proxy @subApi) hoistClientMonad pm _ hst = hoistClientMonad pm (Proxy @subApi) hst -instance HasLoggingServer config subApi ctx =>- HasLoggingServer config (Tag name :> subApi) ctx where- routeWithLog = inRouteServer @(Tag name :> LoggingApiRec config subApi) route id+instance HasLoggingServer config lcontext subApi ctx =>+ HasLoggingServer config lcontext (Tag name :> subApi) ctx where+ routeWithLog = inRouteServer @(Tag name :> LoggingApiRec config lcontext subApi) route id instance (HasSwagger subApi, KnownSymbol name) => HasSwagger (Tag name :> subApi) where@@ -68,10 +68,10 @@ clientWithRoute pm _ = clientWithRoute pm (Proxy @subApi) hoistClientMonad pm _ hst = hoistClientMonad pm (Proxy @subApi) hst -instance HasLoggingServer config subApi ctx =>- HasLoggingServer config (TagDescriptions ver mapping :> subApi) ctx where+instance HasLoggingServer config context subApi ctx =>+ HasLoggingServer config context (TagDescriptions ver mapping :> subApi) ctx where routeWithLog =- inRouteServer @(TagDescriptions ver mapping :> LoggingApiRec config subApi)+ inRouteServer @(TagDescriptions ver mapping :> LoggingApiRec config context subApi) route id -- | Gather all tag names used in API. Result may contain duplicates.
src/Servant/Util/Common/PolyKinds.hs view
@@ -21,14 +21,19 @@ , type (//) , InsSorted , UnionSorted+ , Demote (..)+ , Demoted+ , tyBoolCase ) where import Universum +import Data.Constraint (Dict (..)) import qualified Data.Set as S import GHC.TypeLits (AppendSymbol, CmpSymbol, ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal) import Servant (If)+import Unsafe.Coerce (unsafeCoerce) -- | Pair of type and its name as it appears in API. data TyNamedParam a = TyNamedParam Symbol a@@ -129,3 +134,39 @@ (s1 ': UnionSorted ss1 (s2 ': ss2)) (s2 ': UnionSorted (s1 ': ss1) ss2) )++-- | Bring a type-level data to term-level.+--+-- We don't want to depend on large @singletons@ library, so+-- providing our own small parts.+--+-- TODO: use this instead of custom typeclasses in other places.+class Demote (ty :: k) where+ demote :: Proxy ty -> Demoted k++type family Demoted k :: Type++type instance Demoted Bool = Bool+instance Demote 'True where+ demote _ = True+instance Demote 'False where+ demote _ = False++-- | Pattern-match on type-level bool.+tyBoolCase+ :: Demote b+ => Proxy (b :: Bool)+ -> Either (Dict (b ~ 'False)) (Dict (b ~ 'True))+tyBoolCase p = case demote p of+ False -> Left $ unsafeCoerce $ Dict @(() ~ ())+ True -> Right $ unsafeCoerce $ Dict @(() ~ ())++type instance Demoted (Maybe k) = Maybe (Demoted k)+instance Demote 'Nothing where+ demote _ = Nothing+instance Demote a => Demote ('Just (a :: k)) where+ demote _ = Just $ demote (Proxy @a)++type instance Demoted Nat = Natural+instance KnownNat a => Demote a where+ demote = natVal
tests/Test/Servant/Helpers.hs view
@@ -1,6 +1,7 @@ module Test.Servant.Helpers ( runTestServer , runTestServerE+ , runTestServer' ) where import Universum@@ -12,7 +13,7 @@ import Servant.Client (BaseUrl (..), Client, ClientEnv, ClientError, ClientM, HasClient, Scheme (Http), mkClientEnv, runClientM) import Servant.Client.Generic (AsClientT, genericClientHoist)-import Servant.Server (HasServer, Server)+import Servant.Server (HasServer, Server, serve) import Servant.Server.Generic (AsServer, genericServe) mkTestClientEnv :: Port -> IO ClientEnv@@ -64,6 +65,28 @@ -> IO () runTestServer handlers acceptClientHandlers = testWithApplication (pure $ genericServe handlers) $ \port -> do+ cliEnv <- mkTestClientEnv port+ acceptClientHandlers $+ genericClientHoist (flip runClientM cliEnv >=> either throwM pure)++-- | Runs server and returns client handlers to it.+--+-- This is similar to 'runTestServer', but accepts any server that matches the client,+-- not necessarily in servant-generic format (which is a quite tough restriction).+runTestServer'+ :: forall api methods.+ ( HasServer api '[]+ , ToServant methods AsServer ~ Server api+ , GenericServant methods (AsClientT IO)+ , HasClient ClientM (ToServantApi methods)+ , Client IO (ToServantApi methods) ~ ToServant methods (AsClientT IO)+ )+ => Proxy api+ -> Server api+ -> (methods (AsClientT IO) -> IO ())+ -> IO ()+runTestServer' apiP handlers acceptClientHandlers =+ testWithApplication (pure $ serve apiP handlers) $ \port -> do cliEnv <- mkTestClientEnv port acceptClientHandlers $ genericClientHoist (flip runClientM cliEnv >=> either throwM pure)
+ tests/Test/Servant/Logging/ImplSpec.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedLists #-}++module Test.Servant.Logging.ImplSpec where++import Universum++import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Text as T+import Servant.API (Get, JSON, (:>))+import Servant.API.Generic (ToServantApi, (:-))+import Servant.Client.Generic (AsClientT)+import Servant.Server.Generic (AsServer, genericServer)++import Test.Hspec (Spec, around, it)+import Test.Hspec.Expectations (expectationFailure, shouldBe, shouldSatisfy)++import Servant.Util++import Test.Servant.Helpers++-- Server+---------------------------------------------------------------------------++-- | A type that has no 'Buildable ForResponseLog` instance.+newtype NeverLogMe = NeverLogMe ()+ deriving (ToJSON, FromJSON)++data ApiMethods route = ApiMethods+ { amSimple+ :: route+ :- "simple"+ :> Get '[JSON] ()++ , amSetLevel+ :: route+ :- "setLevel"+ :> LoggingLevel 10+ :> Get '[JSON] ()++ , amRequestsDisabled+ :: route+ :- "-requests"+ :> LoggingRequestsDisabled+ :> Get '[JSON] ()++ , amResponsesDisabled+ :: route+ :- "-responses"+ :> LoggingResponsesDisabled+ :> Get '[JSON] NeverLogMe++ , amFullyDisabled+ :: route+ :- "-allLogs"+ :> LoggingDisabled+ :> Get '[JSON] ()++ } deriving Generic++apiHandlers :: ApiMethods AsServer+apiHandlers = ApiMethods pass pass pass (pure $ NeverLogMe ()) pass++runOurHandlers+ :: ((ApiMethods (AsClientT IO), IO [(LogContext, Text)]) -> IO ())+ -> IO ()+runOurHandlers clientCb = do+ logRecords <- newIORef []+ let config = ServantLogConfig+ { clcLog = \ctx txt -> modifyIORef logRecords ((ctx, txt) : )+ }+ serverWithLogging config (Proxy @(ToServantApi ApiMethods)) $ \apiP ->+ runTestServer' apiP (genericServer apiHandlers) $ \clientMethods ->+ clientCb (clientMethods, reverse <$> readIORef logRecords)++-- Tests+---------------------------------------------------------------------------++spec :: Spec+spec =+ around runOurHandlers $ do++ it "Simple logging" $+ \(ApiMethods{..}, getLogRecords) -> do+ amSimple+ getLogRecords >>= \case+ [(reqCtx, reqTxt), (respCtx, respTxt)] -> do+ reqCtx `shouldBe` LogContext Nothing+ reqTxt `shouldSatisfy` ("simple" `T.isInfixOf`)+ reqTxt `shouldSatisfy` ("Request" `T.isInfixOf`)+ respCtx `shouldBe` LogContext Nothing+ respTxt `shouldSatisfy` ("Response" `T.isInfixOf`)++ other -> expectationFailure $+ "Unexpected number of log entries: " <> show (length other)++ it "Recommended log levels" $+ \(ApiMethods{..}, getLogRecords) -> do+ amSetLevel+ getLogRecords >>= \case+ [(reqCtx, _), (respCtx, _)] -> do+ reqCtx `shouldBe` LogContext (Just 10)+ respCtx `shouldBe` LogContext (Just 10)++ other -> expectationFailure $+ "Unexpected number of log entries: " <> show (length other)++ it "Requests disabled" $+ \(ApiMethods{..}, getLogRecords) -> do+ amRequestsDisabled+ getLogRecords >>= \case+ [(_, _)] ->+ pass+ other -> expectationFailure $+ "Unexpected number of log entries: " <> show (length other)++ it "Responses disabled" $+ \(ApiMethods{..}, getLogRecords) -> do+ amResponsesDisabled+ getLogRecords >>= \case+ [(_, _)] ->+ pass+ other -> expectationFailure $+ "Unexpected number of log entries: " <> show (length other)++ it "Logging fully disabled" $+ \(ApiMethods{..}, getLogRecords) -> do+ amFullyDisabled+ getLogRecords >>= \case+ [] ->+ pass+ other -> expectationFailure $+ "Unexpected number of log entries: " <> show (length other)