    {-# 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
        { Logger -> IORef Builder
    _queuedMessages :: !(IORef Builder)
        , Logger -> MVar ()
    _dataWaiting    :: !(MVar ())
        , Logger -> FilePath
    _loggerPath     :: !(FilePath)
        , Logger -> MVar ThreadId
    _loggingThread  :: !(MVar ThreadId)
        , Logger -> StrictByteString -> IO ()
    _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 :: FilePath -> IO Logger
    newLogger = (StrictByteString -> IO ()) -> FilePath -> IO Logger
    newLoggerWithCustomErrorFunction
                  (\StrictByteString
    s -> Handle -> StrictByteString -> IO ()
    S.hPutStr Handle
    stderr StrictByteString
    s IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Handle -> IO ()
    hFlush Handle
    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 :: (StrictByteString -> IO ()) -> FilePath -> IO Logger
    newLoggerWithCustomErrorFunction StrictByteString -> IO ()
    errAction FilePath
    fp = do
        q  <- Builder -> IO (IORef Builder)
    forall a. a -> IO (IORef a)
    newIORef Builder
    forall a. Monoid a => a
    mempty
        dw <- newEmptyMVar
        th <- newEmptyMVar

        let lg = IORef Builder
    -> MVar ()
    -> FilePath
    -> MVar ThreadId
    -> (StrictByteString -> IO ())
    -> Logger
    Logger IORef Builder
    q MVar ()
    dw FilePath
    fp MVar ThreadId
    th StrictByteString -> IO ()
    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 :: forall a. FilePath -> (Logger -> IO a) -> IO a
    withLogger FilePath
    f = IO Logger -> (Logger -> IO ()) -> (Logger -> IO a) -> IO a
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket (FilePath -> IO Logger
    newLogger FilePath
    f) Logger -> IO ()
    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 :: forall a.
    (StrictByteString -> IO ()) -> FilePath -> (Logger -> IO a) -> IO a
    withLoggerWithCustomErrorFunction StrictByteString -> IO ()
    e FilePath
    f =
        IO Logger -> (Logger -> IO ()) -> (Logger -> IO a) -> IO a
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket ((StrictByteString -> IO ()) -> FilePath -> IO Logger
    newLoggerWithCustomErrorFunction StrictByteString -> IO ()
    e FilePath
    f) Logger -> IO ()
    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 :: StrictByteString -> IO StrictByteString
    timestampedLogEntry StrictByteString
    msg = do
        timeStr <- IO StrictByteString
    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 :: StrictByteString
    -> Maybe StrictByteString
    -> StrictByteString
    -> Int
    -> Word64
    -> Maybe StrictByteString
    -> StrictByteString
    -> IO StrictByteString
    combinedLogEntry !StrictByteString
    host !Maybe StrictByteString
    mbUser !StrictByteString
    req !Int
    status !Word64
    numBytes !Maybe StrictByteString
    mbReferer !StrictByteString
    ua = do
        timeStr <- IO StrictByteString
    getLogDateString

        let !l = [ StrictByteString -> Builder
    byteString StrictByteString
    host
                 , StrictByteString -> Builder
    byteString StrictByteString
    " - "
                 , Builder
    user
                 , StrictByteString -> Builder
    byteString StrictByteString
    " ["
                 , StrictByteString -> Builder
    byteString StrictByteString
    timeStr
                 , StrictByteString -> Builder
    byteString StrictByteString
    "] \""
                 , StrictByteString -> Builder
    byteString StrictByteString
    req
                 , StrictByteString -> Builder
    byteString StrictByteString
    "\" "
                 , Int -> Builder
    forall a. Show a => a -> Builder
    fromShow Int
    status
                 , Builder
    space
                 , Word64 -> Builder
    forall a. Show a => a -> Builder
    fromShow Word64
    numBytes
                 , Builder
    space
                 , Builder
    referer
                 , StrictByteString -> Builder
    byteString StrictByteString
    " \""
                 , StrictByteString -> Builder
    byteString StrictByteString
    ua
                 , Builder
    quote ]

        return $! S.concat . L.toChunks $ toLazyByteString $ mconcat l

      where
        dash :: Builder
    dash     = Char -> Builder
    char8 Char
    '-'
        quote :: Builder
    quote    = Char -> Builder
    char8 Char
    '\"'
        space :: Builder
    space    = Char -> Builder
    char8 Char
    ' '
        user :: Builder
    user     = Builder
    -> (StrictByteString -> Builder)
    -> Maybe StrictByteString
    -> Builder
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Builder
    dash StrictByteString -> Builder
    byteString Maybe StrictByteString
    mbUser
        referer :: Builder
    referer  = Builder
    -> (StrictByteString -> Builder)
    -> Maybe StrictByteString
    -> Builder
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Builder
    dash
                         (\StrictByteString
    s -> [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat [ Builder
    quote
                                        , StrictByteString -> Builder
    byteString StrictByteString
    s
                                        , Builder
    quote ])
                         Maybe StrictByteString
    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 :: Logger -> StrictByteString -> IO ()
    logMsg !Logger
    lg !StrictByteString
    s = do
        let !s' :: Builder
    s' = StrictByteString -> Builder
    byteString StrictByteString
    s Builder -> Builder -> Builder
    forall a. Monoid a => a -> a -> a
    `mappend` Char -> Builder
    char8 Char
    '\n'
        IORef Builder -> (Builder -> (Builder, ())) -> IO ()
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' (Logger -> IORef Builder
    _queuedMessages Logger
    lg) ((Builder -> (Builder, ())) -> IO ())
    -> (Builder -> (Builder, ())) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \Builder
    d -> (Builder
    d Builder -> Builder -> Builder
    forall a. Monoid a => a -> a -> a
    `mappend` Builder
    s',())
        IO Bool -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO Bool -> IO ()) -> IO Bool -> IO ()
    forall a b. (a -> b) -> a -> b
    $ MVar () -> () -> IO Bool
    forall a. MVar a -> a -> IO Bool
    tryPutMVar (Logger -> MVar ()
    _dataWaiting Logger
    lg) ()

    ------------------------------------------------------------------------------
    loggingThread :: Logger -> (forall a. IO a -> IO a) -> IO ()
    loggingThread :: Logger -> (forall a. IO a -> IO a) -> IO ()
    loggingThread (Logger IORef Builder
    queue MVar ()
    notifier FilePath
    filePath MVar ThreadId
    _ StrictByteString -> IO ()
    errAct) forall a. IO a -> IO a
    unmask = do
        IO (IORef Handle, IORef EpochTime)
    initialize IO (IORef Handle, IORef EpochTime)
    -> ((IORef Handle, IORef EpochTime) -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (IORef Handle, IORef EpochTime) -> IO ()
    go

      where
        openIt :: IO Handle
    openIt =
            if FilePath
    filePath FilePath -> FilePath -> Bool
    forall a. Eq a => a -> a -> Bool
    == FilePath
    "-"
              then Handle -> IO Handle
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Handle
    stdout
              else
                if FilePath
    filePath FilePath -> FilePath -> Bool
    forall a. Eq a => a -> a -> Bool
    == FilePath
    "stderr"
                  then Handle -> IO Handle
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Handle
    stderr
                  else FilePath -> IOMode -> IO Handle
    openFile FilePath
    filePath IOMode
    AppendMode IO Handle -> (IOException -> IO Handle) -> IO Handle
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `catch`
                         \(IOException
    e::IOException) -> do
                           FilePath -> IO ()
    logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
    forall a b. (a -> b) -> a -> b
    $ FilePath
    "Can't open log file \"" FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++
                                              FilePath
    filePath FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    "\".\n"
                           FilePath -> IO ()
    logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
    forall a b. (a -> b) -> a -> b
    $ FilePath
    "Exception: " FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ IOException -> FilePath
    forall a. Show a => a -> FilePath
    show IOException
    e FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    "\n"
                           FilePath -> IO ()
    logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
    forall a b. (a -> b) -> a -> b
    $ FilePath
    "Logging to stderr instead. " FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++
                                              FilePath
    "**THIS IS BAD, YOU OUGHT TO " FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++
                                              FilePath
    "FIX THIS**\n\n"
                           Handle -> IO Handle
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Handle
    stderr

        closeIt :: Handle -> IO ()
    closeIt Handle
    h = Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (Handle
    h Handle -> Handle -> Bool
    forall a. Eq a => a -> a -> Bool
    == Handle
    stdout Bool -> Bool -> Bool
    || Handle
    h Handle -> Handle -> Bool
    forall a. Eq a => a -> a -> Bool
    == Handle
    stderr) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                      Handle -> IO ()
    hClose Handle
    h

        logInternalError :: FilePath -> IO ()
    logInternalError = StrictByteString -> IO ()
    errAct (StrictByteString -> IO ())
    -> (FilePath -> StrictByteString) -> FilePath -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> StrictByteString
    T.encodeUtf8 (Text -> StrictByteString)
    -> (FilePath -> Text) -> FilePath -> StrictByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FilePath -> Text
    T.pack

        --------------------------------------------------------------------------
        go :: (IORef Handle, IORef EpochTime) -> IO ()
    go (IORef Handle
    href, IORef EpochTime
    lastOpened) = IO () -> IO ()
    forall a. IO a -> IO a
    unmask IO ()
    forall {b}. IO b
    loop IO () -> [Handler ()] -> IO ()
    forall a. IO a -> [Handler a] -> IO a
    `catches`
              [ (AsyncException -> IO ()) -> Handler ()
    forall a e. Exception e => (e -> IO a) -> Handler a
    Handler ((AsyncException -> IO ()) -> Handler ())
    -> (AsyncException -> IO ()) -> Handler ()
    forall a b. (a -> b) -> a -> b
    $ \(AsyncException
    _::AsyncException) -> (IORef Handle, IORef EpochTime) -> IO ()
    killit (IORef Handle
    href, IORef EpochTime
    lastOpened)
              , (SomeException -> IO ()) -> Handler ()
    forall a e. Exception e => (e -> IO a) -> Handler a
    Handler ((SomeException -> IO ()) -> Handler ())
    -> (SomeException -> IO ()) -> Handler ()
    forall a b. (a -> b) -> a -> b
    $ \(SomeException
    e::SomeException)  -> do
                    FilePath -> IO ()
    logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
    forall a b. (a -> b) -> a -> b
    $ FilePath
    "logger got exception: "
                                       FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ SomeException -> FilePath
    forall a. Show a => a -> FilePath
    Prelude.show SomeException
    e FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    "\n"
                    Int -> IO ()
    threadDelay Int
    20000000
                    (IORef Handle, IORef EpochTime) -> IO ()
    go (IORef Handle
    href, IORef EpochTime
    lastOpened) ]
          where
            loop :: IO b
    loop = (IORef Handle, IORef EpochTime) -> IO ()
    waitFlushDelay (IORef Handle
    href, IORef EpochTime
    lastOpened) IO () -> IO b -> IO b
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO b
    loop

        --------------------------------------------------------------------------
        initialize :: IO (IORef Handle, IORef EpochTime)
    initialize = do
            lh   <- IO Handle
    openIt
            href <- newIORef lh
            t    <- epochTime
            tref <- newIORef t
            return (href, tref)

        --------------------------------------------------------------------------
        killit :: (IORef Handle, IORef EpochTime) -> IO ()
    killit (IORef Handle
    href, IORef EpochTime
    lastOpened) = do
            (IORef Handle, IORef EpochTime) -> IO ()
    flushIt (IORef Handle
    href, IORef EpochTime
    lastOpened)
            h <- IORef Handle -> IO Handle
    forall a. IORef a -> IO a
    readIORef IORef Handle
    href
            closeIt h

        --------------------------------------------------------------------------
        flushIt :: (IORef Handle, IORef EpochTime) -> IO ()
    flushIt (!IORef Handle
    href, !IORef EpochTime
    lastOpened) = do
            dl <- IORef Builder -> (Builder -> (Builder, Builder)) -> IO Builder
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' IORef Builder
    queue ((Builder -> (Builder, Builder)) -> IO Builder)
    -> (Builder -> (Builder, Builder)) -> IO Builder
    forall a b. (a -> b) -> a -> b
    $ \Builder
    x -> (Builder
    forall a. Monoid a => a
    mempty,Builder
    x)

            let !msgs = Builder -> LazyByteString
    toLazyByteString Builder
    dl
            h <- readIORef href
            (do L.hPut h msgs
                hFlush h) `catch` \(IOException
    e::IOException) -> do
                    FilePath -> IO ()
    logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
    forall a b. (a -> b) -> a -> b
    $ FilePath
    "got exception writing to log " FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++
                                       FilePath
    filePath FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    ": " FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ IOException -> FilePath
    forall a. Show a => a -> FilePath
    show IOException
    e FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    "\n"
                    FilePath -> IO ()
    logInternalError FilePath
    "writing log entries to stderr.\n"
                    (StrictByteString -> IO ()) -> [StrictByteString] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ StrictByteString -> IO ()
    errAct ([StrictByteString] -> IO ()) -> [StrictByteString] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ LazyByteString -> [StrictByteString]
    L.toChunks LazyByteString
    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 :: (IORef Handle, IORef EpochTime) -> IO ()
    waitFlushDelay !(IORef Handle, IORef EpochTime)
    d = do
            -- wait on the notification mvar
            _ <- MVar () -> IO ()
    forall a. MVar a -> IO a
    takeMVar MVar ()
    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 :: Logger -> IO ()
    stopLogger Logger
    lg = MVar ThreadId -> (ThreadId -> IO ()) -> IO ()
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar (Logger -> MVar ThreadId
    _loggingThread Logger
    lg) ThreadId -> IO ()
    killThread

    ------------------------------------------------------------------------------
    fromShow :: Show a => a -> Builder
    fromShow :: forall a. Show a => a -> Builder
    fromShow = FilePath -> Builder
    stringUtf8 (FilePath -> Builder) -> (a -> FilePath) -> a -> Builder
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> FilePath
    forall a. Show a => a -> FilePath
    show