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