-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
-- 
--  * Redistributions of source code must retain the above copyright notice,
--    this list of conditions and the following disclaimer.
-- 
--  * Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
-- 
--  * Neither the name of the copyright holder(s) nor the names of
--    contributors may be used to endorse or promote products derived from
--    this software without specific prior written permission.
-- 
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- -----------------------------------------------------------------------------

module AccessLogger (
	startAccessLogger,
	stopAccessLogger,
	logAccess
  ) where

import ErrorLogger
import Request
import Response
import Config
import Util

import IO
import Char (toLower)
import Foreign
import Time
import System.Time
import Network.Socket
import Network.BSD
import Control.Exception
import Control.Concurrent

-----------------------------------------------------------------------------
-- Access Logging

-- logging is done by a separate thread, so it doesn't hold anything else up.

data LogRequest =
  LogReq { 
     log_ipaddr	        :: HostAddress,		-- %a
     log_logname	:: String,		-- %l
     log_request	:: Request,		-- %r etc.
     log_response	:: Response,		-- 
     log_time	        :: ClockTime,		-- %{format}t
     log_delay		:: TimeDiff,		-- %T
     log_user	        :: String,		-- %u
     log_server	        :: HostEntry		-- %v
  }

logAccess :: Request -> Response -> HostAddress -> TimeDiff -> IO ()
logAccess req resp haddr delay
  = do
    time <- getClockTime

    -- ToDo: for servers serving multiple virtual domains, this
    -- servername should be dynamic.
    server <- readMVar local_hostent

    writeChan access_log_chan
      LogReq {
        log_ipaddr = haddr,
        log_logname = "<nobody>", -- ToDo
        log_request = req,
        log_response = resp,
        log_time = time,
        log_delay = delay,
        log_user = "<nouser>", -- ToDo
	log_server = server
      }
 where
    
access_log_chan :: Chan LogRequest
access_log_chan = unsafePerformIO (newChan)

access_log_pid :: MVar ThreadId
access_log_pid = unsafePerformIO (newEmptyMVar)

startAccessLogger :: Config -> IO ()
startAccessLogger conf = do
  logError ("access logger started on '" ++ accessLogFile conf ++ "'")
  t <- forkIO (Control.Exception.catch (run_access_logger conf) (error_handler conf))
  putMVar access_log_pid t

-- ToDo: shouldn't really kill the access logger with a signal, it might
-- be partway through servicing a log request.
stopAccessLogger :: IO ()
stopAccessLogger = do
   t <- takeMVar access_log_pid
   throwTo t (ErrorCall "**stop**")

error_handler conf (ErrorCall "**stop**") =
   logError ("access logger stopped")
error_handler conf exception = do
   logError ("access logger died: " ++ show exception)
   Control.Exception.catch (run_access_logger conf) (error_handler conf)

run_access_logger conf =
   Control.Exception.bracket 
      (openFile (accessLogFile conf) AppendMode) 
      (\hdl -> hClose hdl)
      (\hdl -> doLogRequests conf hdl)

doLogRequests conf hdl = do
  req <- readChan access_log_chan
  ip_addr <- inet_ntoa (log_ipaddr req)
  -- look up the hostname if hostnameLookups is on
  host <- if hostnameLookups conf
	     then do Control.Exception.catch
			  (do ent <- getHostByAddr AF_INET (log_ipaddr req)
			      return (Just ent)
			  )
			  (\e -> let _ = e :: IOError in return Nothing)
	     else return Nothing
  let line = mkLogLine req ip_addr host (accessLogFormat conf)
  hPutStrLn hdl line
  hFlush hdl
  doLogRequests conf hdl

-- ToDo: could probably make this a lot faster by pre-parsing the log
-- specification.

mkLogLine
	:: LogRequest			-- info to log
	-> String			-- IP addr if we need it
	-> Maybe HostEntry		-- hostname
	-> String			-- log format
	-> String

mkLogLine _info _ip_addr _host "" = ""
mkLogLine info ip_addr host ('%':'{':rest)
  = expand info ip_addr host (Just str) c ++ mkLogLine info ip_addr host rest1
  where (str, '}':c:rest1) = span (/= '}') rest
mkLogLine info ip_addr host ('%':c:rest)
  = expand info ip_addr host Nothing c ++ mkLogLine info ip_addr host rest
mkLogLine info ip_addr host (c:rest) = c : mkLogLine info ip_addr host rest


expand info ip_addr host arg c = 
          case c of
            'b'	-> show (contentLength  resp_body)
	    'f'	-> getFileName resp_body

	    -- %h is the hostname if hostnameLookups is on, otherwise the 
	    -- IP address.
	    'h' -> case host of
			Just ent -> hostName ent
			Nothing  -> ip_addr
	    'a' -> ip_addr
	    'l' -> log_logname info
	    'r' -> show (log_request info)
	    -- ToDo: 'p' -> canonical port number of server
	    's' -> show resp_code
	    't' -> formatTimeSensibly (toUTCTime (log_time info))
	    'T' -> timeDiffToString (log_delay info)
	    'v' -> hostName (log_server info)
	    'u' -> log_user info

	    'i' -> getReqHeader arg (reqHeaders (log_request info))
	    -- 'o' -> getRespHeader arg resp_headers

	    -- ToDo: other stuff
	    _ -> ['%',c]
  where
   Response {
    respCode = resp_code,
    respHeaders = resp_headers,
    respCoding = resp_coding,
    respBody = resp_body,
    respSendBody = resp_send_body
    } = log_response info

getReqHeader Nothing    _hdrs = ""
getReqHeader (Just hdr) hdrs = concat (
  case map toLower hdr of
    -- missing:
    -- Connection          [Connection]
    -- Date 		   String
    -- Pragma              String
    -- Trailer             String
    -- TransferEncoding    String
    -- Upgrade             String
    -- Via                 String
    -- Warning             String
    "accept"              -> [ s | Accept s <- hdrs ]
    "accept-charset"      -> [ s | AcceptCharset s <- hdrs ]
    "accept-encoding"     -> [ s | AcceptEncoding s <- hdrs ]
    "accept-language"     -> [ s | AcceptLanguage s <- hdrs ]
    "authorization"       -> [ s | Authorization s <- hdrs ]
    "cachecontrol"        -> [ s | CacheControl s <- hdrs ]
    -- Expect Expect
    "from"                -> [ s | From s <- hdrs ]
    -- Host String{-hostname-} (Maybe Int){-port-}
    "if-match"            -> [ s | IfMatch s <- hdrs ]
    "if-modified-since"   -> [ s | IfModifiedSince s <- hdrs ]
    "if-none-match"       -> [ s | IfNoneMatch s <- hdrs ]
    "if-range"            -> [ s | IfRange s <- hdrs ]
    "if-unmodified-since" -> [ s | IfUnmodifiedSince s <- hdrs ]
    "max-forwards"        -> [ s | MaxForwards s <- hdrs ]
    "proxy-authorization" -> [ s | ProxyAuthorization s <- hdrs ]
    "range"               -> [ s | Range s <- hdrs ]
    "referer"             -> [ s | Referer s <- hdrs ]
    "te"                  -> [ s | TE s <- hdrs ]
    "user-agent"          -> [ s | UserAgent s <- hdrs ]
    _                     -> []
   )

-----------------------------------------------------------------------------
-- older GHC compat

#if __GLASGOW_HASKELL__ < 409
catchJust = Control.Exception.catchIO
ioErrors = justIoErrors
#endif