Feature/json logging

hastl.cabal

@@ -40,7 +40,9 @@ library
     build-depends:    
       katip == 0.8.8.0, 
       aeson >= 2.2.2 && < 2.4,
+      aeson-pretty >= 0.8.10 && < 0.9,
       base ^>= {4.17.2, 4.18.2, 4.19},
+      http-types >= 0.12.3 && < 0.13,
       containers >= 0.6.7 && < 0.8,
       random >= 1.2.1 && < 1.3,
       bytestring >= 0.11.5 && < 0.13,

src/Config.hs

@@ -20,10 +20,17 @@ import Database.Persist.Postgresql
     ConnectionString,
     createPostgresqlPool,
   )
-import Logger
+import Logger (LogEnv, Katip(..), KatipT(..), logMsg, adapt, runKatipT, logInfoJSON)
 import Network.Wai (Middleware)
 import Network.Wai.Handler.Warp (Port)
 import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
+import Network.Wai qualified as WAI
+import Network.HTTP.Types qualified as HTTP
+
+import Data.Text.Encoding qualified as TE
+import Data.Time (getCurrentTime, diffUTCTime)
+import Data.Aeson qualified as A
+import Data.Aeson ((.=))
 import Servant.Server.Internal.ServerError (ServerError)
 import System.Environment (lookupEnv)
 
@@ -86,13 +93,49 @@ setLogger Test = id
 setLogger Development = logStdoutDev
 setLogger Production = logStdout
 
--- | Web request logger (currently unimplemented and unused). For inspiration
--- see ApacheLogger from wai-logger package.
+-- | Environment-aware logger that uses JSON for production
+setJSONLogger :: Environment -> LogEnv -> Middleware
+setJSONLogger Test _ = id
+setJSONLogger Development env = katipLogger env
+setJSONLogger Production env = katipLogger env
+
+-- | JSON-based HTTP request logger using Katip
 katipLogger :: LogEnv -> Middleware
-katipLogger env app req respond = runKatipT env $ do
-  -- todo: log proper request data
-  logMsg "web" InfoS "todo: received some request"
-  liftIO $ app req respond
+katipLogger env app req respond = do
+  startTime <- getCurrentTime
+  runKatipT env $ do
+    -- Log incoming request
+    logInfoJSON "http_request" $ A.object
+      [ "method" .= TE.decodeUtf8 (WAI.requestMethod req)
+      , "path" .= TE.decodeUtf8 (WAI.rawPathInfo req)
+      , "query" .= TE.decodeUtf8 (WAI.rawQueryString req)
+      , "remote_host" .= show (WAI.remoteHost req)
+      , "user_agent" .= maybe "" (TE.decodeUtf8) (lookup "User-Agent" (WAI.requestHeaders req))
+      , "content_type" .= maybe "" (TE.decodeUtf8) (lookup "Content-Type" (WAI.requestHeaders req))
+      , "timestamp" .= startTime
+      ]
+
+  -- Call the application and capture response
+  app req $ \response -> do
+    endTime <- getCurrentTime
+    let status = WAI.responseStatus response
+    let statusCode = HTTP.statusCode status
+    let duration = realToFrac $ diffUTCTime endTime startTime * 1000 -- milliseconds
+
+    runKatipT env $ do
+      logInfoJSON "http_response" $ A.object
+        [ "method" .= TE.decodeUtf8 (WAI.requestMethod req)
+        , "path" .= TE.decodeUtf8 (WAI.rawPathInfo req)
+        , "status_code" .= statusCode
+        , "status_message" .= TE.decodeUtf8 (HTTP.statusMessage status)
+        , "duration_ms" .= (duration :: Double)
+        , "remote_host" .= show (WAI.remoteHost req)
+        , "timestamp" .= endTime
+        ]
+
+    respond response
+
+
 
 -- | This function creates a 'ConnectionPool' for the given environment.
 -- For 'Development' and 'Test' environments, we use a stock and highly

src/Init.hs

@@ -3,34 +3,41 @@
 
 module Init where
 
-import Control.Exception.Safe (
-  SomeException (SomeException),
-  bracket,
-  catch,
-  finally,
-  onException,
-  throwIO,
- )
+import Api (app)
+import Config (Config (..), Environment (..), makePool, setJSONLogger)
+import Control.Exception.Safe
+  ( SomeException (SomeException),
+    bracket,
+    catch,
+    finally,
+    onException,
+    throwIO,
+  )
+import Data.Aeson (object, (.=))
+import Data.Pool qualified as Pool
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Typeable (typeOf)
 import Database.Persist.Postgresql (runSqlPool)
-import Network.Wai (Application)
-import Say
-import System.Environment (lookupEnv)
-
-import Api (app)
-import Config (Config (..), Environment (..), makePool, setLogger)
-import Data.Pool qualified as Pool
+import Katip (LogEnv, runKatipT)
 import Katip qualified
-import Logger (defaultLogEnv)
+import Logger (LogFormat (..), Severity (..), createLogEnv, logInfoJSON, logMsg)
 import Models (doMigrations)
+import Network.Wai (Application)
 import Network.Wai.Handler.Warp (run)
 import Safe (readMay)
+import Say
+import System.Environment (lookupEnv)
+
+-- | Create a LogEnv based on the environment
+-- Production uses JSON format, Development and Test use text format
+createLogEnvForEnvironment :: Environment -> IO LogEnv
+createLogEnvForEnvironment Production = createLogEnv JSONFormat
+createLogEnvForEnvironment Development = createLogEnv JSONFormat
+createLogEnvForEnvironment Test = createLogEnv TextFormat
 
-{- | An action that creates a WAI 'Application' together with its resources,
-  runs it, and tears it down on exit
--}
+-- | An action that creates a WAI 'Application' together with its resources,
+--  runs it, and tears it down on exit
 runAppDevel :: IO ()
 runAppDevel = do
   say "in runAppDevel"
@@ -45,13 +52,25 @@ runAppDevel = do
     run (configPort config) cfg
       `finally` say "server is closed"
 
-{- | The 'initialize' function accepts the required environment information,
-initializes the WAI 'Application' and returns it
--}
+-- | The 'initialize' function accepts the required environment information,
+-- initializes the WAI 'Application' and returns it
 initialize :: Config -> IO Application
 initialize cfg = do
   say "initialize"
-  let logger = setLogger (configEnv cfg)
+
+  -- Test JSON logging
+  runKatipT (configLogEnv cfg) $ do
+    logMsg "init" InfoS "Application initialization started"
+    logMsg "config" DebugS "Loading configuration parameters"
+    logInfoJSON "startup_info" $
+      object
+        [ "environment" .= show (configEnv cfg),
+          "port" .= configPort cfg,
+          "component" .= ("hastl-app" :: Text)
+        ]
+    logMsg "database" WarningS "About to run database migrations"
+
+  let logger = setJSONLogger (configEnv cfg) (configLogEnv cfg)
   say "run migrations"
   bracket
     (say "starting to run migrations")
@@ -61,13 +80,19 @@ initialize cfg = do
       runSqlPool doMigrations (configPool cfg) `catch` \(SomeException e) -> do
         say $
           mconcat
-            [ "exception in doMigrations, type: "
-            , tshow (typeOf e)
-            , ", shown: "
-            , tshow e
+            [ "exception in doMigrations, type: ",
+              tshow (typeOf e),
+              ", shown: ",
+              tshow e
             ]
         throwIO e
       say "okay all done"
+
+  -- Test more JSON logging after migrations
+  runKatipT (configLogEnv cfg) $ do
+    logMsg "database" InfoS "Database migrations completed successfully"
+    logMsg "init" InfoS "Application initialization completed"
+
   say "making app"
   pure . logger . app $ cfg
 
@@ -78,16 +103,16 @@ withConfig action = do
   say $ "on port:" <> tshow port
   env <- lookupSetting "ENV" Development
   say $ "on env: " <> tshow env
-  bracket defaultLogEnv (\x -> say "closing katip scribes" >> Katip.closeScribes x) $ \logEnv -> do
+  bracket (createLogEnvForEnvironment env) (\x -> say "closing katip scribes" >> Katip.closeScribes x) $ \logEnv -> do
     say "got log env"
     !pool <- makePool env logEnv `onException` say "exception in makePool"
     say "got pool "
     action
       Config
-        { configPool = pool
-        , configEnv = env
-        , configLogEnv = logEnv
-        , configPort = port
+        { configPool = pool,
+          configEnv = env,
+          configLogEnv = logEnv,
+          configPort = port
         }
 
 -- | Takes care of cleaning up 'Config' resources
@@ -97,9 +122,8 @@ shutdownApp cfg = do
   Pool.destroyAllResources (configPool cfg)
   pure ()
 
-{- | Looks up a setting in the environment, with a provided default, and
-'read's that information into the inferred type.
--}
+-- | Looks up a setting in the environment, with a provided default, and
+-- 'read's that information into the inferred type.
 lookupSetting :: (Read a) => String -> a -> IO a
 lookupSetting env def = do
   maybeValue <- lookupEnv env
@@ -108,15 +132,15 @@ lookupSetting env def = do
       return def
     Just str ->
       maybe (handleFailedRead str) return (readMay str)
- where
-  handleFailedRead str =
-    error $
-      mconcat
-        [ "Failed to read [["
-        , str
-        , "]] for environment variable "
-        , env
-        ]
+  where
+    handleFailedRead str =
+      error $
+        mconcat
+          [ "Failed to read [[",
+            str,
+            "]] for environment variable ",
+            env
+          ]
 
 tshow :: (Show a) => a -> Text
 tshow = Text.pack . show