Logger.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}

-- | Apache style logger for WAI applications.
--
-- An example:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > module Main where
-- >
-- > import Data.ByteString.Builder (byteString)
-- > import Control.Monad.IO.Class (liftIO)
-- > import qualified Data.ByteString.Char8 as BS
-- > import Network.HTTP.Types (status200)
-- > import Network.Wai (Application, responseBuilder)
-- > import Network.Wai.Handler.Warp (run)
-- > import Network.Wai.Logger (withStdoutLogger, ApacheLogger)
-- >
-- > main :: IO ()
-- > main = withStdoutLogger $ \aplogger ->
-- >     run 3000 $ logApp aplogger
-- >
-- > logApp :: ApacheLogger -> Application
-- > logApp aplogger req response = do
-- >     liftIO $ aplogger req status (Just len)
-- >     response $ responseBuilder status hdr msg
-- >   where
-- >     status = status200
-- >     hdr = [("Content-Type", "text/plain")]
-- >     pong = "PONG"
-- >     msg = byteString pong
-- >     len = fromIntegral $ BS.length pong
module Network.Wai.Logger (
    -- * High level functions
    ApacheLogger,
    withStdoutLogger,
    ServerPushLogger,

    -- * Creating a logger
    ApacheLoggerActions,
    apacheLogger,
    serverpushLogger,
    logRotator,
    logRemover,
    initLoggerUser,
    initLogger,

    -- * Types
    IPAddrSource (..),
    LogType' (..),
    LogType,
    FileLogSpec (..),

    -- * Utilities
    showSockAddr,
    logCheck,

    -- * Backward compability
    clockDateCacher,
    ZonedDate,
    DateCacheGetter,
    DateCacheUpdater,
) where

#if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<$>))
#endif
import Control.Exception (bracket)
import Control.Monad (void)
import Data.ByteString (ByteString)
import Network.HTTP.Types (Status)
import Network.Wai (Request)
import System.Log.FastLogger

import Network.Wai.Logger.Apache
import Network.Wai.Logger.IP (showSockAddr)

----------------------------------------------------------------

-- | Executing a function which takes 'ApacheLogger'.
--   This 'ApacheLogger' writes log message to stdout.
--   Each buffer (4K bytes) is flushed every second.
withStdoutLogger :: (ApacheLogger -> IO a) -> IO a
withStdoutLogger app = bracket setup teardown $ \(aplogger, _) ->
    app aplogger
  where
    setup = do
        tgetter <- newTimeCache simpleTimeFormat
        apf <- initLogger FromFallback (LogStdout 4096) tgetter
        let aplogger = apacheLogger apf
            remover = logRemover apf
        return (aplogger, remover)
    teardown (_, remover) = void remover

----------------------------------------------------------------

-- | Apache style logger.
type ApacheLogger = Request -> Status -> Maybe Integer -> IO ()

-- | HTTP/2 server push logger in Apache style.
type ServerPushLogger = Request -> ByteString -> Integer -> IO ()

-- | Function set of Apache style logger.
data ApacheLoggerActions = ApacheLoggerActions
    { apacheLogger :: ApacheLogger
    -- ^ The Apache logger.
    , serverpushLogger :: ServerPushLogger
    -- ^ The HTTP/2 server push logger.
    , logRotator :: IO ()
    -- ^ This is obsoleted. Rotation is done on-demand.
    --   So, this is now an empty action.
    , logRemover :: IO ()
    -- ^ Removing resources relating to Apache logger.
    --   E.g. flushing and deallocating internal buffers.
    }

----------------------------------------------------------------

-- | Creating 'ApacheLogger' according to 'LogType'.
initLoggerUser
    :: ToLogStr user
    => Maybe (Request -> Maybe user)
    -> IPAddrSource
    -> LogType
    -> IO FormattedTime
    -> IO ApacheLoggerActions
initLoggerUser ugetter ipsrc typ tgetter = do
    (fl, cleanUp) <- newFastLogger typ
    return $
        ApacheLoggerActions
            { apacheLogger = apache fl ipsrc ugetter tgetter
            , serverpushLogger = serverpush fl ipsrc ugetter tgetter
            , logRotator = return ()
            , logRemover = cleanUp
            }

initLogger
    :: IPAddrSource
    -> LogType
    -> IO FormattedTime
    -> IO ApacheLoggerActions
initLogger = initLoggerUser nouser
  where
    nouser :: Maybe (Request -> Maybe ByteString)
    nouser = Nothing

--- | Checking if a log file can be written if 'LogType' is 'LogFileNoRotate' or 'LogFile'.
logCheck :: LogType -> IO ()
logCheck LogNone = return ()
logCheck (LogStdout _) = return ()
logCheck (LogStderr _) = return ()
logCheck (LogFileNoRotate fp _) = check fp
logCheck (LogFile spec _) = check (log_file spec)
logCheck (LogFileTimedRotate spec _) = check (timed_log_file spec)
logCheck (LogCallback _ _) = return ()

----------------------------------------------------------------

apache
    :: ToLogStr user
    => (LogStr -> IO ())
    -> IPAddrSource
    -> Maybe (Request -> Maybe user)
    -> IO FormattedTime
    -> ApacheLogger
apache cb ipsrc userget dateget req st mlen = do
    zdata <- dateget
    cb (apacheLogStr ipsrc (justGetUser userget) zdata req st mlen)

serverpush
    :: ToLogStr user
    => (LogStr -> IO ())
    -> IPAddrSource
    -> Maybe (Request -> Maybe user)
    -> IO FormattedTime
    -> ServerPushLogger
serverpush cb ipsrc userget dateget req path size = do
    zdata <- dateget
    cb (serverpushLogStr ipsrc (justGetUser userget) zdata req path size)

---------------------------------------------------------------

-- | Getting cached 'ZonedDate'.
type DateCacheGetter = IO ZonedDate

-- | Updateing cached 'ZonedDate'. This should be called every second.
--   See the source code of 'withStdoutLogger'.
type DateCacheUpdater = IO ()

-- | A type for zoned date.
type ZonedDate = FormattedTime

-- |
-- Returning 'DateCacheGetter' and 'DateCacheUpdater'.
--
-- Note: Since version 2.1.2, this function uses the auto-update package
-- internally, and therefore the @DateCacheUpdater@ value returned need
-- not be called. To wit, the return value is in fact an empty action.
clockDateCacher :: IO (DateCacheGetter, DateCacheUpdater)
clockDateCacher = do
    tgetter <- newTimeCache simpleTimeFormat
    return (tgetter, return ())

justGetUser :: Maybe (Request -> Maybe user) -> (Request -> Maybe user)
justGetUser (Just getter) = getter
justGetUser Nothing = \_ -> Nothing