-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- Copyright 2009, Henning Thielemann.
-- 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 Network.MoHWS.Logger.Access (
    Handle,
    Request(..),
    start,
    stop,
    mkRequest,
    log,
  ) where

import qualified Network.MoHWS.Logger as Logger
import qualified Network.MoHWS.HTTP.Header as Header
import qualified Network.MoHWS.HTTP.Response as Response
import qualified Network.MoHWS.Server.Request as ServerRequest
import Network.MoHWS.Utility (formatTimeSensibly, )

import Network.BSD (HostEntry, hostName, )
import qualified Network.Socket as Socket
import System.Time (ClockTime, toUTCTime, getClockTime, TimeDiff, timeDiffToString, )
import Control.Monad (liftM, liftM2, )

import Prelude hiding (log, )


type Handle = Logger.Handle Request

{-
FIXME:
Instead of using body type ()
we should have data structures for the Response and Request headers
without the body,
like ResponseData and RequestData that are internally used in Network.HTTP.
-}
data Request = Request
   {
      Request -> T ()
request     :: ServerRequest.T (),
      Request -> T ()
response    :: Response.T (),
      Request -> HostEntry
serverHost  :: HostEntry,
      Request -> ClockTime
time        :: ClockTime,
      Request -> TimeDiff
delay       :: TimeDiff
   }


start :: String -> FilePath -> IO Handle
start :: String -> String -> IO Handle
start String
format String
file = (Request -> IO String) -> String -> IO Handle
forall a. (a -> IO String) -> String -> IO (Handle a)
Logger.start (String -> Request -> IO String
forall (m :: * -> *). Help m => String -> Request -> m String
mkLine String
format) String
file

{-
Instead of the class we could just use IO monad,
but I like to make explicit,
what are the functions that force us to do IO.
-}
class Monad m => Help m where
   inet_ntoa :: Socket.HostAddress -> m String

instance Help IO where
   inet_ntoa :: HostAddress -> IO String
inet_ntoa = HostAddress -> IO String
Socket.inet_ntoa

infixr 5 +^+, ^:

(+^+) :: Monad m => m [a] -> m [a] -> m [a]
+^+ :: m [a] -> m [a] -> m [a]
(+^+) = ([a] -> [a] -> [a]) -> m [a] -> m [a] -> m [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)

(^:) :: Monad m => a -> m [a] -> m [a]
^: :: a -> m [a] -> m [a]
(^:) a
x = ([a] -> [a]) -> m [a] -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)

mkLine :: Help m => String -> Request -> m String
mkLine :: String -> Request -> m String
mkLine String
"" Request
_ = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
mkLine (Char
'%':Char
'{':String
rest) Request
r =
    case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}') String
rest of
      (String
str, Char
'}':Char
c:String
rest1) -> Maybe String -> Char -> Request -> m String
forall (m :: * -> *).
Help m =>
Maybe String -> Char -> Request -> m String
expand (String -> Maybe String
forall a. a -> Maybe a
Just String
str) Char
c Request
r m String -> m String -> m String
forall (m :: * -> *) a. Monad m => m [a] -> m [a] -> m [a]
+^+ String -> Request -> m String
forall (m :: * -> *). Help m => String -> Request -> m String
mkLine String
rest1 Request
r
      (String, String)
_                  -> Char
'%' Char -> m String -> m String
forall (m :: * -> *) a. Monad m => a -> m [a] -> m [a]
^: Char
'{' Char -> m String -> m String
forall (m :: * -> *) a. Monad m => a -> m [a] -> m [a]
^: String -> Request -> m String
forall (m :: * -> *). Help m => String -> Request -> m String
mkLine String
rest Request
r
mkLine (Char
'%':Char
c:String
rest) Request
r = Maybe String -> Char -> Request -> m String
forall (m :: * -> *).
Help m =>
Maybe String -> Char -> Request -> m String
expand Maybe String
forall a. Maybe a
Nothing Char
c Request
r m String -> m String -> m String
forall (m :: * -> *) a. Monad m => m [a] -> m [a] -> m [a]
+^+ String -> Request -> m String
forall (m :: * -> *). Help m => String -> Request -> m String
mkLine String
rest Request
r
mkLine (Char
c:String
rest) Request
r = Char
c Char -> m String -> m String
forall (m :: * -> *) a. Monad m => a -> m [a] -> m [a]
^: String -> Request -> m String
forall (m :: * -> *). Help m => String -> Request -> m String
mkLine String
rest Request
r

expand :: Help m => Maybe String -> Char -> Request -> m String
expand :: Maybe String -> Char -> Request -> m String
expand Maybe String
arg Char
c Request
info =
   let resp :: T ()
resp = Request -> T ()
response Request
info
       sreq :: T ()
sreq = Request -> T ()
request Request
info
       req :: T ()
req  = T () -> T ()
forall body. T body -> T body
ServerRequest.clientRequest T ()
sreq
       -- host = clientName (log_request info)
       header :: a -> Maybe String -> String
header a
_ Maybe String
Nothing  = String
""
       header a
x (Just String
n) = [String] -> String
unwords (Name -> a -> [String]
forall a. HasHeaders a => Name -> a -> [String]
Header.lookupMany (String -> Name
Header.makeName String
n) a
x)
       addr :: m String
addr = HostAddress -> m String
forall (m :: * -> *). Help m => HostAddress -> m String
inet_ntoa (T () -> HostAddress
forall body. T body -> HostAddress
ServerRequest.clientAddress T ()
sreq)
   in  case Char
c of
         Char
'b' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String -> (Integer -> String) -> Maybe Integer -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"unknown" Integer -> String
forall a. Show a => a -> String
show (Maybe Integer -> String) -> Maybe Integer -> String
forall a b. (a -> b) -> a -> b
$ Body () -> Maybe Integer
forall body. Body body -> Maybe Integer
Response.size (T () -> Body ()
forall body. T body -> Body body
Response.body T ()
resp)
         Char
'f' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ T () -> String
forall body. T body -> String
ServerRequest.serverFilename T ()
sreq

         -- %h is the hostname if hostnameLookups is on, otherwise the
         -- IP address.
         Char
'h' -> m String -> (HostEntry -> m String) -> Maybe HostEntry -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m String
addr (String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String)
-> (HostEntry -> String) -> HostEntry -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostEntry -> String
hostName) (T () -> Maybe HostEntry
forall body. T body -> Maybe HostEntry
ServerRequest.clientName T ()
sreq)
         Char
'a' -> m String
addr
         Char
'l' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"-" -- FIXME: does anyone use identd these days?
         Char
'r' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ T () -> String
forall a. Show a => a -> String
show T ()
req
         -- ToDo: 'p' -> canonical port number of server
         Char
's' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (T () -> Int
forall body. T body -> Int
Response.code T ()
resp)
         Char
't' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ CalendarTime -> String
formatTimeSensibly (ClockTime -> CalendarTime
toUTCTime (Request -> ClockTime
time Request
info))
         Char
'T' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ TimeDiff -> String
timeDiffToString (Request -> TimeDiff
delay Request
info)
         Char
'v' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ HostEntry -> String
hostName (Request -> HostEntry
serverHost Request
info)
         Char
'u' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"-" -- FIXME: implement HTTP auth

         Char
'i' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ T () -> Maybe String -> String
forall a. HasHeaders a => a -> Maybe String -> String
header T ()
req Maybe String
arg
         Char
'o' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ T () -> Maybe String -> String
forall a. HasHeaders a => a -> Maybe String -> String
header T ()
resp Maybe String
arg

         -- ToDo: other stuff
         Char
_ -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
'%',Char
c]

stop :: Handle -> IO ()
stop :: Handle -> IO ()
stop Handle
l = Handle -> IO ()
forall a. Handle a -> IO ()
Logger.stop Handle
l

mkRequest :: ServerRequest.T body -> Response.T body -> HostEntry -> TimeDiff -> IO Request
mkRequest :: T body -> T body -> HostEntry -> TimeDiff -> IO Request
mkRequest T body
req T body
resp HostEntry
host TimeDiff
delay0 =
    do ClockTime
time0 <- IO ClockTime
getClockTime
       Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$
          Request :: T () -> T () -> HostEntry -> ClockTime -> TimeDiff -> Request
Request {
             request :: T ()
request     = (body -> ()) -> T body -> T ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> body -> ()
forall a b. a -> b -> a
const ()) T body
req,
             response :: T ()
response    = (body -> ()) -> T body -> T ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> body -> ()
forall a b. a -> b -> a
const ()) T body
resp,
             serverHost :: HostEntry
serverHost  = HostEntry
host,
             time :: ClockTime
time        = ClockTime
time0,
             delay :: TimeDiff
delay       = TimeDiff
delay0
          }

log :: Handle -> Request -> IO ()
log :: Handle -> Request -> IO ()
log Handle
l Request
r = Handle -> Request -> IO ()
forall a. Handle a -> a -> IO ()
Logger.log Handle
l Request
r