1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 {-# LANGUAGE ScopedTypeVariables #-} 4 5 module System.FastLogger 6 ( Logger 7 , timestampedLogEntry 8 , combinedLogEntry 9 , newLogger 10 , logMsg 11 , stopLogger 12 ) where 13 14 15 ------------------------------------------------------------------------------ 16 import Blaze.ByteString.Builder 17 import Blaze.ByteString.Builder.Char.Utf8 18 import Control.Concurrent 19 import Control.Exception 20 import Data.ByteString.Char8 (ByteString) 21 import qualified Data.ByteString.Lazy.Char8 as L 22 import Data.ByteString.Internal (c2w) 23 import Data.Int 24 import Data.IORef 25 import Data.Monoid 26 import System.IO 27 28 import Snap.Internal.Http.Server.Date 29 30 31 ------------------------------------------------------------------------------ 32 -- | Holds the state for a logger. 33 data Logger = Logger 34 { _queuedMessages :: !(IORef Builder) 35 , _dataWaiting :: !(MVar ()) 36 , _loggerPath :: !(FilePath) 37 , _loggingThread :: !(MVar ThreadId) } 38 39 40 ------------------------------------------------------------------------------ 41 -- | Creates a new logger, logging to the given file. If the file argument is 42 -- \"-\", then log to stdout; if it's \"stderr\" then we log to stderr, 43 -- otherwise we log to a regular file in append mode. The file is closed and 44 -- re-opened every 15 minutes to facilitate external log rotation. 45 newLogger :: FilePath -> IO Logger 46 newLogger fp = do 47 q <- newIORef mempty 48 dw <- newEmptyMVar 49 th <- newEmptyMVar 50 51 let lg = Logger q dw fp th 52 53 tid <- forkIO $ loggingThread lg 54 putMVar th tid 55 56 return lg 57 58 59 ------------------------------------------------------------------------------ 60 -- | Prepares a log message with the time prepended. 61 timestampedLogEntry :: ByteString -> IO ByteString 62 timestampedLogEntry msg = do 63 timeStr <- getLogDateString 64 65 return $! toByteString 66 $! mconcat [ fromWord8 $ c2w '[' 67 , fromByteString timeStr 68 , fromByteString "] " 69 , fromByteString msg ] 70 71 72 ------------------------------------------------------------------------------ 73 -- | Prepares a log message in \"combined\" format. 74 combinedLogEntry :: ByteString -- ^ remote host 75 -> Maybe ByteString -- ^ remote user 76 -> ByteString -- ^ request line (up to you to ensure 77 -- there are no quotes in here) 78 -> Int -- ^ status code 79 -> Maybe Int64 -- ^ num bytes sent 80 -> Maybe ByteString -- ^ referer (up to you to ensure 81 -- there are no quotes in here) 82 -> ByteString -- ^ user agent (up to you to ensure 83 -- there are no quotes in here) 84 -> IO ByteString 85 combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !ua = do 86 timeStr <- getLogDateString 87 88 let !l = [ fromByteString host 89 , fromByteString " - " 90 , user 91 , fromByteString " [" 92 , fromByteString timeStr 93 , fromByteString "] \"" 94 , fromByteString req 95 , fromByteString "\" " 96 , fromShow status 97 , space 98 , numBytes 99 , space 100 , referer 101 , fromByteString " \"" 102 , fromByteString ua 103 , quote ] 104 105 let !output = toByteString $ mconcat l 106 107 return $! output 108 109 where 110 dash = fromWord8 $ c2w '-' 111 quote = fromWord8 $ c2w '\"' 112 space = fromWord8 $ c2w ' ' 113 user = maybe dash fromByteString mbUser 114 numBytes = maybe dash fromShow mbNumBytes 115 referer = maybe dash 116 (\s -> mconcat [ quote 117 , fromByteString s 118 , quote ]) 119 mbReferer 120 121 122 ------------------------------------------------------------------------------ 123 -- | Sends out a log message verbatim with a newline appended. Note: 124 -- if you want a fancy log message you'll have to format it yourself 125 -- (or use 'combinedLogEntry'). 126 logMsg :: Logger -> ByteString -> IO () 127 logMsg !lg !s = do 128 let !s' = fromByteString s `mappend` (fromWord8 $ c2w '\n') 129 atomicModifyIORef (_queuedMessages lg) $ \d -> (d `mappend` s',()) 130 tryPutMVar (_dataWaiting lg) () >> return () 131 132 133 ------------------------------------------------------------------------------ 134 loggingThread :: Logger -> IO () 135 loggingThread (Logger queue notifier filePath _) = do 136 initialize >>= go 137 138 where 139 openIt = if filePath == "-" 140 then return stdout 141 else if filePath == "stderr" 142 then return stderr 143 else openFile filePath AppendMode 144 145 closeIt h = if filePath == "-" || filePath == "stderr" 146 then return () 147 else hClose h 148 149 go (href, lastOpened) = 150 (loop (href, lastOpened)) 151 `catches` 152 [ Handler $ \(_::AsyncException) -> killit (href, lastOpened) 153 , Handler $ \(e::SomeException) -> do 154 hPutStrLn stderr $ "logger got exception: " ++ Prelude.show e 155 threadDelay 20000000 156 go (href, lastOpened) ] 157 158 159 initialize = do 160 lh <- openIt 161 href <- newIORef lh 162 t <- getCurrentDateTime 163 tref <- newIORef t 164 return (href, tref) 165 166 167 killit (href, lastOpened) = do 168 flushIt (href, lastOpened) 169 h <- readIORef href 170 closeIt h 171 172 173 flushIt (!href, !lastOpened) = do 174 dl <- atomicModifyIORef queue $ \x -> (mempty,x) 175 176 let !msgs = toLazyByteString dl 177 h <- readIORef href 178 L.hPut h msgs 179 hFlush h 180 181 -- close the file every 15 minutes (for log rotation) 182 t <- getCurrentDateTime 183 old <- readIORef lastOpened 184 185 if t-old > 900 186 then do 187 closeIt h 188 openIt >>= writeIORef href 189 writeIORef lastOpened t 190 else return () 191 192 193 loop !d = do 194 -- wait on the notification mvar 195 _ <- takeMVar notifier 196 197 -- grab the queued messages and write them out 198 flushIt d 199 200 -- at least five seconds between log dumps 201 threadDelay 5000000 202 loop d 203 204 205 ------------------------------------------------------------------------------ 206 -- | Kills a logger thread, causing any unwritten contents to be 207 -- flushed out to disk 208 stopLogger :: Logger -> IO () 209 stopLogger lg = withMVar (_loggingThread lg) killThread