{-# 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 :: (ApacheLogger -> IO a) -> IO a
withStdoutLogger ApacheLogger -> IO a
app = IO (ApacheLogger, IO ())
-> ((ApacheLogger, IO ()) -> IO ())
-> ((ApacheLogger, IO ()) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (ApacheLogger, IO ())
setup (ApacheLogger, IO ()) -> IO ()
forall (f :: * -> *) a a. Functor f => (a, f a) -> f ()
teardown (((ApacheLogger, IO ()) -> IO a) -> IO a)
-> ((ApacheLogger, IO ()) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(ApacheLogger
aplogger, IO ()
_) ->
    ApacheLogger -> IO a
app ApacheLogger
aplogger
  where
    setup :: IO (ApacheLogger, IO ())
setup = do
        IO FormattedTime
tgetter <- FormattedTime -> IO (IO FormattedTime)
newTimeCache FormattedTime
simpleTimeFormat
        ApacheLoggerActions
apf <- IPAddrSource
-> LogType -> IO FormattedTime -> IO ApacheLoggerActions
initLogger IPAddrSource
FromFallback (BufSize -> LogType
LogStdout BufSize
4096) IO FormattedTime
tgetter
        let aplogger :: ApacheLogger
aplogger = ApacheLoggerActions -> ApacheLogger
apacheLogger ApacheLoggerActions
apf
            remover :: IO ()
remover = ApacheLoggerActions -> IO ()
logRemover ApacheLoggerActions
apf
        (ApacheLogger, IO ()) -> IO (ApacheLogger, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ApacheLogger
aplogger, IO ()
remover)
    teardown :: (a, f a) -> f ()
teardown (a
_, f a
remover) = f a -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void f a
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 {
    -- | The Apache logger.
    ApacheLoggerActions -> ApacheLogger
apacheLogger :: ApacheLogger
    -- | The HTTP/2 server push logger.
  , ApacheLoggerActions -> ServerPushLogger
serverpushLogger :: ServerPushLogger
    -- | This is obsoleted. Rotation is done on-demand.
    --   So, this is now an empty action.
  , ApacheLoggerActions -> IO ()
logRotator :: IO ()
    -- | Removing resources relating to Apache logger.
    --   E.g. flushing and deallocating internal buffers.
  , ApacheLoggerActions -> IO ()
logRemover :: IO ()
  }

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

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

initLogger :: IPAddrSource -> LogType -> IO FormattedTime
           -> IO ApacheLoggerActions
initLogger :: IPAddrSource
-> LogType -> IO FormattedTime -> IO ApacheLoggerActions
initLogger = Maybe (Request -> Maybe FormattedTime)
-> IPAddrSource
-> LogType
-> IO FormattedTime
-> IO ApacheLoggerActions
forall user.
ToLogStr user =>
Maybe (Request -> Maybe user)
-> IPAddrSource
-> LogType
-> IO FormattedTime
-> IO ApacheLoggerActions
initLoggerUser Maybe (Request -> Maybe FormattedTime)
nouser
  where
    nouser :: Maybe (Request -> Maybe ByteString)
    nouser :: Maybe (Request -> Maybe FormattedTime)
nouser = Maybe (Request -> Maybe FormattedTime)
forall a. Maybe a
Nothing

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

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

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

serverpush :: ToLogStr user => (LogStr -> IO ()) -> IPAddrSource -> Maybe (Request -> Maybe user) -> IO FormattedTime -> ServerPushLogger
serverpush :: (LogStr -> IO ())
-> IPAddrSource
-> Maybe (Request -> Maybe user)
-> IO FormattedTime
-> ServerPushLogger
serverpush LogStr -> IO ()
cb IPAddrSource
ipsrc Maybe (Request -> Maybe user)
userget IO FormattedTime
dateget Request
req FormattedTime
path Integer
size = do
    FormattedTime
zdata <- IO FormattedTime
dateget
    LogStr -> IO ()
cb (IPAddrSource
-> (Request -> Maybe user)
-> FormattedTime
-> Request
-> FormattedTime
-> Integer
-> LogStr
forall user.
ToLogStr user =>
IPAddrSource
-> (Request -> Maybe user)
-> FormattedTime
-> Request
-> FormattedTime
-> Integer
-> LogStr
serverpushLogStr IPAddrSource
ipsrc (Maybe (Request -> Maybe user) -> Request -> Maybe user
forall user. Maybe (Request -> Maybe user) -> Request -> Maybe user
justGetUser Maybe (Request -> Maybe user)
userget) FormattedTime
zdata Request
req FormattedTime
path Integer
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 :: IO (IO FormattedTime, IO ())
clockDateCacher = do
    IO FormattedTime
tgetter <- FormattedTime -> IO (IO FormattedTime)
newTimeCache FormattedTime
simpleTimeFormat
    (IO FormattedTime, IO ()) -> IO (IO FormattedTime, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO FormattedTime
tgetter, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

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