diff --git a/Guide/config.markdown b/Guide/config.markdown index 9cd67d643..7e7b3a405 100644 --- a/Guide/config.markdown +++ b/Guide/config.markdown @@ -425,62 +425,12 @@ Controls log level, format, and destination. | | | |---|---| -| **Type** | `Logger` | -| **Default (Development)** | Debug level, default format, stdout | -| **Default (Production)** | Info level, default format, stdout | +| **Type** | `FastLogger` (from `System.Log.FastLogger`) | +| **Default** | Logs to stdout | -```haskell --- Config.hs -import IHP.Log as Log -import IHP.Log.Types - -config = do - -- Log only warnings and above - logger <- liftIO $ newLogger def { level = Warn } - option logger -``` - -##### Log Levels - -Log levels from lowest to highest: `Debug`, `Info`, `Warn`, `Error`, `Fatal`, `Unknown`. Messages below the configured level are discarded. - -| Level | Description | -|-------|-------------| -| `Debug` | General debugging messages, SQL queries. Default in Development. | -| `Info` | Informational messages for monitoring. Default in Production. | -| `Warn` | Potential problems. | -| `Error` | Recoverable application errors. | -| `Fatal` | Unrecoverable errors (does not exit the program). | -| `Unknown` | Always logged regardless of level setting. | - -##### Log Destinations - -```haskell --- Log to a file without rotation -logger <- liftIO $ newLogger def { destination = File "Log/production.log" NoRotate defaultBufSize } - --- Log to a file with size-based rotation (4 MB, keep 7 rotated files) -logger <- liftIO $ newLogger def { destination = File "Log/production.log" (SizeRotate (Bytes (4 * 1024 * 1024)) 7) defaultBufSize } - --- Log to stderr -logger <- liftIO $ newLogger def { destination = Stderr defaultBufSize } - --- Disable logging -logger <- liftIO $ newLogger def { destination = None } -``` +IHP uses [fast-logger](https://hackage.haskell.org/package/fast-logger) directly. The logger is a `FastLogger` (`LogStr -> IO ()`) created at startup and available via `?context.logger` in controllers. -##### Log Formatters - -```haskell --- Include timestamps -logger <- liftIO $ newLogger def { formatter = withTimeFormatter } - --- Include log level -logger <- liftIO $ newLogger def { formatter = withLevelFormatter } - --- Include both timestamp and log level -logger <- liftIO $ newLogger def { formatter = withTimeAndLevelFormatter } -``` +Log via `?context.logger (toLogStr "message")`. See the [Logging Guide](logging.html) for details. #### Request Logger IP Source diff --git a/Guide/debugging.markdown b/Guide/debugging.markdown index 25afecfe6..04115c51e 100644 --- a/Guide/debugging.markdown +++ b/Guide/debugging.markdown @@ -37,14 +37,13 @@ Web/Controller/Posts.hs:10:14: error: This means GHC cannot find a variable or function with the name `postsz`. Usually this is a typo. In this case, you probably meant `posts` instead of `postsz`. -It can also mean you forgot to import a module. For example, if you use `Log.debug` without importing the logging module, you will see: +It can also mean you forgot to import a module. For example, if you use `toLogStr` without importing it, you will see: ``` -Not in scope: `Log.debug' -No module named `Log' is imported. +Not in scope: `toLogStr' ``` -**Fix:** Add `import qualified IHP.Log as Log` to the top of your module. +**Fix:** Add `import System.Log.FastLogger (toLogStr)` to the top of your module. ### Couldn't Match Type @@ -228,25 +227,25 @@ action ShowPostAction { postId } = do The output appears in the terminal where `devenv up` is running. -### Using `Log.debug` (Recommended) +### Using the Logger (Recommended) -For more structured output, use the IHP logging system. Import it at the top of your module: +For more structured output, use the fast-logger based logging system. Import it at the top of your module: ```haskell -import qualified IHP.Log as Log +import System.Log.FastLogger (toLogStr) ``` -Then use `Log.debug`, `Log.info`, `Log.warn`, or `Log.error`: +Then log via `?context.logger`: ```haskell action ShowPostAction { postId } = do - Log.debug ("ShowPostAction called with postId: " <> show postId) + ?context.logger (toLogStr ("ShowPostAction called with postId: " <> show postId :: Text)) post <- fetch postId - Log.info ("Rendering post: " <> post.title) + ?context.logger (toLogStr ("Rendering post: " <> post.title)) render ShowView { .. } ``` -The advantage of `Log.debug` over `putStrLn` is that log levels can be configured. In production, debug messages are hidden by default while errors are always shown. See the [Logging Guide](logging.html) for details on configuration. +See the [Logging Guide](logging.html) for more details. ### Quick Reference: Which Logging Tool to Use @@ -254,7 +253,7 @@ The advantage of `Log.debug` over `putStrLn` is that log levels can be configure |-----------|------|---------------------| | Quick throwaway debugging | `traceShowId` / `debug` | Terminal (stderr) | | Debugging in controller actions | `putStrLn` | Terminal (stdout) | -| Structured, permanent logging | `Log.debug` / `Log.info` | Terminal + configurable destination | +| Structured, permanent logging | `?context.logger` | Terminal (stdout) | | Inspecting a value inline without changing code flow | `traceShowId` | Terminal (stderr) | ## Using the Dev Server Error Overlay diff --git a/Guide/logging.markdown b/Guide/logging.markdown index f9c6f8a7b..95468f8d8 100644 --- a/Guide/logging.markdown +++ b/Guide/logging.markdown @@ -6,248 +6,48 @@ ## Introduction -IHP applications and the framework itself can log output using the `IHP.Log` module. - -**Note:** since the logging system is multi-threaded for optimal performance, it is not guaranteed that messages will be printed in order. -If you need to know exact ordering it's recommended you rely on the timestamp. - -### Log levels -IHP logging uses log levels to determine which messages should be printed. -This way, you can log messages to help in development without flooding production logs. - -The available log levels are [`debug`](https://ihp.digitallyinduced.com/api-docs/IHP-Log.html#v:debug), [`info`](https://ihp.digitallyinduced.com/api-docs/IHP-Log.html#v:info), [`warn`](https://ihp.digitallyinduced.com/api-docs/IHP-Log.html#v:warn), [`error`](https://ihp.digitallyinduced.com/api-docs/IHP-Log.html#v:error), [`fatal`](https://ihp.digitallyinduced.com/api-docs/IHP-Log.html#v:fatal), and [`unknown`](https://ihp.digitallyinduced.com/api-docs/IHP-Log.html#v:unknown). -In development, the default log level is debug. In production, the default log level is info. -Log messages will only be output if their log level is greater than or equal to the logger's configured log level. +IHP uses [fast-logger](https://hackage.haskell.org/package/fast-logger) for logging. A `FastLogger` (which is just `LogStr -> IO ()`) is available via `?context.logger` in controllers and `?modelContext.logger` in model code. ### Sending messages -In any controller or model code, you can log a message at a given log level by simply calling -[`Log.debug`](https://ihp.digitallyinduced.com/api-docs/IHP-Log.html#v:debug), [`Log.info`](https://ihp.digitallyinduced.com/api-docs/IHP-Log.html#v:info), or any of the other available log levels. +In any controller or model code, you can log a message by calling the logger directly: -Example: ```haskell action TopPerformancesAction {collection} = do - Log.debug "starting TopPerformancesAction" + ?context.logger (toLogStr ("starting TopPerformancesAction" :: Text)) let n = paramOrDefault 5 "numPerformances" band <- fetchBand collection topPerformances <- fetchTopPerformances collection n - Log.debug $ show (length topPerformances) <> " top performances received." - whenEmpty topPerformances $ Log.warn "No performances found! Something might be wrong" + ?context.logger (toLogStr (show (length topPerformances) <> " top performances received." :: Text)) render TopPerformancesView {..} ``` -Make sure you have the `IHP.Log` module imported qualified as `Log`: - -```haskell -import qualified IHP.Log as Log -``` - -### Configuration - -Configure the IHP logger in `Config/Config.hs`. First, make sure you have imported the `IHP.Log` modules: - -```haskell -import qualified IHP.Log as Log -import IHP.Log.Types -``` - -Using the [`newLogger`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#v:newLogger) function, create a logger with the desired options. For example, here is a logger that formats -logs with a timestamp at the `Debug` log level: - -```haskell -logger <- liftIO $ newLogger def { - level = Debug, - formatter = withTimeFormatter - } -option logger -``` - -The available configuration options can be found in the [`LoggerSettings`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#t:LoggerSettings) record. - -```haskell -data LoggerSettings = LoggerSettings { - level :: LogLevel, - formatter :: LogFormatter, - destination :: LogDestination, - timeFormat :: TimeFormat -} -``` - -#### Configuring log level - -Set [`level`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#t:LoggerSettings) to one of the available constructors for the [`LogLevel`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#t:LogLevel) type: - -```haskell -data LogLevel - = Debug - | Info - | Warn - | Error - | Fatal - | Unknown -``` - -#### Configuring log format - -IHP ships with four available log formats. - -- [`defaultFormatter`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#v:defaultFormatter) simply prints the log message with a newline. - - `Server started` -- [`withTimeFormatter`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#v:withTimeFormatter) prepends a timestamp. - - `[28-Jan-2021 10:07:58] Server started` -- [`withLevelFormatter`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#v:withLevelFormatter) prepends the message's log level - - `[INFO] Server started` -- [`withTimeAndLevelFormatter`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#v:withTimeAndLevelFormatter) prepends both a timestamp and log level. - - `[INFO] [28-Jan-2021 10:07:58] Server started` - -You can also define your own formatter. Since a LogFormatter is just a type alias: - -```haskell -type LogFormatter = FormattedTime -> LogLevel -> Text -> Text -``` - -you can define a formatter as a simple function: - -```haskell --- | For when debugging is getting you down -withTimeAndLevelFormatterUpcaseAndHappy :: LogFormatter -withTimeAndLevelFormatterUpcaseAndHappy time level msg = - "[" <> toUpper (show level) <> "]" - <> "[" <> time <> "] " - <> toUpper msg <> " :) \n" -``` - -Which logs a message like: - - [INFO] [28-Jan-2021 10:07:58] SERVER STARTED :) - -#### Configuring log destination - -By default, messages are logged to standard out. -IHP includes all the destinations included in `fast-logger` wrapped in a custom API. - -```haskell -data LogDestination - = None - -- | Log messages to standard output. - | Stdout BufSize - -- | Log messages to standard error. - | Stderr BufSize - -- | Log message to a file. Rotate the log file with the behavior given by 'RotateSettings'. - | File FilePath RotateSettings BufSize - -- | Send logged messages to a callback. Flush action called after every log. - | Callback (LogStr -> IO ()) (IO ()) -``` - -##### Logging to a file - -When logging to a file, it is common to rotate the file logged to in order to prevent -the log file from getting too big. IHP allows for this in three ways, through the [`RotateSettings`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#t:RotateSettings) record. - -- [`NoRotate`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#t:RotateSettings) never rotates the file, meaning the log file can become arbitrarily large. - Use with caution. The following example will log all messages to a file at `Log/production.log`. - -```haskell -newLogger def { - destination = File "Log/production.log" NoRotate defaultBufSize -} -``` - -- [`SizeRotate`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#t:RotateSettings) rotates the file after reaching a specified size (in bytes). - The following example will log all messages to a file at `Log/production.log`, - and rotate the file once it reaches 4 megabytes in size. It will - keep 7 log files before overwriting the first file. - -```haskell -newLogger def { - destination = File "Log/production.log" (SizeRotate (Bytes (4 * 1024 * 1024)) 7) defaultBufSize -} -``` - -- [`TimedRotate`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#t:RotateSettings) rotates the file based on a time format string and a function which compares two times formatted by said format string. It also passes the rotated log's file path to a function, which can be used to compress old logs as in this example which rotates once per day: +Make sure you have `System.Log.FastLogger` imported: ```haskell -let - filePath = "Log/production.log" - formatString = "%FT%H%M%S" - timeCompare = (==) on C8.takeWhile (/=T)) - compressFile fp = void . forkIO $ - callProcess "tar" [ "--remove-files", "-caf", fp <> ".gz", fp ] -in - newLogger def { - destination = File - filePath - (TimedRotate formatString timeCompare compressFile) - defaultBufSize - } +import System.Log.FastLogger (toLogStr) ``` -#### Configuring timestamp format +### How it works -[`timeFormat`](https://ihp.digitallyinduced.com/api-docs/IHP-Log-Types.html#t:TimeFormat) expects a time format string as defined [here](https://man7.org/linux/man-pages/man3/strptime.3.html). +IHP creates a `FastLogger` at startup using `withFastLogger` from the fast-logger package. This logger writes to stdout by default. It is stored in `FrameworkConfig.logger` and `ModelContext.logger`, and is accessible via implicit parameters in controllers and models. -Example: +The `FastLogger` type is just a function: ```haskell -newLogger def { - timeFormat = "%A, %Y-%m-%d %H:%M:%S" -} +type FastLogger = LogStr -> IO () ``` -Would log a timestamp as: +You convert text to `LogStr` using `toLogStr` and append a newline with `<> "\n"`. -> Sunday, 2020-1-31 22:10:21 +### Query timing -### Decorating the Logs with the User ID +In development mode (when the `DEBUG` environment variable is set), IHP automatically logs query timing information. This is controlled by the `debugMode` field on `ModelContext`, which is set based on the `DEBUG` environment variable. -You can override the default logger and have it decorated with additional information. A typical use case is adding the current user's ID or name to the log messages. +### Suppressing query logging +Use `withoutQueryLogging` to suppress query logs for a specific block: ```haskell --- Web/FrontController.hs - --- Add imports -import IHP.Log.Types as Log -import IHP.Controller.Context - -instance InitControllerContext WebApplication where - initContext = do - initAuthentication @User - -- ... your other initContext code - - putContext userIdLogger - -userIdLogger :: (?context :: ControllerContext) => Logger -userIdLogger = - defaultLogger { Log.formatter = userIdFormatter defaultLogger.formatter } - where - defaultLogger = ?context.frameworkConfig.logger - - -userIdFormatter :: (?context :: ControllerContext) => Log.LogFormatter -> Log.LogFormatter -userIdFormatter existingFormatter time level string = - existingFormatter time level (prependUserId string) - -prependUserId :: (?context :: ControllerContext) => LogStr -> LogStr -prependUserId string = - toLogStr $ userInfo <> show string - where - userInfo = - case currentUserOrNothing of - Just currentUser -> "Authenticated user ID: " <> show currentUser.id <> " " - Nothing -> "Anonymous user: " -``` - -From your controller you can now add a log message - -```haskell - action PostsAction = do - Log.debug ("This log message should have user info" :: Text) - -- Rest of the action code. -``` - -In your log output, you will see the user info prepended to the log message. - +users <- withoutQueryLogging (sqlQuery "SELECT * FROM users" ()) ``` -[30-Mar-2024 18:28:29] Authenticated user ID: 5f32a9e3-da09-48d8-9712-34c935a72c7a "This log message should have user info" -``` \ No newline at end of file diff --git a/Guide/production-checklist.markdown b/Guide/production-checklist.markdown index 68ad7cc7a..7dfd408b2 100644 --- a/Guide/production-checklist.markdown +++ b/Guide/production-checklist.markdown @@ -72,29 +72,11 @@ IHP uses the `IHP_ENV` environment variable (or the `option` in `Config/Config.h IHP's default production logger uses `Info` level with Apache-style request logging. You can customize this in `Config/Config.hs`. -- **Set an appropriate log level**: For production, `Info` or `Warn` is recommended. Avoid `Debug` in production as it generates excessive output and may include sensitive data. +- **Review logging output**: IHP logs to stdout via fast-logger. All log messages are always emitted — control verbosity at the deployment level (e.g., redirect stdout, use log aggregation). - ```haskell - -- Config/Config.hs - import IHP.Log.Types - - config :: ConfigBuilder - config = do - logger <- liftIO $ newLogger def { level = Info } - option logger - ``` - -- **Set up log aggregation**: If you are deploying on AWS, consider forwarding logs to CloudWatch using Vector. The deployment guide includes a complete [CloudWatch configuration](https://ihp.digitallyinduced.com/Guide/deployment.html). On other platforms, you can log to a file with rotation: - - ```haskell - logger <- liftIO $ newLogger def { - level = Info, - destination = File "Log/production.log" (SizeRotate (Bytes (4 * 1024 * 1024)) 7) defaultBufSize - } - option logger - ``` +- **Set up log aggregation**: If you are deploying on AWS, consider forwarding logs to CloudWatch using Vector. The deployment guide includes a complete [CloudWatch configuration](https://ihp.digitallyinduced.com/Guide/deployment.html). -- **Verify logs do not contain sensitive data**: Check that log messages do not include passwords, session tokens, API keys, or other secrets. Be cautious with `Log.debug` calls that may dump request bodies. +- **Verify logs do not contain sensitive data**: Check that log messages do not include passwords, session tokens, API keys, or other secrets. - **Monitor application logs after deployment**: Check `journalctl --unit=app.service -n 100 --no-pager` on your server to verify the app started cleanly and is handling requests without unexpected errors. diff --git a/Guide/scripts.markdown b/Guide/scripts.markdown index b76ae98ca..fce6a073b 100644 --- a/Guide/scripts.markdown +++ b/Guide/scripts.markdown @@ -97,8 +97,6 @@ You can define custom configurations in your `Config.hs`: ```haskell -- Config.hs -import IHP.Log.Types - appConfig :: ConfigBuilder appConfig = do option Development diff --git a/NixSupport/overlay.nix b/NixSupport/overlay.nix index 69afa41c3..f1c9630fa 100644 --- a/NixSupport/overlay.nix +++ b/NixSupport/overlay.nix @@ -48,7 +48,6 @@ let ihp-with-docs = localPackageWithHaddock "ihp"; ihp-context = localPackage "ihp-context"; ihp-pagehead = localPackage "ihp-pagehead"; - ihp-log = localPackage "ihp-log"; ihp-pglistener = localPackage "ihp-pglistener"; ihp-modal = localPackage "ihp-modal"; ihp-ide = localPackage "ihp-ide"; diff --git a/devenv-module.nix b/devenv-module.nix index be4bdc1fe..da28c3b6e 100644 --- a/devenv-module.nix +++ b/devenv-module.nix @@ -156,7 +156,7 @@ that is defined in flake-module.nix ihpPackageNames = [ "ihp-ide" "ihp-hsx" "ihp-schema-compiler" "ihp-postgres-parser" "ihp-context" "ihp-pagehead" - "ihp-log" "ihp-modal" "ihp-mail" + "ihp-modal" "ihp-mail" "ihp-migrate" "ihp-openai" "ihp-ssc" "ihp-graphql" "ihp-datasync-typescript" "ihp-sitemap" "ihp-job-dashboard" "ihp-imagemagick" @@ -183,7 +183,7 @@ that is defined in flake-module.nix ihpPackageNames = [ "ihp-ide" "ihp-hsx" "ihp-schema-compiler" "ihp-postgres-parser" "ihp-context" "ihp-pagehead" - "ihp-log" "ihp-modal" "ihp-mail" + "ihp-modal" "ihp-mail" "ihp-migrate" "ihp-openai" "ihp-ssc" "ihp-graphql" "ihp-datasync-typescript" "ihp-sitemap" "ihp-job-dashboard" "ihp-imagemagick" diff --git a/ihp-datasync/IHP/DataSync/ControllerImpl.hs b/ihp-datasync/IHP/DataSync/ControllerImpl.hs index a712ece9c..32d7e2b63 100644 --- a/ihp-datasync/IHP/DataSync/ControllerImpl.hs +++ b/ihp-datasync/IHP/DataSync/ControllerImpl.hs @@ -3,7 +3,7 @@ module IHP.DataSync.ControllerImpl where import IHP.ControllerPrelude hiding (OrderByClause, sqlQuery, sqlExec, sqlQueryScalar) import qualified Control.Exception.Safe as Exception -import qualified IHP.Log as Log +import System.Log.FastLogger (toLogStr) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Aeson @@ -76,7 +76,7 @@ runDataSyncController hasqlPool ensureRLSEnabled installTableChangeTriggers rece Left (e :: Exception.SomeException) -> do let requestId = decodedMessage.requestId let errorMessage = cs (displayException e) - Log.error (tshow e) + ?modelContext.logger (toLogStr (tshow e)) sendJSON DataSyncError { requestId, errorMessage } Right _ -> pure () ) diff --git a/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs b/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs index e9cc6f755..fb196a0fd 100644 --- a/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs +++ b/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs @@ -18,6 +18,7 @@ import IHP.RequestVault (pgListenerVaultKey, frameworkConfigVaultKey) import IHP.Controller.Context (newControllerContext, putContext, freeze) import IHP.LoginSupport.Types (HasNewSessionUrl(..), CurrentUserRecord) import qualified IHP.ModelSupport as ModelSupport +import IHP.ModelSupport (noopLogger) import IHP.ModelSupport.Types (Id'(..), PrimaryKey) import qualified IHP.PGListener as PGListener import IHP.FrameworkConfig (buildFrameworkConfig) @@ -34,7 +35,6 @@ import Data.Aeson (Value(..), object, (.=)) import qualified Data.Aeson as Aeson import Control.Concurrent.STM import Control.Concurrent (threadDelay) -import qualified IHP.Log as Log -- | Define CurrentUserRecord for this test module data TestUser = TestUser { id :: Id' "test_users" } @@ -143,10 +143,10 @@ withDataSyncController connStr testUserId action = do let actualConnStr = if "dbname=" `Text.isPrefixOf` connStr then cs connStr else cs ("dbname=" <> connStr) - logger <- Log.newLogger def { Log.level = Log.Error } + let logger = noopLogger ModelSupport.withModelContext actualConnStr logger \modelContext -> do PGListener.withPGListener actualConnStr logger \pgListener -> do - frameworkConfig <- buildFrameworkConfig (pure ()) + frameworkConfig <- buildFrameworkConfig logger (pure ()) let frameworkConfig' = frameworkConfig { databaseUrl = actualConnStr } let v = Vault.empty diff --git a/ihp-datasync/default.nix b/ihp-datasync/default.nix index ce968cfc9..0c1f85ee0 100644 --- a/ihp-datasync/default.nix +++ b/ihp-datasync/default.nix @@ -3,7 +3,7 @@ , haskell-src-exts, haskell-src-meta, hasql , hasql-dynamic-statements, hasql-mapping, hasql-pool , hasql-postgresql-types, hasql-transaction, hspec, http-media -, http-types, ihp, ihp-hsx, ihp-log, interpolate, lib +, http-types, ihp, ihp-hsx, interpolate, lib , mono-traversable, mtl, postgresql-types, safe-exceptions , scientific, stm, template-haskell, text, time, transformers , typerep-map, unliftio, unordered-containers, uuid, vault, vector @@ -18,7 +18,7 @@ mkDerivation { classy-prelude containers deepseq haskell-src-exts haskell-src-meta hasql hasql-dynamic-statements hasql-mapping hasql-pool hasql-postgresql-types hasql-transaction http-media http-types ihp - ihp-hsx ihp-log interpolate mono-traversable mtl postgresql-types + ihp-hsx interpolate mono-traversable mtl postgresql-types safe-exceptions scientific stm template-haskell text time transformers typerep-map unliftio unordered-containers uuid vault vector wai wai-websockets warp websockets @@ -28,7 +28,7 @@ mkDerivation { classy-prelude containers deepseq haskell-src-exts haskell-src-meta hasql hasql-dynamic-statements hasql-mapping hasql-pool hasql-postgresql-types hasql-transaction hspec http-media - http-types ihp ihp-hsx ihp-log interpolate mono-traversable mtl + http-types ihp ihp-hsx interpolate mono-traversable mtl postgresql-types safe-exceptions scientific stm template-haskell text time transformers typerep-map unliftio unordered-containers uuid vault vector wai wai-websockets warp websockets diff --git a/ihp-datasync/ihp-datasync.cabal b/ihp-datasync/ihp-datasync.cabal index f96d12ffa..38a8cd386 100644 --- a/ihp-datasync/ihp-datasync.cabal +++ b/ihp-datasync/ihp-datasync.cabal @@ -52,7 +52,7 @@ common shared-properties , unliftio , async , ihp - , ihp-log + , fast-logger , ihp-hsx , deepseq , safe-exceptions diff --git a/ihp-hspec/IHP/Hspec.hs b/ihp-hspec/IHP/Hspec.hs index 63c1aeb02..edeab0e92 100644 --- a/ihp-hspec/IHP/Hspec.hs +++ b/ihp-hspec/IHP/Hspec.hs @@ -20,7 +20,7 @@ import IHP.ControllerSupport (InitControllerContext) import IHP.FrameworkConfig (ConfigBuilder (..), FrameworkConfig (..)) import qualified IHP.FrameworkConfig as FrameworkConfig import qualified IHP.ModelSupport as ModelSupport -import IHP.Log.Types +import IHP.ModelSupport (noopLogger) import qualified System.Process as Process import IHP.Test.Mocking (MockContext(..), runTestMiddlewares) @@ -44,7 +44,7 @@ runSessionOnConnection conn session = do withIHPApp :: (InitControllerContext application) => application -> ConfigBuilder -> (MockContext application -> IO ()) -> IO () withIHPApp application configBuilder hspecAction = do FrameworkConfig.withFrameworkConfig configBuilder \frameworkConfig -> do - logger <- newLogger def { level = Warn } -- don't log queries + let logger = noopLogger -- don't log queries withTestDatabase frameworkConfig.databaseUrl \testDatabaseUrl -> do ModelSupport.withModelContext testDatabaseUrl logger \modelContext -> do diff --git a/ihp-hspec/default.nix b/ihp-hspec/default.nix index 7a77b8a3a..70f573561 100644 --- a/ihp-hspec/default.nix +++ b/ihp-hspec/default.nix @@ -1,4 +1,4 @@ -{ mkDerivation, base, hasql, ihp, ihp-ide, ihp-log, lib, process +{ mkDerivation, base, hasql, ihp, ihp-ide, lib, process , text, uuid, vault, wai, wai-request-params }: mkDerivation { @@ -6,7 +6,7 @@ mkDerivation { version = "1.5.0"; src = ./.; libraryHaskellDepends = [ - base hasql ihp ihp-ide ihp-log process text uuid vault wai + base hasql ihp ihp-ide process text uuid vault wai wai-request-params ]; homepage = "https://ihp.digitallyinduced.com/"; diff --git a/ihp-hspec/ihp-hspec.cabal b/ihp-hspec/ihp-hspec.cabal index 1026e1eec..d58e6ef9f 100644 --- a/ihp-hspec/ihp-hspec.cabal +++ b/ihp-hspec/ihp-hspec.cabal @@ -36,6 +36,6 @@ library ImplicitParams RecordWildCards ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields - build-depends: base >= 4.17.0 && < 4.22, ihp, ihp-log, wai, process, text, ihp-ide, vault, uuid, hasql, wai-request-params + build-depends: base >= 4.17.0 && < 4.22, ihp, fast-logger, wai, process, text, ihp-ide, vault, uuid, hasql, wai-request-params hs-source-dirs: . exposed-modules: IHP.Hspec \ No newline at end of file diff --git a/ihp-ide/IHP/IDE/Postgres.hs b/ihp-ide/IHP/IDE/Postgres.hs index d27629445..122a431d9 100644 --- a/ihp-ide/IHP/IDE/Postgres.hs +++ b/ihp-ide/IHP/IDE/Postgres.hs @@ -4,7 +4,7 @@ import IHP.IDE.Types import IHP.Prelude import Control.Concurrent (threadDelay) -import qualified IHP.Log as Log +import System.Log.FastLogger (toLogStr) import qualified IHP.EnvVar as EnvVar import qualified System.Process as Process @@ -20,6 +20,6 @@ waitPostgres = do case exitCode of ExitSuccess -> pure () ExitFailure _ -> do - when isDebugMode (Log.debug ("Waiting for postgres to start" :: Text)) + when isDebugMode (?context.logger (toLogStr ("Waiting for postgres to start" :: Text))) threadDelay 100000 -- 100ms between checks waitPostgres diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Migrations.hs b/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Migrations.hs index 1833da891..65ad93781 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Migrations.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Migrations.hs @@ -151,6 +151,6 @@ withMigrateConnection :: (Connection.Connection -> IO result) -> IO result withMigrateConnection inner = Exception.bracket acquire Connection.release inner where acquire = do - frameworkConfig <- buildFrameworkConfig (pure ()) + frameworkConfig <- buildFrameworkConfig noopLogger (pure ()) Connection.acquire (ConnectionSettings.connectionString (cs frameworkConfig.databaseUrl)) >>= either (\e -> error ("DB connect failed: " <> show e)) pure diff --git a/ihp-ide/IHP/IDE/ToolServer.hs b/ihp-ide/IHP/IDE/ToolServer.hs index 7d551fea7..a2382b199 100644 --- a/ihp-ide/IHP/IDE/ToolServer.hs +++ b/ihp-ide/IHP/IDE/ToolServer.hs @@ -1,6 +1,7 @@ module IHP.IDE.ToolServer (runToolServer, withToolServerApplication, ToolServerApplicationWithConfig(..)) where import IHP.Prelude +import System.Log.FastLogger (LogType'(..), withFastLogger, defaultBufSize) import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import IHP.IDE.Types @@ -92,65 +93,66 @@ data ToolServerApplicationWithConfig = ToolServerApplicationWithConfig -- - websocket support (for live reload) withToolServerApplication :: ToolServerApplication -> Int -> _ -> (ToolServerApplicationWithConfig -> IO result) -> IO result withToolServerApplication toolServerApplication port liveReloadClients action = do - frameworkConfig <- Config.buildFrameworkConfig do - Config.option $ Config.AppHostname "localhost" - Config.option $ Config.AppPort port - Config.option $ Config.AssetVersion Version.ihpVersion - - ihpIdeBaseUrlEnvVar <- EnvVar.envOrNothing "IHP_IDE_BASEURL" - case ihpIdeBaseUrlEnvVar of - Just baseUrl -> Config.option $ Config.BaseUrl baseUrl - Nothing -> pure () - - withModelContext frameworkConfig.databaseUrl frameworkConfig.logger \modelContext -> do - store <- fmap clientsessionStore (ClientSession.getKey "Config/client_session_key.aes") - let sessionMiddleware :: Wai.Middleware = withSession store "SESSION" (frameworkConfig.sessionCookie) sessionVaultKey - - approotMiddleware <- Approot.envFallbackNamed "IDE_APPROOT" - - staticApp <- initStaticApp - - let innerApplication :: Wai.Application = \request respond -> do - frontControllerToWAIApp @ToolServerApplication @AutoRefresh.AutoRefreshWSApp (\app -> app) toolServerApplication staticApp request respond - - let responseHeadersMiddleware = insertNewIORefVaultMiddleware responseHeadersVaultKey [] - let rlsContextMiddleware = insertNewIORefVaultMiddleware rlsContextVaultKey Nothing - let modalMiddleware = insertNewIORefVaultMiddleware modalContainerVaultKey Nothing - - let toolServerVaultMiddleware app req respond = do - availableApps <- AvailableApps <$> findApplications - webControllers <- WebControllers <$> findWebControllers - let defaultAppUrl = "http://localhost:" <> tshow toolServerApplication.appPort - appUrl <- AppUrl <$> EnvVar.envOrDefault "IHP_BASEURL" defaultAppUrl - databaseNeedsMigration <- DatabaseNeedsMigration <$> readIORef toolServerApplication.databaseNeedsMigration - hooglePort <- EnvVar.envOrNothing "IHP_HOOGLE_PORT" - let hoogleUrl = HoogleUrl $ case hooglePort of - Just port | port /= "" -> Just ("http://localhost:" <> port) - _ -> Nothing - let req' = req { Wai.vault = Vault.insert availableAppsVaultKey availableApps - . Vault.insert webControllersVaultKey webControllers - . Vault.insert appUrlVaultKey appUrl - . Vault.insert databaseNeedsMigrationVaultKey databaseNeedsMigration - . Vault.insert hoogleUrlVaultKey hoogleUrl - $ req.vault } - app req' respond - - let application = - methodOverridePost $ sessionMiddleware $ approotMiddleware - $ viewLayoutMiddleware - $ responseHeadersMiddleware - $ rlsContextMiddleware - $ modalMiddleware - $ toolServerVaultMiddleware - $ modelContextMiddleware modelContext - $ frameworkConfigMiddleware frameworkConfig - $ requestBodyMiddleware frameworkConfig.parseRequestBodyOptions - $ Websocket.websocketsOr - Websocket.defaultConnectionOptions - (LiveReloadNotificationServer.app liveReloadClients) - innerApplication - - action ToolServerApplicationWithConfig { application, frameworkConfig } + withFastLogger (LogStdout defaultBufSize) \logger -> do + frameworkConfig <- Config.buildFrameworkConfig logger do + Config.option $ Config.AppHostname "localhost" + Config.option $ Config.AppPort port + Config.option $ Config.AssetVersion Version.ihpVersion + + ihpIdeBaseUrlEnvVar <- EnvVar.envOrNothing "IHP_IDE_BASEURL" + case ihpIdeBaseUrlEnvVar of + Just baseUrl -> Config.option $ Config.BaseUrl baseUrl + Nothing -> pure () + + withModelContext frameworkConfig.databaseUrl frameworkConfig.logger \modelContext -> do + store <- fmap clientsessionStore (ClientSession.getKey "Config/client_session_key.aes") + let sessionMiddleware :: Wai.Middleware = withSession store "SESSION" (frameworkConfig.sessionCookie) sessionVaultKey + + approotMiddleware <- Approot.envFallbackNamed "IDE_APPROOT" + + staticApp <- initStaticApp + + let innerApplication :: Wai.Application = \request respond -> do + frontControllerToWAIApp @ToolServerApplication @AutoRefresh.AutoRefreshWSApp (\app -> app) toolServerApplication staticApp request respond + + let responseHeadersMiddleware = insertNewIORefVaultMiddleware responseHeadersVaultKey [] + let rlsContextMiddleware = insertNewIORefVaultMiddleware rlsContextVaultKey Nothing + let modalMiddleware = insertNewIORefVaultMiddleware modalContainerVaultKey Nothing + + let toolServerVaultMiddleware app req respond = do + availableApps <- AvailableApps <$> findApplications + webControllers <- WebControllers <$> findWebControllers + let defaultAppUrl = "http://localhost:" <> tshow toolServerApplication.appPort + appUrl <- AppUrl <$> EnvVar.envOrDefault "IHP_BASEURL" defaultAppUrl + databaseNeedsMigration <- DatabaseNeedsMigration <$> readIORef toolServerApplication.databaseNeedsMigration + hooglePort <- EnvVar.envOrNothing "IHP_HOOGLE_PORT" + let hoogleUrl = HoogleUrl $ case hooglePort of + Just port | port /= "" -> Just ("http://localhost:" <> port) + _ -> Nothing + let req' = req { Wai.vault = Vault.insert availableAppsVaultKey availableApps + . Vault.insert webControllersVaultKey webControllers + . Vault.insert appUrlVaultKey appUrl + . Vault.insert databaseNeedsMigrationVaultKey databaseNeedsMigration + . Vault.insert hoogleUrlVaultKey hoogleUrl + $ req.vault } + app req' respond + + let application = + methodOverridePost $ sessionMiddleware $ approotMiddleware + $ viewLayoutMiddleware + $ responseHeadersMiddleware + $ rlsContextMiddleware + $ modalMiddleware + $ toolServerVaultMiddleware + $ modelContextMiddleware modelContext + $ frameworkConfigMiddleware frameworkConfig + $ requestBodyMiddleware frameworkConfig.parseRequestBodyOptions + $ Websocket.websocketsOr + Websocket.defaultConnectionOptions + (LiveReloadNotificationServer.app liveReloadClients) + innerApplication + + action ToolServerApplicationWithConfig { application, frameworkConfig } initStaticApp :: IO Wai.Application initStaticApp = do diff --git a/ihp-ide/IHP/IDE/Types.hs b/ihp-ide/IHP/IDE/Types.hs index 9ef3c8c3a..27f8b129c 100644 --- a/ihp-ide/IHP/IDE/Types.hs +++ b/ihp-ide/IHP/IDE/Types.hs @@ -8,8 +8,7 @@ import qualified Data.ByteString.Char8 as ByteString import IHP.IDE.PortConfig import Data.String.Conversions (cs) import Data.UUID -import qualified IHP.Log.Types as Log -import qualified IHP.Log as Log +import System.Log.FastLogger (FastLogger, toLogStr) import qualified Control.Concurrent.Chan.Unagi as Queue import qualified Network.Socket as Socket import System.OsPath (OsPath, decodeUtf) @@ -23,7 +22,7 @@ procDirenvAware command args = do sendGhciCommand :: (?context :: Context) => Handle -> ByteString -> IO () sendGhciCommand inputHandle command = do - when (isDebugMode ?context) (Log.debug ("GHCI: " <> cs command :: Text)) + when (isDebugMode ?context) (?context.logger (toLogStr ("GHCI: " <> cs command :: Text))) ByteString.hPutStrLn inputHandle command Handle.hFlush inputHandle @@ -36,7 +35,7 @@ data OutputLine = StandardOutput !ByteString | ErrorOutput !ByteString deriving data Context = Context { portConfig :: !PortConfig , isDebugMode :: !Bool - , logger :: !Log.Logger + , logger :: !FastLogger , ghciInChan :: !(Queue.InChan OutputLine) -- ^ Output of the app ghci is written here , ghciOutChan :: !(Queue.OutChan OutputLine) -- ^ Output of the app ghci is consumed here , liveReloadClients :: !(IORef (Map UUID Websocket.Connection)) diff --git a/ihp-ide/IHP/Telemetry.hs b/ihp-ide/IHP/Telemetry.hs index 7d2796c5c..a0739364a 100644 --- a/ihp-ide/IHP/Telemetry.hs +++ b/ihp-ide/IHP/Telemetry.hs @@ -18,8 +18,7 @@ import System.OsPath (decodeUtf) import qualified Data.Text as T import qualified Data.Text.IO as TIO -import qualified IHP.Log.Types as Log -import qualified IHP.Log as Log +import System.Log.FastLogger (FastLogger, toLogStr) import qualified IHP.EnvVar as EnvVar data TelemetryInfo = TelemetryInfo @@ -32,16 +31,17 @@ data TelemetryInfo = TelemetryInfo -- | Reports telemetry info to the IHP Telemetry server -- -- This can be disabled by setting the env var IHP_TELEMETRY_DISABLED=1 -reportTelemetry :: (?context :: context, Log.LoggingProvider context) => IO () +reportTelemetry :: (?context :: context, HasField "logger" context FastLogger) => IO () reportTelemetry = do isDisabled <- EnvVar.envOrDefault "IHP_TELEMETRY_DISABLED" False unless isDisabled do + let logger = ?context.logger payload <- toPayload <$> getTelemetryInfo - Log.info (tshow payload) + logger (toLogStr (tshow payload)) result <- Exception.try (Wreq.post "https://ihp-telemetry.digitallyinduced.com/CreateEvent" payload) case result of - Left (e :: IOException) -> Log.warn ("Telemetry failed: " <> show e) - Right _ -> Log.info ("IHP Telemetry is activated. This can be disabled by setting env variable IHP_TELEMETRY_DISABLED=1" :: Text) + Left (e :: IOException) -> logger (toLogStr ("Telemetry failed: " <> show e)) + Right _ -> logger (toLogStr ("IHP Telemetry is activated. This can be disabled by setting env variable IHP_TELEMETRY_DISABLED=1" :: Text)) getTelemetryInfo :: IO TelemetryInfo getTelemetryInfo = do diff --git a/ihp-ide/default.nix b/ihp-ide/default.nix index 992046b74..1fe6f48b9 100644 --- a/ihp-ide/default.nix +++ b/ihp-ide/default.nix @@ -4,7 +4,7 @@ , containers, countable-inflections, cryptohash, data-default , directory, filepath, fsnotify, hasql, hasql-dynamic-statements , hasql-implicits, hasql-pool, hspec, http-types, ihp, ihp-hsx -, ihp-log, ihp-migrate, ihp-modal, ihp-postgres-parser +, fast-logger, ihp-migrate, ihp-modal, ihp-postgres-parser , ihp-schema-compiler, inflections, interpolate, lib, megaparsec , mono-traversable, neat-interpolation, network, network-uri , process, safe-exceptions, split, string-conversions, text, time @@ -27,7 +27,7 @@ mkDerivation { clientsession containers countable-inflections cryptohash data-default directory filepath fsnotify hasql hasql-dynamic-statements hasql-implicits hasql-pool http-types ihp - ihp-hsx ihp-log ihp-migrate ihp-modal ihp-postgres-parser + ihp-hsx fast-logger ihp-migrate ihp-modal ihp-postgres-parser ihp-schema-compiler inflections interpolate megaparsec mono-traversable neat-interpolation network network-uri process safe-exceptions split string-conversions text time transformers @@ -42,7 +42,7 @@ mkDerivation { classy-prelude clientsession containers countable-inflections cryptohash data-default directory filepath fsnotify hasql hasql-dynamic-statements hasql-implicits hasql-pool http-types ihp - ihp-hsx ihp-log ihp-migrate ihp-postgres-parser ihp-schema-compiler + ihp-hsx fast-logger ihp-migrate ihp-postgres-parser ihp-schema-compiler inflections interpolate megaparsec mono-traversable neat-interpolation network network-uri process safe-exceptions split string-conversions text time transformers unagi-chan unix @@ -56,7 +56,7 @@ mkDerivation { clientsession containers countable-inflections cryptohash data-default directory filepath fsnotify hasql hasql-dynamic-statements hasql-implicits hasql-pool hspec - http-types ihp ihp-hsx ihp-log ihp-migrate ihp-modal + http-types ihp ihp-hsx fast-logger ihp-migrate ihp-modal ihp-postgres-parser ihp-schema-compiler inflections interpolate megaparsec mono-traversable neat-interpolation network network-uri process safe-exceptions split string-conversions text time diff --git a/ihp-ide/exe/IHP/IDE/DevServer.hs b/ihp-ide/exe/IHP/IDE/DevServer.hs index 2d178ce2e..5aedea8aa 100644 --- a/ihp-ide/exe/IHP/IDE/DevServer.hs +++ b/ihp-ide/exe/IHP/IDE/DevServer.hs @@ -18,9 +18,7 @@ import Data.String.Conversions (cs) import qualified IHP.Telemetry as Telemetry import qualified IHP.Version as Version -import qualified IHP.Log.Types as Log -import qualified IHP.Log as Log -import Data.Default (def, Default (..)) +import System.Log.FastLogger (FastLogger, toLogStr, LogType'(..), withFastLogger, defaultBufSize) import qualified IHP.IDE.CodeGen.MigrationGenerator as MigrationGenerator import Main.Utf8 (withUtf8) import qualified IHP.FrameworkConfig as FrameworkConfig @@ -85,14 +83,15 @@ mainWithOptions wrapWithDirenv = withUtf8 do -- ensuring seamless transitions during app restarts (no connection refused errors) appSocket <- createListeningSocket portConfig.appPort - bracket (Log.newLogger def) (\logger -> logger.cleanup) \logger -> do + withFastLogger (LogStdout defaultBufSize) \rawLogger -> do + let logger msg = rawLogger (msg <> "\n") (ghciInChan, ghciOutChan) <- Queue.newChan liveReloadClients <- newIORef mempty lastSchemaCompilerError <- newIORef Nothing let ?context = Context { portConfig, isDebugMode, logger, ghciInChan, ghciOutChan, wrapWithDirenv, liveReloadClients, lastSchemaCompilerError, appSocket } -- Print IHP Version when in debug mode - when isDebugMode (Log.debug ("IHP Version: " <> Version.ihpVersion)) + when isDebugMode (logger (toLogStr ("IHP Version: " <> Version.ihpVersion))) ghciIsLoadingVar <- newIORef False reloadGhciVar :: MVar () <- newEmptyMVar @@ -364,7 +363,7 @@ updateDatabaseIsOutdated databaseNeedsMigrationRef = do writeIORef databaseNeedsMigrationRef databaseNeedsMigration case result of - Left exception -> Log.error (tshow exception) + Left exception -> ?context.logger (toLogStr (tshow exception)) Right _ -> pure () tryCompileSchema :: (?context :: Context) => MVar () -> MVar () -> IO () @@ -373,7 +372,7 @@ tryCompileSchema reloadGhciVar startStatusServer = do case result of Left exception -> do - Log.error (tshow exception) + ?context.logger (toLogStr (tshow exception)) receiveAppOutput (ErrorOutput (cs $ displayException exception)) writeIORef ?context.lastSchemaCompilerError (Just exception) diff --git a/ihp-ide/ihp-ide.cabal b/ihp-ide/ihp-ide.cabal index a72a2c6cb..8dc7845cd 100644 --- a/ihp-ide/ihp-ide.cabal +++ b/ihp-ide/ihp-ide.cabal @@ -147,7 +147,7 @@ common shared-properties library import: shared-properties hs-source-dirs: . - build-depends: ihp, ihp-log, ihp-modal, wai-request-params, ihp-schema-compiler + build-depends: ihp, fast-logger, ihp-modal, wai-request-params, ihp-schema-compiler exposed-modules: IHP.IDE.Prelude , IHP.IDE.SchemaDesigner.Controller.Columns @@ -238,7 +238,7 @@ library executable RunDevServer import: shared-properties - build-depends: ihp, ihp-log, ihp-ide, ihp-schema-compiler + build-depends: ihp, fast-logger, ihp-ide, ihp-schema-compiler hs-source-dirs: exe main-is: IHP/IDE/DevServer.hs ghc-options: -rtsopts=all @@ -329,7 +329,7 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Test/Main.hs hs-source-dirs: . - build-depends: ihp, ihp-log, ihp-modal, ihp-schema-compiler, hspec, wai-request-params, wai-asset-path + build-depends: ihp, fast-logger, ihp-modal, ihp-schema-compiler, hspec, wai-request-params, wai-asset-path other-modules: Test.IDE.SchemaDesigner.CompilerSpec Test.IDE.SchemaDesigner.ParserSpec diff --git a/ihp-log/IHP/Log.hs b/ihp-log/IHP/Log.hs deleted file mode 100644 index 11fd6e6d3..000000000 --- a/ihp-log/IHP/Log.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-| -Module: IHP.Log -Description: Functions to write logs at all log levels. - -Import this module qualified! All code examples -assume you have imported the module as follows: - -> import qualified IHP.Log as Log - --} -module IHP.Log -( module IHP.Log.Types -, debug -, info -, warn -, error -, fatal -, unknown -, writeLog -, makeRequestLogger -, defaultRequestLogger -) where - -import Prelude hiding (error, log) -import Control.Monad (when) -import IHP.Log.Types -import Network.Wai (Middleware) -import Network.Wai.Middleware.RequestLogger (mkRequestLogger, RequestLoggerSettings, destination) -import qualified Network.Wai.Middleware.RequestLogger as RequestLogger -import Data.Default (Default (def)) -import qualified System.Log.FastLogger as FastLogger - --- | Format a log and send it to the logger. --- Internal use only -- application code should call the --- function corresponding to the desired log level. -log :: (?context :: context, LoggingProvider context, FastLogger.ToLogStr string) => LogLevel -> string -> IO () -log level text = do - writeLog level ?context.logger text - --- | Log a debug level message. --- --- > action CreateUserAction { .. } = do --- > Log.debug "entered CreateUserAction" --- > ... -debug :: (?context :: context, LoggingProvider context, FastLogger.ToLogStr string) => string -> IO () -debug = log Debug - --- | Log an info level message. --- --- > action UsersAction = do --- > users <- query @User |> fetch --- > Log.info $ show (lengh users) <> " users fetched." --- > ... -info :: (?context :: context, LoggingProvider context, FastLogger.ToLogStr string) => string -> IO () -info = log Info - --- | Log a warning level message. --- --- > action UsersAction = do --- > users <- query @User |> fetch --- > whenEmpty users $ Log.warn "No users found. Something might be wrong!" --- > ... -warn :: (?context :: context, LoggingProvider context, FastLogger.ToLogStr string) => string -> IO () -warn = log Warn - --- |Log a warning level message. --- --- @ --- action CreatePostAction = do --- let post = newRecord @Post --- post --- |> buildPost --- |> ifValid \case --- Left post -> do --- Log.error "Invalid post." --- render NewView { .. } --- Right post -> do --- post <- post |> createRecord --- setSuccessMessage "Post created" --- redirectTo PostsAction --- @ -error :: (?context :: context, LoggingProvider context, FastLogger.ToLogStr string) => string -> IO () -error = log Error - --- | Log a fatal level message. --- Note this does not exit the program for you -- it only logs to the "Fatal" log level. --- --- > Log.fatal "Unrecoverable application error!" -fatal :: (?context :: context, LoggingProvider context, FastLogger.ToLogStr string) => string -> IO () -fatal = log Fatal - --- | Log an "unknown" level message. --- This is the highest log level and will always be output by the logger. --- --- > Log.unknown "This will be sent to the logger no matter what!" -unknown :: (?context :: context, LoggingProvider context, FastLogger.ToLogStr string) => string -> IO () -unknown = log Unknown - --- | Write a log if the given log level is greater than or equal to the logger's log level. -writeLog :: (FastLogger.ToLogStr string) => LogLevel -> Logger -> string -> IO () -writeLog level logger text = do - let write = logger.write - let formatter = logger.formatter - when (level >= logger.level) $ - write (\time -> formatter time level (toLogStr text)) - --- | Wraps 'RequestLogger' from wai-extra to log to an IHP logger. --- See 'Network.Wai.Middleware.RequestLogger'. -makeRequestLogger :: RequestLoggerSettings -> Logger -> IO Middleware -makeRequestLogger settings logger = - mkRequestLogger settings { - destination = RequestLogger.Callback (\logStr -> - let ?context = logger in - info (fromLogStr logStr) - ) - } - --- | Create a request logger with default settings wrapped in an IHP logger. --- See 'Network.Wai.Middleware.RequestLogger'. -defaultRequestLogger :: Logger -> IO Middleware -defaultRequestLogger = makeRequestLogger def diff --git a/ihp-log/IHP/Log/Types.hs b/ihp-log/IHP/Log/Types.hs deleted file mode 100644 index a1eadcedc..000000000 --- a/ihp-log/IHP/Log/Types.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-| -Module: IHP.Log.Types -Description: Types for the IHP logging system --} - -module IHP.Log.Types -( Bytes(..) -, LogStr -, BufSize -, TimeFormat -, RotateSettings(..) -, toLogStr -, fromLogStr -, defaultBufSize -, simpleTimeFormat -, simpleTimeFormat' -, Logger(..) -, LogLevel(..) -, LogDestination(..) -, LoggingProvider(..) -, LoggerSettings(..) -, LogFormatter -, FormattedTime -, newLogger -, defaultLogger -, defaultDestination -, defaultFormatter -, withLevelFormatter -, withTimeFormatter -, withTimeAndLevelFormatter -, OsPath -) where - -import Prelude -import Data.ByteString (ByteString) -import Data.Text as Text -import Data.Default (Default (def)) -import System.Log.FastLogger ( - LogStr, - LogType'(..), - BufSize, - FileLogSpec(..), - TimedFileLogSpec(..), - TimeFormat, - toLogStr, - fromLogStr, - defaultBufSize, - newTimeCache, - simpleTimeFormat, - simpleTimeFormat', - newTimedFastLogger, - ToLogStr (..) - ) - -import qualified System.Log.FastLogger as FastLogger (FormattedTime) -import GHC.Records -import System.OsPath (OsPath, encodeUtf, decodeUtf) - - --- some functions brought over from IHP.Prelude --- can't import due to circular dependency with IHP.ModelSupport which relies on this module - -tshow :: Show a => a -> Text -tshow value = Text.pack (Prelude.show value) - -show :: Show a => a -> Text -show = tshow - --- | Interal logger type that encapsulates information needed to perform --- logging operations. Users can also access this though the 'LoggingProvider' --- class in controller and model actions to perform logic based on the set log level. -data Logger = Logger { - write :: !((FastLogger.FormattedTime -> LogStr) -> IO ()), - level :: !LogLevel, - formatter :: !LogFormatter, - timeCache :: !(IO FastLogger.FormattedTime), - cleanup :: !(IO ()) -} - -data LogLevel - -- | For general messages to help with debugging during development. - -- Default log level in development. - -- Also the log level used for SQL queries. - -- See 'IHP.Log.debug' for example usage. - = Debug - -- | For info messages that help montior application usage. - -- Default log level for production. - -- See 'IHP.Log.info' for example usage. - | Info - -- | For warning messages when something might be wrong. - -- See 'IHP.Log.warn' for example usage. - | Warn - -- | For application errors that can be recovered from. - -- See 'IHP.Log.error' for example usage. - | Error - -- | For application errors that are fatal - -- See 'IHP.Log.fatal' for example usage. - | Fatal - -- | For miscallenaous log messages. Highest log level - will always be logged - -- See 'IHP.Log.unknown' for example usage. - | Unknown - deriving (Enum, Eq, Ord, Show) - -instance ToLogStr LogLevel where - toLogStr Debug = "DEBUG" - toLogStr Info = "INFO" - toLogStr Warn = "WARN" - toLogStr Error = "ERROR" - toLogStr Fatal = "FATAL" - toLogStr Unknown = "UNKNOWN" - --- | The timestamp in the formatted defined by the logger's timeFormat string. -type FormattedTime = ByteString - --- | Called every time a message is sent to the logger. --- Since this is just a function type, it's trivial to define custom formatters: --- --- @ --- withTimeAndLevelFormatterUpcaseAndHappy :: LogFormatter --- withTimeAndLevelFormatterUpcaseAndHappy time level msg = --- "[" <> toUpper (show level) <> "]" --- <> "[" <> time <> "] " --- <> toUpper msg <> " :) \n" --- @ -type LogFormatter = FormattedTime -> LogLevel -> LogStr -> LogStr - --- | A number of bytes, used in 'RotateSettings' -newtype Bytes = Bytes Integer - -data RotateSettings - -- | Log messages to a file which is never rotated. - -- - -- @ - -- newLogger def { - -- destination = File "Log/production.log" NoRotate defaultBufSize - -- } - -- @ - = NoRotate - -- | Log messages to a file and rotate the file after it reaches the given size in bytes. - -- Third argument is the max number of rotated log files to keep around before overwriting the oldest one. - -- - -- Example: log to a file rotated once it is 4MB, and keep 7 files before overwriting the first file. - -- - -- @ - -- newLogger def { - -- destination = File "Log/production.log" (SizeRotate (Bytes (4 * 1024 * 1024)) 7) defaultBufSize - -- } - -- @ - | SizeRotate !Bytes !Int - -- | Log messages to a file rotated on a timed basis. - -- Expects a time format string as well as a function which compares two formatted time strings - -- which is used to determine if the file should be rotated. - -- Last argument is a function which is called on a log file once its rotated. - -- - -- Example: rotate a file daily and compress the log file once rotated. - -- - -- @ - -- let - -- filePath = "Log/production.log" - -- formatString = "%FT%H%M%S" - -- timeCompare = (==) on C8.takeWhile (/=T)) - -- compressFile fp = void . forkIO $ - -- callProcess "tar" [ "--remove-files", "-caf", fp <> ".gz", fp ] - -- in - -- newLogger def { - -- destination = File - -- filePath - -- (TimedRotate formatString timeCompare compressFile) - -- defaultBufSize - -- } - -- @ - | TimedRotate !TimeFormat (FastLogger.FormattedTime -> FastLogger.FormattedTime -> Bool) (OsPath -> IO ()) - --- | Where logged messages will be delivered to. -data LogDestination - = None - -- | Log messages to standard output. - | Stdout !BufSize - -- | Log messages to standard error. - | Stderr !BufSize - -- | Log message to a file. Rotate the log file with the behavior given by 'RotateSettings'. - | File !OsPath !RotateSettings !BufSize - -- | Send logged messages to a callback. Flush action called after every log. - | Callback !(LogStr -> IO ()) !(IO ()) - -data LoggerSettings = LoggerSettings { - level :: LogLevel, - formatter :: LogFormatter, - destination :: LogDestination, - timeFormat :: TimeFormat -} - -instance Default LoggerSettings where - def = LoggerSettings { - level = Debug, - formatter = defaultFormatter, - destination = defaultDestination, - timeFormat = simpleTimeFormat' - } - --- | Logger default destination is to standard out. -defaultDestination :: LogDestination -defaultDestination = Stdout defaultBufSize - --- | Used to get the logger for a given environment. --- | Call in any instance of 'LoggingProvider' get the the environment's current logger. --- Useful in controller and model actions, which both have logging contexts. -type LoggingProvider context = HasField "logger" context Logger - -instance HasField "logger" Logger Logger where - getField logger = logger - --- | Create a new 'FastLogger' and wrap it in an IHP 'Logger'. --- Use with the default logger settings and record update syntax for nice configuration: --- --- > newLogger def { level = Error } -newLogger :: LoggerSettings -> IO Logger -newLogger LoggerSettings { .. } = do - timeCache <- newTimeCache timeFormat - (write, cleanup) <- makeFastLogger timeCache destination - pure Logger { .. } - where - makeFastLogger timeCache = \case - None -> newTimedFastLogger timeCache LogNone - Stdout buf -> newTimedFastLogger timeCache (LogStdout buf) - Stderr buf -> newTimedFastLogger timeCache (LogStderr buf) - File path settings buf -> do - logType <- makeFileLogger path settings buf - newTimedFastLogger timeCache logType - Callback callback flush -> newTimedFastLogger timeCache (LogCallback callback flush) - - makeFileLogger path NoRotate buf = do - fp <- decodeUtf path - pure (LogFileNoRotate fp buf) - makeFileLogger path (SizeRotate (Bytes size) count) buf = do - fp <- decodeUtf path - pure (LogFile (FileLogSpec fp size count) buf) - makeFileLogger path (TimedRotate fmt cmp post) buf = do - fp <- decodeUtf path - pure (LogFileTimedRotate (TimedFileLogSpec fp fmt cmp (\fpStr -> post =<< encodeUtf fpStr)) buf) - --- | Formats logs as-is to stdout. -defaultLogger :: IO Logger -defaultLogger = newLogger def - --- | Formats the log as-is with a newline added. -defaultFormatter :: LogFormatter -defaultFormatter _ _ msg = msg <> "\n" - --- | Prepends the timestamp to the log message and adds a new line. -withTimeFormatter :: LogFormatter -withTimeFormatter time _ msg = "[" <> toLogStr time <> "] " <> msg <> "\n" - --- | Prepends the log level to the log message and adds a new line. -withLevelFormatter :: LogFormatter -withLevelFormatter time level msg = "[" <> (toLogStr level) <> "] " <> msg <> "\n" - --- | Prepends the log level and timestamp to the log message and adds a new line. -withTimeAndLevelFormatter :: LogFormatter -withTimeAndLevelFormatter time level msg = "[" <> (toLogStr level) <> "] [" <> toLogStr time <> "] " <> msg <> "\n" diff --git a/ihp-log/LICENSE b/ihp-log/LICENSE deleted file mode 100644 index 098a3a608..000000000 --- a/ihp-log/LICENSE +++ /dev/null @@ -1,21 +0,0 @@ -The MIT License (MIT) - -Copyright (c) 2020 digitally induced GmbH - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. \ No newline at end of file diff --git a/ihp-log/default.nix b/ihp-log/default.nix deleted file mode 100644 index 7a963131d..000000000 --- a/ihp-log/default.nix +++ /dev/null @@ -1,15 +0,0 @@ -{ mkDerivation, base, bytestring, data-default, fast-logger -, filepath, lib, text, wai, wai-extra -}: -mkDerivation { - pname = "ihp-log"; - version = "1.0.0"; - src = ./.; - libraryHaskellDepends = [ - base bytestring data-default fast-logger filepath text wai - wai-extra - ]; - homepage = "https://ihp.digitallyinduced.com/"; - description = "Lightweight logging for IHP applications"; - license = lib.licenses.mit; -} diff --git a/ihp-log/ihp-log.cabal b/ihp-log/ihp-log.cabal deleted file mode 100644 index 279acd649..000000000 --- a/ihp-log/ihp-log.cabal +++ /dev/null @@ -1,42 +0,0 @@ -cabal-version: 2.2 -name: ihp-log -version: 1.0.0 -synopsis: Lightweight logging for IHP applications -description: Provides structured logging with configurable levels, formatters, and destinations. - Can be used standalone or with the full IHP framework. -license: MIT -license-file: LICENSE -author: digitally induced GmbH -maintainer: hello@digitallyinduced.com -homepage: https://ihp.digitallyinduced.com/ -bug-reports: https://github.com/digitallyinduced/ihp/issues -copyright: (c) digitally induced GmbH -category: Web, Logging, IHP - -common shared-properties - default-language: GHC2021 - build-depends: - base >= 4.17.0 && < 4.22 - , filepath >= 1.5 - , text - , bytestring - , data-default - , fast-logger - , wai - , wai-extra - default-extensions: - OverloadedStrings - , ImplicitParams - , DataKinds - , RecordWildCards - , OverloadedRecordDot - , DuplicateRecordFields - , LambdaCase - ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields - -library - import: shared-properties - hs-source-dirs: . - exposed-modules: - IHP.Log - , IHP.Log.Types diff --git a/ihp-pglistener/IHP/PGListener.hs b/ihp-pglistener/IHP/PGListener.hs index 8723f4c18..3307e2933 100644 --- a/ihp-pglistener/IHP/PGListener.hs +++ b/ihp-pglistener/IHP/PGListener.hs @@ -37,7 +37,7 @@ import Control.Exception (SomeException, displayException, uninterruptibleMask_) import Control.Concurrent.Async (Async, async, cancel, uninterruptibleCancel) import Data.Function ((&)) -import IHP.Log.Types (Logger) +import System.Log.FastLogger (FastLogger, toLogStr) import Data.Set (Set) import qualified Data.Set as Set import Control.Concurrent.MVar (MVar) @@ -46,7 +46,6 @@ import Data.HashMap.Strict as HashMap import qualified Control.Concurrent.Async as Async import qualified Data.List as List import qualified Data.Aeson as Aeson -import qualified IHP.Log as Log import qualified Control.Exception.Safe as Exception import qualified Control.Concurrent.Chan.Unagi as Queue import qualified Control.Concurrent @@ -59,8 +58,8 @@ import qualified Hasql.Notifications as HasqlNotifications tshow :: Prelude.Show a => a -> Text tshow = Text.pack . Prelude.show --- | Wrapper to satisfy 'LoggingProvider' constraint for standalone logging -data LogContext = LogContext { logger :: !Logger } +-- | Logger type alias for PGListener +type Logger = FastLogger -- TODO: How to deal with timeout of the connection? @@ -266,7 +265,7 @@ notifyLoop logger databaseUrl listeningToVar listenToVar subscriptions reconnect callbacks <- readIORef reconnectCallbacksRef forM_ callbacks \callback -> Exception.tryAny (callback connection) >>= \case - Left e -> let ?context = LogContext logger in Log.info ("PGListener reconnect callback failed: " <> displayException e) + Left e -> logger (toLogStr ("PGListener reconnect callback failed: " <> displayException e)) Right _ -> pure () -- We use 'race' to alternate between waiting for notifications and @@ -327,14 +326,13 @@ notifyLoop logger databaseUrl listeningToVar listenToVar subscriptions reconnect result <- Exception.tryAny innerLoop case result of Left error -> do - let ?context = LogContext logger if isFirstError then do - Log.info ("PGListener is going to restart, loop failed with exception: " <> (displayException error) <> ". Retrying immediately.") + logger (toLogStr ("PGListener is going to restart, loop failed with exception: " <> (displayException error) <> ". Retrying immediately.")) retryLoop delay False -- Retry with no delay interval on first error, but will increase delay interval in subsequent retries else do let increasedDelay = delay * 2 -- Double current delay let nextDelay = min increasedDelay maxDelay -- Picks whichever delay is lowest of increasedDelay * 2 or maxDelay - Log.info ("PGListener is going to restart, loop failed with exception: " <> (displayException error) <> ". Retrying in " <> cs (printTimeToNextRetry delay) <> ".") + logger (toLogStr ("PGListener is going to restart, loop failed with exception: " <> (displayException error) <> ". Retrying in " <> cs (printTimeToNextRetry delay) <> ".")) Control.Concurrent.threadDelay delay -- Sleep for the current delay retryLoop nextDelay False -- Retry with longer interval Right _ -> @@ -353,4 +351,4 @@ listenToChannel connection channel = do HasqlNotifications.listen connection (HasqlNotifications.toPgIdentifier (cs channel)) logError :: PGListener -> Text -> IO () -logError pgListener message = let ?context = LogContext pgListener.logger in Log.error message +logError pgListener message = pgListener.logger (toLogStr message) diff --git a/ihp-pglistener/Test/PGListenerSpec.hs b/ihp-pglistener/Test/PGListenerSpec.hs index 988554a21..aa6214506 100644 --- a/ihp-pglistener/Test/PGListenerSpec.hs +++ b/ihp-pglistener/Test/PGListenerSpec.hs @@ -18,21 +18,15 @@ import qualified Control.Concurrent.Async as Async import qualified Control.Exception.Safe as Exception import System.Environment (lookupEnv) -import IHP.Log.Types (Logger(..), LogLevel(..)) +import System.Log.FastLogger (FastLogger) import qualified IHP.PGListener as PGListener import qualified Hasql.Connection as Hasql import qualified Hasql.Connection.Settings as HasqlSettings import qualified Hasql.Session as Session -logger :: Logger -logger = Logger - { write = \_ -> pure () - , level = Debug - , formatter = \_ _ msg -> msg - , timeCache = pure "" - , cleanup = pure () - } +logger :: FastLogger +logger = \_ -> pure () getDatabaseUrl :: IO ByteString getDatabaseUrl = do diff --git a/ihp-pglistener/default.nix b/ihp-pglistener/default.nix index 3227098bc..f583f48fd 100644 --- a/ihp-pglistener/default.nix +++ b/ihp-pglistener/default.nix @@ -1,5 +1,5 @@ { mkDerivation, aeson, async, base, bytestring, containers -, hashable, hasql, hasql-notifications, hspec, ihp-log, lib +, hashable, hasql, hasql-notifications, hspec, fast-logger, lib , safe-exceptions, string-conversions, text, unagi-chan , unordered-containers, uuid }: @@ -9,12 +9,12 @@ mkDerivation { src = ./.; libraryHaskellDepends = [ aeson async base bytestring containers hashable hasql - hasql-notifications ihp-log safe-exceptions string-conversions text + hasql-notifications fast-logger safe-exceptions string-conversions text unagi-chan unordered-containers uuid ]; testHaskellDepends = [ aeson async base bytestring containers hashable hasql - hasql-notifications hspec ihp-log safe-exceptions + hasql-notifications hspec fast-logger safe-exceptions string-conversions text unagi-chan unordered-containers uuid ]; homepage = "https://ihp.digitallyinduced.com/"; diff --git a/ihp-pglistener/ihp-pglistener.cabal b/ihp-pglistener/ihp-pglistener.cabal index 5a4e588b0..e868649ce 100644 --- a/ihp-pglistener/ihp-pglistener.cabal +++ b/ihp-pglistener/ihp-pglistener.cabal @@ -30,7 +30,7 @@ common shared-properties , containers , unordered-containers , hashable - , ihp-log + , fast-logger default-extensions: OverloadedStrings , ImplicitParams diff --git a/ihp-sitemap/default.nix b/ihp-sitemap/default.nix index 1b44a08e4..a05d20c85 100644 --- a/ihp-sitemap/default.nix +++ b/ihp-sitemap/default.nix @@ -1,5 +1,5 @@ { mkDerivation, base, blaze-html, blaze-markup, hspec, http-types -, ihp, ihp-hsx, ihp-log, lib, text, wai, wai-extra +, ihp, ihp-hsx, lib, text, wai, wai-extra }: mkDerivation { pname = "ihp-sitemap"; @@ -9,7 +9,7 @@ mkDerivation { base blaze-html blaze-markup ihp text wai ]; testHaskellDepends = [ - base hspec http-types ihp ihp-hsx ihp-log wai wai-extra + base hspec http-types ihp ihp-hsx wai wai-extra ]; homepage = "https://ihp.digitallyinduced.com/"; description = "SEO"; diff --git a/ihp-sitemap/ihp-sitemap.cabal b/ihp-sitemap/ihp-sitemap.cabal index 72b6ea94a..15e1ea3f0 100644 --- a/ihp-sitemap/ihp-sitemap.cabal +++ b/ihp-sitemap/ihp-sitemap.cabal @@ -64,5 +64,4 @@ test-suite tests , wai-extra , http-types , ihp-hsx - , ihp-log hs-source-dirs: Test \ No newline at end of file diff --git a/ihp-ssc/IHP/ServerSideComponent/Controller/ComponentsController.hs b/ihp-ssc/IHP/ServerSideComponent/Controller/ComponentsController.hs index cc0758f27..ebbc8f3a6 100644 --- a/ihp-ssc/IHP/ServerSideComponent/Controller/ComponentsController.hs +++ b/ihp-ssc/IHP/ServerSideComponent/Controller/ComponentsController.hs @@ -6,7 +6,7 @@ import IHP.ServerSideComponent.Types as SSC import IHP.ServerSideComponent.ControllerFunctions as SSC import qualified Data.Aeson as Aeson -import qualified IHP.Log as Log +import System.Log.FastLogger (toLogStr) import qualified Control.Exception as Exception import Data.Typeable (typeOf) @@ -19,17 +19,18 @@ instance (Component component controller, FromJSON controller, Typeable componen let ?instanceRef = instanceRef let componentName = tshow (typeOf state) - Log.info ("SSC: Component " <> componentName <> " connected") + let log msg = ?modelContext.logger (toLogStr msg) + log ("SSC: Component " <> componentName <> " connected") -- Handle componentDidMount with exception handling mountResult <- Exception.try (componentDidMount state) case mountResult of Left (e :: SomeException) -> do let errorText = tshow e - Log.error ("SSC: componentDidMount failed for " <> componentName <> ": " <> errorText) + log ("SSC: componentDidMount failed for " <> componentName <> ": " <> errorText) SSC.sendError (SSCActionError { errorMessage = "Component initialization failed: " <> errorText }) Right nextState -> do - Log.debug ("SSC: Component " <> componentName <> " mounted") + log ("SSC: Component " <> componentName <> " mounted") SSC.setState nextState forever do @@ -46,12 +47,12 @@ instance (Component component controller, FromJSON controller, Typeable componen case actionResult of Left (e :: SomeException) -> do let errorText = tshow e - Log.error ("SSC: Action failed for " <> componentName <> ": " <> errorText) + log ("SSC: Action failed for " <> componentName <> ": " <> errorText) SSC.sendError (SSCActionError { errorMessage = errorText }) Right nextState -> do SSC.setState nextState Left parseError -> do let errorText = cs parseError - Log.error ("SSC: Failed parsing action for " <> componentName <> ": " <> errorText) - Log.debug ("SSC: Invalid payload: " <> tshow actionPayload) + log ("SSC: Failed parsing action for " <> componentName <> ": " <> errorText) + log ("SSC: Invalid payload: " <> tshow actionPayload) SSC.sendError (SSCParseError { errorMessage = errorText }) diff --git a/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs b/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs index 1d0e4100d..ded47137a 100644 --- a/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs +++ b/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs @@ -18,7 +18,7 @@ import qualified Data.Aeson.TH as Aeson import IHP.ServerSideComponent.HtmlParser import IHP.ServerSideComponent.HtmlDiff -import qualified IHP.Log as Log +import System.Log.FastLogger (toLogStr) $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { tagFieldName = "type" }} ''Attribute) $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { tagFieldName = "type" }} ''AttributeOperation) @@ -41,7 +41,7 @@ setState state = do case diffHtml oldHtml newHtml of Left parseError -> do let errorText = tshow parseError - Log.error ("SSC HTML diff failed: " <> errorText) + ?context.logger (toLogStr ("SSC HTML diff failed: " <> errorText)) sendError (SSCDiffError { errorMessage = errorText }) Right patches -> sendTextData (Aeson.encode patches) diff --git a/ihp-ssc/default.nix b/ihp-ssc/default.nix index 03c16f210..4c612aa16 100644 --- a/ihp-ssc/default.nix +++ b/ihp-ssc/default.nix @@ -1,5 +1,5 @@ { mkDerivation, aeson, attoparsec, base, basic-prelude, blaze-html -, bytestring, ihp, ihp-hsx, ihp-log, lib, megaparsec +, bytestring, ihp, ihp-hsx, lib, megaparsec , string-conversions, text, wai, wai-request-params, websockets }: mkDerivation { @@ -8,7 +8,7 @@ mkDerivation { src = ./.; libraryHaskellDepends = [ aeson attoparsec base basic-prelude blaze-html bytestring ihp - ihp-hsx ihp-log megaparsec string-conversions text wai + ihp-hsx megaparsec string-conversions text wai wai-request-params websockets ]; homepage = "https://ihp.digitallyinduced.com/"; diff --git a/ihp-ssc/ihp-ssc.cabal b/ihp-ssc/ihp-ssc.cabal index 7be15cc9d..45a2062f1 100644 --- a/ihp-ssc/ihp-ssc.cabal +++ b/ihp-ssc/ihp-ssc.cabal @@ -42,7 +42,7 @@ library , DeepSubsumption ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields hs-source-dirs: . - build-depends: ihp, ihp-log, aeson, megaparsec, bytestring, wai, websockets, ihp-hsx, base >= 4.17.0 && < 4.22, string-conversions, basic-prelude, text, blaze-html, attoparsec, wai-request-params + build-depends: ihp, fast-logger, aeson, megaparsec, bytestring, wai, websockets, ihp-hsx, base >= 4.17.0 && < 4.22, string-conversions, basic-prelude, text, blaze-html, attoparsec, wai-request-params exposed-modules: IHP.ServerSideComponent.Types , IHP.ServerSideComponent.ViewFunctions diff --git a/ihp-typed-sql/Test/Test/TypedSqlSpec.hs b/ihp-typed-sql/Test/Test/TypedSqlSpec.hs index 589a52cdb..8e6b08433 100644 --- a/ihp-typed-sql/Test/Test/TypedSqlSpec.hs +++ b/ihp-typed-sql/Test/Test/TypedSqlSpec.hs @@ -4,10 +4,10 @@ import qualified Control.Exception as Exception import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.IO as Text -import IHP.Log.Types import IHP.ModelSupport (createModelContext, releaseModelContext, - sqlExecDiscardResult) + sqlExecDiscardResult, + noopLogger) import IHP.Prelude import IHP.TypedSql.ParamHints (parseSql, extractJoinNullableTables, extractNonNullableComputedColumnsFromAst) @@ -383,7 +383,7 @@ requirePostgresTestHook = do withTestModelContext :: ((?modelContext :: ModelContext) => IO a) -> IO a withTestModelContext action = do - logger <- newLogger def { level = Warn } + let logger = noopLogger databaseUrl <- cs . fromMaybe "" <$> lookupEnv "DATABASE_URL" modelContext <- createModelContext databaseUrl logger let ?modelContext = modelContext @@ -835,8 +835,7 @@ runtimeModule = Text.unlines , "" , "import qualified Control.Exception as Exception" , "import IHP.Prelude" - , "import IHP.Log.Types" - , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext)" + , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext, noopLogger)" , "import IHP.Hasql.FromRow (FromRowHasql (..))" , "import IHP.TypedSql (sqlExecTyped, sqlQueryTyped, typedSql)" , "import qualified Hasql.Decoders as HasqlDecoders" @@ -866,7 +865,7 @@ runtimeModule = Text.unlines , "" , "main :: IO ()" , "main = do" - , " logger <- newLogger def { level = Warn }" + , " let logger = noopLogger" , " databaseUrl <- cs . fromMaybe \"\" <$> lookupEnv \"DATABASE_URL\"" , " modelContext <- createModelContext databaseUrl logger" , " let ?modelContext = modelContext" @@ -1086,8 +1085,7 @@ runtimeUpdateDeleteModule = Text.unlines , "" , "import qualified Control.Exception as Exception" , "import IHP.Prelude" - , "import IHP.Log.Types" - , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext)" + , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext, noopLogger)" , "import IHP.TypedSql (sqlExecTyped, sqlQueryTyped, typedSql)" , "import System.Environment (lookupEnv)" , "" @@ -1100,7 +1098,7 @@ runtimeUpdateDeleteModule = Text.unlines , "" , "main :: IO ()" , "main = do" - , " logger <- newLogger def { level = Warn }" + , " let logger = noopLogger" , " databaseUrl <- cs . fromMaybe \"\" <$> lookupEnv \"DATABASE_URL\"" , " modelContext <- createModelContext databaseUrl logger" , " let ?modelContext = modelContext" @@ -1177,8 +1175,7 @@ runtimeEdgeCasesModule = Text.unlines , "" , "import qualified Control.Exception as Exception" , "import IHP.Prelude" - , "import IHP.Log.Types" - , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext)" + , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext, noopLogger)" , "import IHP.TypedSql (sqlExecTyped, sqlQueryTyped, typedSql)" , "import System.Environment (lookupEnv)" , "" @@ -1191,7 +1188,7 @@ runtimeEdgeCasesModule = Text.unlines , "" , "main :: IO ()" , "main = do" - , " logger <- newLogger def { level = Warn }" + , " let logger = noopLogger" , " databaseUrl <- cs . fromMaybe \"\" <$> lookupEnv \"DATABASE_URL\"" , " modelContext <- createModelContext databaseUrl logger" , " let ?modelContext = modelContext" @@ -1262,8 +1259,7 @@ runtimeExtraTypesModule = Text.unlines , "" , "import qualified Control.Exception as Exception" , "import IHP.Prelude" - , "import IHP.Log.Types" - , "import IHP.ModelSupport (ModelContext, PrimaryKey, createModelContext, releaseModelContext)" + , "import IHP.ModelSupport (ModelContext, PrimaryKey, createModelContext, releaseModelContext, noopLogger)" , "import IHP.TypedSql (sqlQueryTyped, typedSql)" , "import Data.Time (UTCTime, Day, parseTimeM, defaultTimeLocale)" , "import Data.Scientific (Scientific)" @@ -1279,7 +1275,7 @@ runtimeExtraTypesModule = Text.unlines , "" , "main :: IO ()" , "main = do" - , " logger <- newLogger def { level = Warn }" + , " let logger = noopLogger" , " databaseUrl <- cs . fromMaybe \"\" <$> lookupEnv \"DATABASE_URL\"" , " modelContext <- createModelContext databaseUrl logger" , " let ?modelContext = modelContext" diff --git a/ihp-typed-sql/default.nix b/ihp-typed-sql/default.nix index 7870f8b53..22a09fbaf 100644 --- a/ihp-typed-sql/default.nix +++ b/ihp-typed-sql/default.nix @@ -1,6 +1,6 @@ { mkDerivation, aeson, base, bytestring, containers, directory , filepath, haskell-src-meta, hasql, hasql-dynamic-statements -, hasql-mapping, hasql-pool, hspec, ihp, ihp-log, lib +, hasql-mapping, hasql-pool, hspec, ihp, fast-logger, lib , postgresql-libpq, postgresql-syntax, postgresql-types, process , scientific, string-conversions, template-haskell, temporary-ospath, text }: @@ -15,7 +15,7 @@ mkDerivation { string-conversions template-haskell text ]; testHaskellDepends = [ - base containers directory filepath hspec ihp ihp-log process + base containers directory filepath hspec ihp fast-logger process string-conversions temporary-ospath text ]; homepage = "https://ihp.digitallyinduced.com/"; diff --git a/ihp-typed-sql/ihp-typed-sql.cabal b/ihp-typed-sql/ihp-typed-sql.cabal index a7817b518..63a406bd3 100644 --- a/ihp-typed-sql/ihp-typed-sql.cabal +++ b/ihp-typed-sql/ihp-typed-sql.cabal @@ -84,7 +84,7 @@ test-suite tests build-depends: base >= 4.17.0 && < 4.22 , ihp - , ihp-log + , fast-logger , ihp-typed-sql , containers , directory diff --git a/ihp/IHP/AutoRefresh.hs b/ihp/IHP/AutoRefresh.hs index 6586c5538..250f5160f 100644 --- a/ihp/IHP/AutoRefresh.hs +++ b/ihp/IHP/AutoRefresh.hs @@ -24,7 +24,7 @@ import IHP.Controller.Context import Network.Wai.Middleware.EarlyReturn (earlyReturnMiddleware) import qualified IHP.PGListener as PGListener import qualified Hasql.Session as HasqlSession -import qualified IHP.Log as Log +import System.Log.FastLogger (toLogStr) import qualified Data.Vault.Lazy as Vault import System.IO.Unsafe (unsafePerformIO) import Network.Wai @@ -140,7 +140,7 @@ instance WSApp AutoRefreshWSApp where AutoRefreshSession { renderView, event } <- getSessionById autoRefreshServer sessionId let handleOtherException :: SomeException -> IO () - handleOtherException ex = Log.error ("AutoRefresh: Failed to re-render view: " <> tshow ex) + handleOtherException ex = ?context.logger (toLogStr ("AutoRefresh: Failed to re-render view: " <> tshow ex)) async $ forever do MVar.takeMVar event diff --git a/ihp/IHP/Controller/Context.hs b/ihp/IHP/Controller/Context.hs index 39ec42222..2b51308d8 100644 --- a/ihp/IHP/Controller/Context.hs +++ b/ihp/IHP/Controller/Context.hs @@ -24,7 +24,7 @@ import GHC.Records (HasField(..)) import Data.Maybe (fromMaybe) import qualified Data.TMap as TypeMap import IHP.FrameworkConfig.Types (FrameworkConfig(..)) -import IHP.Log.Types +import System.Log.FastLogger (FastLogger) import System.IO.Unsafe (unsafePerformIO) import Network.Wai (Request) import IHP.RequestVault (requestFrameworkConfig) @@ -66,43 +66,7 @@ instance HasField "frameworkConfig" ControllerContext FrameworkConfig where getField controllerContext = requestFrameworkConfig controllerContext.request {-# INLINABLE getField #-} --- The following hack is bad, but allows us to override the logger using 'putContext' --- The alternative would be https://github.com/digitallyinduced/ihp/pull/1921 which is also not very nice --- --- This can be useful to customize the log formatter for all actions of an app: --- --- > -- Web/FrontController.hs --- > --- > import IHP.Log.Types as Log --- > import IHP.Controller.Context --- > --- > instance InitControllerContext WebApplication where --- > initContext = do --- > -- ... your other initContext code --- > --- > putContext userIdLogger --- > --- > userIdLogger :: (?context :: ControllerContext) => Logger --- > userIdLogger = --- > defaultLogger { Log.formatter = userIdFormatter defaultLogger.formatter } --- > where --- > defaultLogger = ?context.frameworkConfig.logger --- > --- > --- > userIdFormatter :: (?context :: ControllerContext) => Log.LogFormatter -> Log.LogFormatter --- > userIdFormatter existingFormatter time level string = --- > existingFormatter time level (prependUserId string) --- > --- > prependUserId :: (?context :: ControllerContext) => LogStr -> LogStr --- > prependUserId string = --- > toLogStr $ userInfo <> show string --- > where --- > userInfo = --- > case currentUserOrNothing of --- > Just currentUser -> "Authenticated user ID: " <> show currentUser.id <> " " --- > Nothing -> "Anonymous user: " --- --- This design mistake should be fixed in IHP v2 -instance HasField "logger" ControllerContext Logger where - getField context@(FrozenControllerContext { customFields }) = fromMaybe context.frameworkConfig.logger (TypeMap.lookup @Logger customFields) - getField context = (unsafePerformIO (freeze context)).logger -- Hacky, but there's no better way. The only way to retrieve the logger here, is by reading from the IORef in an unsafe way +-- | Allows overriding the logger per-controller via 'putContext' +instance HasField "logger" ControllerContext FastLogger where + getField context@(FrozenControllerContext { customFields }) = fromMaybe context.frameworkConfig.logger (TypeMap.lookup @FastLogger customFields) + getField context = (unsafePerformIO (freeze context)).logger diff --git a/ihp/IHP/ErrorController.hs b/ihp/IHP/ErrorController.hs index 99454b347..409f74032 100644 --- a/ihp/IHP/ErrorController.hs +++ b/ihp/IHP/ErrorController.hs @@ -40,9 +40,7 @@ import IHP.FrameworkConfig import qualified IHP.Environment as Environment import IHP.Controller.Context import IHP.Controller.NotFound (handleNotFound, buildNotFoundResponse) -import qualified IHP.Log as Log -import IHP.Log (writeLog) -import IHP.Log.Types (LogLevel(..)) +import System.Log.FastLogger (toLogStr) import IHP.ActionType (actionTypeVaultKey) import qualified Data.Vault.Lazy as Vault @@ -113,7 +111,7 @@ genericHandler exception controller additionalInfo = do let devErrorMessage = [hsx|{errorMessageText}|] let devTitle = [hsx|{errorMessageTitle}|] - Log.error (errorMessageText <> ": " <> cs errorMessageTitle) + ?context.logger (toLogStr (errorMessageText <> ": " <> cs errorMessageTitle)) let prodErrorMessage = [hsx|An exception was raised while running the action|] let prodTitle = [hsx|An error happened|] @@ -504,7 +502,7 @@ genericHandlerMiddleware frameworkConfig request exception actionDescription = d let devErrorMessage = [hsx|{errorMessageText}|] let devTitle = [hsx|{errorMessageTitle}|] - writeLog Error frameworkConfig.logger (errorMessageText <> ": " <> cs errorMessageTitle) + frameworkConfig.logger (toLogStr (errorMessageText <> ": " <> cs errorMessageTitle)) let prodErrorMessage = [hsx|An exception was raised while running the action|] let prodTitle = [hsx|An error happened|] diff --git a/ihp/IHP/FetchPipelined.hs b/ihp/IHP/FetchPipelined.hs index 370ae3c2f..3e761f202 100644 --- a/ihp/IHP/FetchPipelined.hs +++ b/ihp/IHP/FetchPipelined.hs @@ -41,7 +41,6 @@ import qualified Hasql.Encoders as Encoders import qualified Hasql.Pipeline as Pipeline import qualified Hasql.Session as HasqlSession import qualified Hasql.Statement as HasqlStatement -import qualified IHP.Log as Log import IHP.Hasql.Pool (usePoolWithRetry) import Data.Functor.Contravariant (contramap) import Data.Functor.Contravariant.Divisible (conquer) @@ -157,11 +156,10 @@ pipeline thePipeline = do _ -> thePipeline let session = HasqlSession.pipeline effectivePipeline let ?context = ?modelContext - let currentLogLevel = ?modelContext.logger.level let runQuery = case ?modelContext.transactionRunner of Just (TransactionRunner runner) -> runner session Nothing -> usePoolWithRetry pool session - logQueryTiming currentLogLevel "🔍 Pipeline" runQuery + logQueryTiming "🔍 Pipeline" runQuery {-# INLINABLE pipeline #-} -- | Session-scoped RLS config for pipeline mode. diff --git a/ihp/IHP/FrameworkConfig.hs b/ihp/IHP/FrameworkConfig.hs index 57fbcb481..2459fb86b 100644 --- a/ihp/IHP/FrameworkConfig.hs +++ b/ihp/IHP/FrameworkConfig.hs @@ -13,7 +13,6 @@ module IHP.FrameworkConfig , RootApplication (..) , defaultPort , defaultDatabaseUrl -, defaultLoggerForEnv , isEnvironment , isDevelopment , isProduction @@ -36,12 +35,10 @@ import qualified Data.TMap as TMap import qualified Data.Typeable as Typeable import IHP.View.Types import IHP.View.CSSFramework.Bootstrap (bootstrap) -import IHP.Log.Types -import IHP.Log (makeRequestLogger, defaultRequestLogger) +import System.Log.FastLogger (FastLogger, LogType'(..), withFastLogger, defaultBufSize) import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Cors as Cors import qualified Network.Wai.Parse as WaiParse -import qualified Control.Exception as Exception import IHP.EnvVar import qualified Prelude @@ -77,8 +74,8 @@ addInitializer onStartup = do |> TMap.insert newInitializers ) -ihpDefaultConfig :: ConfigBuilder -ihpDefaultConfig = do +ihpDefaultConfig :: FastLogger -> ConfigBuilder +ihpDefaultConfig logger = do ihpEnv <- envOrDefault "IHP_ENV" Development option ihpEnv @@ -91,19 +88,15 @@ ihpDefaultConfig = do environment <- findOption @Environment - defaultLogger <- configIO (defaultLoggerForEnv environment) - option defaultLogger - logger <- findOption @Logger - requestLoggerIpAddrSource <- envOrDefault "IHP_REQUEST_LOGGER_IP_ADDR_SOURCE" RequestLogger.FromSocket reqLoggerMiddleware <- configIO $ case environment of Development -> do - reqLogger <- (logger |> defaultRequestLogger) + reqLogger <- RequestLogger.mkRequestLogger def { RequestLogger.destination = RequestLogger.Callback logger } pure (RequestLoggerMiddleware reqLogger) Production -> do - reqLogger <- (logger |> makeRequestLogger def { RequestLogger.outputFormat = RequestLogger.Apache requestLoggerIpAddrSource }) + reqLogger <- RequestLogger.mkRequestLogger def { RequestLogger.outputFormat = RequestLogger.Apache requestLoggerIpAddrSource, RequestLogger.destination = RequestLogger.Callback logger } pure (RequestLoggerMiddleware reqLogger) @@ -169,8 +162,9 @@ findOptionOrNothing = do |> pure {-# INLINABLE findOptionOrNothing #-} -buildFrameworkConfig :: ConfigBuilder -> IO FrameworkConfig -buildFrameworkConfig appConfig = do +buildFrameworkConfig :: FastLogger -> ConfigBuilder -> IO FrameworkConfig +buildFrameworkConfig rawLogger appConfig = do + let logger msg = rawLogger (msg <> "\n") let resolve = do (AppHostname appHostname) <- findOption @AppHostname environment <- findOption @Environment @@ -180,7 +174,6 @@ buildFrameworkConfig appConfig = do (SessionCookie sessionCookie) <- findOption @SessionCookie (DatabaseUrl databaseUrl) <- findOption @DatabaseUrl cssFramework <- findOption @CSSFramework - logger <- findOption @Logger exceptionTracker <- findOption @ExceptionTracker corsResourcePolicy <- findOptionOrNothing @Cors.CorsResourcePolicy parseRequestBodyOptions <- findOption @WaiParse.ParseRequestBodyOptions @@ -194,7 +187,7 @@ buildFrameworkConfig appConfig = do pure FrameworkConfig { .. } - (frameworkConfig, _) <- State.runStateT (appConfig >> ihpDefaultConfig >> resolve) TMap.empty + (frameworkConfig, _) <- State.runStateT (appConfig >> ihpDefaultConfig rawLogger >> resolve) TMap.empty pure frameworkConfig {-# INLINABLE buildFrameworkConfig #-} @@ -221,12 +214,6 @@ defaultDatabaseUrl = do let defaultDatabaseUrl = "postgresql:///app?host=" <> cs currentDirectory <> "/build/db" envOrDefault "DATABASE_URL" defaultDatabaseUrl -defaultLoggerForEnv :: HasCallStack => Environment -> IO Logger -defaultLoggerForEnv = \case - Development -> defaultLogger - Production -> newLogger def { level = Info } - - -- Returns 'True' when the application is running in a given environment isEnvironment :: (?context :: context, ConfigProvider context) => Environment -> Bool isEnvironment environment = ?context.frameworkConfig.environment == environment @@ -266,7 +253,10 @@ defaultCorsResourcePolicy = Nothing -- > -- Do something with the FrameworkConfig here -- withFrameworkConfig :: ConfigBuilder -> (FrameworkConfig -> IO result) -> IO result -withFrameworkConfig configBuilder = Exception.bracket (buildFrameworkConfig configBuilder) (\frameworkConfig -> frameworkConfig.logger.cleanup) +withFrameworkConfig configBuilder callback = + withFastLogger (LogStdout defaultBufSize) \rawLogger -> do + frameworkConfig <- buildFrameworkConfig rawLogger configBuilder + callback frameworkConfig -- | Wraps an Exception thrown during the config process, but adds a CallStack -- diff --git a/ihp/IHP/FrameworkConfig/Types.hs b/ihp/IHP/FrameworkConfig/Types.hs index 5011c6b2a..9fbc64d62 100644 --- a/ihp/IHP/FrameworkConfig/Types.hs +++ b/ihp/IHP/FrameworkConfig/Types.hs @@ -43,7 +43,7 @@ import qualified Network.Wai.Parse as WaiParse import Network.Wai (Middleware, Request) import IHP.Environment (Environment) import IHP.View.Types (CSSFramework) -import IHP.Log.Types (Logger) +import System.Log.FastLogger (FastLogger) import IHP.ModelSupport.Types (ModelContext) newtype AppHostname = AppHostname Text @@ -132,7 +132,7 @@ data FrameworkConfig = FrameworkConfig -- -- Override this if you use a CSS framework that is not bootstrap , cssFramework :: !CSSFramework - , logger :: !Logger + , logger :: !FastLogger , exceptionTracker :: !ExceptionTracker -- | Custom 'option's from @Config.hs@ are stored here diff --git a/ihp/IHP/Job/Queue/Result.hs b/ihp/IHP/Job/Queue/Result.hs index 93fdf7336..74e1502d3 100644 --- a/ihp/IHP/Job/Queue/Result.hs +++ b/ihp/IHP/Job/Queue/Result.hs @@ -13,7 +13,7 @@ import IHP.Job.Queue.Pool (runPool) import IHP.Job.Queue.StatusInstances () import IHP.ModelSupport (Table (..), InputValue (..)) import IHP.ModelSupport.Types (Id' (..), PrimaryKey) -import qualified IHP.Log as Log +import System.Log.FastLogger (FastLogger, toLogStr) import qualified Hasql.Pool as HasqlPool import qualified Hasql.Session as HasqlSession import qualified Hasql.Statement as Hasql @@ -30,12 +30,12 @@ jobDidFail :: forall job context. , HasField "runAt" job UTCTime , Job job , ?context :: context - , HasField "logger" context Log.Logger + , HasField "logger" context FastLogger ) => HasqlPool.Pool -> job -> SomeException -> IO () jobDidFail pool job exception = do now <- getCurrentTime - Log.warn ("Failed job with exception: " <> tshow exception) + ?context.logger (toLogStr ("Failed job with exception: " <> tshow exception)) let ?job = job let canRetry = job.attemptsCount < maxAttempts @@ -64,12 +64,12 @@ jobDidTimeout :: forall job context. , HasField "runAt" job UTCTime , Job job , ?context :: context - , HasField "logger" context Log.Logger + , HasField "logger" context FastLogger ) => HasqlPool.Pool -> job -> IO () jobDidTimeout pool job = do now <- getCurrentTime - Log.warn ("Job timed out" :: Text) + ?context.logger (toLogStr ("Job timed out" :: Text)) let ?job = job let canRetry = job.attemptsCount < maxAttempts @@ -97,10 +97,10 @@ jobDidSucceed :: forall job context. , HasField "id" job (Id' (GetTableName job)) , PrimaryKey (GetTableName job) ~ UUID , ?context :: context - , HasField "logger" context Log.Logger + , HasField "logger" context FastLogger ) => HasqlPool.Pool -> job -> IO () jobDidSucceed pool job = do - Log.info ("Succeeded job" :: Text) + ?context.logger (toLogStr ("Succeeded job" :: Text)) updatedAt <- getCurrentTime let Id jobId = job.id let tableNameText = tableName @job diff --git a/ihp/IHP/Job/Queue/Watch.hs b/ihp/IHP/Job/Queue/Watch.hs index 42c288bf7..9ed4819a1 100644 --- a/ihp/IHP/Job/Queue/Watch.hs +++ b/ihp/IHP/Job/Queue/Watch.hs @@ -14,7 +14,7 @@ import IHP.Job.Queue.Fetch (pendingJobConditionSQL) import IHP.Job.Queue.STM (tryWriteTBQueue) import IHP.Job.Types (JobWorkerProcessMessage (..)) import qualified IHP.PGListener as PGListener -import qualified IHP.Log as Log +import System.Log.FastLogger (FastLogger, toLogStr) import Control.Monad.Trans.Resource import qualified Control.Exception.Safe as Exception import qualified Control.Concurrent as Concurrent @@ -44,13 +44,13 @@ import Data.Functor.Contravariant (contramap) -- -- Now insert something into the @projects@ table. E.g. by running @make psql@ and then running @INSERT INTO projects (id, name) VALUES (DEFAULT, 'New project');@ -- You will see that @"Something changed in the projects table"@ is printed onto the screen. -watchForJob :: (?context :: context, HasField "logger" context Log.Logger) => HasqlPool.Pool -> PGListener.PGListener -> Text -> Int -> TBQueue JobWorkerProcessMessage -> ResourceT IO (PGListener.Subscription, ReleaseKey) +watchForJob :: (?context :: context, HasField "logger" context FastLogger) => HasqlPool.Pool -> PGListener.PGListener -> Text -> Int -> TBQueue JobWorkerProcessMessage -> ResourceT IO (PGListener.Subscription, ReleaseKey) watchForJob pool pgListener tableName pollInterval onNewJob = watchForJobWithPollerTriggerRepair False pool pgListener tableName pollInterval onNewJob -- | Like 'watchForJob' but allows enabling a poller-side trigger integrity check. -- Useful in development to recover from missing triggers after `make db`. -watchForJobWithPollerTriggerRepair :: (?context :: context, HasField "logger" context Log.Logger) => Bool -> HasqlPool.Pool -> PGListener.PGListener -> Text -> Int -> TBQueue JobWorkerProcessMessage -> ResourceT IO (PGListener.Subscription, ReleaseKey) +watchForJobWithPollerTriggerRepair :: (?context :: context, HasField "logger" context FastLogger) => Bool -> HasqlPool.Pool -> PGListener.PGListener -> Text -> Int -> TBQueue JobWorkerProcessMessage -> ResourceT IO (PGListener.Subscription, ReleaseKey) watchForJobWithPollerTriggerRepair enablePollerTriggerRepair pool pgListener tableName pollInterval onNewJob = do let tableNameBS = cs tableName liftIO do @@ -60,15 +60,15 @@ watchForJobWithPollerTriggerRepair enablePollerTriggerRepair pool pgListener tab PGListener.onReconnect (\connection -> do result <- HasqlConnection.use connection (HasqlSession.script (createNotificationTriggerSQL tableNameBS)) case result of - Left err -> Log.warn ("Failed to recreate notification triggers for " <> tableName <> ": " <> tshow err <> ". Falling back to poller.") - Right _ -> Log.info ("Recreated notification triggers for " <> tableName) + Left err -> ?context.logger (toLogStr ("Failed to recreate notification triggers for " <> tableName <> ": " <> tshow err <> ". Falling back to poller.")) + Right _ -> ?context.logger (toLogStr ("Recreated notification triggers for " <> tableName)) ) pgListener poller <- pollForJob enablePollerTriggerRepair pool tableName pollInterval onNewJob subscription <- liftIO $ pgListener |> PGListener.subscribe (channelName tableNameBS) (const (do - Log.debug ("Received pg_notify for " <> tableName) + ?context.logger (toLogStr ("Received pg_notify for " <> tableName)) didWrite <- atomically $ tryWriteTBQueue onNewJob JobAvailable - unless didWrite (Log.warn ("Job queue full for " <> tableName)) + unless didWrite (?context.logger (toLogStr ("Job queue full for " <> tableName))) )) pure (subscription, poller) @@ -80,7 +80,7 @@ watchForJobWithPollerTriggerRepair enablePollerTriggerRepair pool pgListener tab -- will not run, and so 'watchForJob' cannot pick up the job even when 'runAt' is now in the past. -- -- This function returns a Async. Call 'cancel' on the async to stop polling the database. -pollForJob :: (?context :: context, HasField "logger" context Log.Logger) => Bool -> HasqlPool.Pool -> Text -> Int -> TBQueue JobWorkerProcessMessage -> ResourceT IO ReleaseKey +pollForJob :: (?context :: context, HasField "logger" context FastLogger) => Bool -> HasqlPool.Pool -> Text -> Int -> TBQueue JobWorkerProcessMessage -> ResourceT IO ReleaseKey pollForJob enablePollerTriggerRepair pool tableName pollInterval onNewJob = do let sql = "SELECT COUNT(*) FROM " <> tableName <> " WHERE " <> pendingJobConditionSQL @@ -101,7 +101,7 @@ pollForJob enablePollerTriggerRepair pool tableName pollInterval onNewJob = do _ <- atomically $ tryWriteTBQueue onNewJob JobAvailable pure () case result of - Left exception -> Log.error ("Job poller: " <> tshow exception) + Left exception -> ?context.logger (toLogStr ("Job poller: " <> tshow exception)) Right _ -> pure () -- Add up to 2 seconds of jitter to avoid all job queues polling at the same time @@ -132,15 +132,15 @@ notificationTriggersHealthy pool tableName = do count :: Int <- fromIntegral <$> runPool pool (HasqlSession.statement (tableName, insertTriggerName, updateTriggerName) statement) pure (count == 2) -ensureNotificationTriggers :: (?context :: context, HasField "logger" context Log.Logger) => HasqlPool.Pool -> Text -> IO () +ensureNotificationTriggers :: (?context :: context, HasField "logger" context FastLogger) => HasqlPool.Pool -> Text -> IO () ensureNotificationTriggers pool tableName = do healthy <- notificationTriggersHealthy pool tableName unless healthy do let insertTriggerName = "did_insert_job_" <> tableName let updateTriggerName = "did_update_job_" <> tableName - Log.warn ("Job poller: Missing notification triggers for " <> tableName <> " (" <> insertTriggerName <> ", " <> updateTriggerName <> "). Recreating.") + ?context.logger (toLogStr ("Job poller: Missing notification triggers for " <> tableName <> " (" <> insertTriggerName <> ", " <> updateTriggerName <> "). Recreating.")) runPool pool (HasqlSession.script (createNotificationTriggerSQL (cs tableName))) - Log.info ("Job poller: Recreated notification triggers for " <> tableName) + ?context.logger (toLogStr ("Job poller: Recreated notification triggers for " <> tableName)) -- | Returns a SQL script to create the notification trigger. -- diff --git a/ihp/IHP/Job/Runner/MainLoop.hs b/ihp/IHP/Job/Runner/MainLoop.hs index 2a7e0b1f4..2eaa4ce7d 100644 --- a/ihp/IHP/Job/Runner/MainLoop.hs +++ b/ihp/IHP/Job/Runner/MainLoop.hs @@ -17,7 +17,7 @@ import qualified System.Exit as Exit import qualified IHP.PGListener as PGListener import Control.Monad.Trans.Resource import qualified Control.Exception.Safe as Exception -import qualified IHP.Log as Log +import System.Log.FastLogger (toLogStr) import Control.Concurrent.STM (atomically, writeTBQueue) -- | Used by the RunJobs binary @@ -34,9 +34,8 @@ dedicatedProcessMainLoop jobWorkers = do threadId <- Concurrent.myThreadId exitSignalsCount <- newIORef 0 workerId <- UUID.nextRandom - let logger = ?context.logger - Log.info ("Starting worker " <> tshow workerId) + ?context.logger (toLogStr ("Starting worker " <> tshow workerId)) -- The job workers use their own dedicated PG listener as e.g. AutoRefresh or DataSync -- could overload the main PGListener connection. In that case we still want jobs to be @@ -54,7 +53,7 @@ dedicatedProcessMainLoop jobWorkers = do liftIO waitForExitSignal - liftIO $ Log.info ("Waiting for jobs to complete. CTRL+C again to force exit" :: Text) + liftIO $ ?context.logger (toLogStr ("Waiting for jobs to complete. CTRL+C again to force exit" :: Text)) -- Stop subscriptions and poller already -- This will stop all producers for the queue @@ -74,7 +73,7 @@ dedicatedProcessMainLoop jobWorkers = do liftIO $ async do waitForExitSignal - Log.info ("Canceling all running jobs. CTRL+C again to force exit" :: Text) + ?context.logger (toLogStr ("Canceling all running jobs. CTRL+C again to force exit" :: Text)) forEach processes \JobWorkerProcess { dispatcher = (dispatcherKey, _) } -> do release dispatcherKey -- cancels dispatcher, whose finally cancels all workers @@ -93,9 +92,8 @@ devServerMainLoop :: (?modelContext :: ModelContext) => FrameworkConfig -> PGLis devServerMainLoop frameworkConfig pgListener jobWorkers = do workerId <- UUID.nextRandom let ?context = frameworkConfig - let logger = frameworkConfig.logger - Log.info ("Starting worker " <> tshow workerId) + ?context.logger (toLogStr ("Starting worker " <> tshow workerId)) runResourceT do let jobWorkerArgs = JobWorkerArgs { workerId, modelContext = ?modelContext, frameworkConfig = ?context, pgListener } diff --git a/ihp/IHP/Job/Runner/WorkerLoop.hs b/ihp/IHP/Job/Runner/WorkerLoop.hs index 187bc2a1c..8f4c90632 100644 --- a/ihp/IHP/Job/Runner/WorkerLoop.hs +++ b/ihp/IHP/Job/Runner/WorkerLoop.hs @@ -13,7 +13,7 @@ import qualified Control.Concurrent as Concurrent import qualified Control.Concurrent.Async as Async import qualified System.Timeout as Timeout import Control.Monad.Trans.Resource -import qualified IHP.Log as Log +import System.Log.FastLogger (toLogStr) import IHP.Hasql.FromRow (FromRowHasql) import Control.Concurrent.STM (atomically, newTBQueue, readTBQueue, writeTBQueue, newTVarIO, readTVar, readTVarIO, writeTVar, modifyTVar', check) import IHP.Job.Queue (tryWriteTBQueue) @@ -62,11 +62,11 @@ jobWorkerFetchAndRunLoop JobWorkerArgs { .. } = do fetchResult <- Exception.tryAny (Queue.fetchNextJob @job pool workerId) case fetchResult of Left exception -> do - Log.error ("Job worker: Failed to fetch next job: " <> tshow exception) + ?context.logger (toLogStr ("Job worker: Failed to fetch next job: " <> tshow exception)) Concurrent.threadDelay 1000000 -- 1s backoff to avoid tight error loops runJobLoop -- retry after transient error Right (Just job) -> do - Log.info ("Starting job: " <> tshow job) + ?context.logger (toLogStr ("Starting job: " <> tshow job)) let ?job = job let timeout :: Int = fromMaybe (-1) (timeoutInMicroseconds @job) diff --git a/ihp/IHP/ModelSupport.hs b/ihp/IHP/ModelSupport.hs index cf09b9c03..493305bc1 100644 --- a/ihp/IHP/ModelSupport.hs +++ b/ihp/IHP/ModelSupport.hs @@ -57,8 +57,7 @@ import PostgresqlTypes.Polygon import PostgresqlTypes.Inet import PostgresqlTypes.Interval import PostgresqlTypes.Tsvector -import IHP.Log.Types -import qualified IHP.Log as Log +import System.Log.FastLogger (FastLogger, toLogStr) import Data.Dynamic import IHP.EnvVar import Data.Scientific @@ -75,16 +74,17 @@ import IHP.Hasql.Pool (usePoolWithRetry) import IHP.PGSimpleCompat () -- | Provides a mock ModelContext to be used when a database connection is not available -notConnectedModelContext :: Logger -> ModelContext +notConnectedModelContext :: FastLogger -> ModelContext notConnectedModelContext logger = ModelContext { hasqlPool = error "Not connected" , transactionRunner = Nothing , logger = logger + , queryLoggingEnabled = False , trackTableReadCallback = Nothing , rowLevelSecurity = Nothing } -createModelContext :: ByteString -> Logger -> IO ModelContext +createModelContext :: ByteString -> FastLogger -> IO ModelContext createModelContext databaseUrl logger = do -- Create hasql pool for prepared statement-based queries -- HASQL_POOL_SIZE: pool size (default: 20). Set to 1 for consistent prepared statement caching. @@ -102,6 +102,7 @@ createModelContext databaseUrl logger = do let trackTableReadCallback = Nothing let transactionRunner = Nothing let rowLevelSecurity = Nothing + queryLoggingEnabled <- envOrDefault "DEBUG" False pure ModelContext { .. } releaseModelContext :: ModelContext -> IO () @@ -110,7 +111,7 @@ releaseModelContext modelContext = do -- | Bracket-style wrapper around 'createModelContext' that ensures the database -- pool is released when the callback completes (or throws an exception). -withModelContext :: ByteString -> Logger -> (ModelContext -> IO a) -> IO a +withModelContext :: ByteString -> FastLogger -> (ModelContext -> IO a) -> IO a withModelContext databaseUrl logger = bracket (createModelContext databaseUrl logger) releaseModelContext @@ -336,7 +337,6 @@ setRLSConfigStatement = Hasql.preparable sqlStatementHasql :: (?modelContext :: ModelContext) => HasqlPool.Pool -> a -> Hasql.Statement a b -> IO b sqlStatementHasql pool input statement = do let ?context = ?modelContext - let currentLogLevel = ?modelContext.logger.level let session = case (?modelContext.transactionRunner, ?modelContext.rowLevelSecurity) of (Nothing, Just RowLevelSecurityContext { rlsAuthenticatedRole, rlsUserId }) -> Tx.transaction Tx.ReadCommitted Tx.Read $ do @@ -347,7 +347,7 @@ sqlStatementHasql pool input statement = do let runQuery = case ?modelContext.transactionRunner of Just (TransactionRunner runner) -> runner session Nothing -> usePoolWithRetry pool session - logQueryTiming currentLogLevel ("🔍 " <> truncateQuery (cs (Hasql.toSql statement))) runQuery + logQueryTiming ("🔍 " <> truncateQuery (cs (Hasql.toSql statement))) runQuery {-# INLINABLE sqlStatementHasql #-} -- | Runs a query built from a dynamic 'Snippet'. @@ -376,7 +376,6 @@ sqlQueryHasql pool snippet decoder = sqlExecStatement :: (?modelContext :: ModelContext) => HasqlPool.Pool -> a -> Hasql.Statement a () -> IO () sqlExecStatement pool input statement = do let ?context = ?modelContext - let currentLogLevel = ?modelContext.logger.level let session = case (?modelContext.transactionRunner, ?modelContext.rowLevelSecurity) of (Just _, _) -> Hasql.statement input statement @@ -389,7 +388,7 @@ sqlExecStatement pool input statement = do let runQuery = case ?modelContext.transactionRunner of Just (TransactionRunner runner) -> runner session Nothing -> usePoolWithRetry pool session - logQueryTiming currentLogLevel ("💾 " <> truncateQuery (cs (Hasql.toSql statement))) runQuery + logQueryTiming ("💾 " <> truncateQuery (cs (Hasql.toSql statement))) runQuery {-# INLINABLE sqlExecStatement #-} -- | Like 'sqlQueryHasql' but for statements that don't return results (DELETE, etc.) @@ -407,7 +406,6 @@ sqlExecHasql pool snippet = sqlExecStatement pool () (Snippet.toPreparableStatem sqlExecHasqlCount :: (?modelContext :: ModelContext) => HasqlPool.Pool -> Snippet.Snippet -> IO Int64 sqlExecHasqlCount pool snippet = do let ?context = ?modelContext - let currentLogLevel = ?modelContext.logger.level let statement = Snippet.toPreparableStatement snippet Decoders.rowsAffected let session = case (?modelContext.transactionRunner, ?modelContext.rowLevelSecurity) of (Nothing, Just RowLevelSecurityContext { rlsAuthenticatedRole, rlsUserId }) -> @@ -419,7 +417,7 @@ sqlExecHasqlCount pool snippet = do let runQuery = case ?modelContext.transactionRunner of Just (TransactionRunner runner) -> runner session Nothing -> usePoolWithRetry pool session - logQueryTiming currentLogLevel ("💾 " <> cs (Hasql.toSql statement)) runQuery + logQueryTiming ("💾 " <> cs (Hasql.toSql statement)) runQuery {-# INLINABLE sqlExecHasqlCount #-} -- | Like 'sqlExecHasql' but for raw 'Hasql.Session' values (e.g. multi-statement DDL via 'Hasql.sql') @@ -434,26 +432,25 @@ sqlExecHasqlCount pool snippet = do runSessionHasql :: (?modelContext :: ModelContext) => HasqlPool.Pool -> Hasql.Session () -> IO () runSessionHasql pool session = do let ?context = ?modelContext - let currentLogLevel = ?modelContext.logger.level let runQuery = case ?modelContext.transactionRunner of Just (TransactionRunner runner) -> runner session Nothing -> usePoolWithRetry pool session - logQueryTiming currentLogLevel "💾 runSessionHasql" runQuery + logQueryTiming "💾 runSessionHasql" runQuery {-# INLINABLE runSessionHasql #-} --- | Run an IO action, logging its duration when the log level is 'Debug'. +-- | Run an IO action, logging its duration when debug mode is enabled. -- The label is prepended to the timing message, e.g. @"🔍 SELECT ..."@. {-# INLINE logQueryTiming #-} -logQueryTiming :: (?context :: ModelContext) => LogLevel -> Text -> IO a -> IO a -logQueryTiming currentLogLevel label runQuery = - if currentLogLevel == Debug +logQueryTiming :: (?context :: ModelContext) => Text -> IO a -> IO a +logQueryTiming label runQuery = + if ?context.queryLoggingEnabled then do start <- getCurrentTime runQuery `finally` do end <- getCurrentTime let queryTimeInMs = round (realToFrac (end `diffUTCTime` start) * 1000 :: Double) :: Int - Log.debug (label <> " (" <> Text.pack (show queryTimeInMs) <> "ms)") + ?context.logger (toLogStr (label <> " (" <> Text.pack (show queryTimeInMs) <> "ms)")) else runQuery -- | Existential wrapper for sub-session requests in a transaction @@ -560,7 +557,7 @@ withTransaction block case blockResult of Left exc -> do catchError (Hasql.script "ROLLBACK") (\rollbackErr -> liftIO $ - Log.warn ("withTransaction: ROLLBACK failed: " <> Text.pack (show rollbackErr))) + ?context.logger (toLogStr ("withTransaction: ROLLBACK failed: " <> Text.pack (show rollbackErr)))) liftIO (throwIO exc) Right a -> do Hasql.script "COMMIT" @@ -1010,8 +1007,8 @@ withoutQueryLogging :: (?modelContext :: ModelContext) => ((?modelContext :: Mod withoutQueryLogging callback = let modelContext = ?modelContext - nullLogger = modelContext.logger { write = \_ -> pure ()} in - let ?modelContext = modelContext { logger = nullLogger } + let ?modelContext = modelContext { logger = noopLogger } in - callback \ No newline at end of file + callback + diff --git a/ihp/IHP/ModelSupport/Types.hs b/ihp/IHP/ModelSupport/Types.hs index ecb1ea544..fd6059cfb 100644 --- a/ihp/IHP/ModelSupport/Types.hs +++ b/ihp/IHP/ModelSupport/Types.hs @@ -46,6 +46,8 @@ module IHP.ModelSupport.Types , CanUpdate (..) , ParsePrimaryKey (..) , FieldBit (..) + -- * Logging +, noopLogger ) where import Prelude @@ -64,7 +66,7 @@ import GHC.TypeLits import GHC.Types import Data.Data import Data.Dynamic -import IHP.Log.Types (Logger) +import System.Log.FastLogger (FastLogger) -- | Runner that executes a hasql Session on the current transaction's connection newtype TransactionRunner = TransactionRunner @@ -86,8 +88,8 @@ instance Exception HasqlError data ModelContext = ModelContext { hasqlPool :: Hasql.Pool -- ^ Hasql pool for prepared statement-based queries , transactionRunner :: Maybe TransactionRunner -- ^ When set, queries are sent through this runner instead of 'HasqlPool.use' directly - -- | Logs all queries to this logger at log level info - , logger :: Logger + , logger :: FastLogger + , queryLoggingEnabled :: !Bool -- | A callback that is called whenever a specific table is accessed using a SELECT query , trackTableReadCallback :: Maybe (Text -> IO ()) -- | Is set to a value if row level security was enabled at runtime @@ -240,3 +242,7 @@ class CanUpdate a where class ParsePrimaryKey primaryKey where parsePrimaryKey :: Text -> Maybe primaryKey + +-- | A logger that discards all messages. Useful in tests and for 'withoutQueryLogging'. +noopLogger :: FastLogger +noopLogger = \_ -> pure () diff --git a/ihp/IHP/ScriptSupport.hs b/ihp/IHP/ScriptSupport.hs index 3cef4da77..6e5181cc5 100644 --- a/ihp/IHP/ScriptSupport.hs +++ b/ihp/IHP/ScriptSupport.hs @@ -40,4 +40,4 @@ runScript configBuilder taskMain = withUtf8 do -- > runDevScript do { users <- query @User |> fetch; forEach users \user -> putStrLn user.name } -- runDevScript :: Script -> IO () -runDevScript = runScript ihpDefaultConfig \ No newline at end of file +runDevScript = runScript (pure ()) \ No newline at end of file diff --git a/ihp/IHP/Test/Mocking.hs b/ihp/IHP/Test/Mocking.hs index bc746a844..4dc74c11e 100644 --- a/ihp/IHP/Test/Mocking.hs +++ b/ihp/IHP/Test/Mocking.hs @@ -18,9 +18,8 @@ import Wai.Request.Params.Middleware (Respond) import IHP.ControllerSupport (InitControllerContext, Controller, runActionWithNewContext) import IHP.FrameworkConfig (ConfigBuilder (..), FrameworkConfig (..), RootApplication (..)) import qualified IHP.FrameworkConfig as FrameworkConfig -import IHP.ModelSupport (createModelContext, withModelContext, Id') +import IHP.ModelSupport (createModelContext, withModelContext, Id', noopLogger) import IHP.Prelude -import IHP.Log.Types import IHP.Job.Types import Test.Hspec import qualified Data.Text as Text @@ -68,8 +67,8 @@ runTestMiddlewares frameworkConfig modelContext maybePgListener baseRequest = do {-# DEPRECATED mockContextNoDatabase "Use withMockContext instead for bracket-style resource management" #-} mockContextNoDatabase :: (InitControllerContext application) => application -> ConfigBuilder -> IO (MockContext application) mockContextNoDatabase application configBuilder = do - frameworkConfig@(FrameworkConfig {databaseUrl}) <- FrameworkConfig.buildFrameworkConfig configBuilder - logger <- newLogger (def :: LoggerSettings) { level = Warn } -- don't log queries + let logger = noopLogger -- don't log queries + frameworkConfig@(FrameworkConfig {databaseUrl}) <- FrameworkConfig.buildFrameworkConfig logger configBuilder modelContext <- createModelContext databaseUrl logger -- Start with a minimal request - the middleware stack will set up session, etc. diff --git a/ihp/IHP/WebSocket.hs b/ihp/IHP/WebSocket.hs index 83516db1e..cc6cf0eb9 100644 --- a/ihp/IHP/WebSocket.hs +++ b/ihp/IHP/WebSocket.hs @@ -26,7 +26,7 @@ import IHP.Controller.Context import qualified Data.Aeson as Aeson import Network.Wai (Request) -import qualified IHP.Log as Log +import System.Log.FastLogger (toLogStr) import qualified Network.WebSockets.Connection as WebSocket @@ -72,7 +72,7 @@ startWSApp initialState connection = do (Just Websocket.ConnectionClosed) -> pure () (Just (Websocket.CloseRequest {})) -> pure () (Just other) -> error ("Unhandled Websocket exception: " <> show other) - Nothing -> Log.error (tshow e) + Nothing -> ?context.logger (toLogStr (tshow e)) Right _ -> pure () setState :: (?state :: IORef state) => state -> IO () diff --git a/ihp/Test/Test/AutoRefreshSpec.hs b/ihp/Test/Test/AutoRefreshSpec.hs index 84d625e2f..66b895803 100644 --- a/ihp/Test/Test/AutoRefreshSpec.hs +++ b/ihp/Test/Test/AutoRefreshSpec.hs @@ -17,7 +17,7 @@ import IHP.AutoRefresh (globalAutoRefreshServerVar, sessionResponseHasChanged, u import IHP.AutoRefresh.Types import qualified Control.Concurrent.MVar as MVar import qualified IHP.PGListener as PGListener -import IHP.Log.Types (Logger(..), LogLevel(..)) +import System.Log.FastLogger (FastLogger) import IHP.Server (initMiddlewareStack) import Network.Wai.Test (runSession, request, SResponse(..), simpleBody) import IHP.Test.Mocking @@ -80,14 +80,8 @@ callActionWithQueryParams pgListener controller queryParams = do middlewareStack <- initMiddlewareStack frameworkConfig modelContext (Just pgListener) runSession (request baseRequest) (middlewareStack controllerApp) -testLogger :: Logger -testLogger = Logger - { write = \_ -> pure () - , level = Debug - , formatter = \_ _ msg -> msg - , timeCache = pure "" - , cleanup = pure () - } +testLogger :: FastLogger +testLogger = noopLogger tests :: Spec tests = beforeAll (mockContextNoDatabase WebApplication config) do diff --git a/ihp/Test/Test/ControllerSupportSpec.hs b/ihp/Test/Test/ControllerSupportSpec.hs index ee212faf9..804051fae 100644 --- a/ihp/Test/Test/ControllerSupportSpec.hs +++ b/ihp/Test/Test/ControllerSupportSpec.hs @@ -5,6 +5,7 @@ module Test.ControllerSupportSpec where import IHP.Prelude import Test.Hspec +import IHP.ModelSupport (noopLogger) import IHP.ControllerSupport (requestBodyJSON) import IHP.Controller.Response (responseHeadersVaultKey) import IHP.Environment (Environment (..)) @@ -80,7 +81,7 @@ runRequestBodyJSON requestBody environment = do buildRequest :: RequestBody -> Environment -> IO Wai.Request buildRequest requestBody environment = do - frameworkConfig <- FrameworkConfig.buildFrameworkConfig (FrameworkConfig.option environment) + frameworkConfig <- FrameworkConfig.buildFrameworkConfig noopLogger (FrameworkConfig.option environment) headersRef <- newIORef [] pure Wai.defaultRequest { Wai.vault = Vault.insert RequestVault.frameworkConfigVaultKey frameworkConfig diff --git a/ihp/Test/Test/FetchPipelinedSpec.hs b/ihp/Test/Test/FetchPipelinedSpec.hs index 8a3ab064c..c7f9e658b 100644 --- a/ihp/Test/Test/FetchPipelinedSpec.hs +++ b/ihp/Test/Test/FetchPipelinedSpec.hs @@ -14,8 +14,6 @@ import IHP.Hasql.FromRow (FromRowHasql(..), HasqlDecodeColumn(..)) import IHP.FetchPipelined import qualified Hasql.Pool as HasqlPool import qualified Hasql.Session as Session -import qualified IHP.Log as Log -import IHP.Log.Types (LogLevel(..), LoggerSettings(..)) import System.Environment (lookupEnv) import qualified Control.Exception as Exception @@ -48,7 +46,7 @@ withDB :: (ModelContext -> IO ()) -> IO () withDB action = do envUrl <- lookupEnv "DATABASE_URL" let databaseUrl = maybe "postgresql:///postgres" cs envUrl - logger <- Log.newLogger def { level = Warn } + let logger = noopLogger modelContext <- createModelContext databaseUrl logger let pool = modelContext.hasqlPool let setup = do diff --git a/ihp/Test/Test/JobQueueSpec.hs b/ihp/Test/Test/JobQueueSpec.hs index 44be3b335..6a298a21e 100644 --- a/ihp/Test/Test/JobQueueSpec.hs +++ b/ihp/Test/Test/JobQueueSpec.hs @@ -3,9 +3,8 @@ module Test.JobQueueSpec where import Test.Hspec import IHP.Prelude import qualified IHP.Job.Queue as JobQueue -import IHP.ModelSupport (createModelContext, releaseModelContext, HasqlError (..)) -import qualified IHP.Log as Log -import IHP.Log.Types (Logger, LogLevel (..), LoggerSettings (..)) +import IHP.ModelSupport (createModelContext, releaseModelContext, HasqlError (..), noopLogger) +import System.Log.FastLogger (FastLogger) import qualified IHP.PGListener as PGListener import qualified Hasql.Pool as HasqlPool import qualified Hasql.Session as HasqlSession @@ -16,7 +15,7 @@ import qualified Control.Exception as Exception import System.Environment (lookupEnv) data TestContext = TestContext - { logger :: Logger + { logger :: FastLogger } tests :: Spec @@ -71,11 +70,11 @@ withJobWatcherForTable enablePollerTriggerRepair tableName action = do liftIO (action pool `Exception.finally` PGListener.unsubscribe subscription pgListener)) (dropTestArtifacts pool tableName) -withDB :: (ModelContext -> Logger -> ByteString -> IO ()) -> IO () +withDB :: (ModelContext -> FastLogger -> ByteString -> IO ()) -> IO () withDB action = do envUrl <- lookupEnv "DATABASE_URL" let databaseUrl = maybe "postgresql:///postgres" cs envUrl - logger <- Log.newLogger def { level = Warn } + let logger = noopLogger modelContext <- createModelContext databaseUrl logger result <- Exception.try (action modelContext logger databaseUrl `Exception.finally` releaseModelContext modelContext) case result of diff --git a/ihp/Test/Test/PGListenerSpec.hs b/ihp/Test/Test/PGListenerSpec.hs index dc621b696..9b0f4b303 100644 --- a/ihp/Test/Test/PGListenerSpec.hs +++ b/ihp/Test/Test/PGListenerSpec.hs @@ -7,18 +7,12 @@ module Test.PGListenerSpec where import Test.Hspec import IHP.Prelude import qualified IHP.PGListener as PGListener -import IHP.Log.Types (Logger(..), LogLevel(..)) +import IHP.ModelSupport (noopLogger) import Data.HashMap.Strict as HashMap tests = do describe "IHP.PGListener" do - let logger = Logger - { write = \_ -> pure () - , level = Debug - , formatter = \_ _ msg -> msg - , timeCache = pure "" - , cleanup = pure () - } + let logger = noopLogger describe "subscribe" do it "should add a subscriber" do diff --git a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs index 209b12391..a804b6be7 100644 --- a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs +++ b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs @@ -5,10 +5,8 @@ import Test.Hspec import IHP.Pagination.ControllerFunctions import IHP.Pagination.Types (Options(..), Pagination(..)) import IHP.Controller.Context -import IHP.ModelSupport (createModelContext, releaseModelContext, HasqlError(..)) +import IHP.ModelSupport (createModelContext, releaseModelContext, HasqlError(..), noopLogger) import qualified Hasql.Pool as HasqlPool -import qualified IHP.Log as Log -import IHP.Log.Types (LogLevel(..), LoggerSettings(..)) import Wai.Request.Params.Middleware (RequestBody (..), requestBodyVaultKey) import qualified Data.Vault.Lazy as Vault import qualified Data.TMap as TypeMap @@ -150,7 +148,7 @@ withDB :: (ModelContext -> IO ()) -> IO () withDB action = do envUrl <- lookupEnv "DATABASE_URL" let databaseUrl = maybe "postgresql:///postgres" cs envUrl - logger <- Log.newLogger def { level = Warn } + let logger = noopLogger modelContext <- createModelContext databaseUrl logger result <- Exception.try (action modelContext `Exception.finally` releaseModelContext modelContext) case result of diff --git a/ihp/Test/Test/View/CSSFrameworkSpec.hs b/ihp/Test/Test/View/CSSFrameworkSpec.hs index 156929ec2..5de3fdff1 100644 --- a/ihp/Test/Test/View/CSSFrameworkSpec.hs +++ b/ihp/Test/Test/View/CSSFrameworkSpec.hs @@ -720,7 +720,7 @@ shouldRenderTo renderFunction expectedHtml = renderMarkupText renderFunction `sh -} createControllerContextWithCSSFramework :: Typeable option => option -> IO ControllerContext createControllerContextWithCSSFramework cssFramework = do - frameworkConfig <- FrameworkConfig.buildFrameworkConfig do + frameworkConfig <- FrameworkConfig.buildFrameworkConfig noopLogger do option cssFramework let requestBody = FormBody { params = [], files = [], rawPayload = "" } let request = Wai.defaultRequest { Wai.vault = Vault.insert IHP.RequestVault.frameworkConfigVaultKey frameworkConfig diff --git a/ihp/Test/Test/View/FormSpec.hs b/ihp/Test/Test/View/FormSpec.hs index 5ec51b916..0fd7c8ae2 100644 --- a/ihp/Test/Test/View/FormSpec.hs +++ b/ihp/Test/Test/View/FormSpec.hs @@ -83,7 +83,7 @@ shouldRenderTo renderFunction expectedHtml = renderMarkupText renderFunction `sh createControllerContext :: IO ControllerContext createControllerContext = do - frameworkConfig <- FrameworkConfig.buildFrameworkConfig (pure ()) + frameworkConfig <- FrameworkConfig.buildFrameworkConfig noopLogger (pure ()) let requestBody = FormBody { params = [], files = [], rawPayload = "" } let request = Wai.defaultRequest { Wai.vault = Vault.insert IHP.RequestVault.frameworkConfigVaultKey frameworkConfig $ Vault.insert IHP.RequestVault.requestBodyVaultKey requestBody Vault.empty } diff --git a/ihp/default.nix b/ihp/default.nix index c5e3ec1ae..323f27a03 100644 --- a/ihp/default.nix +++ b/ihp/default.nix @@ -7,7 +7,7 @@ , hasql-dynamic-statements, hasql-implicits, hasql-mapping , hasql-pool, hasql-postgresql-types, hasql-transaction, hspec , http-client, http-client-tls, http-media, http-types, ihp-context -, ihp-hsx, ihp-imagemagick, ihp-log, ihp-modal, ihp-pagehead +, ihp-hsx, ihp-imagemagick, ihp-modal, ihp-pagehead , ihp-pglistener, inflections, interpolate, lens, lib, mime-types , minio-hs, mono-traversable, mtl, neat-interpolation, network , network-uri, parser-combinators, postgresql-simple @@ -36,7 +36,7 @@ mkDerivation { haskell-src-meta hasql hasql-dynamic-statements hasql-implicits hasql-mapping hasql-pool hasql-postgresql-types hasql-transaction hspec http-client http-client-tls http-media http-types ihp-context - ihp-hsx ihp-imagemagick ihp-log ihp-modal ihp-pagehead + ihp-hsx ihp-imagemagick ihp-modal ihp-pagehead ihp-pglistener inflections interpolate lens mime-types minio-hs mono-traversable mtl neat-interpolation network network-uri parser-combinators postgresql-simple @@ -60,7 +60,7 @@ mkDerivation { haskell-src-meta hasql hasql-dynamic-statements hasql-implicits hasql-mapping hasql-pool hasql-postgresql-types hasql-transaction hspec http-client http-client-tls http-media http-types ihp-context - ihp-hsx ihp-imagemagick ihp-log ihp-modal ihp-pagehead + ihp-hsx ihp-imagemagick ihp-modal ihp-pagehead ihp-pglistener inflections interpolate lens mime-types minio-hs mono-traversable mtl neat-interpolation network network-uri parser-combinators postgresql-simple @@ -84,7 +84,7 @@ mkDerivation { haskell-src-meta hasql hasql-dynamic-statements hasql-implicits hasql-mapping hasql-pool hasql-postgresql-types hasql-transaction hspec http-client http-client-tls http-media http-types ihp-context - ihp-hsx ihp-imagemagick ihp-log ihp-modal ihp-pagehead + ihp-hsx ihp-imagemagick ihp-modal ihp-pagehead ihp-pglistener inflections interpolate lens mime-types minio-hs mono-traversable mtl neat-interpolation network network-uri parser-combinators postgresql-simple diff --git a/ihp/ihp.cabal b/ihp/ihp.cabal index 6e3cdbe68..51c40cc82 100644 --- a/ihp/ihp.cabal +++ b/ihp/ihp.cabal @@ -116,7 +116,6 @@ common shared-properties , ihp-hsx , ihp-context , ihp-pagehead - , ihp-log , ihp-modal , mime-types , safe-exceptions