From 06ad6c254b1088119d2242600915854483dbad76 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 3 Apr 2011 22:24:13 +0300
Subject: [PATCH] messageLogger

---
 Yesod/Core.hs | 35 +++++++++++++++++++++++++++++++++++
 1 file changed, 35 insertions(+)

diff --git a/Yesod/Core.hs b/Yesod/Core.hs
index 15a4a984..26759eba 100644
--- a/Yesod/Core.hs
+++ b/Yesod/Core.hs
@@ -19,6 +19,9 @@ module Yesod.Core
     , defaultErrorHandler
       -- * Data types
     , AuthResult (..)
+      -- * Logging
+    , LogLevel (..)
+    , formatLogMessage
       -- * Misc
     , yesodVersion
     , yesodRender
@@ -63,6 +66,10 @@ import Blaze.ByteString.Builder (Builder, toByteString)
 import Blaze.ByteString.Builder.Char.Utf8 (fromText)
 import Data.List (foldl')
 import qualified Network.HTTP.Types as H
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO
+import qualified System.IO
+import qualified Data.Text.Lazy.Builder as TB
 
 #if GHC7
 #define HAMLET hamlet
@@ -236,6 +243,34 @@ class RenderRoute (Route a) => Yesod a where
     maximumContentLength :: a -> Maybe (Route a) -> Int
     maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
 
+    -- | Send a message to the log. By default, prints to stderr.
+    messageLogger :: a
+                  -> LogLevel
+                  -> Text -- ^ source
+                  -> Text -- ^ message
+                  -> IO ()
+    messageLogger _ level src msg =
+        formatLogMessage level src msg >>=
+        Data.Text.Lazy.IO.hPutStrLn System.IO.stderr
+
+data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
+    deriving (Eq, Show, Read, Ord)
+
+formatLogMessage :: LogLevel
+                 -> Text -- ^ source
+                 -> Text -- ^ message
+                 -> IO TL.Text
+formatLogMessage level src msg = do
+    now <- getCurrentTime
+    return $ TB.toLazyText $
+        TB.fromText (TS.pack $ show now)
+        `mappend` TB.fromText ": "
+        `mappend` TB.fromText (TS.pack $ show level)
+        `mappend` TB.fromText "@("
+        `mappend` TB.fromText src
+        `mappend` TB.fromText ") "
+        `mappend` TB.fromText msg
+
 defaultYesodRunner :: Yesod master
                    => a
                    -> master