content: {-# LANGUAGE BangPatterns        #-}
  {-# LANGUAGE CPP                 #-}
  {-# LANGUAGE OverloadedStrings   #-}
  {-# LANGUAGE RankNTypes          #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  module System.FastLogger
    ( Logger
    , timestampedLogEntry
    , combinedLogEntry
    , newLogger
    , newLoggerWithCustomErrorFunction
    , withLogger
    , withLoggerWithCustomErrorFunction
    , stopLogger
    , logMsg
    ) where
  
  ------------------------------------------------------------------------------
  import           Control.Concurrent               (MVar, ThreadId, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay, tryPutMVar, withMVar)
  import           Control.Concurrent.Extended      (forkIOLabeledWithUnmaskBs)
  import           Control.Exception                (AsyncException, Handler (..), IOException, SomeException, bracket, catch, catches, mask_)
  import           Control.Monad                    (unless, void, when)
  import           Data.ByteString.Builder          (Builder, byteString, char8, stringUtf8, toLazyByteString, toLazyByteString)
  import           Data.ByteString.Char8            (ByteString)
  import qualified Data.ByteString.Char8            as S
  import qualified Data.ByteString.Lazy.Char8       as L
  import           Data.IORef                       (IORef, newIORef, readIORef, writeIORef)
  import           Data.Monoid                      (mappend, mconcat, mempty)
  import qualified Data.Text                        as T
  import qualified Data.Text.Encoding               as T
  import           Data.Word                        (Word64)
  import           Prelude                          (Eq (..), FilePath, IO, Int, Maybe, Monad (..), Num (..), Ord (..), Show (..), mapM_, maybe, ($), ($!), (++), (.), (||))
  import           System.IO                        (IOMode (AppendMode), hClose, hFlush, openFile, stderr, stdout)
  import           System.PosixCompat.Time          (epochTime)
  ------------------------------------------------------------------------------
  import           Snap.Internal.Http.Server.Common (atomicModifyIORef')
  import           Snap.Internal.Http.Server.Date   (getLogDateString)
  
  
  ------------------------------------------------------------------------------
  -- | Holds the state for a logger.
  data Logger = Logger
      { _queuedMessages :: !(IORef Builder)
      , _dataWaiting    :: !(MVar ())
      , _loggerPath     :: !(FilePath)
      , _loggingThread  :: !(MVar ThreadId)
      , _errAction      :: ByteString -> IO ()
      }
  
  
  ------------------------------------------------------------------------------
  -- | Creates a new logger, logging to the given file. If the file argument is
  -- \"-\", then log to stdout; if it's \"stderr\" then we log to stderr,
  -- otherwise we log to a regular file in append mode. The file is closed and
  -- re-opened every 15 minutes to facilitate external log rotation.
  newLogger :: FilePath                      -- ^ log file to use
            -> IO Logger
  newLogger = newLoggerWithCustomErrorFunction
                (\s -> S.hPutStr stderr s >> hFlush stderr)
  
  
  ------------------------------------------------------------------------------
  -- | Like 'newLogger', but uses a custom error action if the logger needs to
  -- print an error message of its own (for instance, if it can't open the
  -- output file.)
  newLoggerWithCustomErrorFunction :: (ByteString -> IO ())
                                       -- ^ logger uses this action to log any
                                       -- error messages of its own
                                   -> FilePath   -- ^ log file to use
                                   -> IO Logger
  newLoggerWithCustomErrorFunction errAction fp = do
      q  <- newIORef mempty
      dw <- newEmptyMVar
      th <- newEmptyMVar
  
      let lg = Logger q dw fp th errAction
  
      mask_ $ do
        tid <- forkIOLabeledWithUnmaskBs "snap-server: logging" $
                 loggingThread lg
        putMVar th tid
  
      return lg
  
  
  ------------------------------------------------------------------------------
  -- | Creates a Logger and passes it into the given function, cleaning up
  -- with \"stopLogger\" afterwards.
  withLogger :: FilePath                      -- ^ log file to use
            -> (Logger -> IO a)
            -> IO a
  withLogger f = bracket (newLogger f) stopLogger
  
  
  ------------------------------------------------------------------------------
  -- | Creates a Logger with \"newLoggerWithCustomErrorFunction\" and passes it
  -- into the given function, cleaning up with \"stopLogger\" afterwards.
  withLoggerWithCustomErrorFunction :: (ByteString -> IO ())
                                       -- ^ logger uses this action to log any
                                       -- error messages of its own
                                    -> FilePath       -- ^ log file to use
                                    -> (Logger -> IO a)
                                    -> IO a
  withLoggerWithCustomErrorFunction e f =
      bracket (newLoggerWithCustomErrorFunction e f) stopLogger
  
  
  ------------------------------------------------------------------------------
  -- FIXME: can be a builder, and we could even use the same trick we use for
  -- HTTP
  --
  -- | Prepares a log message with the time prepended.
  timestampedLogEntry :: ByteString -> IO ByteString
  timestampedLogEntry msg = do
      timeStr <- getLogDateString
  
      return $! S.concat
             $  L.toChunks
             $  toLazyByteString
             $  mconcat [ char8 '['
                        , byteString timeStr
                        , byteString "] "
                        , byteString msg ]
  
  
  ------------------------------------------------------------------------------
  -- FIXME: builder
  --
  -- | Prepares a log message in \"combined\" format.
  combinedLogEntry :: ByteString        -- ^ remote host
                   -> Maybe ByteString  -- ^ remote user
                   -> ByteString        -- ^ request line (up to you to ensure
                                        --   there are no quotes in here)
                   -> Int               -- ^ status code
                   -> Word64            -- ^ num bytes sent
                   -> Maybe ByteString  -- ^ referer (up to you to ensure
                                        --   there are no quotes in here)
                   -> ByteString        -- ^ user agent (up to you to ensure
                                        --   there are no quotes in here)
                   -> IO ByteString
  combinedLogEntry !host !mbUser !req !status !numBytes !mbReferer !ua = do
      timeStr <- getLogDateString
  
      let !l = [ byteString host
               , byteString " - "
               , user
               , byteString " ["
               , byteString timeStr
               , byteString "] \""
               , byteString req
               , byteString "\" "
               , fromShow status
               , space
               , fromShow numBytes
               , space
               , referer
               , byteString " \""
               , byteString ua
               , quote ]
  
      return $! S.concat . L.toChunks $ toLazyByteString $ mconcat l
  
    where
      dash     = char8 '-'
      quote    = char8 '\"'
      space    = char8 ' '
      user     = maybe dash byteString mbUser
      referer  = maybe dash
                       (\s -> mconcat [ quote
                                      , byteString s
                                      , quote ])
                       mbReferer
  
  
  ------------------------------------------------------------------------------
  -- | Sends out a log message verbatim with a newline appended. Note:
  -- if you want a fancy log message you'll have to format it yourself
  -- (or use 'combinedLogEntry').
  logMsg :: Logger -> ByteString -> IO ()
  logMsg !lg !s = do
      let !s' = byteString s `mappend` char8 '\n'
      atomicModifyIORef' (_queuedMessages lg) $ \d -> (d `mappend` s',())
      void $ tryPutMVar (_dataWaiting lg) ()
  
  
  ------------------------------------------------------------------------------
  loggingThread :: Logger -> (forall a. IO a -> IO a) -> IO ()
  loggingThread (Logger queue notifier filePath _ errAct) unmask = do
      initialize >>= go
  
    where
      openIt =
          if filePath == "-"
            then return stdout
            else
              if filePath == "stderr"
                then return stderr
                else openFile filePath AppendMode `catch`
                       \(e::IOException) -> do
                         logInternalError $ "Can't open log file \"" ++
                                            filePath ++ "\".\n"
                         logInternalError $ "Exception: " ++ show e ++ "\n"
                         logInternalError $ "Logging to stderr instead. " ++
                                            "**THIS IS BAD, YOU OUGHT TO " ++
                                            "FIX THIS**\n\n"
                         return stderr
  
      closeIt h = unless (h == stdout || h == stderr) $
                    hClose h
  
      logInternalError = errAct . T.encodeUtf8 . T.pack
  
      --------------------------------------------------------------------------
      go (href, lastOpened) = unmask loop `catches`
            [ Handler $ \(_::AsyncException) -> killit (href, lastOpened)
            , Handler $ \(e::SomeException)  -> do
                  logInternalError $ "logger got exception: "
                                     ++ Prelude.show e ++ "\n"
                  threadDelay 20000000
                  go (href, lastOpened) ]
        where
          loop = waitFlushDelay (href, lastOpened) >> loop
  
      --------------------------------------------------------------------------
      initialize = do
          lh   <- openIt
          href <- newIORef lh
          t    <- epochTime
          tref <- newIORef t
          return (href, tref)
  
  
      --------------------------------------------------------------------------
      killit (href, lastOpened) = do
          flushIt (href, lastOpened)
          h <- readIORef href
          closeIt h
  
      --------------------------------------------------------------------------
      flushIt (!href, !lastOpened) = do
          dl <- atomicModifyIORef' queue $ \x -> (mempty,x)
  
          let !msgs = toLazyByteString dl
          h <- readIORef href
          (do L.hPut h msgs
              hFlush h) `catch` \(e::IOException) -> do
                  logInternalError $ "got exception writing to log " ++
                                     filePath ++ ": " ++ show e ++ "\n"
                  logInternalError "writing log entries to stderr.\n"
                  mapM_ errAct $ L.toChunks msgs
  
          -- close the file every 15 minutes (for log rotation)
          t   <- epochTime
          old <- readIORef lastOpened
  
          when (t-old > 900) $ do
              closeIt h
              mask_ $ openIt >>= writeIORef href
              writeIORef lastOpened t
  
  
      waitFlushDelay !d = do
          -- wait on the notification mvar
          _ <- takeMVar notifier
  
          -- grab the queued messages and write them out
          flushIt d
  
          -- at least five seconds between log dumps
          threadDelay 5000000
  
  
  ------------------------------------------------------------------------------
  -- | Kills a logger thread, causing any unwritten contents to be
  -- flushed out to disk
  stopLogger :: Logger -> IO ()
  stopLogger lg = withMVar (_loggingThread lg) killThread
  
  
  ------------------------------------------------------------------------------
  fromShow :: Show a => a -> Builder
  fromShow = stringUtf8 . show
  