swagger-api · wing328 · Sep 18, 2017 · Sep 8, 2017
diff --git a/.../swagger-codegen/src/main/java/io/swagger/codegen/languages/HaskellHttpClientCodegen.java b/.../swagger-codegen/src/main/java/io/swagger/codegen/languages/HaskellHttpClientCodegen.java
@@ -44,6 +44,8 @@ public class HaskellHttpClientCodegen extends DefaultCodegen implements CodegenC
 
     protected String defaultDateFormat = "%Y-%m-%d";
 
+    protected Boolean useMonadLogger = false;
+
     // CLI
     public static final String ALLOW_FROMJSON_NULLS = "allowFromJsonNulls";
     public static final String ALLOW_TOJSON_NULLS = "allowToJsonNulls";
@@ -54,6 +56,7 @@ public class HaskellHttpClientCodegen extends DefaultCodegen implements CodegenC
     public static final String GENERATE_MODEL_CONSTRUCTORS = "generateModelConstructors";
     public static final String MODEL_DERIVING = "modelDeriving";
     public static final String STRICT_FIELDS = "strictFields";
+    public static final String USE_MONAD_LOGGER = "useMonadLogger";
 
     // protected String MODEL_IMPORTS = "modelImports";
     // protected String MODEL_EXTENSIONS = "modelExtensions";
@@ -192,7 +195,8 @@ public HaskellHttpClientCodegen() {
         cliOptions.add(CliOption.newBoolean(GENERATE_FORM_URLENCODED_INSTANCES, "Generate FromForm/ToForm instances for models that are used by operations that produce or consume application/x-www-form-urlencoded").defaultValue(Boolean.TRUE.toString()));
 
         cliOptions.add(CliOption.newString(MODEL_DERIVING, "Additional classes to include in the deriving() clause of Models"));
-        cliOptions.add(CliOption.newBoolean(STRICT_FIELDS, "Add strictness annotations to all model fields").defaultValue((Boolean.FALSE.toString())));
+        cliOptions.add(CliOption.newBoolean(STRICT_FIELDS, "Add strictness annotations to all model fields").defaultValue((Boolean.TRUE.toString())));
+        cliOptions.add(CliOption.newBoolean(USE_MONAD_LOGGER, "Use the monad-logger package to provide logging (if false, use the katip logging package)").defaultValue((Boolean.FALSE.toString())));
 
         cliOptions.add(CliOption.newString(DATETIME_FORMAT, "format string used to parse/render a datetime"));
         cliOptions.add(CliOption.newString(DATE_FORMAT, "format string used to parse/render a date").defaultValue(defaultDateFormat));
@@ -252,6 +256,11 @@ public void setStrictFields(Boolean value) {
         additionalProperties.put("x-strictFields", value);
     }
 
+    public void setUseMonadLogger(Boolean value) {
+        additionalProperties.put("x-useMonadLogger", value);
+        this.useMonadLogger = value;
+    }
+
     @Override
     public void processOpts() {
         super.processOpts();
@@ -313,7 +322,12 @@ public void processOpts() {
         if (additionalProperties.containsKey(STRICT_FIELDS)) {
             setStrictFields(convertPropertyToBoolean(STRICT_FIELDS));
         } else {
-            setStrictFields(false);
+            setStrictFields(true);
+        }
+        if (additionalProperties.containsKey(USE_MONAD_LOGGER)) {
+            setUseMonadLogger(convertPropertyToBoolean(USE_MONAD_LOGGER));
+        } else {
+            setUseMonadLogger(false);
         }
 
     }
@@ -366,9 +380,6 @@ public void preprocessSwagger(Swagger swagger) {
         // root
         supportingFiles.add(new SupportingFile("haskell-http-client.cabal.mustache", "", cabalName + ".cabal"));
 
-        supportingFiles.add(new SupportingFile("haskell-http-client.cabal.mustache", "", cabalName + ".cabal"));
-        supportingFiles.add(new SupportingFile("package.mustache", "", "package.yaml"));
-
         // lib
         supportingFiles.add(new SupportingFile("TopLevel.mustache", "lib/", apiName + ".hs"));
         supportingFiles.add(new SupportingFile("Client.mustache", "lib/" + apiName, "Client.hs"));
@@ -377,6 +388,9 @@ public void preprocessSwagger(Swagger swagger) {
         supportingFiles.add(new SupportingFile("Model.mustache", "lib/" + apiName, "Model.hs"));
         supportingFiles.add(new SupportingFile("MimeTypes.mustache", "lib/" + apiName, "MimeTypes.hs"));
 
+        // logger
+        supportingFiles.add(new SupportingFile(useMonadLogger ? "LoggingMonadLogger.mustache" : "LoggingKatip.mustache", "lib/" + apiName, "Logging.hs"));
+
         // modelTemplateFiles.put("API.mustache", ".hs");
         // apiTemplateFiles.put("Model.mustache", ".hs");
 

diff --git a/modules/swagger-codegen/src/main/resources/haskell-http-client/Client.mustache b/modules/swagger-codegen/src/main/resources/haskell-http-client/Client.mustache
@@ -17,6 +17,7 @@ module {{title}}.Client where
 import {{title}}.Model
 import {{title}}.API
 import {{title}}.MimeTypes
+import {{title}}.Logging
 
 import qualified Control.Monad.IO.Class as P
 import qualified Data.Aeson as A
@@ -30,8 +31,6 @@ 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
@@ -57,8 +56,8 @@ import qualified Control.Exception.Safe as E
 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.
+  , configLogExecWithContext :: LogExecWithContext -- ^ Run a block using a Logger instance
+  , configLogContext :: LogContext -- ^ Configures the logger
   }
 
 -- | display the config
@@ -79,29 +78,29 @@ instance Show {{configType}} where
 --
 -- @"{{#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}
+newConfig :: IO {{configType}}
+newConfig = do
+    logCxt <- initLogContext
+    return $ SwaggerPetstoreConfig
+        { configHost = "{{{basePath}}}"
+        , configUserAgent = "{{#httpUserAgent}}{{{.}}}{{/httpUserAgent}}{{^httpUserAgent}}{{{artifactId}}}/{{{artifactVersion}}}{{/httpUserAgent}}"
+        , configLogExecWithContext = runDefaultLogExecWithContext
+        , configLogContext = logCxt
+        }  
+
+withStdoutLogging :: {{configType}} -> IO {{configType}}
+withStdoutLogging p = do
+    logCxt <- stdoutLoggingContext (configLogContext p)
+    return $ p { configLogExecWithContext = stdoutLoggingExec, configLogContext = logCxt }
+
+withStderrLogging :: {{configType}} -> IO {{configType}}
+withStderrLogging p = do
+    logCxt <- stderrLoggingContext (configLogContext p)
+    return $ p { configLogExecWithContext = stderrLoggingExec, configLogContext = logCxt }
 
 -- | updates the config to disable logging
 withNoLogging :: {{configType}} -> {{configType}}
-withNoLogging p = p { configExecLoggingT = runNullLoggingT}
+withNoLogging p = p { configLogExecWithContext =  runNullLogExec}
 
 -- * Dispatch
 
@@ -146,10 +145,10 @@ dispatchMime
 dispatchMime manager config request accept = do
   httpResponse <- dispatchLbs manager config request accept
   parsedResult <-
-    runExceptionLoggingT "Client" config $
+    runConfigLogWithExceptions "Client" config $
     do case mimeUnrender' accept (NH.responseBody httpResponse) of
          Left s -> do
-           logNST LG.LevelError "Client" (T.pack s)
+           _log "Client" levelError (T.pack s)
            pure (Left (MimeError s httpResponse))
          Right r -> pure (Right r)
   return (MimeResult parsedResult httpResponse)
@@ -187,15 +186,15 @@ dispatchInitUnsafe
   -> 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
+  runConfigLogWithExceptions src config $
+    do _log src levelInfo requestLogMsg
+       _log src levelDebug requestDbgLogMsg
        res <- P.liftIO $ NH.httpLbs req manager
-       logNST LG.LevelInfo logSrc (responseLogMsg res)
-       logNST LG.LevelDebug logSrc ((T.pack . show) res)
+       _log src levelInfo (responseLogMsg res)
+       _log src levelDebug ((T.pack . show) res)
        return res
   where
-    logSrc = "Client"
+    src = "Client"
     endpoint =
       T.pack $
       BC.unpack $
@@ -250,68 +249,16 @@ modifyInitRequest (InitRequest req) f = InitRequest (f req)
 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
+-- | Run a block using the configured logger instance
+runConfigLog
+  :: P.MonadIO m
+  => {{configType}} -> LogExec m
+runConfigLog config = configLogExecWithContext config (configLogContext config)
+
+-- | Run a block using the configured logger instance (logs exceptions)
+runConfigLogWithExceptions
   :: (E.MonadCatch m, P.MonadIO m)
-  => T.Text -> {{configType}} -> LG.LoggingT m a -> m a
-runExceptionLoggingT logSrc config = runLoggingT config . logExceptions logSrc
+  => T.Text -> {{configType}} -> LogExec m
+runConfigLogWithExceptions src config = runConfigLog config . logExceptions src
diff --git a/modules/swagger-codegen/src/main/resources/haskell-http-client/LoggingKatip.mustache b/modules/swagger-codegen/src/main/resources/haskell-http-client/LoggingKatip.mustache
@@ -0,0 +1,108 @@
+{-|
+Module : {{title}}.Logging
+Katip Logging functions
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module {{title}}.Logging where
+
+import Data.Text (Text)
+import GHC.Exts (IsString(..))
+
+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 qualified Katip as LG
+
+-- * Type Aliases (for compatability)
+
+-- | 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 "{{title}}" "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
+