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.Session 9 ( httpAcceptLoop 10 , httpSession 11 , snapToServerHandler 12 , BadRequestException(..) 13 , LengthRequiredException(..) 14 , TerminateSessionException(..) 15 ) where 16 17 ------------------------------------------------------------------------------ 18 #if !MIN_VERSION_base(4,8,0) 19 import Control.Applicative ((<$>)) 20 #endif 21 import Control.Arrow (first, second) 22 import Control.Concurrent (MVar, newEmptyMVar, putMVar, readMVar) 23 import Control.Exception (AsyncException, Exception, Handler (..), SomeException (..)) 24 import qualified Control.Exception as E 25 import Control.Monad (join, unless, void, when, (>=>)) 26 import Data.ByteString.Char8 (ByteString) 27 import qualified Data.ByteString.Char8 as S 28 import qualified Data.ByteString.Unsafe as S 29 import qualified Data.CaseInsensitive as CI 30 import Data.Int (Int64) 31 import Data.IORef (IORef, newIORef, readIORef, writeIORef) 32 import Data.List (foldl') 33 import qualified Data.Map as Map 34 import Data.Maybe (fromJust, fromMaybe, isNothing) 35 #if !MIN_VERSION_base(4,8,0) 36 import Data.Monoid (mconcat) 37 #endif 38 import Data.Monoid ((<>)) 39 import Data.Time.Format (formatTime) 40 import Data.Typeable (Typeable) 41 import Data.Version (showVersion) 42 import Data.Word (Word64, Word8) 43 import Foreign.Marshal.Utils (copyBytes) 44 import Foreign.Ptr (Ptr, castPtr, plusPtr) 45 import Foreign.Storable (pokeByteOff) 46 #if MIN_VERSION_time(1,5,0) 47 import Data.Time.Format (defaultTimeLocale) 48 #else 49 import System.Locale (defaultTimeLocale) 50 #endif 51 ------------------------------------------------------------------------------ 52 import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8) 53 import Data.ByteString.Builder.Extra (flush) 54 import Data.ByteString.Builder.Internal (Buffer, defaultChunkSize, newBuffer) 55 import Data.ByteString.Builder.Prim (FixedPrim, primFixed, (>$<), (>*<)) 56 import Data.ByteString.Builder.Prim.Internal (fixedPrim, size) 57 import System.IO.Streams (InputStream, OutputStream) 58 import qualified System.IO.Streams as Streams 59 ------------------------------------------------------------------------------ 60 import qualified Paths_snap_server as V 61 import Snap.Core (EscapeSnap (..)) 62 import Snap.Core (Snap, runSnap) 63 import Snap.Internal.Core (fixupResponse) 64 import Snap.Internal.Http.Server.Clock (getClockTime) 65 import Snap.Internal.Http.Server.Common (eatException) 66 import Snap.Internal.Http.Server.Date (getDateString) 67 import Snap.Internal.Http.Server.Parser (IRequest (..), getStdConnection, getStdContentLength, getStdContentType, getStdCookie, getStdHost, getStdTransferEncoding, parseCookie, parseRequest, parseUrlEncoded, readChunkedTransferEncoding, writeChunkedTransferEncoding) 68 import Snap.Internal.Http.Server.Thread (SnapThread) 69 import qualified Snap.Internal.Http.Server.Thread as Thread 70 import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager) 71 import qualified Snap.Internal.Http.Server.TimeoutManager as TM 72 import Snap.Internal.Http.Server.Types (AcceptFunc (..), PerSessionData (..), SendFileHandler, ServerConfig (..), ServerHandler) 73 import Snap.Internal.Http.Types (Cookie (..), HttpVersion, Method (..), Request (..), Response (..), ResponseBody (..), StreamProc, getHeader, headers, rspBodyToEnum, updateHeaders) 74 import Snap.Internal.Parsing (unsafeFromNat) 75 import Snap.Types.Headers (Headers) 76 import qualified Snap.Types.Headers as H 77 import System.IO.Unsafe (unsafePerformIO) 78 79 80 ------------------------------------------------------------------------------ 81 data TerminateSessionException = TerminateSessionException SomeException 82 deriving (Typeable, Show) 83 instance Exception TerminateSessionException 84 85 data BadRequestException = BadRequestException 86 deriving (Typeable, Show) 87 instance Exception BadRequestException 88 89 data LengthRequiredException = LengthRequiredException 90 deriving (Typeable, Show) 91 instance Exception LengthRequiredException 92 93 94 ------------------------------------------------------------------------------ 95 snapToServerHandler :: Snap a -> ServerHandler hookState 96 snapToServerHandler !snap !serverConfig !perSessionData !req = 97 runSnap snap logErr tickle req 98 where 99 logErr = _logError serverConfig . byteString 100 tickle = _twiddleTimeout perSessionData 101 102 103 ------------------------------------------------------------------------------ 104 mAX_HEADERS_SIZE :: Int64 105 mAX_HEADERS_SIZE = 256 * 1024 106 107 108 ------------------------------------------------------------------------------ 109 -- | For each cpu, we store: 110 -- * An accept thread 111 -- * A TimeoutManager 112 -- * An mvar to signal when the timeout thread is shutdown 113 data EventLoopCpu = EventLoopCpu 114 { _acceptThread :: SnapThread 115 , _timeoutManager :: TimeoutManager 116 } 117 118 119 ------------------------------------------------------------------------------ 120 -- | The main Snap webserver loop. Given a server handler, configuration, and a 121 -- function to accept new connections, runs an HTTP loop forever over N 122 -- threads, until a ThreadKilled exception is received. 123 httpAcceptLoop :: forall hookState . 124 ServerHandler hookState -- ^ server handler 125 -> ServerConfig hookState -- ^ server config 126 -> AcceptFunc -- ^ accept function 127 -> IO () 128 httpAcceptLoop serverHandler serverConfig acceptFunc = runLoops 129 where 130 -------------------------------------------------------------------------- 131 logError = _logError serverConfig 132 nLoops = _numAcceptLoops serverConfig 133 defaultTimeout = _defaultTimeout serverConfig 134 135 -------------------------------------------------------------------------- 136 logException :: Exception e => e -> IO () 137 logException e = 138 logError $ 139 mconcat [ byteString "got exception in httpAcceptFunc: " 140 , fromShow e 141 ] 142 143 -------------------------------------------------------------------------- 144 runLoops = E.bracket (mapM newLoop [0 .. (nLoops - 1)]) 145 (mapM_ killLoop) 146 (mapM_ waitLoop) 147 148 -------------------------------------------------------------------------- 149 loop :: TimeoutManager 150 -> (forall a. IO a -> IO a) 151 -> IO () 152 loop tm loopRestore = eatException go 153 where 154 ---------------------------------------------------------------------- 155 handlers = 156 [ Handler $ \(e :: AsyncException) -> loopRestore (E.throwIO $! e) 157 , Handler $ \(e :: SomeException) -> logException e >> go 158 ] 159 160 go = do 161 (sendFileHandler, localAddress, localPort, remoteAddress, 162 remotePort, readEnd, writeEnd, 163 cleanup) <- runAcceptFunc acceptFunc loopRestore 164 `E.catches` handlers 165 let threadLabel = S.concat [ "snap-server: client " 166 , remoteAddress 167 , ":" 168 , S.pack $ show remotePort 169 ] 170 thMVar <- newEmptyMVar 171 th <- TM.register tm threadLabel $ \restore -> 172 eatException $ 173 prep thMVar sendFileHandler localAddress localPort remoteAddress 174 remotePort readEnd writeEnd cleanup restore 175 putMVar thMVar th 176 go 177 178 prep :: MVar TM.TimeoutThread 179 -> SendFileHandler 180 -> ByteString 181 -> Int 182 -> ByteString 183 -> Int 184 -> InputStream ByteString 185 -> OutputStream ByteString 186 -> IO () 187 -> (forall a . IO a -> IO a) 188 -> IO () 189 prep thMVar sendFileHandler localAddress localPort remoteAddress 190 remotePort readEnd writeEnd cleanup restore = 191 do 192 connClose <- newIORef False 193 newConn <- newIORef True 194 let twiddleTimeout = unsafePerformIO $ do 195 th <- readMVar thMVar 196 return $ TM.modify th 197 198 let !psd = PerSessionData connClose 199 twiddleTimeout 200 newConn 201 sendFileHandler 202 localAddress 203 localPort 204 remoteAddress 205 remotePort 206 readEnd 207 writeEnd 208 restore (session psd) `E.finally` cleanup 209 210 -------------------------------------------------------------------------- 211 session psd = do 212 buffer <- newBuffer defaultChunkSize 213 httpSession buffer serverHandler serverConfig psd 214 215 -------------------------------------------------------------------------- 216 newLoop cpu = E.mask_ $ do 217 -- TODO(greg): move constant into config 218 tm <- TM.initialize (fromIntegral defaultTimeout) 2 getClockTime 219 let threadLabel = S.concat [ "snap-server: accept loop #" 220 , S.pack $ show cpu 221 ] 222 223 tid <- Thread.forkOn threadLabel cpu $ loop tm 224 return $! EventLoopCpu tid tm 225 226 -------------------------------------------------------------------------- 227 waitLoop (EventLoopCpu tid _) = Thread.wait tid 228 229 -------------------------------------------------------------------------- 230 killLoop ev = E.uninterruptibleMask_ $ do 231 Thread.cancelAndWait tid 232 TM.stop tm 233 where 234 tid = _acceptThread ev 235 tm = _timeoutManager ev 236 237 ------------------------------------------------------------------------------ 238 httpSession :: forall hookState . 239 Buffer 240 -> ServerHandler hookState 241 -> ServerConfig hookState 242 -> PerSessionData 243 -> IO () 244 httpSession !buffer !serverHandler !config !sessionData = loop 245 where 246 -------------------------------------------------------------------------- 247 defaultTimeout = _defaultTimeout config 248 isSecure = _isSecure config 249 localHostname = _localHostname config 250 logAccess = _logAccess config 251 logError = _logError config 252 newRequestHook = _onNewRequest config 253 parseHook = _onParse config 254 userHandlerFinishedHook = _onUserHandlerFinished config 255 dataFinishedHook = _onDataFinished config 256 exceptionHook = _onException config 257 escapeHook = _onEscape config 258 259 -------------------------------------------------------------------------- 260 forceConnectionClose = _forceConnectionClose sessionData 261 isNewConnection = _isNewConnection sessionData 262 localAddress = _localAddress sessionData 263 localPort = _localPort sessionData 264 remoteAddress = _remoteAddress sessionData 265 remotePort = _remotePort sessionData 266 readEnd = _readEnd sessionData 267 tickle f = _twiddleTimeout sessionData f 268 writeEnd = _writeEnd sessionData 269 sendfileHandler = _sendfileHandler sessionData 270 271 -------------------------------------------------------------------------- 272 mkBuffer :: IO (OutputStream Builder) 273 mkBuffer = Streams.unsafeBuilderStream (return buffer) writeEnd 274 275 -------------------------------------------------------------------------- 276 -- Begin HTTP session processing. 277 loop :: IO () 278 loop = do 279 -- peek first to ensure startHook gets generated at the right time. 280 readEndAtEof >>= (flip unless $ do 281 hookState <- newRequestHook sessionData >>= newIORef 282 -- parse HTTP request 283 req <- receiveRequest 284 parseHook hookState req 285 processRequest hookState req) 286 287 ------------------------------------------------------------------------------ 288 readEndAtEof = Streams.read readEnd >>= 289 maybe (return True) 290 (\c -> if S.null c 291 then readEndAtEof 292 else Streams.unRead c readEnd >> return False) 293 {-# INLINE readEndAtEof #-} 294 295 -------------------------------------------------------------------------- 296 -- Read the HTTP request from the socket, parse it, and pre-process it. 297 receiveRequest :: IO Request 298 receiveRequest = {-# SCC "httpSession/receiveRequest" #-} do 299 readEnd' <- Streams.throwIfProducesMoreThan mAX_HEADERS_SIZE readEnd 300 parseRequest readEnd' >>= toRequest 301 {-# INLINE receiveRequest #-} 302 303 -------------------------------------------------------------------------- 304 toRequest :: IRequest -> IO Request 305 toRequest !ireq = {-# SCC "httpSession/toRequest" #-} do 306 -- HTTP spec section 14.23: "All Internet-based HTTP/1.1 servers MUST 307 -- respond with a 400 (Bad Request) status code to any HTTP/1.1 request 308 -- message which lacks a Host header field." 309 -- 310 -- Here we interpret this slightly more liberally: if an absolute URI 311 -- including a hostname is given in the request line, we'll take that 312 -- if there's no Host header. 313 -- 314 -- For HTTP/1.0 requests, we pick the configured local hostname by 315 -- default. 316 host <- maybe (if isHttp11 317 then badRequestWithNoHost 318 else return localHostname) 319 return mbHost 320 321 -- Call setupReadEnd, which handles transfer-encoding: chunked or 322 -- content-length restrictions, etc 323 !readEnd' <- setupReadEnd 324 325 -- Parse an application/x-www-form-urlencoded form, if it was sent 326 (!readEnd'', postParams) <- parseForm readEnd' 327 328 let allParams = Map.unionWith (++) queryParams postParams 329 330 -- Decide whether the connection should be closed after the response is 331 -- sent (stored in the forceConnectionClose IORef). 332 checkConnectionClose version $ getStdConnection stdHdrs 333 334 -- The request is now ready for processing. 335 return $! Request host 336 remoteAddress 337 remotePort 338 localAddress 339 localPort 340 localHost 341 isSecure 342 hdrs 343 readEnd'' 344 mbCL 345 method 346 version 347 cookies 348 pathInfo 349 contextPath 350 uri 351 queryString 352 allParams 353 queryParams 354 postParams 355 356 where 357 ---------------------------------------------------------------------- 358 !method = iMethod ireq 359 !version = iHttpVersion ireq 360 !stdHdrs = iStdHeaders ireq 361 !hdrs = iRequestHeaders ireq 362 363 !isHttp11 = version >= (1, 1) 364 365 !mbHost = getStdHost stdHdrs 366 !localHost = fromMaybe localHostname mbHost 367 mbCL = unsafeFromNat <$> 368 getStdContentLength stdHdrs 369 !isChunked = (CI.mk <$> getStdTransferEncoding stdHdrs) 370 == Just "chunked" 371 cookies = fromMaybe [] (getStdCookie stdHdrs >>= parseCookie) 372 contextPath = "/" 373 !uri = iRequestUri ireq 374 queryParams = parseUrlEncoded queryString 375 emptyParams = Map.empty 376 377 ---------------------------------------------------------------------- 378 (pathInfo, queryString) = first dropLeadingSlash . second (S.drop 1) 379 $ S.break (== '?') uri 380 381 ---------------------------------------------------------------------- 382 dropLeadingSlash s = if S.null s 383 then s 384 else let !a = S.unsafeIndex s 0 385 in if a == 47 -- 47 == '/' 386 then S.unsafeDrop 1 s 387 else s 388 {-# INLINE dropLeadingSlash #-} 389 390 ---------------------------------------------------------------------- 391 -- | We have to transform the read end of the socket, to limit the 392 -- number of bytes read to the content-length, to decode chunked 393 -- transfer encoding, or to immediately yield EOF if the request body 394 -- is empty. 395 setupReadEnd :: IO (InputStream ByteString) 396 setupReadEnd = 397 if isChunked 398 then readChunkedTransferEncoding readEnd 399 else maybe (const noContentLength) 400 (Streams.takeBytes . fromIntegral) mbCL readEnd 401 {-# INLINE setupReadEnd #-} 402 403 ---------------------------------------------------------------------- 404 -- | If a request is not in chunked transfer encoding and lacks a 405 -- content-length, the request body is null string. 406 noContentLength :: IO (InputStream ByteString) 407 noContentLength = do 408 when (method == POST || method == PUT) return411 409 Streams.fromList [] 410 411 ---------------------------------------------------------------------- 412 return411 = do 413 let (major, minor) = version 414 let resp = mconcat [ byteString "HTTP/" 415 , fromShow major 416 , char8 '.' 417 , fromShow minor 418 , byteString " 411 Length Required\r\n\r\n" 419 , byteString "411 Length Required\r\n" 420 , flush 421 ] 422 writeEndB <- mkBuffer 423 Streams.write (Just resp) writeEndB 424 Streams.write Nothing writeEndB 425 terminateSession LengthRequiredException 426 427 ---------------------------------------------------------------------- 428 parseForm readEnd' = if hasForm 429 then getForm 430 else return (readEnd', emptyParams) 431 where 432 trimIt = fst . S.spanEnd (== ' ') . S.takeWhile (/= ';') 433 . S.dropWhile (== ' ') 434 mbCT = trimIt <$> getStdContentType stdHdrs 435 hasForm = mbCT == Just "application/x-www-form-urlencoded" 436 437 mAX_POST_BODY_SIZE = 1024 * 1024 438 439 getForm = do 440 readEnd'' <- Streams.throwIfProducesMoreThan 441 mAX_POST_BODY_SIZE readEnd' 442 contents <- S.concat <$> Streams.toList readEnd'' 443 let postParams = parseUrlEncoded contents 444 finalReadEnd <- Streams.fromList [contents] 445 return (finalReadEnd, postParams) 446 447 ---------------------------------------------------------------------- 448 checkConnectionClose version connection = do 449 -- For HTTP/1.1: if there is an explicit Connection: close, we'll close 450 -- the socket later. 451 -- 452 -- For HTTP/1.0: if there is no explicit Connection: Keep-Alive, 453 -- close the socket later. 454 let v = CI.mk <$> connection 455 when ((version == (1, 1) && v == Just "close") || 456 (version == (1, 0) && v /= Just "keep-alive")) $ 457 writeIORef forceConnectionClose True 458 459 -------------------------------------------------------------------------- 460 {-# INLINE badRequestWithNoHost #-} 461 badRequestWithNoHost :: IO a 462 badRequestWithNoHost = do 463 let msg = mconcat [ 464 byteString "HTTP/1.1 400 Bad Request\r\n\r\n" 465 , byteString "400 Bad Request: HTTP/1.1 request with no " 466 , byteString "Host header\r\n" 467 , flush 468 ] 469 writeEndB <- mkBuffer 470 Streams.write (Just msg) writeEndB 471 Streams.write Nothing writeEndB 472 terminateSession BadRequestException 473 474 -------------------------------------------------------------------------- 475 {-# INLINE checkExpect100Continue #-} 476 checkExpect100Continue req = 477 when (getHeader "expect" req == Just "100-continue") $ do 478 let v = if rqVersion req == (1,1) then "HTTP/1.1" else "HTTP/1.0" 479 480 let hl = byteString v <> 481 byteString " 100 Continue\r\n\r\n" <> 482 flush 483 os <- mkBuffer 484 Streams.write (Just hl) os 485 486 -------------------------------------------------------------------------- 487 {-# INLINE processRequest #-} 488 processRequest !hookState !req = {-# SCC "httpSession/processRequest" #-} do 489 -- successfully parsed a request, so restart the timer 490 tickle $ max defaultTimeout 491 492 -- check for Expect: 100-continue 493 checkExpect100Continue req 494 b <- runServerHandler hookState req 495 `E.catches` [ Handler $ escapeSnapHandler hookState 496 , Handler $ 497 catchUserException hookState "user handler" req 498 ] 499 if b 500 then do writeIORef isNewConnection False 501 -- the timer resets to its default value here. 502 loop 503 else return $! () 504 505 -------------------------------------------------------------------------- 506 {-# INLINE runServerHandler #-} 507 runServerHandler !hookState !req = {-# SCC "httpSession/runServerHandler" #-} do 508 (_, rsp0) <- serverHandler config sessionData req 509 userHandlerFinishedHook hookState req rsp0 510 511 -- check whether we should close the connection after sending the 512 -- response 513 let v = rqVersion req 514 let is_1_0 = (v == (1,0)) 515 cc <- if is_1_0 && (isNothing $ rspContentLength rsp0) 516 then return $! True 517 else readIORef forceConnectionClose 518 519 -- skip unread portion of request body if rspTransformingRqBody is not 520 -- true 521 unless (rspTransformingRqBody rsp0) $ Streams.skipToEof (rqBody req) 522 523 !date <- getDateString 524 rsp1 <- fixupResponse req rsp0 525 let (!hdrs, !cc') = addDateAndServerHeaders is_1_0 date cc $ 526 headers rsp1 527 let rsp = updateHeaders (const hdrs) rsp1 528 writeIORef forceConnectionClose cc' 529 bytesSent <- sendResponse req rsp `E.catch` 530 catchUserException hookState "sending-response" req 531 dataFinishedHook hookState req rsp 532 logAccess req rsp bytesSent 533 return $! not cc' 534 535 -------------------------------------------------------------------------- 536 addDateAndServerHeaders !is1_0 !date !cc !hdrs = 537 {-# SCC "addDateAndServerHeaders" #-} 538 let (!hdrs', !newcc) = go [("date",date)] False cc 539 $ H.unsafeToCaseFoldedList hdrs 540 in (H.unsafeFromCaseFoldedList hdrs', newcc) 541 where 542 -- N.B.: here we know the date header has already been removed by 543 -- "fixupResponse". 544 go !l !seenServer !connClose [] = 545 let !l1 = if seenServer then l else (("server", sERVER_HEADER):l) 546 !l2 = if connClose then (("connection", "close"):l1) else l1 547 in (l2, connClose) 548 go l _ c (x@("server",_):xs) = go (x:l) True c xs 549 go l seenServer c (x@("connection", v):xs) 550 | c = go l seenServer c xs 551 | v == "close" || (is1_0 && v /= "keep-alive") = 552 go l seenServer True xs 553 | otherwise = go (x:l) seenServer c xs 554 go l seenServer c (x:xs) = go (x:l) seenServer c xs 555 556 -------------------------------------------------------------------------- 557 escapeSnapHandler hookState (EscapeHttp escapeHandler) = do 558 escapeHook hookState 559 mkBuffer >>= escapeHandler tickle readEnd 560 return False 561 escapeSnapHandler _ (TerminateConnection e) = terminateSession e 562 563 -------------------------------------------------------------------------- 564 catchUserException :: IORef hookState 565 -> ByteString 566 -> Request 567 -> SomeException 568 -> IO a 569 catchUserException hookState phase req e = do 570 logError $ mconcat [ 571 byteString "Exception leaked to httpSession during phase '" 572 , byteString phase 573 , byteString "': \n" 574 , requestErrorMessage req e 575 ] 576 -- Note: the handler passed to httpSession needs to catch its own 577 -- exceptions if it wants to avoid an ungracious exit here. 578 eatException $ exceptionHook hookState e 579 terminateSession e 580 581 -------------------------------------------------------------------------- 582 sendResponse :: Request -> Response -> IO Word64 583 sendResponse !req !rsp = {-# SCC "httpSession/sendResponse" #-} do 584 let !v = rqVersion req 585 let !hdrs' = renderCookies rsp (headers rsp) 586 let !code = rspStatus rsp 587 let body = rspBody rsp 588 let needChunked = rqMethod req /= HEAD 589 && isNothing (rspContentLength rsp) 590 && code /= 204 591 && code /= 304 592 593 let (hdrs'', body', shouldClose) = if needChunked 594 then noCL req hdrs' body 595 else (hdrs', body, False) 596 597 when shouldClose $ writeIORef forceConnectionClose $! True 598 let hdrPrim = mkHeaderPrim v rsp hdrs'' 599 let hlen = size hdrPrim 600 let headerBuilder = primFixed hdrPrim $! () 601 602 nBodyBytes <- case body' of 603 Stream s -> 604 whenStream headerBuilder hlen rsp s 605 SendFile f Nothing -> 606 whenSendFile headerBuilder rsp f 0 607 -- ignore end length here because we know we had a 608 -- content-length, use that instead. 609 SendFile f (Just (st, _)) -> 610 whenSendFile headerBuilder rsp f st 611 return $! nBodyBytes - fromIntegral hlen 612 613 -------------------------------------------------------------------------- 614 noCL :: Request 615 -> Headers 616 -> ResponseBody 617 -> (Headers, ResponseBody, Bool) 618 noCL req hdrs body = 619 if v == (1,1) 620 then let origBody = rspBodyToEnum body 621 body' = \os -> do 622 os' <- writeChunkedTransferEncoding os 623 origBody os' 624 in ( H.set "transfer-encoding" "chunked" hdrs 625 , Stream body' 626 , False) 627 else 628 -- We've already noted that we have to close the socket earlier in 629 -- runServerHandler. 630 (hdrs, body, True) 631 where 632 v = rqVersion req 633 {-# INLINE noCL #-} 634 635 -------------------------------------------------------------------------- 636 -- | If the response contains a content-length, make sure the response body 637 -- StreamProc doesn't yield more (or fewer) than the given number of bytes. 638 limitRspBody :: Int -- ^ header length 639 -> Response -- ^ response 640 -> OutputStream ByteString -- ^ write end of socket 641 -> IO (OutputStream ByteString) 642 limitRspBody hlen rsp os = maybe (return os) f $ rspContentLength rsp 643 where 644 f cl = Streams.giveExactly (fromIntegral hlen + fromIntegral cl) os 645 {-# INLINE limitRspBody #-} 646 647 -------------------------------------------------------------------------- 648 whenStream :: Builder -- ^ headers 649 -> Int -- ^ header length 650 -> Response -- ^ response 651 -> StreamProc -- ^ output body 652 -> IO Word64 -- ^ returns number of bytes written 653 whenStream headerString hlen rsp body = do 654 -- note: 655 -- 656 -- * precondition here is that we have a content-length and that we're 657 -- not using chunked transfer encoding. 658 -- 659 -- * "headerString" includes http status line. 660 -- 661 -- If you're transforming the request body, you have to manage your own 662 -- timeouts. 663 let t = if rspTransformingRqBody rsp 664 then return $! () 665 else tickle $ max defaultTimeout 666 writeEnd0 <- Streams.ignoreEof writeEnd 667 (writeEnd1, getCount) <- Streams.countOutput writeEnd0 668 writeEnd2 <- limitRspBody hlen rsp writeEnd1 669 writeEndB <- Streams.unsafeBuilderStream (return buffer) writeEnd2 >>= 670 Streams.contramapM (\x -> t >> return x) 671 672 Streams.write (Just headerString) writeEndB 673 writeEnd' <- body writeEndB 674 Streams.write Nothing writeEnd' 675 -- Just in case the user handler didn't. 676 Streams.write Nothing writeEnd1 677 n <- getCount 678 return $! fromIntegral n - fromIntegral hlen 679 {-# INLINE whenStream #-} 680 681 -------------------------------------------------------------------------- 682 whenSendFile :: Builder -- ^ headers 683 -> Response -- ^ response 684 -> FilePath -- ^ file to serve 685 -> Word64 -- ^ file start offset 686 -> IO Word64 -- ^ returns number of bytes written 687 whenSendFile headerString rsp filePath offset = do 688 let !cl = fromJust $ rspContentLength rsp 689 sendfileHandler buffer headerString filePath offset cl 690 return cl 691 {-# INLINE whenSendFile #-} 692 693 694 -------------------------------------------------------------------------- 695 mkHeaderLine :: HttpVersion -> Response -> FixedPrim () 696 mkHeaderLine outVer r = 697 case outCode of 698 200 | outVer == (1, 1) -> 699 -- typo in bytestring here 700 fixedPrim 17 $ const (void . cpBS "HTTP/1.1 200 OK\r\n") 701 200 | otherwise -> 702 fixedPrim 17 $ const (void . cpBS "HTTP/1.0 200 OK\r\n") 703 _ -> fixedPrim len $ const (void . line) 704 where 705 outCode = rspStatus r 706 707 v = if outVer == (1,1) then "HTTP/1.1 " else "HTTP/1.0 " 708 709 outCodeStr = S.pack $ show outCode 710 space !op = do 711 pokeByteOff op 0 (32 :: Word8) 712 return $! plusPtr op 1 713 714 line = cpBS v >=> cpBS outCodeStr >=> space >=> cpBS reason 715 >=> crlfPoke 716 717 reason = rspStatusReason r 718 len = 12 + S.length outCodeStr + S.length reason 719 720 721 ------------------------------------------------------------------------------ 722 mkHeaderPrim :: HttpVersion -> Response -> Headers -> FixedPrim () 723 mkHeaderPrim v r hdrs = mkHeaderLine v r <+> headersToPrim hdrs 724 725 726 ------------------------------------------------------------------------------ 727 infixl 4 <+> 728 (<+>) :: FixedPrim () -> FixedPrim () -> FixedPrim () 729 p1 <+> p2 = ignore >$< p1 >*< p2 730 where 731 ignore = join (,) 732 733 734 ------------------------------------------------------------------------------ 735 {-# INLINE headersToPrim #-} 736 headersToPrim :: Headers -> FixedPrim () 737 headersToPrim hdrs = fixedPrim len (const copy) 738 where 739 len = H.foldedFoldl' f 0 hdrs + 2 740 where 741 f l k v = l + S.length k + S.length v + 4 742 743 copy = go $ H.unsafeToCaseFoldedList hdrs 744 745 go [] !op = void $ crlfPoke op 746 go ((k,v):xs) !op = do 747 !op' <- cpBS k op 748 pokeByteOff op' 0 (58 :: Word8) -- colon 749 pokeByteOff op' 1 (32 :: Word8) -- space 750 !op'' <- cpBS v $ plusPtr op' 2 751 crlfPoke op'' >>= go xs 752 753 754 {-# INLINE cpBS #-} 755 cpBS :: ByteString -> Ptr Word8 -> IO (Ptr Word8) 756 cpBS s !op = S.unsafeUseAsCStringLen s $ \(cstr, clen) -> do 757 let !cl = fromIntegral clen 758 copyBytes op (castPtr cstr) cl 759 return $! plusPtr op cl 760 761 {-# INLINE crlfPoke #-} 762 crlfPoke :: Ptr Word8 -> IO (Ptr Word8) 763 crlfPoke !op = do 764 pokeByteOff op 0 (13 :: Word8) -- cr 765 pokeByteOff op 1 (10 :: Word8) -- lf 766 return $! plusPtr op 2 767 768 769 ------------------------------------------------------------------------------ 770 sERVER_HEADER :: ByteString 771 sERVER_HEADER = S.concat ["Snap/", snapServerVersion] 772 773 774 ------------------------------------------------------------------------------ 775 snapServerVersion :: ByteString 776 snapServerVersion = S.pack $ showVersion $ V.version 777 778 779 ------------------------------------------------------------------------------ 780 terminateSession :: Exception e => e -> IO a 781 terminateSession = E.throwIO . TerminateSessionException . SomeException 782 783 784 ------------------------------------------------------------------------------ 785 requestErrorMessage :: Request -> SomeException -> Builder 786 requestErrorMessage req e = 787 mconcat [ byteString "During processing of request from " 788 , byteString $ rqClientAddr req 789 , byteString ":" 790 , fromShow $ rqClientPort req 791 , byteString "\nrequest:\n" 792 , fromShow $ show req 793 , byteString "\n" 794 , msgB 795 ] 796 where 797 msgB = mconcat [ 798 byteString "A web handler threw an exception. Details:\n" 799 , fromShow e 800 ] 801 802 803 ------------------------------------------------------------------------------ 804 -- | Convert 'Cookie' into 'ByteString' for output. 805 cookieToBS :: Cookie -> ByteString 806 cookieToBS (Cookie k v mbExpTime mbDomain mbPath isSec isHOnly) = cookie 807 where 808 cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly] 809 path = maybe "" (S.append "; path=") mbPath 810 domain = maybe "" (S.append "; domain=") mbDomain 811 exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime 812 secure = if isSec then "; Secure" else "" 813 hOnly = if isHOnly then "; HttpOnly" else "" 814 fmt = S.pack . formatTime defaultTimeLocale 815 "%a, %d-%b-%Y %H:%M:%S GMT" 816 817 818 ------------------------------------------------------------------------------ 819 renderCookies :: Response -> Headers -> Headers 820 renderCookies r hdrs 821 | null cookies = hdrs 822 | otherwise = foldl' (\m v -> H.unsafeInsert "set-cookie" v m) hdrs cookies 823 824 where 825 cookies = fmap cookieToBS . Map.elems $ rspCookies r 826 827 ------------------------------------------------------------------------------ 828 fromShow :: Show a => a -> Builder 829 fromShow = stringUtf8 . show