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