diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 ===== diff --git a/examples/Books.hs b/examples/Books.hs --- a/examples/Books.hs +++ b/examples/Books.hs @@ -101,4 +101,4 @@ serve @(SwaggerSchemaUI "swagger-ui" "swagger.json" :<|> api) Proxy (swaggerSchemaUIServer swagger :<|> booksHandlers) where - loggingConfig = ServantLogConfig putTextLn + loggingConfig = ServantLogConfig $ \_ -> putTextLn diff --git a/servant-util.cabal b/servant-util.cabal --- a/servant-util.cabal +++ b/servant-util.cabal @@ -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 diff --git a/src/Servant/Util/Combinators/ErrorResponses.hs b/src/Servant/Util/Combinators/ErrorResponses.hs --- a/src/Servant/Util/Combinators/ErrorResponses.hs +++ b/src/Servant/Util/Combinators/ErrorResponses.hs @@ -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 diff --git a/src/Servant/Util/Combinators/Filtering/Logging.hs b/src/Servant/Util/Combinators/Filtering/Logging.hs --- a/src/Servant/Util/Combinators/Filtering/Logging.hs +++ b/src/Servant/Util/Combinators/Filtering/Logging.hs @@ -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" diff --git a/src/Servant/Util/Combinators/Logging.hs b/src/Servant/Util/Combinators/Logging.hs --- a/src/Servant/Util/Combinators/Logging.hs +++ b/src/Servant/Util/Combinators/Logging.hs @@ -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 diff --git a/src/Servant/Util/Combinators/Pagination.hs b/src/Servant/Util/Combinators/Pagination.hs --- a/src/Servant/Util/Combinators/Pagination.hs +++ b/src/Servant/Util/Combinators/Pagination.hs @@ -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) diff --git a/src/Servant/Util/Combinators/Sorting/Logging.hs b/src/Servant/Util/Combinators/Sorting/Logging.hs --- a/src/Servant/Util/Combinators/Sorting/Logging.hs +++ b/src/Servant/Util/Combinators/Sorting/Logging.hs @@ -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" diff --git a/src/Servant/Util/Combinators/Tag.hs b/src/Servant/Util/Combinators/Tag.hs --- a/src/Servant/Util/Combinators/Tag.hs +++ b/src/Servant/Util/Combinators/Tag.hs @@ -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. diff --git a/src/Servant/Util/Common/PolyKinds.hs b/src/Servant/Util/Common/PolyKinds.hs --- a/src/Servant/Util/Common/PolyKinds.hs +++ b/src/Servant/Util/Common/PolyKinds.hs @@ -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 diff --git a/tests/Test/Servant/Helpers.hs b/tests/Test/Servant/Helpers.hs --- a/tests/Test/Servant/Helpers.hs +++ b/tests/Test/Servant/Helpers.hs @@ -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) diff --git a/tests/Test/Servant/Logging/ImplSpec.hs b/tests/Test/Servant/Logging/ImplSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Servant/Logging/ImplSpec.hs @@ -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)