[haskell-http-client] Allow logger selection via cabal flags. Emit Consumes */* for requestBody when not specified

[haskell-http-client] Allow logger selection via cabal flags. Emit Consumes */* for requestBody when not specified

samples/client/petstore/haskell-http-client/lib/OpenAPIPetstore/API/Fake.hs

@@ -113,6 +113,9 @@ data FakeOuterBooleanSerialize
 
 -- | /Body Param/ "body" - Input boolean as post body
 instance HasBodyParam FakeOuterBooleanSerialize BodyBool 
+    
+-- | @*/*@
+instance MimeType mtype => Consumes FakeOuterBooleanSerialize mtype
 
 -- | @*/*@
 instance MimeType mtype => Produces FakeOuterBooleanSerialize mtype
@@ -136,6 +139,9 @@ data FakeOuterCompositeSerialize
 
 -- | /Body Param/ "body" - Input composite as post body
 instance HasBodyParam FakeOuterCompositeSerialize OuterComposite 
+    
+-- | @*/*@
+instance MimeType mtype => Consumes FakeOuterCompositeSerialize mtype
 
 -- | @*/*@
 instance MimeType mtype => Produces FakeOuterCompositeSerialize mtype
@@ -159,6 +165,9 @@ data FakeOuterNumberSerialize
 
 -- | /Body Param/ "body" - Input number as post body
 instance HasBodyParam FakeOuterNumberSerialize BodyDouble 
+    
+-- | @*/*@
+instance MimeType mtype => Consumes FakeOuterNumberSerialize mtype
 
 -- | @*/*@
 instance MimeType mtype => Produces FakeOuterNumberSerialize mtype
@@ -182,6 +191,9 @@ data FakeOuterStringSerialize
 
 -- | /Body Param/ "body" - Input string as post body
 instance HasBodyParam FakeOuterStringSerialize BodyText 
+    
+-- | @*/*@
+instance MimeType mtype => Consumes FakeOuterStringSerialize mtype
 
 -- | @*/*@
 instance MimeType mtype => Produces FakeOuterStringSerialize mtype
@@ -441,7 +453,6 @@ instance HasOptionalParam TestGroupParameters BooleanGroup where
 instance HasOptionalParam TestGroupParameters Int64Group where
   applyOptionalParam req (Int64Group xs) =
     req `setQuery` toQuery ("int64_group", Just xs)
-
 instance Produces TestGroupParameters MimeNoContent
 
 

samples/client/petstore/haskell-http-client/lib/OpenAPIPetstore/API/Pet.hs

@@ -107,7 +107,6 @@ data DeletePet
 instance HasOptionalParam DeletePet ApiKey where
   applyOptionalParam req (ApiKey xs) =
     req `setHeader` toHeader ("api_key", xs)
-
 instance Produces DeletePet MimeNoContent
 
 
@@ -131,7 +130,6 @@ findPetsByStatus  _ (Status status) =
     `setQuery` toQueryColl CommaSeparated ("status", Just status)
 
 data FindPetsByStatus  
-
 -- | @application/xml@
 instance Produces FindPetsByStatus MimeXML
 -- | @application/json@
@@ -160,7 +158,6 @@ findPetsByTags  _ (Tags tags) =
 {-# DEPRECATED findPetsByTags "" #-}
 
 data FindPetsByTags  
-
 -- | @application/xml@
 instance Produces FindPetsByTags MimeXML
 -- | @application/json@
@@ -186,7 +183,6 @@ getPetById  _ (PetId petId) =
     `_hasAuthType` (P.Proxy :: P.Proxy AuthApiKeyApiKey)
 
 data GetPetById  
-
 -- | @application/xml@
 instance Produces GetPetById MimeXML
 -- | @application/json@

samples/client/petstore/haskell-http-client/lib/OpenAPIPetstore/API/Store.hs

@@ -72,7 +72,6 @@ deleteOrder (OrderIdText orderId) =
   _mkRequest "DELETE" ["/store/order/",toPath orderId]
 
 data DeleteOrder  
-
 instance Produces DeleteOrder MimeNoContent
 
 
@@ -93,7 +92,6 @@ getInventory =
     `_hasAuthType` (P.Proxy :: P.Proxy AuthApiKeyApiKey)
 
 data GetInventory  
-
 -- | @application/json@
 instance Produces GetInventory MimeJSON
 
@@ -114,7 +112,6 @@ getOrderById  _ (OrderId orderId) =
   _mkRequest "GET" ["/store/order/",toPath orderId]
 
 data GetOrderById  
-
 -- | @application/xml@
 instance Produces GetOrderById MimeXML
 -- | @application/json@
@@ -141,6 +138,9 @@ data PlaceOrder
 
 -- | /Body Param/ "body" - order placed for purchasing the pet
 instance HasBodyParam PlaceOrder Order 
+    
+-- | @*/*@
+instance MimeType mtype => Consumes PlaceOrder mtype
 
 -- | @application/xml@
 instance Produces PlaceOrder MimeXML

samples/client/petstore/haskell-http-client/lib/OpenAPIPetstore/API/User.hs

@@ -78,6 +78,9 @@ data CreateUser
 
 -- | /Body Param/ "body" - Created user object
 instance HasBodyParam CreateUser User 
+    
+-- | @*/*@
+instance MimeType mtype => Consumes CreateUser mtype
 
 instance Produces CreateUser MimeNoContent
 
@@ -101,6 +104,9 @@ data CreateUsersWithArrayInput
 
 -- | /Body Param/ "body" - List of user object
 instance HasBodyParam CreateUsersWithArrayInput Body 
+    
+-- | @*/*@
+instance MimeType mtype => Consumes CreateUsersWithArrayInput mtype
 
 instance Produces CreateUsersWithArrayInput MimeNoContent
 
@@ -124,6 +130,9 @@ data CreateUsersWithListInput
 
 -- | /Body Param/ "body" - List of user object
 instance HasBodyParam CreateUsersWithListInput Body 
+    
+-- | @*/*@
+instance MimeType mtype => Consumes CreateUsersWithListInput mtype
 
 instance Produces CreateUsersWithListInput MimeNoContent
 
@@ -143,7 +152,6 @@ deleteUser (Username username) =
   _mkRequest "DELETE" ["/user/",toPath username]
 
 data DeleteUser  
-
 instance Produces DeleteUser MimeNoContent
 
 
@@ -161,7 +169,6 @@ getUserByName  _ (Username username) =
   _mkRequest "GET" ["/user/",toPath username]
 
 data GetUserByName  
-
 -- | @application/xml@
 instance Produces GetUserByName MimeXML
 -- | @application/json@
@@ -185,7 +192,6 @@ loginUser  _ (Username username) (Password password) =
     `setQuery` toQuery ("password", Just password)
 
 data LoginUser  
-
 -- | @application/xml@
 instance Produces LoginUser MimeXML
 -- | @application/json@
@@ -204,7 +210,6 @@ logoutUser =
   _mkRequest "GET" ["/user/logout"]
 
 data LogoutUser  
-
 instance Produces LogoutUser MimeNoContent
 
 
@@ -230,6 +235,9 @@ data UpdateUser
 
 -- | /Body Param/ "body" - Updated user object
 instance HasBodyParam UpdateUser User 
+    
+-- | @*/*@
+instance MimeType mtype => Consumes UpdateUser mtype
 
 instance Produces UpdateUser MimeNoContent
 

samples/client/petstore/haskell-http-client/lib/OpenAPIPetstore/Logging.hs

@@ -10,109 +10,24 @@
 
 {-|
 Module : OpenAPIPetstore.Logging
-Katip Logging functions
+Logging functions
 -}
+{-# LANGUAGE CPP #-}
 
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+#ifdef USE_KATIP
 
-module OpenAPIPetstore.Logging where
+module OpenAPIPetstore.Logging
+  ( module OpenAPIPetstore.LoggingKatip
+  ) where
 
-import qualified Control.Exception.Safe as E
-import qualified Control.Monad.IO.Class as P
-import qualified Control.Monad.Trans.Reader as P
-import qualified Data.Text as T
-import qualified Lens.Micro as L
-import qualified System.IO as IO
+import OpenAPIPetstore.LoggingKatip
 
-import Data.Text (Text)
-import GHC.Exts (IsString(..))
+#else
 
-import qualified Katip as LG
+module OpenAPIPetstore.Logging
+  ( module OpenAPIPetstore.LoggingMonadLogger
+  ) where
 
--- * Type Aliases (for compatibility)
-
--- | Runs a Katip logging block with the Log environment
-type LogExecWithContext = forall m. P.MonadIO m =>
-                                    LogContext -> LogExec m
-
--- | A Katip logging block
-type LogExec m = forall a. LG.KatipT m a -> m a
-
--- | A Katip Log environment
-type LogContext = LG.LogEnv
-
--- | A Katip Log severity
-type LogLevel = LG.Severity
-
--- * default logger
-
--- | the default log environment
-initLogContext :: IO LogContext
-initLogContext = LG.initLogEnv "OpenAPIPetstore" "dev"
-
--- | Runs a Katip logging block with the Log environment
-runDefaultLogExecWithContext :: LogExecWithContext
-runDefaultLogExecWithContext = LG.runKatipT
-
--- * stdout logger
-
--- | Runs a Katip logging block with the Log environment
-stdoutLoggingExec :: LogExecWithContext
-stdoutLoggingExec = runDefaultLogExecWithContext
-
--- | A Katip Log environment which targets stdout
-stdoutLoggingContext :: LogContext -> IO LogContext
-stdoutLoggingContext cxt = do
-    handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stdout LG.InfoS LG.V2
-    LG.registerScribe "stdout" handleScribe LG.defaultScribeSettings cxt
-
--- * stderr logger
-
--- | Runs a Katip logging block with the Log environment
-stderrLoggingExec :: LogExecWithContext
-stderrLoggingExec = runDefaultLogExecWithContext
-
--- | A Katip Log environment which targets stderr
-stderrLoggingContext :: LogContext -> IO LogContext
-stderrLoggingContext cxt = do
-    handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stderr LG.InfoS LG.V2
-    LG.registerScribe "stderr" handleScribe LG.defaultScribeSettings cxt
-
--- * Null logger
-
--- | Disables Katip logging
-runNullLogExec :: LogExecWithContext
-runNullLogExec le (LG.KatipT f) = P.runReaderT f (L.set LG.logEnvScribes mempty le)
-
--- * Log Msg
-
--- | Log a katip message
-_log :: (Applicative m, LG.Katip m) => Text -> LogLevel -> Text -> m ()
-_log src level msg = do
-  LG.logMsg (fromString $ T.unpack src) level (LG.logStr msg)
-
--- * Log Exceptions
-
--- | re-throws exceptions after logging them
-logExceptions
-  :: (LG.Katip m, E.MonadCatch m, Applicative m)
-  => Text -> m a -> m a
-logExceptions src =
-  E.handle
-    (\(e :: E.SomeException) -> do
-       _log src LG.ErrorS ((T.pack . show) e)
-       E.throw e)
-
--- * Log Level
-
-levelInfo :: LogLevel
-levelInfo = LG.InfoS
-
-levelError :: LogLevel
-levelError = LG.ErrorS
-
-levelDebug :: LogLevel
-levelDebug = LG.DebugS
+import OpenAPIPetstore.LoggingMonadLogger
 
+#endif

samples/client/petstore/haskell-http-client/lib/OpenAPIPetstore/LoggingKatip.hs

@@ -0,0 +1,118 @@
+{-
+   OpenAPI Petstore
+
+   This spec is mainly for testing Petstore server and contains fake endpoints, models. Please do not use this for any other purpose. Special characters: \" \\
+
+   OpenAPI Version: 3.0.1
+   OpenAPI Petstore API version: 1.0.0
+   Generated by OpenAPI Generator (https://openapi-generator.tech)
+-}
+
+{-|
+Module : OpenAPIPetstore.LoggingKatip
+Katip Logging functions
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module OpenAPIPetstore.LoggingKatip where
+
+import qualified Control.Exception.Safe as E
+import qualified Control.Monad.IO.Class as P
+import qualified Control.Monad.Trans.Reader as P
+import qualified Data.Text as T
+import qualified Lens.Micro as L
+import qualified System.IO as IO
+
+import Data.Text (Text)
+import GHC.Exts (IsString(..))
+
+import qualified Katip as LG
+
+-- * Type Aliases (for compatibility)
+
+-- | Runs a Katip logging block with the Log environment
+type LogExecWithContext = forall m. P.MonadIO m =>
+                                    LogContext -> LogExec m
+
+-- | A Katip logging block
+type LogExec m = forall a. LG.KatipT m a -> m a
+
+-- | A Katip Log environment
+type LogContext = LG.LogEnv
+
+-- | A Katip Log severity
+type LogLevel = LG.Severity
+
+-- * default logger
+
+-- | the default log environment
+initLogContext :: IO LogContext
+initLogContext = LG.initLogEnv "OpenAPIPetstore" "dev"
+
+-- | Runs a Katip logging block with the Log environment
+runDefaultLogExecWithContext :: LogExecWithContext
+runDefaultLogExecWithContext = LG.runKatipT
+
+-- * stdout logger
+
+-- | Runs a Katip logging block with the Log environment
+stdoutLoggingExec :: LogExecWithContext
+stdoutLoggingExec = runDefaultLogExecWithContext
+
+-- | A Katip Log environment which targets stdout
+stdoutLoggingContext :: LogContext -> IO LogContext
+stdoutLoggingContext cxt = do
+    handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stdout (LG.permitItem LG.InfoS) LG.V2
+    LG.registerScribe "stdout" handleScribe LG.defaultScribeSettings cxt
+
+-- * stderr logger
+
+-- | Runs a Katip logging block with the Log environment
+stderrLoggingExec :: LogExecWithContext
+stderrLoggingExec = runDefaultLogExecWithContext
+
+-- | A Katip Log environment which targets stderr
+stderrLoggingContext :: LogContext -> IO LogContext
+stderrLoggingContext cxt = do
+    handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stderr (LG.permitItem LG.InfoS) LG.V2
+    LG.registerScribe "stderr" handleScribe LG.defaultScribeSettings cxt
+
+-- * Null logger
+
+-- | Disables Katip logging
+runNullLogExec :: LogExecWithContext
+runNullLogExec le (LG.KatipT f) = P.runReaderT f (L.set LG.logEnvScribes mempty le)
+
+-- * Log Msg
+
+-- | Log a katip message
+_log :: (Applicative m, LG.Katip m) => Text -> LogLevel -> Text -> m ()
+_log src level msg = do
+  LG.logMsg (fromString $ T.unpack src) level (LG.logStr msg)
+
+-- * Log Exceptions
+
+-- | re-throws exceptions after logging them
+logExceptions
+  :: (LG.Katip m, E.MonadCatch m, Applicative m)
+  => Text -> m a -> m a
+logExceptions src =
+  E.handle
+    (\(e :: E.SomeException) -> do
+       _log src LG.ErrorS ((T.pack . show) e)
+       E.throw e)
+
+-- * Log Level
+
+levelInfo :: LogLevel
+levelInfo = LG.InfoS
+
+levelError :: LogLevel
+levelError = LG.ErrorS
+
+levelDebug :: LogLevel
+levelDebug = LG.DebugS
+

samples/client/petstore/haskell-http-client/lib/OpenAPIPetstore/LoggingMonadLogger.hs

@@ -0,0 +1,127 @@
+{-
+   OpenAPI Petstore
+
+   This spec is mainly for testing Petstore server and contains fake endpoints, models. Please do not use this for any other purpose. Special characters: \" \\
+
+   OpenAPI Version: 3.0.1
+   OpenAPI Petstore API version: 1.0.0
+   Generated by OpenAPI Generator (https://openapi-generator.tech)
+-}
+
+{-|
+Module : OpenAPIPetstore.LoggingMonadLogger
+monad-logger Logging functions
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module OpenAPIPetstore.LoggingMonadLogger where
+
+import qualified Control.Exception.Safe as E
+import qualified Control.Monad.IO.Class as P
+import qualified Data.Text as T
+import qualified Data.Time as TI
+
+import Data.Monoid ((<>))
+import Data.Text (Text)
+
+import qualified Control.Monad.Logger as LG
+
+-- * Type Aliases (for compatibility)
+
+-- | Runs a monad-logger  block with the filter predicate
+type LogExecWithContext = forall m. P.MonadIO m =>
+                                    LogContext -> LogExec m
+
+-- | A monad-logger block
+type LogExec m = forall a. LG.LoggingT m a -> m a
+
+-- | A monad-logger filter predicate
+type LogContext = LG.LogSource -> LG.LogLevel -> Bool
+
+-- | A monad-logger log level
+type LogLevel = LG.LogLevel
+
+-- * default logger
+
+-- | the default log environment
+initLogContext :: IO LogContext
+initLogContext = pure infoLevelFilter
+
+-- | Runs a monad-logger block with the filter predicate
+runDefaultLogExecWithContext :: LogExecWithContext
+runDefaultLogExecWithContext = runNullLogExec
+
+-- * stdout logger
+
+-- | Runs a monad-logger block targeting stdout, with the filter predicate
+stdoutLoggingExec :: LogExecWithContext
+stdoutLoggingExec cxt = LG.runStdoutLoggingT . LG.filterLogger cxt
+
+-- | @pure@
+stdoutLoggingContext :: LogContext -> IO LogContext
+stdoutLoggingContext = pure
+
+-- * stderr logger
+
+-- | Runs a monad-logger block targeting stderr, with the filter predicate
+stderrLoggingExec :: LogExecWithContext
+stderrLoggingExec cxt = LG.runStderrLoggingT . LG.filterLogger cxt
+
+-- | @pure@
+stderrLoggingContext :: LogContext -> IO LogContext
+stderrLoggingContext = pure
+
+-- * Null logger
+
+-- | Disables monad-logger logging
+runNullLogExec :: LogExecWithContext
+runNullLogExec = const (`LG.runLoggingT` nullLogger)
+
+-- | monad-logger which does nothing
+nullLogger :: LG.Loc -> LG.LogSource -> LG.LogLevel -> LG.LogStr -> IO ()
+nullLogger _ _ _ _ = return ()
+
+-- * Log Msg
+
+-- | Log a message using the current time
+_log :: (P.MonadIO m, LG.MonadLogger m) => Text -> LG.LogLevel -> Text -> m ()
+_log src level msg = do
+  now <- P.liftIO (formatTimeLog <$> TI.getCurrentTime)
+  LG.logOtherNS ("OpenAPIPetstore." <> src) level ("[" <> now <> "] " <> msg)
+ where
+  formatTimeLog =
+    T.pack . TI.formatTime TI.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Z"
+
+-- * Log Exceptions
+
+-- | 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
+        _log src LG.LevelError ((T.pack . show) e)
+        E.throw e)
+
+-- * Log Level
+
+levelInfo :: LogLevel
+levelInfo = LG.LevelInfo
+
+levelError :: LogLevel
+levelError = LG.LevelError
+
+levelDebug :: LogLevel
+levelDebug = LG.LevelDebug
+
+-- * Level Filter
+
+minLevelFilter :: LG.LogLevel -> LG.LogSource -> LG.LogLevel -> Bool
+minLevelFilter l _ l' = l' >= l
+
+infoLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool
+infoLevelFilter = minLevelFilter LG.LevelInfo