{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Session ( httpAcceptLoop , httpSession , snapToServerHandler , BadRequestException(..) , LengthRequiredException(..) , TerminateSessionException(..) ) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Arrow (first, second) import Control.Concurrent (MVar, newEmptyMVar, putMVar, readMVar) import Control.Exception (AsyncException, Exception, Handler (..), SomeException (..)) import qualified Control.Exception as E import Control.Monad (join, unless, void, when, (>=>)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Unsafe as S import qualified Data.CaseInsensitive as CI import Data.Int (Int64) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (foldl') import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe, isNothing) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mconcat) #endif import Data.Monoid ((<>)) import Data.Time.Format (formatTime) import Data.Typeable (Typeable) import Data.Version (showVersion) import Data.Word (Word64, Word8) import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (pokeByteOff) #if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif ------------------------------------------------------------------------------ import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8) import Data.ByteString.Builder.Extra (flush) import Data.ByteString.Builder.Internal (Buffer, defaultChunkSize, newBuffer) import Data.ByteString.Builder.Prim (FixedPrim, primFixed, (>$<), (>*<)) import Data.ByteString.Builder.Prim.Internal (fixedPrim, size) import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams as Streams ------------------------------------------------------------------------------ import qualified Paths_snap_server as V import Snap.Core (EscapeSnap (..)) import Snap.Core (Snap, runSnap) import Snap.Internal.Core (fixupResponse) import Snap.Internal.Http.Server.Clock (getClockTime) import Snap.Internal.Http.Server.Common (eatException) import Snap.Internal.Http.Server.Date (getDateString) import Snap.Internal.Http.Server.Parser (IRequest (..), getStdConnection, getStdContentLength, getStdContentType, getStdCookie, getStdHost, getStdTransferEncoding, parseCookie, parseRequest, parseUrlEncoded, readChunkedTransferEncoding, writeChunkedTransferEncoding) import Snap.Internal.Http.Server.Thread (SnapThread) import qualified Snap.Internal.Http.Server.Thread as Thread import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager) import qualified Snap.Internal.Http.Server.TimeoutManager as TM import Snap.Internal.Http.Server.Types (AcceptFunc (..), PerSessionData (..), SendFileHandler, ServerConfig (..), ServerHandler) import Snap.Internal.Http.Types (Cookie (..), HttpVersion, Method (..), Request (..), Response (..), ResponseBody (..), StreamProc, getHeader, headers, rspBodyToEnum, updateHeaders) import Snap.Internal.Parsing (unsafeFromNat) import Snap.Types.Headers (Headers) import qualified Snap.Types.Headers as H import System.IO.Unsafe (unsafePerformIO) ------------------------------------------------------------------------------ data TerminateSessionException = TerminateSessionException SomeException deriving (Typeable, Show) instance Exception TerminateSessionException data BadRequestException = BadRequestException deriving (Typeable, Show) instance Exception BadRequestException data LengthRequiredException = LengthRequiredException deriving (Typeable, Show) instance Exception LengthRequiredException ------------------------------------------------------------------------------ snapToServerHandler :: Snap a -> ServerHandler hookState snapToServerHandler !snap !serverConfig !perSessionData !req = runSnap snap logErr tickle req where logErr = _logError serverConfig . byteString tickle = _twiddleTimeout perSessionData ------------------------------------------------------------------------------ mAX_HEADERS_SIZE :: Int64 mAX_HEADERS_SIZE = 256 * 1024 ------------------------------------------------------------------------------ -- | For each cpu, we store: -- * An accept thread -- * A TimeoutManager -- * An mvar to signal when the timeout thread is shutdown data EventLoopCpu = EventLoopCpu { _acceptThread :: SnapThread , _timeoutManager :: TimeoutManager } ------------------------------------------------------------------------------ -- | The main Snap webserver loop. Given a server handler, configuration, and a -- function to accept new connections, runs an HTTP loop forever over N -- threads, until a ThreadKilled exception is received. httpAcceptLoop :: forall hookState . ServerHandler hookState -- ^ server handler -> ServerConfig hookState -- ^ server config -> AcceptFunc -- ^ accept function -> IO () httpAcceptLoop serverHandler serverConfig acceptFunc = runLoops where -------------------------------------------------------------------------- logError = _logError serverConfig nLoops = _numAcceptLoops serverConfig defaultTimeout = _defaultTimeout serverConfig -------------------------------------------------------------------------- logException :: Exception e => e -> IO () logException e = logError $ mconcat [ byteString "got exception in httpAcceptFunc: " , fromShow e ] -------------------------------------------------------------------------- runLoops = E.bracket (mapM newLoop [0 .. (nLoops - 1)]) (mapM_ killLoop) (mapM_ waitLoop) -------------------------------------------------------------------------- loop :: TimeoutManager -> (forall a. IO a -> IO a) -> IO () loop tm loopRestore = eatException go where ---------------------------------------------------------------------- handlers = [ Handler $ \(e :: AsyncException) -> loopRestore (E.throwIO $! e) , Handler $ \(e :: SomeException) -> logException e >> go ] go = do (sendFileHandler, localAddress, localPort, remoteAddress, remotePort, readEnd, writeEnd, cleanup) <- runAcceptFunc acceptFunc loopRestore `E.catches` handlers let threadLabel = S.concat [ "snap-server: client " , remoteAddress , ":" , S.pack $ show remotePort ] thMVar <- newEmptyMVar th <- TM.register tm threadLabel $ \restore -> eatException $ prep thMVar sendFileHandler localAddress localPort remoteAddress remotePort readEnd writeEnd cleanup restore putMVar thMVar th go prep :: MVar TM.TimeoutThread -> SendFileHandler -> ByteString -> Int -> ByteString -> Int -> InputStream ByteString -> OutputStream ByteString -> IO () -> (forall a . IO a -> IO a) -> IO () prep thMVar sendFileHandler localAddress localPort remoteAddress remotePort readEnd writeEnd cleanup restore = do connClose <- newIORef False newConn <- newIORef True let twiddleTimeout = unsafePerformIO $ do th <- readMVar thMVar return $! TM.modify th let cleanupTimeout = readMVar thMVar >>= TM.cancel let !psd = PerSessionData connClose twiddleTimeout newConn sendFileHandler localAddress localPort remoteAddress remotePort readEnd writeEnd restore (session psd) `E.finally` cleanup `E.finally` cleanupTimeout -------------------------------------------------------------------------- session psd = do buffer <- newBuffer defaultChunkSize httpSession buffer serverHandler serverConfig psd -------------------------------------------------------------------------- newLoop cpu = E.mask_ $ do -- TODO(greg): move constant into config tm <- TM.initialize (fromIntegral defaultTimeout) 2 getClockTime let threadLabel = S.concat [ "snap-server: accept loop #" , S.pack $ show cpu ] tid <- Thread.forkOn threadLabel cpu $ loop tm return $! EventLoopCpu tid tm -------------------------------------------------------------------------- waitLoop (EventLoopCpu tid _) = Thread.wait tid -------------------------------------------------------------------------- killLoop ev = E.uninterruptibleMask_ $ do Thread.cancelAndWait tid TM.stop tm where tid = _acceptThread ev tm = _timeoutManager ev ------------------------------------------------------------------------------ httpSession :: forall hookState . Buffer -> ServerHandler hookState -> ServerConfig hookState -> PerSessionData -> IO () httpSession !buffer !serverHandler !config !sessionData = loop where -------------------------------------------------------------------------- defaultTimeout = _defaultTimeout config isSecure = _isSecure config localHostname = _localHostname config logAccess = _logAccess config logError = _logError config newRequestHook = _onNewRequest config parseHook = _onParse config userHandlerFinishedHook = _onUserHandlerFinished config dataFinishedHook = _onDataFinished config exceptionHook = _onException config escapeHook = _onEscape config -------------------------------------------------------------------------- forceConnectionClose = _forceConnectionClose sessionData isNewConnection = _isNewConnection sessionData localAddress = _localAddress sessionData localPort = _localPort sessionData remoteAddress = _remoteAddress sessionData remotePort = _remotePort sessionData readEnd = _readEnd sessionData tickle f = _twiddleTimeout sessionData f writeEnd = _writeEnd sessionData sendfileHandler = _sendfileHandler sessionData -------------------------------------------------------------------------- mkBuffer :: IO (OutputStream Builder) mkBuffer = Streams.unsafeBuilderStream (return buffer) writeEnd -------------------------------------------------------------------------- -- Begin HTTP session processing. loop :: IO () loop = do -- peek first to ensure startHook gets generated at the right time. readEndAtEof >>= (flip unless $ do hookState <- newRequestHook sessionData >>= newIORef -- parse HTTP request req <- receiveRequest parseHook hookState req processRequest hookState req) ------------------------------------------------------------------------------ readEndAtEof = Streams.read readEnd >>= maybe (return True) (\c -> if S.null c then readEndAtEof else Streams.unRead c readEnd >> return False) {-# INLINE readEndAtEof #-} -------------------------------------------------------------------------- -- Read the HTTP request from the socket, parse it, and pre-process it. receiveRequest :: IO Request receiveRequest = {-# SCC "httpSession/receiveRequest" #-} do readEnd' <- Streams.throwIfProducesMoreThan mAX_HEADERS_SIZE readEnd parseRequest readEnd' >>= toRequest {-# INLINE receiveRequest #-} -------------------------------------------------------------------------- toRequest :: IRequest -> IO Request toRequest !ireq = {-# SCC "httpSession/toRequest" #-} do -- HTTP spec section 14.23: "All Internet-based HTTP/1.1 servers MUST -- respond with a 400 (Bad Request) status code to any HTTP/1.1 request -- message which lacks a Host header field." -- -- Here we interpret this slightly more liberally: if an absolute URI -- including a hostname is given in the request line, we'll take that -- if there's no Host header. -- -- For HTTP/1.0 requests, we pick the configured local hostname by -- default. host <- maybe (if isHttp11 then badRequestWithNoHost else return localHostname) return mbHost -- Call setupReadEnd, which handles transfer-encoding: chunked or -- content-length restrictions, etc !readEnd' <- setupReadEnd -- Parse an application/x-www-form-urlencoded form, if it was sent (!readEnd'', postParams) <- parseForm readEnd' let allParams = Map.unionWith (++) queryParams postParams -- Decide whether the connection should be closed after the response is -- sent (stored in the forceConnectionClose IORef). checkConnectionClose version $ getStdConnection stdHdrs -- The request is now ready for processing. return $! Request host remoteAddress remotePort localAddress localPort localHost isSecure hdrs readEnd'' mbCL method version cookies pathInfo contextPath uri queryString allParams queryParams postParams where ---------------------------------------------------------------------- !method = iMethod ireq !version = iHttpVersion ireq !stdHdrs = iStdHeaders ireq !hdrs = iRequestHeaders ireq !isHttp11 = version >= (1, 1) !mbHost = getStdHost stdHdrs !localHost = fromMaybe localHostname mbHost mbCL = unsafeFromNat <$> getStdContentLength stdHdrs !isChunked = (CI.mk <$> getStdTransferEncoding stdHdrs) == Just "chunked" cookies = fromMaybe [] (getStdCookie stdHdrs >>= parseCookie) contextPath = "/" !uri = iRequestUri ireq queryParams = parseUrlEncoded queryString emptyParams = Map.empty ---------------------------------------------------------------------- (pathInfo, queryString) = first dropLeadingSlash . second (S.drop 1) $ S.break (== '?') uri ---------------------------------------------------------------------- dropLeadingSlash s = if S.null s then s else let !a = S.unsafeIndex s 0 in if a == 47 -- 47 == '/' then S.unsafeDrop 1 s else s {-# INLINE dropLeadingSlash #-} ---------------------------------------------------------------------- -- | We have to transform the read end of the socket, to limit the -- number of bytes read to the content-length, to decode chunked -- transfer encoding, or to immediately yield EOF if the request body -- is empty. setupReadEnd :: IO (InputStream ByteString) setupReadEnd = if isChunked then readChunkedTransferEncoding readEnd else maybe (const noContentLength) (Streams.takeBytes . fromIntegral) mbCL readEnd {-# INLINE setupReadEnd #-} ---------------------------------------------------------------------- -- | If a request is not in chunked transfer encoding and lacks a -- content-length, the request body is null string. noContentLength :: IO (InputStream ByteString) noContentLength = do when (method == POST || method == PUT) return411 Streams.fromList [] ---------------------------------------------------------------------- return411 = do let (major, minor) = version let resp = mconcat [ byteString "HTTP/" , fromShow major , char8 '.' , fromShow minor , byteString " 411 Length Required\r\n\r\n" , byteString "411 Length Required\r\n" , flush ] writeEndB <- mkBuffer Streams.write (Just resp) writeEndB Streams.write Nothing writeEndB terminateSession LengthRequiredException ---------------------------------------------------------------------- parseForm readEnd' = if hasForm then getForm else return (readEnd', emptyParams) where trimIt = fst . S.spanEnd (== ' ') . S.takeWhile (/= ';') . S.dropWhile (== ' ') mbCT = trimIt <$> getStdContentType stdHdrs hasForm = mbCT == Just "application/x-www-form-urlencoded" mAX_POST_BODY_SIZE = 1024 * 1024 getForm = do readEnd'' <- Streams.throwIfProducesMoreThan mAX_POST_BODY_SIZE readEnd' contents <- S.concat <$> Streams.toList readEnd'' let postParams = parseUrlEncoded contents finalReadEnd <- Streams.fromList [contents] return (finalReadEnd, postParams) ---------------------------------------------------------------------- checkConnectionClose version connection = do -- For HTTP/1.1: if there is an explicit Connection: close, we'll close -- the socket later. -- -- For HTTP/1.0: if there is no explicit Connection: Keep-Alive, -- close the socket later. let v = CI.mk <$> connection when ((version == (1, 1) && v == Just "close") || (version == (1, 0) && v /= Just "keep-alive")) $ writeIORef forceConnectionClose True -------------------------------------------------------------------------- {-# INLINE badRequestWithNoHost #-} badRequestWithNoHost :: IO a badRequestWithNoHost = do let msg = mconcat [ byteString "HTTP/1.1 400 Bad Request\r\n\r\n" , byteString "400 Bad Request: HTTP/1.1 request with no " , byteString "Host header\r\n" , flush ] writeEndB <- mkBuffer Streams.write (Just msg) writeEndB Streams.write Nothing writeEndB terminateSession BadRequestException -------------------------------------------------------------------------- {-# INLINE checkExpect100Continue #-} checkExpect100Continue req = when (getHeader "expect" req == Just "100-continue") $ do let v = if rqVersion req == (1,1) then "HTTP/1.1" else "HTTP/1.0" let hl = byteString v <> byteString " 100 Continue\r\n\r\n" <> flush os <- mkBuffer Streams.write (Just hl) os -------------------------------------------------------------------------- {-# INLINE processRequest #-} processRequest !hookState !req = {-# SCC "httpSession/processRequest" #-} do -- successfully parsed a request, so restart the timer tickle $ max defaultTimeout -- check for Expect: 100-continue checkExpect100Continue req b <- runServerHandler hookState req `E.catches` [ Handler $ escapeSnapHandler hookState , Handler $ catchUserException hookState "user handler" req ] if b then do writeIORef isNewConnection False -- the timer resets to its default value here. loop else return $! () -------------------------------------------------------------------------- {-# INLINE runServerHandler #-} runServerHandler !hookState !req = {-# SCC "httpSession/runServerHandler" #-} do (req0, rsp0) <- serverHandler config sessionData req userHandlerFinishedHook hookState req rsp0 -- check whether we should close the connection after sending the -- response let v = rqVersion req let is_1_0 = (v == (1,0)) cc <- if is_1_0 && (isNothing $ rspContentLength rsp0) then return $! True else readIORef forceConnectionClose -- skip unread portion of request body if rspTransformingRqBody is not -- true unless (rspTransformingRqBody rsp0) $ Streams.skipToEof (rqBody req) !date <- getDateString rsp1 <- fixupResponse req rsp0 let (!hdrs, !cc') = addDateAndServerHeaders is_1_0 date cc $ headers rsp1 let rsp = updateHeaders (const hdrs) rsp1 writeIORef forceConnectionClose cc' bytesSent <- sendResponse req rsp `E.catch` catchUserException hookState "sending-response" req dataFinishedHook hookState req rsp logAccess req0 rsp bytesSent return $! not cc' -------------------------------------------------------------------------- addDateAndServerHeaders !is1_0 !date !cc !hdrs = {-# SCC "addDateAndServerHeaders" #-} let (!hdrs', !newcc) = go [("date",date)] False cc $ H.unsafeToCaseFoldedList hdrs in (H.unsafeFromCaseFoldedList hdrs', newcc) where -- N.B.: here we know the date header has already been removed by -- "fixupResponse". go !l !seenServer !connClose [] = let !l1 = if seenServer then l else (("server", sERVER_HEADER):l) !l2 = if connClose then (("connection", "close"):l1) else l1 in (l2, connClose) go l _ c (x@("server",_):xs) = go (x:l) True c xs go l seenServer c (x@("connection", v):xs) | c = go l seenServer c xs | v == "close" || (is1_0 && v /= "keep-alive") = go l seenServer True xs | otherwise = go (x:l) seenServer c xs go l seenServer c (x:xs) = go (x:l) seenServer c xs -------------------------------------------------------------------------- escapeSnapHandler hookState (EscapeHttp escapeHandler) = do escapeHook hookState mkBuffer >>= escapeHandler tickle readEnd return False escapeSnapHandler _ (TerminateConnection e) = terminateSession e -------------------------------------------------------------------------- catchUserException :: IORef hookState -> ByteString -> Request -> SomeException -> IO a catchUserException hookState phase req e = do logError $ mconcat [ byteString "Exception leaked to httpSession during phase '" , byteString phase , byteString "': \n" , requestErrorMessage req e ] -- Note: the handler passed to httpSession needs to catch its own -- exceptions if it wants to avoid an ungracious exit here. eatException $ exceptionHook hookState e terminateSession e -------------------------------------------------------------------------- sendResponse :: Request -> Response -> IO Word64 sendResponse !req !rsp = {-# SCC "httpSession/sendResponse" #-} do let !v = rqVersion req let !hdrs' = renderCookies rsp (headers rsp) let !code = rspStatus rsp let body = rspBody rsp let needChunked = rqMethod req /= HEAD && isNothing (rspContentLength rsp) && code /= 204 && code /= 304 let (hdrs'', body', shouldClose) = if needChunked then noCL req hdrs' body else (hdrs', body, False) when shouldClose $ writeIORef forceConnectionClose $! True let hdrPrim = mkHeaderPrim v rsp hdrs'' let hlen = size hdrPrim let headerBuilder = primFixed hdrPrim $! () nBodyBytes <- case body' of Stream s -> whenStream headerBuilder hlen rsp s SendFile f Nothing -> whenSendFile headerBuilder rsp f 0 -- ignore end length here because we know we had a -- content-length, use that instead. SendFile f (Just (st, _)) -> whenSendFile headerBuilder rsp f st return $! nBodyBytes -------------------------------------------------------------------------- noCL :: Request -> Headers -> ResponseBody -> (Headers, ResponseBody, Bool) noCL req hdrs body = if v == (1,1) then let origBody = rspBodyToEnum body body' = \os -> do os' <- writeChunkedTransferEncoding os origBody os' in ( H.set "transfer-encoding" "chunked" hdrs , Stream body' , False) else -- We've already noted that we have to close the socket earlier in -- runServerHandler. (hdrs, body, True) where v = rqVersion req {-# INLINE noCL #-} -------------------------------------------------------------------------- -- | If the response contains a content-length, make sure the response body -- StreamProc doesn't yield more (or fewer) than the given number of bytes. limitRspBody :: Int -- ^ header length -> Response -- ^ response -> OutputStream ByteString -- ^ write end of socket -> IO (OutputStream ByteString) limitRspBody hlen rsp os = maybe (return os) f $ rspContentLength rsp where f cl = Streams.giveExactly (fromIntegral hlen + fromIntegral cl) os {-# INLINE limitRspBody #-} -------------------------------------------------------------------------- whenStream :: Builder -- ^ headers -> Int -- ^ header length -> Response -- ^ response -> StreamProc -- ^ output body -> IO Word64 -- ^ returns number of bytes written whenStream headerString hlen rsp body = do -- note: -- -- * precondition here is that we have a content-length and that we're -- not using chunked transfer encoding. -- -- * "headerString" includes http status line. -- -- If you're transforming the request body, you have to manage your own -- timeouts. let t = if rspTransformingRqBody rsp then return $! () else tickle $ max defaultTimeout writeEnd0 <- Streams.ignoreEof writeEnd (writeEnd1, getCount) <- Streams.countOutput writeEnd0 writeEnd2 <- limitRspBody hlen rsp writeEnd1 writeEndB <- Streams.unsafeBuilderStream (return buffer) writeEnd2 >>= Streams.contramapM (\x -> t >> return x) Streams.write (Just headerString) writeEndB writeEnd' <- body writeEndB Streams.write Nothing writeEnd' -- Just in case the user handler didn't. Streams.write Nothing writeEnd1 n <- getCount return $! fromIntegral n - fromIntegral hlen {-# INLINE whenStream #-} -------------------------------------------------------------------------- whenSendFile :: Builder -- ^ headers -> Response -- ^ response -> FilePath -- ^ file to serve -> Word64 -- ^ file start offset -> IO Word64 -- ^ returns number of bytes written whenSendFile headerString rsp filePath offset = do let !cl = fromJust $ rspContentLength rsp sendfileHandler buffer headerString filePath offset cl return cl {-# INLINE whenSendFile #-} -------------------------------------------------------------------------- mkHeaderLine :: HttpVersion -> Response -> FixedPrim () mkHeaderLine outVer r = case outCode of 200 | outVer == (1, 1) -> -- typo in bytestring here fixedPrim 17 $ const (void . cpBS "HTTP/1.1 200 OK\r\n") 200 | otherwise -> fixedPrim 17 $ const (void . cpBS "HTTP/1.0 200 OK\r\n") _ -> fixedPrim len $ const (void . line) where outCode = rspStatus r v = if outVer == (1,1) then "HTTP/1.1 " else "HTTP/1.0 " outCodeStr = S.pack $ show outCode space !op = do pokeByteOff op 0 (32 :: Word8) return $! plusPtr op 1 line = cpBS v >=> cpBS outCodeStr >=> space >=> cpBS reason >=> crlfPoke reason = rspStatusReason r len = 12 + S.length outCodeStr + S.length reason ------------------------------------------------------------------------------ mkHeaderPrim :: HttpVersion -> Response -> Headers -> FixedPrim () mkHeaderPrim v r hdrs = mkHeaderLine v r <+> headersToPrim hdrs ------------------------------------------------------------------------------ infixl 4 <+> (<+>) :: FixedPrim () -> FixedPrim () -> FixedPrim () p1 <+> p2 = ignore >$< p1 >*< p2 where ignore = join (,) ------------------------------------------------------------------------------ {-# INLINE headersToPrim #-} headersToPrim :: Headers -> FixedPrim () headersToPrim hdrs = fixedPrim len (const copy) where len = H.foldedFoldl' f 0 hdrs + 2 where f l k v = l + S.length k + S.length v + 4 copy = go $ H.unsafeToCaseFoldedList hdrs go [] !op = void $ crlfPoke op go ((k,v):xs) !op = do !op' <- cpBS k op pokeByteOff op' 0 (58 :: Word8) -- colon pokeByteOff op' 1 (32 :: Word8) -- space !op'' <- cpBS v $ plusPtr op' 2 crlfPoke op'' >>= go xs {-# INLINE cpBS #-} cpBS :: ByteString -> Ptr Word8 -> IO (Ptr Word8) cpBS s !op = S.unsafeUseAsCStringLen s $ \(cstr, clen) -> do let !cl = fromIntegral clen copyBytes op (castPtr cstr) cl return $! plusPtr op cl {-# INLINE crlfPoke #-} crlfPoke :: Ptr Word8 -> IO (Ptr Word8) crlfPoke !op = do pokeByteOff op 0 (13 :: Word8) -- cr pokeByteOff op 1 (10 :: Word8) -- lf return $! plusPtr op 2 ------------------------------------------------------------------------------ sERVER_HEADER :: ByteString sERVER_HEADER = S.concat ["Snap/", snapServerVersion] ------------------------------------------------------------------------------ snapServerVersion :: ByteString snapServerVersion = S.pack $ showVersion $ V.version ------------------------------------------------------------------------------ terminateSession :: Exception e => e -> IO a terminateSession = E.throwIO . TerminateSessionException . SomeException ------------------------------------------------------------------------------ requestErrorMessage :: Request -> SomeException -> Builder requestErrorMessage req e = mconcat [ byteString "During processing of request from " , byteString $ rqClientAddr req , byteString ":" , fromShow $ rqClientPort req , byteString "\nrequest:\n" , fromShow $ show req , byteString "\n" , msgB ] where msgB = mconcat [ byteString "A web handler threw an exception. Details:\n" , fromShow e ] ------------------------------------------------------------------------------ -- | Convert 'Cookie' into 'ByteString' for output. cookieToBS :: Cookie -> ByteString cookieToBS (Cookie k v mbExpTime mbDomain mbPath isSec isHOnly) = cookie where cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly] path = maybe "" (S.append "; path=") mbPath domain = maybe "" (S.append "; domain=") mbDomain exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime secure = if isSec then "; Secure" else "" hOnly = if isHOnly then "; HttpOnly" else "" fmt = S.pack . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT" ------------------------------------------------------------------------------ renderCookies :: Response -> Headers -> Headers renderCookies r hdrs | null cookies = hdrs | otherwise = foldl' (\m v -> H.unsafeInsert "set-cookie" v m) hdrs cookies where cookies = fmap cookieToBS . Map.elems $ rspCookies r ------------------------------------------------------------------------------ fromShow :: Show a => a -> Builder fromShow = stringUtf8 . show