{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Snap.Internal.Http.Server where

------------------------------------------------------------------------------
import           Control.Arrow (first, second)
import           Control.Monad.State.Strict
import           Control.Exception
import           Data.Char
import           Data.CIByteString
import           Data.Binary.Put
import           Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as SC
import qualified Data.ByteString.Lazy as L
import           Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Nums.Careless.Int as Cvt
import           Data.Int
import           Data.IORef
import           Data.List (foldl')
import qualified Data.Map as Map
import           Data.Maybe (fromJust, catMaybes, fromMaybe)
import           Data.Monoid
import           Data.Version
import           Data.Time
import           Foreign.C.Types
import           Foreign.ForeignPtr
import           GHC.Conc
import           Prelude hiding (catch, show, Show)
import qualified Prelude
import           System.PosixCompat.Files hiding (setFileSize)
import           System.Posix.Types (FileOffset)
import           System.Locale
import           Text.Show.ByteString hiding (runPut)
------------------------------------------------------------------------------
import           System.FastLogger
import           Snap.Internal.Http.Types
import           Snap.Internal.Debug
import           Snap.Internal.Http.Parser
import           Snap.Internal.Http.Server.Date

import           Snap.Internal.Http.Server.Backend
import           Snap.Internal.Http.Server.HttpPort
import qualified Snap.Internal.Http.Server.GnuTLS as TLS
import           Snap.Internal.Http.Server.SimpleBackend
import           Snap.Internal.Http.Server.LibevBackend

import           Snap.Internal.Iteratee.Debug
import           Snap.Iteratee hiding (head, take, map)
import qualified Snap.Iteratee as I

import qualified Paths_snap_server as V


------------------------------------------------------------------------------
-- | The handler has to return the request object because we have to clear the
-- HTTP request body before we send the response. If the handler consumes the
-- request body, it is responsible for setting @rqBody=return@ in the returned
-- request (otherwise we will mess up reading the input stream).
--
-- Note that we won't be bothering end users with this -- the details will be
-- hidden inside the Snap monad
type ServerHandler = (ByteString -> IO ())
                   -> Request
                   -> Iteratee ByteString IO (Request,Response)


------------------------------------------------------------------------------
type ServerMonad = StateT ServerState (Iteratee ByteString IO)


------------------------------------------------------------------------------
data ListenPort =
    -- (bind address, port)
    HttpPort  ByteString Int |
    -- (bind address, port, path to certificate, path to key)
    HttpsPort ByteString Int FilePath FilePath


------------------------------------------------------------------------------
data EventLoopType = EventLoopSimple
                   | EventLoopLibEv
  deriving (Prelude.Show)


------------------------------------------------------------------------------
defaultEvType :: EventLoopType
#ifdef LIBEV
defaultEvType = EventLoopLibEv
#else
defaultEvType = EventLoopSimple
#endif


------------------------------------------------------------------------------
data ServerState = ServerState
    { _forceConnectionClose  :: Bool
    , _localHostname         :: ByteString
    , _sessionPort           :: SessionInfo
    , _logAccess             :: Request -> Response -> IO ()
    , _logError              :: ByteString -> IO ()
    }


------------------------------------------------------------------------------
runServerMonad :: ByteString                     -- ^ local host name
               -> SessionInfo                    -- ^ session port information
               -> (Request -> Response -> IO ()) -- ^ access log function
               -> (ByteString -> IO ())          -- ^ error log function
               -> ServerMonad a                  -- ^ monadic action to run
               -> Iteratee ByteString IO a
runServerMonad lh s la le m = evalStateT m st
  where
    st = ServerState False lh s la le


------------------------------------------------------------------------------
-- input/output


------------------------------------------------------------------------------
httpServe :: [ListenPort]        -- ^ ports to listen on
          -> Maybe EventLoopType -- ^ Specify a given event loop,
                                 --   otherwise a default is picked
          -> ByteString          -- ^ local hostname (server name)
          -> Maybe FilePath      -- ^ path to the access log
          -> Maybe FilePath      -- ^ path to the error log
          -> ServerHandler       -- ^ handler procedure
          -> IO ()
httpServe ports mevType localHostname alogPath elogPath handler =
    withLoggers alogPath elogPath
                (\(alog, elog) -> spawnAll alog elog)

  where
    --------------------------------------------------------------------------
    spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do

        let evType = maybe defaultEvType id mevType

        logE elog $ S.concat [ "Server.httpServe: START ("
                             , toBS $ Prelude.show evType, ")"]

        let isHttps p = case p of { (HttpsPort _ _ _ _) -> True; _ -> False;}
        let initHttps = foldr (\p b -> b || isHttps p) False ports

        if initHttps
            then TLS.initTLS
            else return ()

        nports <- mapM bindPort ports

        (runEventLoop evType nports numCapabilities (logE elog) $
                      runHTTP alog elog handler localHostname) `finally` do

            logE elog "Server.httpServe: SHUTDOWN"

            if initHttps
                then TLS.stopTLS
                else return ()

            logE elog "Server.httpServe: BACKEND STOPPED"

    --------------------------------------------------------------------------
    bindPort (HttpPort  baddr port)          = bindHttp  baddr port
    bindPort (HttpsPort baddr port cert key) =
        TLS.bindHttps baddr port cert key


    --------------------------------------------------------------------------
    runEventLoop EventLoopSimple       = simpleEventLoop
    runEventLoop EventLoopLibEv        = libEvEventLoop


    --------------------------------------------------------------------------
    maybeSpawnLogger = maybe (return Nothing) $ (liftM Just) . newLogger


    --------------------------------------------------------------------------
    withLoggers afp efp =
        bracket (do alog <- maybeSpawnLogger afp
                    elog <- maybeSpawnLogger efp
                    return (alog, elog))
                (\(alog, elog) -> do
                    maybe (return ()) stopLogger alog
                    maybe (return ()) stopLogger elog)


------------------------------------------------------------------------------
debugE :: (MonadIO m) => ByteString -> m ()
debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s)


------------------------------------------------------------------------------
logE :: Maybe Logger -> ByteString -> IO ()
logE elog = maybe debugE (\l s -> debugE s >> logE' l s) elog


------------------------------------------------------------------------------
logE' :: Logger -> ByteString -> IO ()
logE' logger s = (timestampedLogEntry s) >>= logMsg logger


------------------------------------------------------------------------------
bshow :: (Prelude.Show a) => a -> ByteString
bshow = toBS . Prelude.show


------------------------------------------------------------------------------
logA ::Maybe Logger -> Request -> Response -> IO ()
logA alog = maybe (\_ _ -> return ()) logA' alog


------------------------------------------------------------------------------
logA' :: Logger -> Request -> Response -> IO ()
logA' logger req rsp = do
    let hdrs      = rqHeaders req
    let host      = rqRemoteAddr req
    let user      = Nothing -- TODO we don't do authentication yet
    let (v, v')   = rqVersion req
    let ver       = S.concat [ "HTTP/", bshow v, ".", bshow v' ]
    let method    = toBS $ Prelude.show (rqMethod req)
    let reql      = S.intercalate " " [ method, rqURI req, ver ]
    let status    = rspStatus rsp
    let cl        = rspContentLength rsp
    let referer   = maybe Nothing (Just . head) $ Map.lookup "referer" hdrs
    let userAgent = maybe "-" head $ Map.lookup "user-agent" hdrs

    msg <- combinedLogEntry host user reql status cl referer userAgent
    logMsg logger msg


------------------------------------------------------------------------------
runHTTP :: Maybe Logger                  -- ^ access logger
        -> Maybe Logger                  -- ^ error logger
        -> ServerHandler                 -- ^ handler procedure
        -> ByteString                    -- ^ local host name
        -> SessionInfo                   -- ^ session port information
        -> Enumerator ByteString IO ()   -- ^ read end of socket
        -> Iteratee ByteString IO ()     -- ^ write end of socket
        -> (FilePath -> Int64 -> Int64 -> IO ())
                                         -- ^ sendfile end
        -> IO ()                         -- ^ timeout tickler
        -> IO ()
runHTTP alog elog handler lh sinfo readEnd writeEnd onSendFile tickle =
    go `catches` [ Handler $ \(e :: AsyncException) -> do
                       throwIO e

                 , Handler $ \(e :: SomeException) ->
                       logE elog $ S.concat [ logPrefix , bshow e ] ]

  where
    logPrefix = S.concat [ "[", remoteAddress sinfo, "]: error: " ]

    go = do
        buf <- mkIterateeBuffer
        let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $
                                   httpSession writeEnd buf onSendFile tickle
                                   handler
        let iter = iterateeDebugWrapper "httpSession iteratee" iter1

        debug "runHTTP/go: prepping iteratee for start"

        step <- liftIO $ runIteratee iter

        debug "runHTTP/go: running..."
        run_ $ readEnd step
        debug "runHTTP/go: finished"


------------------------------------------------------------------------------
sERVER_HEADER :: [ByteString]
sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]]


------------------------------------------------------------------------------
snapServerVersion :: ByteString
snapServerVersion = SC.pack $ showVersion $ V.version


------------------------------------------------------------------------------
logAccess :: Request -> Response -> ServerMonad ()
logAccess req rsp = gets _logAccess >>= (\l -> liftIO $ l req rsp)


------------------------------------------------------------------------------
logError :: ByteString -> ServerMonad ()
logError s = gets _logError >>= (\l -> liftIO $ l s)


------------------------------------------------------------------------------
-- | Runs an HTTP session.
httpSession :: Iteratee ByteString IO ()     -- ^ write end of socket
            -> ForeignPtr CChar              -- ^ iteratee buffer
            -> (FilePath -> Int64 -> Int64 -> IO ())
                                             -- ^ sendfile continuation
            -> IO ()                         -- ^ timeout tickler
            -> ServerHandler                 -- ^ handler procedure
            -> ServerMonad ()
httpSession writeEnd' ibuf onSendFile tickle handler = do

    let writeEnd1 = I.unsafeBufferIterateeWithBuffer ibuf writeEnd'
    let writeEndI = iterateeDebugWrapper "writeEnd" writeEnd1

    -- everything downstream expects a Step here
    writeEnd <- liftIO $ runIteratee writeEndI

    liftIO $ debug "Server.httpSession: entered"
    mreq  <- receiveRequest
    liftIO $ debug "Server.httpSession: receiveRequest finished"

    -- successfully got a request, so restart timer
    liftIO tickle

    case mreq of
      (Just req) -> do
          liftIO $ debug $ "Server.httpSession: got request: " ++
                           Prelude.show (rqMethod req) ++
                           " " ++ SC.unpack (rqURI req) ++
                           " " ++ Prelude.show (rqVersion req)

          -- check for Expect: 100-continue
          checkExpect100Continue req writeEnd

          logerr <- gets _logError

          (req',rspOrig) <- lift $ handler logerr req

          liftIO $ debug $ "Server.httpSession: finished running user handler"

          let rspTmp = rspOrig { rspHttpVersion = rqVersion req }
          checkConnectionClose (rspHttpVersion rspTmp) (rspHeaders rspTmp)

          cc <- gets _forceConnectionClose
          let rsp = if cc
                      then (setHeader "Connection" "close" rspTmp)
                      else rspTmp

          liftIO $ debug "Server.httpSession: handled, skipping request body"

          if rspTransformingRqBody rsp
             then liftIO $ debug $
                      "Server.httpSession: not skipping " ++
                      "request body, transforming."
             else do
               srqEnum <- liftIO $ readIORef $ rqBody req'
               let (SomeEnumerator rqEnum) = srqEnum

               skipStep <- liftIO $ runIteratee $ iterateeDebugWrapper
                               "httpSession/skipToEof" skipToEof
               lift $ rqEnum skipStep

          liftIO $ debug $ "Server.httpSession: request body skipped, " ++
                           "sending response"

          date <- liftIO getDateString
          let ins = Map.insert "Date" [date] .
                    Map.insert "Server" sERVER_HEADER
          let rsp' = updateHeaders ins rsp
          (bytesSent,_) <- sendResponse req rsp' writeEnd onSendFile

          liftIO . debug $ "Server.httpSession: sent " ++
                           (Prelude.show bytesSent) ++ " bytes"

          maybe (logAccess req rsp')
                (\_ -> logAccess req $ setContentLength bytesSent rsp')
                (rspContentLength rsp')

          if cc
             then do
                 debug $ "httpSession: Connection: Close, harikari"
                 liftIO $ myThreadId >>= killThread
             else httpSession writeEnd' ibuf onSendFile tickle handler

      Nothing -> do
          liftIO $ debug $ "Server.httpSession: parser did not produce a " ++
                           "request, ending session"
          return ()


------------------------------------------------------------------------------
checkExpect100Continue :: Request
                       -> Step ByteString IO ()
                       -> ServerMonad ()
checkExpect100Continue req writeEnd = do
    let mbEx = getHeaders "Expect" req

    maybe (return ())
          (\l -> if elem "100-continue" l then go else return ())
          mbEx

  where
    go = do
        let (major,minor) = rqVersion req
        let hl = runPut $ do
                     putByteString "HTTP/"
                     showp major
                     putAscii '.'
                     showp minor
                     putByteString " 100 Continue\r\n\r\n"
        liftIO $ runIteratee $ (enumLBS hl >==> enumEOF) writeEnd
        return ()


------------------------------------------------------------------------------
receiveRequest :: ServerMonad (Maybe Request)
receiveRequest = do
    debug "receiveRequest: entered"
    mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $
            iterateeDebugWrapper "parseRequest" parseRequest
    debug "receiveRequest: parseRequest returned"

    case mreq of
      (Just ireq) -> do
          req' <- toRequest ireq
          setEnumerator req'
          req  <- parseForm req'
          checkConnectionClose (rqVersion req) (rqHeaders req)
          return $ Just req

      Nothing     -> return Nothing


  where
    --------------------------------------------------------------------------
    -- check: did the client specify "transfer-encoding: chunked"? then we
    -- have to honor that.
    --
    -- otherwise: check content-length header. if set: only take N bytes from
    -- the read end of the socket
    --
    -- if no content-length and no chunked encoding, enumerate the entire
    -- socket and close afterwards
    setEnumerator :: Request -> ServerMonad ()
    setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} do
        if isChunked
          then do
              liftIO $ debug $ "receiveRequest/setEnumerator: " ++
                               "input in chunked encoding"
              let e = joinI . readChunkedTransferEncoding
              liftIO $ writeIORef (rqBody req)
                                  (SomeEnumerator e)
          else maybe (noContentLength req) hasContentLength mbCL

      where
        isChunked = maybe False
                          ((== ["chunked"]) . map toCI)
                          (Map.lookup "transfer-encoding" hdrs)

        hasContentLength :: Int64 -> ServerMonad ()
        hasContentLength len = do
            liftIO $ debug $ "receiveRequest/setEnumerator: " ++
                             "request had content-length " ++ Prelude.show len
            liftIO $ writeIORef (rqBody req) (SomeEnumerator e)
            liftIO $ debug "receiveRequest/setEnumerator: body enumerator set"
          where
            e :: Enumerator ByteString IO a
            e st = do
                st' <- lift $
                       runIteratee $
                       iterateeDebugWrapper "rqBody iterator" $
                       returnI st

                joinI $ takeExactly len st'

        noContentLength :: Request -> ServerMonad ()
        noContentLength rq = liftIO $ do
            debug ("receiveRequest/setEnumerator: " ++
                   "request did NOT have content-length")
            let enum = SomeEnumerator $
                       if rqMethod rq == POST || rqMethod rq == PUT
                         then returnI
                         else iterateeDebugWrapper "noContentLength" .
                              joinI . I.take 0
            writeIORef (rqBody rq) enum
            debug "receiveRequest/setEnumerator: body enumerator set"


        hdrs = rqHeaders req
        mbCL = Map.lookup "content-length" hdrs >>= return . Cvt.int . head


    --------------------------------------------------------------------------
    parseForm :: Request -> ServerMonad Request
    parseForm req = {-# SCC "receiveRequest/parseForm" #-}
        if doIt then getIt else return req
      where
        mbCT   = liftM head $ Map.lookup "content-type" (rqHeaders req)
        trimIt = fst . SC.spanEnd isSpace . SC.takeWhile (/= ';')
                     . SC.dropWhile isSpace
        mbCT'  = liftM trimIt mbCT
        doIt   = mbCT' == Just "application/x-www-form-urlencoded"

        maximumPOSTBodySize :: Int64
        maximumPOSTBodySize = 10*1024*1024

        getIt :: ServerMonad Request
        getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do
            liftIO $ debug "parseForm: got application/x-www-form-urlencoded"
            liftIO $ debug "parseForm: reading POST body"
            senum <- liftIO $ readIORef $ rqBody req
            let (SomeEnumerator enum) = senum
            consumeStep <- liftIO $ runIteratee consume
            step <- liftIO $
                    runIteratee $
                    joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep
            body <- liftM S.concat $ lift $ enum step
            let newParams = parseUrlEncoded body

            liftIO $ debug "parseForm: stuffing 'enumBS body' into request"

            let e = enumBS body >==> I.joinI . I.take 0

            let e' = \st -> do
                let ii = iterateeDebugWrapper "regurgitate body" (returnI st)
                st' <- lift $ runIteratee ii
                e st'

            liftIO $ writeIORef (rqBody req) $ SomeEnumerator e'
            return $ req { rqParams = rqParams req `mappend` newParams }


    --------------------------------------------------------------------------
    toRequest (IRequest method uri version kvps) =
        {-# SCC "receiveRequest/toRequest" #-} do
            localAddr     <- gets $ localAddress . _sessionPort
            lport         <- gets $ localPort . _sessionPort
            remoteAddr    <- gets $ remoteAddress . _sessionPort
            rport         <- gets $ remotePort . _sessionPort
            localHostname <- gets $ _localHostname
            secure        <- gets $ isSecure . _sessionPort

            let (serverName, serverPort) = fromMaybe
                                             (localHostname, lport)
                                             (liftM (parseHost . head)
                                                    (Map.lookup "host" hdrs))

            -- will override in "setEnumerator"
            enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")


            return $ Request serverName
                             serverPort
                             remoteAddr
                             rport
                             localAddr
                             lport
                             localHostname
                             secure
                             hdrs
                             enum
                             mbContentLength
                             method
                             version
                             cookies
                             snapletPath
                             pathInfo
                             contextPath
                             uri
                             queryString
                             params

      where
        snapletPath = ""        -- TODO: snaplets in v0.2

        dropLeadingSlash s = maybe s f mbS
          where
            f (a,s') = if a == c2w '/' then s' else s
            mbS = S.uncons s

        hdrs            = toHeaders kvps

        mbContentLength = liftM (Cvt.int . head) $
                          Map.lookup "content-length" hdrs

        cookies         = concat $
                          maybe []
                                (catMaybes . map parseCookie)
                                (Map.lookup "cookie" hdrs)

        contextPath     = "/"

        parseHost h = (a, Cvt.int (S.drop 1 b))
          where
            (a,b) = S.break (== (c2w ':')) h

        params          = parseUrlEncoded queryString

        (pathInfo, queryString) = first dropLeadingSlash . second (S.drop 1) $
                                  S.break (== (c2w '?')) uri


------------------------------------------------------------------------------
-- Response must be well-formed here
sendResponse :: forall a . Request
             -> Response
             -> Step ByteString IO a                 -- ^ iteratee write end
             -> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on
                                                     -- sendfile
             -> ServerMonad (Int64, a)
sendResponse req rsp' writeEnd onSendFile = do
    let rsp'' = renderCookies rsp'
    rsp <- fixupResponse rsp''
    let !headerString = mkHeaderString rsp

    (!x,!bs) <- case (rspBody rsp) of
                  (Enum e)             -> lift $ whenEnum headerString rsp e
                  (SendFile f Nothing) -> lift $
                                          whenSendFile headerString rsp f 0
                  (SendFile f (Just (st,_))) ->
                      lift $ whenSendFile headerString rsp f st

    debug "sendResponse: response sent"

    return $! (bs,x)

  where
    --------------------------------------------------------------------------
    whenEnum :: ByteString
             -> Response
             -> (forall x . Enumerator ByteString IO x)
             -> Iteratee ByteString IO (a,Int64)
    whenEnum hs rsp e = do
        -- "enum" here has to be run in the context of the READ iteratee, even
        -- though it's writing to the output, because we may be transforming
        -- the input. That's why we check if we're transforming the request
        -- body here, and if not, send EOF to the write end; so that it
        -- doesn't join up with the read iteratee and try to get more data
        -- from the socket.
        let enum = if rspTransformingRqBody rsp
                     then enumBS hs >==> e
                     else enumBS hs >==> e >==> (joinI . I.take 0)

        let hl = fromIntegral $ S.length hs

        debug $ "sendResponse: whenEnum: enumerating bytes"

        outstep <- lift $ runIteratee $
                   iterateeDebugWrapper "countBytes writeEnd" $
                   countBytes $ returnI writeEnd
        (x,bs) <- enum outstep
        debug $ "sendResponse: whenEnum: " ++ Prelude.show bs ++
                " bytes enumerated"

        return (x, bs-hl)


    --------------------------------------------------------------------------
    whenSendFile :: ByteString    -- ^ headers
                 -> Response
                 -> FilePath      -- ^ file to send
                 -> Int64         -- ^ start byte offset
                 -> Iteratee ByteString IO (a,Int64)
    whenSendFile hs r f start = do
        -- Guaranteed to have a content length here. Sending EOF through to
        -- the write end guarantees that we flush the buffer before we send
        -- the file with sendfile().
        lift $ runIteratee $ (enumBS hs >==> enumEOF) writeEnd

        let !cl = fromJust $ rspContentLength r
        x <- liftIO $ onSendFile f start cl
        return (x, cl)


    --------------------------------------------------------------------------
    (major,minor) = rspHttpVersion rsp'


    --------------------------------------------------------------------------
    putHdrs hdrs =
        {-# SCC "putHdrs" #-}
        Prelude.mapM_ putHeader $ Map.toList hdrs
      where
        putHeader (k, ys) = Prelude.mapM_ (putOne k) ys

        putOne k y = do
            putByteString $ unCI k
            putByteString ": "
            putByteString y
            putByteString "\r\n"


    --------------------------------------------------------------------------
    noCL :: Response -> ServerMonad Response
    noCL r =
        {-# SCC "noCL" #-}
        do
            -- are we in HTTP/1.1?
            let sendChunked = (rspHttpVersion r) == (1,1)
            if sendChunked
              then do
                  let r' = setHeader "Transfer-Encoding" "chunked" r
                  let origE = rspBodyToEnum $ rspBody r

                  let e i = do
                      step <- lift $ runIteratee $ joinI $
                              writeChunkedTransferEncoding i
                      origE step

                  return $ r' { rspBody = Enum e }

              else do
                  -- HTTP/1.0 and no content-length? We'll have to close the
                  -- socket.
                  modify $! \s -> s { _forceConnectionClose = True }
                  return $ setHeader "Connection" "close" r


    --------------------------------------------------------------------------
    hasCL :: Int64 -> Response -> ServerMonad Response
    hasCL cl r =
        {-# SCC "hasCL" #-}
        do
            -- set the content-length header
            let r' = setHeader "Content-Length" (l2s $ show cl) r
            let b = case (rspBody r') of
                      (Enum e)       -> Enum (i e)
                      (SendFile f m) -> SendFile f m

            return $ r' { rspBody = b }

      where
        i :: forall z . Enumerator ByteString IO z
          -> Enumerator ByteString IO z
        i enum step = do
            step' <- lift $ runIteratee $ joinI $ takeExactly cl step
            enum step'


    --------------------------------------------------------------------------
    setFileSize :: FilePath -> Response -> ServerMonad Response
    setFileSize fp r =
        {-# SCC "setFileSize" #-}
        do
            fs <- liftM fromIntegral $ liftIO $ getFileSize fp
            return $ r { rspContentLength = Just fs }


    --------------------------------------------------------------------------
    handle304 :: Response -> Response
    handle304 r = setResponseBody (enumBS "") $
                  updateHeaders (Map.delete "Transfer-Encoding") $
                  setContentLength 0 r


    --------------------------------------------------------------------------
    renderCookies :: Response -> Response
    renderCookies r = updateHeaders f r
      where
        f h = Map.insert "Set-Cookie" cookies h
        cookies = fmap cookieToBS . Map.elems $ rspCookies r

    --------------------------------------------------------------------------
    fixupResponse :: Response -> ServerMonad Response
    fixupResponse r = {-# SCC "fixupResponse" #-} do
        let r' = deleteHeader "Content-Length" r

        let code = rspStatus r'

        let r'' = if code == 204 || code == 304
                   then handle304 r'
                   else r'

        r''' <- do
            z <- case (rspBody r'') of
                   (Enum _)                  -> return r''
                   (SendFile f Nothing)      -> setFileSize f r''
                   (SendFile _ (Just (s,e))) -> return $
                                                setContentLength (e-s) r''

            case (rspContentLength z) of
              Nothing   -> noCL z
              (Just sz) -> hasCL sz z

        -- HEAD requests cannot have bodies per RFC 2616 sec. 9.4
        if rqMethod req == HEAD
          then return $ deleteHeader "Transfer-Encoding"
                      $ r''' { rspBody = Enum $ enumBS "" }
          else return r'''


    --------------------------------------------------------------------------
    mkHeaderString :: Response -> ByteString
    mkHeaderString r = out
      where
        !out = {-# SCC "mkHeaderString" #-}
               S.concat $ L.toChunks $ runPut $ do
                   putByteString "HTTP/"
                   showp major
                   putAscii '.'
                   showp minor
                   putAscii ' '
                   showp $ rspStatus r
                   putAscii ' '
                   putByteString $ rspStatusReason r
                   putByteString "\r\n"
                   putHdrs $ headers r
                   putByteString "\r\n"


------------------------------------------------------------------------------
checkConnectionClose :: (Int, Int) -> Headers -> ServerMonad ()
checkConnectionClose ver hdrs =
    -- For HTTP/1.1:
    --   if there is an explicit Connection: close, close the socket.
    -- For HTTP/1.0:
    --   if there is no explicit Connection: Keep-Alive, close the socket.
    if (ver == (1,1) && l == Just ["close"]) ||
       (ver == (1,0) && l /= Just ["keep-alive"])
       then modify $ \s -> s { _forceConnectionClose = True }
       else return ()
  where
    l  = liftM (map tl) $ Map.lookup "Connection" hdrs
    tl = S.map (c2w . toLower . w2c)


------------------------------------------------------------------------------
-- FIXME: whitespace-trim the values here.
toHeaders :: [(ByteString,ByteString)] -> Headers
toHeaders kvps = foldl' f Map.empty kvps'
  where
    kvps'     = map (first toCI . second (:[])) kvps
    f m (k,v) = Map.insertWith' (flip (++)) k v m


------------------------------------------------------------------------------
-- | Convert 'Cookie' into 'ByteString' for output.
cookieToBS :: Cookie -> ByteString
cookieToBS (Cookie k v mbExpTime mbDomain mbPath) = cookie
  where
    cookie  = S.concat [k, "=", v, path, exptime, domain]
    path    = maybe "" (S.append "; path=") mbPath
    domain  = maybe "" (S.append "; domain=") mbDomain
    exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime
    fmt     = fromStr . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT"


------------------------------------------------------------------------------
getFileSize :: FilePath -> IO FileOffset
getFileSize fp = liftM fileSize $ getFileStatus fp


------------------------------------------------------------------------------
l2s :: L.ByteString -> S.ByteString
l2s = S.concat . L.toChunks


------------------------------------------------------------------------------
toBS :: String -> ByteString
toBS = S.pack . map c2w