1 {-# LANGUAGE BangPatterns        #-}
    2 {-# LANGUAGE CPP                 #-}
    3 {-# LANGUAGE DeriveDataTypeable  #-}
    4 {-# LANGUAGE OverloadedStrings   #-}
    5 {-# LANGUAGE RankNTypes          #-}
    6 {-# LANGUAGE ScopedTypeVariables #-}
    7 
    8 module Snap.Internal.Http.Server where
    9 
   10 ------------------------------------------------------------------------------
   11 import           Blaze.ByteString.Builder
   12 import           Blaze.ByteString.Builder.Char8
   13 import           Blaze.ByteString.Builder.Enumerator
   14 import           Blaze.ByteString.Builder.HTTP
   15 import           Control.Arrow (first, second)
   16 import           Control.Monad.State.Strict
   17 import           Control.Exception
   18 import           Data.Char
   19 import           Data.CaseInsensitive   (CI)
   20 import qualified Data.CaseInsensitive as CI
   21 import           Data.ByteString (ByteString)
   22 import qualified Data.ByteString as S
   23 import qualified Data.ByteString.Char8 as SC
   24 import qualified Data.ByteString.Lazy as L
   25 import           Data.ByteString.Internal (c2w, w2c)
   26 import qualified Data.ByteString.Nums.Careless.Int as Cvt
   27 import           Data.Int
   28 import           Data.IORef
   29 import           Data.List (foldl')
   30 import           Data.Map (Map)
   31 import qualified Data.Map as Map
   32 import           Data.Maybe (catMaybes, fromJust, fromMaybe)
   33 import           Data.Monoid
   34 import           Data.Time
   35 import           Data.Typeable
   36 import           Data.Version
   37 import           GHC.Conc
   38 import           System.PosixCompat.Files hiding (setFileSize)
   39 import           System.Posix.Types (FileOffset)
   40 import           System.Locale
   41 ------------------------------------------------------------------------------
   42 import           System.FastLogger
   43 import           Snap.Internal.Http.Types
   44 import           Snap.Internal.Debug
   45 import           Snap.Internal.Http.Parser
   46 import           Snap.Internal.Http.Server.Date
   47 
   48 import           Snap.Internal.Http.Server.Backend
   49 import           Snap.Internal.Http.Server.HttpPort
   50 import qualified Snap.Internal.Http.Server.GnuTLS as TLS
   51 import           Snap.Internal.Http.Server.SimpleBackend
   52 import           Snap.Internal.Http.Server.LibevBackend
   53 
   54 import           Snap.Internal.Iteratee.Debug
   55 import           Snap.Iteratee hiding (head, take, map)
   56 import qualified Snap.Iteratee as I
   57 
   58 import qualified Paths_snap_server as V
   59 
   60 
   61 ------------------------------------------------------------------------------
   62 -- | The handler has to return the request object because we have to clear the
   63 -- HTTP request body before we send the response. If the handler consumes the
   64 -- request body, it is responsible for setting @rqBody=return@ in the returned
   65 -- request (otherwise we will mess up reading the input stream).
   66 --
   67 -- Note that we won't be bothering end users with this -- the details will be
   68 -- hidden inside the Snap monad
   69 type ServerHandler = (ByteString -> IO ())
   70                   -> (Int -> IO ())
   71                   -> Request
   72                   -> Iteratee ByteString IO (Request,Response)
   73 
   74 
   75 ------------------------------------------------------------------------------
   76 type ServerMonad = StateT ServerState (Iteratee ByteString IO)
   77 
   78 
   79 ------------------------------------------------------------------------------
   80 data ListenPort =
   81     -- (bind address, port)
   82     HttpPort  ByteString Int |
   83     -- (bind address, port, path to certificate, path to key)
   84     HttpsPort ByteString Int FilePath FilePath
   85 
   86 ------------------------------------------------------------------------------
   87 instance Show ListenPort where
   88     show (HttpPort b p) =
   89         concat [ "http://", SC.unpack b, ":", show p, "/" ]
   90     show (HttpsPort b p _ _) =
   91         concat [ "https://", SC.unpack b, ":", show p, "/" ]
   92 
   93 
   94 ------------------------------------------------------------------------------
   95 data EventLoopType = EventLoopSimple
   96                    | EventLoopLibEv
   97   deriving (Show)
   98 
   99 
  100 ------------------------------------------------------------------------------
  101 -- This exception will be thrown if we decided to terminate the request before
  102 -- running the user handler.
  103 data TerminatedBeforeHandlerException = TerminatedBeforeHandlerException
  104   deriving (Show, Typeable)
  105 instance Exception TerminatedBeforeHandlerException
  106 
  107 
  108 ------------------------------------------------------------------------------
  109 defaultEvType :: EventLoopType
  110 #ifdef LIBEV
  111 defaultEvType = EventLoopLibEv
  112 #else
  113 defaultEvType = EventLoopSimple
  114 #endif
  115 
  116 
  117 ------------------------------------------------------------------------------
  118 data ServerState = ServerState
  119     { _forceConnectionClose  :: Bool
  120     , _localHostname         :: ByteString
  121     , _sessionPort           :: SessionInfo
  122     , _logAccess             :: Request -> Response -> IO ()
  123     , _logError              :: ByteString -> IO ()
  124     }
  125 
  126 
  127 ------------------------------------------------------------------------------
  128 runServerMonad :: ByteString                     -- ^ local host name
  129                -> SessionInfo                    -- ^ session port information
  130                -> (Request -> Response -> IO ()) -- ^ access log function
  131                -> (ByteString -> IO ())          -- ^ error log function
  132                -> ServerMonad a                  -- ^ monadic action to run
  133                -> Iteratee ByteString IO a
  134 runServerMonad lh s la le m = evalStateT m st
  135   where
  136     st = ServerState False lh s la le
  137 
  138 
  139 ------------------------------------------------------------------------------
  140 -- input/output
  141 
  142 
  143 ------------------------------------------------------------------------------
  144 httpServe :: Int                 -- ^ default timeout
  145           -> [ListenPort]        -- ^ ports to listen on
  146           -> Maybe EventLoopType -- ^ Specify a given event loop,
  147                                  --   otherwise a default is picked
  148           -> ByteString          -- ^ local hostname (server name)
  149           -> Maybe FilePath      -- ^ path to the access log
  150           -> Maybe FilePath      -- ^ path to the error log
  151           -> ServerHandler       -- ^ handler procedure
  152           -> IO ()
  153 httpServe defaultTimeout ports mevType localHostname alogPath elogPath
  154           handler =
  155     withLoggers alogPath elogPath
  156                 (\(alog, elog) -> spawnAll alog elog)
  157 
  158   where
  159     --------------------------------------------------------------------------
  160     spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do
  161 
  162         let evType = maybe defaultEvType id mevType
  163 
  164         logE elog $ S.concat [ "Server.httpServe: START ("
  165                              , toBS $ show evType, ")"]
  166 
  167         let isHttps p = case p of { (HttpsPort _ _ _ _) -> True; _ -> False;}
  168         let initHttps = foldr (\p b -> b || isHttps p) False ports
  169 
  170         if initHttps
  171             then TLS.initTLS
  172             else return ()
  173 
  174         nports <- mapM bindPort ports
  175 
  176         (runEventLoop evType defaultTimeout nports numCapabilities (logE elog)
  177                     $ runHTTP defaultTimeout alog elog handler localHostname)
  178           `finally` do
  179             logE elog "Server.httpServe: SHUTDOWN"
  180 
  181             if initHttps
  182                 then TLS.stopTLS
  183                 else return ()
  184 
  185             logE elog "Server.httpServe: BACKEND STOPPED"
  186 
  187     --------------------------------------------------------------------------
  188     bindPort (HttpPort  baddr port)          = bindHttp  baddr port
  189     bindPort (HttpsPort baddr port cert key) =
  190         TLS.bindHttps baddr port cert key
  191 
  192 
  193     --------------------------------------------------------------------------
  194     runEventLoop EventLoopSimple       = simpleEventLoop
  195     runEventLoop EventLoopLibEv        = libEvEventLoop
  196 
  197 
  198     --------------------------------------------------------------------------
  199     maybeSpawnLogger = maybe (return Nothing) $ (liftM Just) . newLogger
  200 
  201 
  202     --------------------------------------------------------------------------
  203     withLoggers afp efp =
  204         bracket (do alog <- maybeSpawnLogger afp
  205                     elog <- maybeSpawnLogger efp
  206                     return (alog, elog))
  207                 (\(alog, elog) -> do
  208                     maybe (return ()) stopLogger alog
  209                     maybe (return ()) stopLogger elog)
  210 
  211 
  212 ------------------------------------------------------------------------------
  213 debugE :: (MonadIO m) => ByteString -> m ()
  214 debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s)
  215 
  216 
  217 ------------------------------------------------------------------------------
  218 logE :: Maybe Logger -> ByteString -> IO ()
  219 logE elog = maybe debugE (\l s -> debugE s >> logE' l s) elog
  220 
  221 
  222 ------------------------------------------------------------------------------
  223 logE' :: Logger -> ByteString -> IO ()
  224 logE' logger s = (timestampedLogEntry s) >>= logMsg logger
  225 
  226 
  227 ------------------------------------------------------------------------------
  228 bshow :: (Show a) => a -> ByteString
  229 bshow = toBS . show
  230 
  231 
  232 ------------------------------------------------------------------------------
  233 logA ::Maybe Logger -> Request -> Response -> IO ()
  234 logA alog = maybe (\_ _ -> return ()) logA' alog
  235 
  236 
  237 ------------------------------------------------------------------------------
  238 logA' :: Logger -> Request -> Response -> IO ()
  239 logA' logger req rsp = do
  240     let hdrs      = rqHeaders req
  241     let host      = rqRemoteAddr req
  242     let user      = Nothing -- TODO we don't do authentication yet
  243     let (v, v')   = rqVersion req
  244     let ver       = S.concat [ "HTTP/", bshow v, ".", bshow v' ]
  245     let method    = toBS $ show (rqMethod req)
  246     let reql      = S.intercalate " " [ method, rqURI req, ver ]
  247     let status    = rspStatus rsp
  248     let cl        = rspContentLength rsp
  249     let referer   = maybe Nothing (Just . head) $ Map.lookup "referer" hdrs
  250     let userAgent = maybe "-" head $ Map.lookup "user-agent" hdrs
  251 
  252     msg <- combinedLogEntry host user reql status cl referer userAgent
  253     logMsg logger msg
  254 
  255 
  256 ------------------------------------------------------------------------------
  257 runHTTP :: Int                           -- ^ default timeout
  258         -> Maybe Logger                  -- ^ access logger
  259         -> Maybe Logger                  -- ^ error logger
  260         -> ServerHandler                 -- ^ handler procedure
  261         -> ByteString                    -- ^ local host name
  262         -> SessionInfo                   -- ^ session port information
  263         -> Enumerator ByteString IO ()   -- ^ read end of socket
  264         -> Iteratee ByteString IO ()     -- ^ write end of socket
  265         -> (FilePath -> Int64 -> Int64 -> IO ())
  266                                          -- ^ sendfile end
  267         -> (Int -> IO ())                -- ^ timeout tickler
  268         -> IO ()
  269 runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile
  270         tickle =
  271     go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do
  272                        return ()
  273                  , Handler $ \(e :: HttpParseException) -> do
  274                        return ()
  275                  , Handler $ \(e :: AsyncException) -> do
  276                        throwIO e
  277                  , Handler $ \(e :: SomeException) ->
  278                        logE elog $ S.concat [ logPrefix , bshow e ] ]
  279 
  280   where
  281     logPrefix = S.concat [ "[", remoteAddress sinfo, "]: error: " ]
  282 
  283     go = do
  284         buf <- allocBuffer 16384
  285         let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $
  286                                    httpSession defaultTimeout writeEnd buf
  287                                                onSendFile tickle handler
  288         let iter = iterateeDebugWrapper "httpSession iteratee" iter1
  289 
  290         debug "runHTTP/go: prepping iteratee for start"
  291 
  292         step <- liftIO $ runIteratee iter
  293 
  294         debug "runHTTP/go: running..."
  295         run_ $ readEnd step
  296         debug "runHTTP/go: finished"
  297 
  298 
  299 ------------------------------------------------------------------------------
  300 sERVER_HEADER :: [ByteString]
  301 sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]]
  302 
  303 
  304 ------------------------------------------------------------------------------
  305 snapServerVersion :: ByteString
  306 snapServerVersion = SC.pack $ showVersion $ V.version
  307 
  308 
  309 ------------------------------------------------------------------------------
  310 logAccess :: Request -> Response -> ServerMonad ()
  311 logAccess req rsp = gets _logAccess >>= (\l -> liftIO $ l req rsp)
  312 
  313 
  314 ------------------------------------------------------------------------------
  315 logError :: ByteString -> ServerMonad ()
  316 logError s = gets _logError >>= (\l -> liftIO $ l s)
  317 
  318 
  319 ------------------------------------------------------------------------------
  320 -- | Runs an HTTP session.
  321 httpSession :: Int
  322             -> Iteratee ByteString IO ()     -- ^ write end of socket
  323             -> Buffer                        -- ^ builder buffer
  324             -> (FilePath -> Int64 -> Int64 -> IO ())
  325                                              -- ^ sendfile continuation
  326             -> (Int -> IO ())                -- ^ timeout tickler
  327             -> ServerHandler                 -- ^ handler procedure
  328             -> ServerMonad ()
  329 httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do
  330 
  331     let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd'
  332 
  333     liftIO $ debug "Server.httpSession: entered"
  334     mreq  <- receiveRequest writeEnd
  335     liftIO $ debug "Server.httpSession: receiveRequest finished"
  336 
  337     -- successfully got a request, so restart timer
  338     liftIO $ tickle defaultTimeout
  339 
  340     case mreq of
  341       (Just req) -> do
  342           liftIO $ debug $ "Server.httpSession: got request: " ++
  343                            show (rqMethod req) ++
  344                            " " ++ SC.unpack (rqURI req) ++
  345                            " " ++ show (rqVersion req)
  346 
  347           -- check for Expect: 100-continue
  348           checkExpect100Continue req writeEnd
  349 
  350           logerr <- gets _logError
  351 
  352           (req',rspOrig) <- lift $ handler logerr tickle req
  353 
  354           liftIO $ debug $ "Server.httpSession: finished running user handler"
  355 
  356           let rspTmp = rspOrig { rspHttpVersion = rqVersion req }
  357           checkConnectionClose (rspHttpVersion rspTmp) (rspHeaders rspTmp)
  358 
  359           cc <- gets _forceConnectionClose
  360           let rsp = if cc
  361                       then (setHeader "Connection" "close" rspTmp)
  362                       else rspTmp
  363 
  364           liftIO $ debug "Server.httpSession: handled, skipping request body"
  365 
  366           if rspTransformingRqBody rsp
  367              then liftIO $ debug $
  368                       "Server.httpSession: not skipping " ++
  369                       "request body, transforming."
  370              else do
  371                srqEnum <- liftIO $ readIORef $ rqBody req'
  372                let (SomeEnumerator rqEnum) = srqEnum
  373 
  374                skipStep <- liftIO $ runIteratee $ iterateeDebugWrapper
  375                                "httpSession/skipToEof" skipToEof
  376                lift $ rqEnum skipStep
  377 
  378           liftIO $ debug $ "Server.httpSession: request body skipped, " ++
  379                            "sending response"
  380 
  381           date <- liftIO getDateString
  382           let ins = Map.insert "Date" [date] .
  383                     Map.insert "Server" sERVER_HEADER
  384           let rsp' = updateHeaders ins rsp
  385           (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile
  386 
  387           liftIO . debug $ "Server.httpSession: sent " ++
  388                            (show bytesSent) ++ " bytes"
  389 
  390           maybe (logAccess req rsp')
  391                 (\_ -> logAccess req $ setContentLength bytesSent rsp')
  392                 (rspContentLength rsp')
  393 
  394           if cc
  395              then do
  396                  debug $ "httpSession: Connection: Close, harikari"
  397                  liftIO $ myThreadId >>= killThread
  398              else httpSession defaultTimeout writeEnd' buffer onSendFile
  399                               tickle handler
  400 
  401       Nothing -> do
  402           liftIO $ debug $ "Server.httpSession: parser did not produce a " ++
  403                            "request, ending session"
  404           return ()
  405 
  406 
  407 ------------------------------------------------------------------------------
  408 checkExpect100Continue :: Request
  409                        -> Iteratee ByteString IO ()
  410                        -> ServerMonad ()
  411 checkExpect100Continue req writeEnd = do
  412     let mbEx = getHeaders "Expect" req
  413 
  414     maybe (return ())
  415           (\l -> if elem "100-continue" l then go else return ())
  416           mbEx
  417 
  418   where
  419     go = do
  420         let (major,minor) = rqVersion req
  421         let hl = mconcat [ fromByteString "HTTP/"
  422                          , fromShow major
  423                          , fromWord8 $ c2w '.'
  424                          , fromShow minor
  425                          , fromByteString " 100 Continue\r\n\r\n" ]
  426         liftIO $ runIteratee
  427                    ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd)
  428         return ()
  429 
  430 
  431 ------------------------------------------------------------------------------
  432 return411 :: Request
  433           -> Iteratee ByteString IO ()
  434           -> ServerMonad a
  435 return411 req writeEnd = do
  436     go
  437     liftIO $ throwIO $ TerminatedBeforeHandlerException
  438 
  439   where
  440     go = do
  441         let (major,minor) = rqVersion req
  442         let hl = mconcat [ fromByteString "HTTP/"
  443                          , fromShow major
  444                          , fromWord8 $ c2w '.'
  445                          , fromShow minor
  446                          , fromByteString " 411 Length Required\r\n\r\n"
  447                          , fromByteString "411 Length Required\r\n" ]
  448         liftIO $ runIteratee
  449                    ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd)
  450         return ()
  451 
  452 
  453 ------------------------------------------------------------------------------
  454 receiveRequest :: Iteratee ByteString IO () -> ServerMonad (Maybe Request)
  455 receiveRequest writeEnd = do
  456     debug "receiveRequest: entered"
  457     mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $
  458             iterateeDebugWrapper "parseRequest" parseRequest
  459     debug "receiveRequest: parseRequest returned"
  460 
  461     case mreq of
  462       (Just ireq) -> do
  463           req' <- toRequest ireq
  464           setEnumerator req'
  465           req  <- parseForm req'
  466           checkConnectionClose (rqVersion req) (rqHeaders req)
  467           return $ Just req
  468 
  469       Nothing     -> return Nothing
  470 
  471 
  472   where
  473     --------------------------------------------------------------------------
  474     -- check: did the client specify "transfer-encoding: chunked"? then we
  475     -- have to honor that.
  476     --
  477     -- otherwise: check content-length header. if set: only take N bytes from
  478     -- the read end of the socket
  479     --
  480     -- if no content-length and no chunked encoding, enumerate the entire
  481     -- socket and close afterwards
  482     setEnumerator :: Request -> ServerMonad ()
  483     setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} do
  484         if isChunked
  485           then do
  486               liftIO $ debug $ "receiveRequest/setEnumerator: " ++
  487                                "input in chunked encoding"
  488               let e = joinI . readChunkedTransferEncoding
  489               liftIO $ writeIORef (rqBody req)
  490                                   (SomeEnumerator e)
  491           else maybe (noContentLength req) hasContentLength mbCL
  492 
  493       where
  494         isChunked = maybe False
  495                           ((== ["chunked"]) . map CI.mk)
  496                           (Map.lookup "transfer-encoding" hdrs)
  497 
  498         hasContentLength :: Int64 -> ServerMonad ()
  499         hasContentLength len = do
  500             liftIO $ debug $ "receiveRequest/setEnumerator: " ++
  501                              "request had content-length " ++ show len
  502             liftIO $ writeIORef (rqBody req) (SomeEnumerator e)
  503             liftIO $ debug "receiveRequest/setEnumerator: body enumerator set"
  504           where
  505             e :: Enumerator ByteString IO a
  506             e st = do
  507                 st' <- lift $
  508                        runIteratee $
  509                        iterateeDebugWrapper "rqBody iterator" $
  510                        returnI st
  511 
  512                 joinI $ takeExactly len st'
  513 
  514         noContentLength :: Request -> ServerMonad ()
  515         noContentLength rq = do
  516             debug ("receiveRequest/setEnumerator: " ++
  517                    "request did NOT have content-length")
  518 
  519             when (rqMethod rq == POST || rqMethod rq == PUT) $
  520                  return411 req writeEnd
  521 
  522             let enum = SomeEnumerator $
  523                        iterateeDebugWrapper "noContentLength" .
  524                        joinI . I.take 0
  525             liftIO $ writeIORef (rqBody rq) enum
  526             debug "receiveRequest/setEnumerator: body enumerator set"
  527 
  528 
  529         hdrs = rqHeaders req
  530         mbCL = Map.lookup "content-length" hdrs >>= return . Cvt.int . head
  531 
  532 
  533     --------------------------------------------------------------------------
  534     parseForm :: Request -> ServerMonad Request
  535     parseForm req = {-# SCC "receiveRequest/parseForm" #-}
  536         if doIt then getIt else return req
  537       where
  538         mbCT   = liftM head $ Map.lookup "content-type" (rqHeaders req)
  539         trimIt = fst . SC.spanEnd isSpace . SC.takeWhile (/= ';')
  540                      . SC.dropWhile isSpace
  541         mbCT'  = liftM trimIt mbCT
  542         doIt   = mbCT' == Just "application/x-www-form-urlencoded"
  543 
  544         maximumPOSTBodySize :: Int64
  545         maximumPOSTBodySize = 10*1024*1024
  546 
  547         getIt :: ServerMonad Request
  548         getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do
  549             liftIO $ debug "parseForm: got application/x-www-form-urlencoded"
  550             liftIO $ debug "parseForm: reading POST body"
  551             senum <- liftIO $ readIORef $ rqBody req
  552             let (SomeEnumerator enum) = senum
  553             consumeStep <- liftIO $ runIteratee consume
  554             step <- liftIO $
  555                     runIteratee $
  556                     joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep
  557             body <- liftM S.concat $ lift $ enum step
  558             let newParams = parseUrlEncoded body
  559 
  560             liftIO $ debug "parseForm: stuffing 'enumBS body' into request"
  561 
  562             let e = enumBS body >==> I.joinI . I.take 0
  563 
  564             let e' = \st -> do
  565                 let ii = iterateeDebugWrapper "regurgitate body" (returnI st)
  566                 st' <- lift $ runIteratee ii
  567                 e st'
  568 
  569             liftIO $ writeIORef (rqBody req) $ SomeEnumerator e'
  570             return $ req { rqParams = rqParams req `mappend` newParams }
  571 
  572 
  573     --------------------------------------------------------------------------
  574     toRequest (IRequest method uri version kvps) =
  575         {-# SCC "receiveRequest/toRequest" #-} do
  576             localAddr     <- gets $ localAddress . _sessionPort
  577             lport         <- gets $ localPort . _sessionPort
  578             remoteAddr    <- gets $ remoteAddress . _sessionPort
  579             rport         <- gets $ remotePort . _sessionPort
  580             localHostname <- gets $ _localHostname
  581             secure        <- gets $ isSecure . _sessionPort
  582 
  583             let (serverName, serverPort) = fromMaybe
  584                                              (localHostname, lport)
  585                                              (liftM (parseHost . head)
  586                                                     (Map.lookup "host" hdrs))
  587 
  588             -- will override in "setEnumerator"
  589             enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")
  590 
  591             return $ Request serverName
  592                              serverPort
  593                              remoteAddr
  594                              rport
  595                              localAddr
  596                              lport
  597                              localHostname
  598                              secure
  599                              hdrs
  600                              enum
  601                              mbContentLength
  602                              method
  603                              version
  604                              cookies
  605                              snapletPath
  606                              pathInfo
  607                              contextPath
  608                              uri
  609                              queryString
  610                              params
  611 
  612       where
  613         snapletPath = ""        -- TODO: snaplets in v0.2
  614 
  615         dropLeadingSlash s = maybe s f mbS
  616           where
  617             f (a,s') = if a == c2w '/' then s' else s
  618             mbS = S.uncons s
  619 
  620         hdrs            = toHeaders kvps
  621 
  622         mbContentLength = liftM (Cvt.int . head) $
  623                           Map.lookup "content-length" hdrs
  624 
  625         cookies         = concat $
  626                           maybe []
  627                                 (catMaybes . map parseCookie)
  628                                 (Map.lookup "cookie" hdrs)
  629 
  630         contextPath     = "/"
  631 
  632         parseHost h = (a, Cvt.int (S.drop 1 b))
  633           where
  634             (a,b) = S.break (== (c2w ':')) h
  635 
  636         params          = parseUrlEncoded queryString
  637 
  638         (pathInfo, queryString) = first dropLeadingSlash . second (S.drop 1) $
  639                                   S.break (== (c2w '?')) uri
  640 
  641 
  642 ------------------------------------------------------------------------------
  643 -- Response must be well-formed here
  644 sendResponse :: forall a . Request
  645              -> Response
  646              -> Buffer
  647              -> Iteratee ByteString IO a             -- ^ iteratee write end
  648              -> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on
  649                                                      -- sendfile
  650              -> ServerMonad (Int64, a)
  651 sendResponse req rsp' buffer writeEnd' onSendFile = do
  652     let rsp'' = renderCookies rsp'
  653     rsp <- fixupResponse rsp''
  654     let (!headerString,!hlen) = mkHeaderBuilder rsp
  655     let writeEnd = fixCLIteratee hlen rsp writeEnd'
  656 
  657     (!x,!bs) <-
  658         case (rspBody rsp) of
  659           (Enum e)             -> lift $ whenEnum writeEnd headerString hlen
  660                                                   rsp e
  661           (SendFile f Nothing) -> lift $
  662                                   whenSendFile writeEnd headerString rsp f 0
  663           (SendFile f (Just (st,_))) ->
  664               lift $ whenSendFile writeEnd headerString rsp f st
  665 
  666     debug "sendResponse: response sent"
  667 
  668     return $! (bs,x)
  669 
  670   where
  671     --------------------------------------------------------------------------
  672     whenEnum :: Iteratee ByteString IO a
  673              -> Builder
  674              -> Int
  675              -> Response
  676              -> (forall x . Enumerator Builder IO x)
  677              -> Iteratee ByteString IO (a,Int64)
  678     whenEnum writeEnd hs hlen rsp e = do
  679         -- "enum" here has to be run in the context of the READ iteratee, even
  680         -- though it's writing to the output, because we may be transforming
  681         -- the input. That's why we check if we're transforming the request
  682         -- body here, and if not, send EOF to the write end; so that it
  683         -- doesn't join up with the read iteratee and try to get more data
  684         -- from the socket.
  685         let eBuilder = enumBuilder hs >==> e
  686         let enum = if rspTransformingRqBody rsp
  687                      then eBuilder
  688                      else eBuilder >==>
  689                           mapEnum toByteString fromByteString
  690                                   (joinI . I.take 0)
  691 
  692         debug $ "sendResponse: whenEnum: enumerating bytes"
  693 
  694         outstep <- lift $ runIteratee $
  695                    iterateeDebugWrapper "countBytes writeEnd" $
  696                    countBytes writeEnd
  697         (x,bs) <- mapIter fromByteString toByteString
  698                           (enum $$ joinI $ unsafeBuilderToByteString
  699                               (return buffer) outstep)
  700         debug $ "sendResponse: whenEnum: " ++ show bs ++
  701                 " bytes enumerated"
  702 
  703         return (x, bs - fromIntegral hlen)
  704 
  705 
  706     --------------------------------------------------------------------------
  707     whenSendFile :: Iteratee ByteString IO a  -- ^ write end
  708                  -> Builder       -- ^ headers
  709                  -> Response
  710                  -> FilePath      -- ^ file to send
  711                  -> Int64         -- ^ start byte offset
  712                  -> Iteratee ByteString IO (a,Int64)
  713     whenSendFile writeEnd hs r f start = do
  714         -- Guaranteed to have a content length here. Sending EOF through to
  715         -- the write end guarantees that we flush the buffer before we send
  716         -- the file with sendfile().
  717         lift $ runIteratee ((enumBuilder hs >==> enumEOF) $$
  718                             unsafeBuilderToByteString (return buffer)
  719                               $$ writeEnd)
  720 
  721         let !cl = fromJust $ rspContentLength r
  722         x <- liftIO $ onSendFile f start cl
  723         return (x, cl)
  724 
  725 
  726     --------------------------------------------------------------------------
  727     (major,minor) = rspHttpVersion rsp'
  728 
  729 
  730     --------------------------------------------------------------------------
  731     buildHdrs :: Map (CI ByteString) [ByteString]
  732               -> (Builder,Int)
  733     buildHdrs hdrs =
  734         {-# SCC "buildHdrs" #-}
  735         Map.foldlWithKey f (mempty,0) hdrs
  736       where
  737         f (b,len) k ys =
  738             let (!b',len') = h k ys
  739             in (b `mappend` b', len+len')
  740 
  741         crlf = fromByteString "\r\n"
  742 
  743         doOne pre plen (b,len) y = ( mconcat [ b
  744                                              , pre
  745                                              , fromByteString y
  746                                              , crlf ]
  747                                    , len + plen + 2 + S.length y )
  748 
  749         h k ys = foldl' (doOne kb klen) (mempty,0) ys
  750           where
  751             k'      = CI.original k
  752             kb      = fromByteString k' `mappend` fromByteString ": "
  753             klen    = S.length k' + 2
  754 
  755 
  756     --------------------------------------------------------------------------
  757     noCL :: Response
  758          -> ServerMonad Response
  759     noCL r = {-# SCC "noCL" #-} do
  760         -- are we in HTTP/1.1?
  761         let sendChunked = (rspHttpVersion r) == (1,1)
  762         if sendChunked
  763           then do
  764               let r' = setHeader "Transfer-Encoding" "chunked" r
  765               let origE = rspBodyToEnum $ rspBody r
  766 
  767               let e = \i -> joinI $ origE $$ chunkIt i
  768 
  769               return $! r' { rspBody = Enum e }
  770 
  771           else do
  772               -- HTTP/1.0 and no content-length? We'll have to close the
  773               -- socket.
  774               modify $! \s -> s { _forceConnectionClose = True }
  775               return $! setHeader "Connection" "close" r
  776 
  777     --------------------------------------------------------------------------
  778     chunkIt :: forall x . Enumeratee Builder Builder IO x
  779     chunkIt = checkDone $ continue . step
  780       where
  781         step k EOF = k (Chunks [chunkedTransferTerminator]) >>== return
  782         step k (Chunks []) = continue $ step k
  783         step k (Chunks xs) = k (Chunks [chunkedTransferEncoding $ mconcat xs])
  784                              >>== chunkIt
  785 
  786     --------------------------------------------------------------------------
  787     fixCLIteratee :: Int                       -- ^ header length
  788                   -> Response                  -- ^ response
  789                   -> Iteratee ByteString IO a  -- ^ write end
  790                   -> Iteratee ByteString IO a
  791     fixCLIteratee hlen resp we = maybe we f mbCL
  792       where
  793         f cl = case rspBody resp of
  794                  (Enum _) -> joinI $ takeExactly (cl + fromIntegral hlen)
  795                                   $$ we
  796                  (SendFile _ _) -> we
  797 
  798         mbCL = rspContentLength resp
  799 
  800     --------------------------------------------------------------------------
  801     hasCL :: Int64
  802           -> Response
  803           -> ServerMonad Response
  804     hasCL cl r = {-# SCC "hasCL" #-}
  805         -- set the content-length header
  806         return $! setHeader "Content-Length" (toByteString $ fromShow cl) r
  807 
  808 
  809     --------------------------------------------------------------------------
  810     setFileSize :: FilePath -> Response -> ServerMonad Response
  811     setFileSize fp r =
  812         {-# SCC "setFileSize" #-}
  813         do
  814             fs <- liftM fromIntegral $ liftIO $ getFileSize fp
  815             return $ r { rspContentLength = Just fs }
  816 
  817 
  818     --------------------------------------------------------------------------
  819     handle304 :: Response -> Response
  820     handle304 r = setResponseBody (enumBuilder mempty) $
  821                   updateHeaders (Map.delete "Transfer-Encoding") $
  822                   setContentLength 0 r
  823 
  824 
  825     --------------------------------------------------------------------------
  826     renderCookies :: Response -> Response
  827     renderCookies r = updateHeaders f r
  828       where
  829         f h = if null cookies
  830                 then h
  831                 else Map.insertWith (flip (++)) "Set-Cookie" cookies h
  832         cookies = fmap cookieToBS . Map.elems $ rspCookies r
  833 
  834 
  835     --------------------------------------------------------------------------
  836     fixupResponse :: Response
  837                   -> ServerMonad Response
  838     fixupResponse r = {-# SCC "fixupResponse" #-} do
  839         let r' = deleteHeader "Content-Length" r
  840         let code = rspStatus r'
  841         let r'' = if code == 204 || code == 304
  842                    then handle304 r'
  843                    else r'
  844 
  845         r''' <- do
  846             z <- case rspBody r'' of
  847                    (Enum _)                  -> return r''
  848                    (SendFile f Nothing)      -> setFileSize f r''
  849                    (SendFile _ (Just (s,e))) -> return $
  850                                                 setContentLength (e-s) r''
  851 
  852             case rspContentLength z of
  853               Nothing   -> noCL z
  854               (Just sz) -> hasCL sz z
  855 
  856         -- HEAD requests cannot have bodies per RFC 2616 sec. 9.4
  857         if rqMethod req == HEAD
  858           then return $! deleteHeader "Transfer-Encoding" $
  859                          r''' { rspBody = Enum $ enumBuilder mempty }
  860           else return $! r'''
  861 
  862 
  863     --------------------------------------------------------------------------
  864     mkHeaderBuilder :: Response -> (Builder,Int)
  865     mkHeaderBuilder r = {-# SCC "mkHeaderBuilder" #-}
  866         ( mconcat [ fromByteString "HTTP/"
  867                   , fromString majstr
  868                   , fromWord8 $ c2w '.'
  869                   , fromString minstr
  870                   , space
  871                   , fromString $ statstr
  872                   , space
  873                   , fromByteString reason
  874                   , crlf
  875                   , hdrs
  876                   , crlf
  877                   ]
  878         , 12 + majlen + minlen + statlen + S.length reason + hlen )
  879 
  880       where
  881         (hdrs,hlen) = buildHdrs $ headers r
  882         majstr      = show major
  883         minstr      = show minor
  884         majlen      = length majstr
  885         minlen      = length minstr
  886         statstr     = show $ rspStatus r
  887         statlen     = length statstr
  888         crlf        = fromByteString "\r\n"
  889         space       = fromWord8 $ c2w ' '
  890         reason      = rspStatusReason r
  891 
  892 
  893 ------------------------------------------------------------------------------
  894 checkConnectionClose :: (Int, Int) -> Headers -> ServerMonad ()
  895 checkConnectionClose ver hdrs =
  896     -- For HTTP/1.1:
  897     --   if there is an explicit Connection: close, close the socket.
  898     -- For HTTP/1.0:
  899     --   if there is no explicit Connection: Keep-Alive, close the socket.
  900     if (ver == (1,1) && l == Just ["close"]) ||
  901        (ver == (1,0) && l /= Just ["keep-alive"])
  902        then modify $ \s -> s { _forceConnectionClose = True }
  903        else return ()
  904   where
  905     l  = liftM (map tl) $ Map.lookup "Connection" hdrs
  906     tl = S.map (c2w . toLower . w2c)
  907 
  908 
  909 ------------------------------------------------------------------------------
  910 -- FIXME: whitespace-trim the values here.
  911 toHeaders :: [(ByteString,ByteString)] -> Headers
  912 toHeaders kvps = foldl' f Map.empty kvps'
  913   where
  914     kvps'     = map (first CI.mk . second (:[])) kvps
  915     f m (k,v) = Map.insertWith' (flip (++)) k v m
  916 
  917 
  918 ------------------------------------------------------------------------------
  919 -- | Convert 'Cookie' into 'ByteString' for output.
  920 cookieToBS :: Cookie -> ByteString
  921 cookieToBS (Cookie k v mbExpTime mbDomain mbPath) = cookie
  922   where
  923     cookie  = S.concat [k, "=", v, path, exptime, domain]
  924     path    = maybe "" (S.append "; path=") mbPath
  925     domain  = maybe "" (S.append "; domain=") mbDomain
  926     exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime
  927     fmt     = fromStr . formatTime defaultTimeLocale
  928                                    "%a, %d-%b-%Y %H:%M:%S GMT"
  929 
  930 
  931 ------------------------------------------------------------------------------
  932 getFileSize :: FilePath -> IO FileOffset
  933 getFileSize fp = liftM fileSize $ getFileStatus fp
  934 
  935 
  936 ------------------------------------------------------------------------------
  937 l2s :: L.ByteString -> S.ByteString
  938 l2s = S.concat . L.toChunks
  939 
  940 
  941 ------------------------------------------------------------------------------
  942 toBS :: String -> ByteString
  943 toBS = S.pack . map c2w