{-# 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, Int -> TerminateSessionException -> ShowS
[TerminateSessionException] -> ShowS
TerminateSessionException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TerminateSessionException] -> ShowS
$cshowList :: [TerminateSessionException] -> ShowS
show :: TerminateSessionException -> String
$cshow :: TerminateSessionException -> String
showsPrec :: Int -> TerminateSessionException -> ShowS
$cshowsPrec :: Int -> TerminateSessionException -> ShowS
Show)
instance Exception TerminateSessionException

data BadRequestException = BadRequestException
  deriving (Typeable, Int -> BadRequestException -> ShowS
[BadRequestException] -> ShowS
BadRequestException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadRequestException] -> ShowS
$cshowList :: [BadRequestException] -> ShowS
show :: BadRequestException -> String
$cshow :: BadRequestException -> String
showsPrec :: Int -> BadRequestException -> ShowS
$cshowsPrec :: Int -> BadRequestException -> ShowS
Show)
instance Exception BadRequestException

data LengthRequiredException = LengthRequiredException
  deriving (Typeable, Int -> LengthRequiredException -> ShowS
[LengthRequiredException] -> ShowS
LengthRequiredException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LengthRequiredException] -> ShowS
$cshowList :: [LengthRequiredException] -> ShowS
show :: LengthRequiredException -> String
$cshow :: LengthRequiredException -> String
showsPrec :: Int -> LengthRequiredException -> ShowS
$cshowsPrec :: Int -> LengthRequiredException -> ShowS
Show)
instance Exception LengthRequiredException


------------------------------------------------------------------------------
snapToServerHandler :: Snap a -> ServerHandler hookState
snapToServerHandler :: forall a hookState. Snap a -> ServerHandler hookState
snapToServerHandler !Snap a
snap !ServerConfig hookState
serverConfig !PerSessionData
perSessionData !Request
req =
    forall a.
Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
runSnap Snap a
snap ByteString -> IO ()
logErr (Int -> Int) -> IO ()
tickle Request
req
  where
    logErr :: ByteString -> IO ()
logErr = forall hookState. ServerConfig hookState -> Builder -> IO ()
_logError ServerConfig hookState
serverConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString
    tickle :: (Int -> Int) -> IO ()
tickle = PerSessionData -> (Int -> Int) -> IO ()
_twiddleTimeout PerSessionData
perSessionData


------------------------------------------------------------------------------
mAX_HEADERS_SIZE :: Int64
mAX_HEADERS_SIZE :: Int64
mAX_HEADERS_SIZE = Int64
256 forall a. Num a => a -> a -> a
* Int64
1024


------------------------------------------------------------------------------
-- | For each cpu, we store:
--    * An accept thread
--    * A TimeoutManager
--    * An mvar to signal when the timeout thread is shutdown
data EventLoopCpu = EventLoopCpu
    { EventLoopCpu -> SnapThread
_acceptThread   :: SnapThread
    , EventLoopCpu -> TimeoutManager
_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 :: forall hookState.
ServerHandler hookState
-> ServerConfig hookState -> AcceptFunc -> IO ()
httpAcceptLoop ServerHandler hookState
serverHandler ServerConfig hookState
serverConfig AcceptFunc
acceptFunc = IO ()
runLoops
  where
    --------------------------------------------------------------------------
    logError :: Builder -> IO ()
logError       = forall hookState. ServerConfig hookState -> Builder -> IO ()
_logError ServerConfig hookState
serverConfig
    nLoops :: Int
nLoops         = forall hookState. ServerConfig hookState -> Int
_numAcceptLoops ServerConfig hookState
serverConfig
    defaultTimeout :: Int
defaultTimeout = forall hookState. ServerConfig hookState -> Int
_defaultTimeout ServerConfig hookState
serverConfig

    --------------------------------------------------------------------------
    logException :: Exception e => e -> IO ()
    logException :: forall e. Exception e => e -> IO ()
logException e
e =
        Builder -> IO ()
logError forall a b. (a -> b) -> a -> b
$
        forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"got exception in httpAcceptFunc: "
                , forall a. Show a => a -> Builder
fromShow e
e
                ]

    --------------------------------------------------------------------------
    runLoops :: IO ()
runLoops = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> IO EventLoopCpu
newLoop [Int
0 .. (Int
nLoops forall a. Num a => a -> a -> a
- Int
1)])
                         (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ EventLoopCpu -> IO ()
killLoop)
                         (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ EventLoopCpu -> IO ()
waitLoop)

    --------------------------------------------------------------------------
    loop :: TimeoutManager
         -> (forall a. IO a -> IO a)
         -> IO ()
    loop :: TimeoutManager -> (forall a. IO a -> IO a) -> IO ()
loop TimeoutManager
tm forall a. IO a -> IO a
loopRestore = forall a. IO a -> IO ()
eatException IO
  (SendFileHandler, ByteString, Int, ByteString, Int,
   InputStream ByteString, OutputStream ByteString, IO ())
go
      where
        ----------------------------------------------------------------------
        handlers :: [Handler
   (SendFileHandler, ByteString, Int, ByteString, Int,
    InputStream ByteString, OutputStream ByteString, IO ())]
handlers =
            [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(AsyncException
e :: AsyncException) -> forall a. IO a -> IO a
loopRestore (forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$! AsyncException
e)
            , forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException)  -> forall e. Exception e => e -> IO ()
logException SomeException
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO
  (SendFileHandler, ByteString, Int, ByteString, Int,
   InputStream ByteString, OutputStream ByteString, IO ())
go
            ]

        go :: IO
  (SendFileHandler, ByteString, Int, ByteString, Int,
   InputStream ByteString, OutputStream ByteString, IO ())
go = do
            (SendFileHandler
sendFileHandler, ByteString
localAddress, Int
localPort, ByteString
remoteAddress,
             Int
remotePort, InputStream ByteString
readEnd, OutputStream ByteString
writeEnd,
             IO ()
cleanup) <- AcceptFunc
-> (forall a. IO a -> IO a)
-> IO
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
runAcceptFunc AcceptFunc
acceptFunc forall a. IO a -> IO a
loopRestore
                                       forall a. IO a -> [Handler a] -> IO a
`E.catches` [Handler
   (SendFileHandler, ByteString, Int, ByteString, Int,
    InputStream ByteString, OutputStream ByteString, IO ())]
handlers
            let threadLabel :: ByteString
threadLabel = [ByteString] -> ByteString
S.concat [ ByteString
"snap-server: client "
                                       , ByteString
remoteAddress
                                       , ByteString
":"
                                       , String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
remotePort
                                       ]
            MVar TimeoutThread
thMVar <- forall a. IO (MVar a)
newEmptyMVar
            TimeoutThread
th <- TimeoutManager
-> ByteString
-> ((forall a. IO a -> IO a) -> IO ())
-> IO TimeoutThread
TM.register TimeoutManager
tm ByteString
threadLabel forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore ->
                    forall a. IO a -> IO ()
eatException forall a b. (a -> b) -> a -> b
$
                    MVar TimeoutThread
-> SendFileHandler
-> ByteString
-> Int
-> ByteString
-> Int
-> InputStream ByteString
-> OutputStream ByteString
-> IO ()
-> (forall a. IO a -> IO a)
-> IO ()
prep MVar TimeoutThread
thMVar SendFileHandler
sendFileHandler ByteString
localAddress Int
localPort ByteString
remoteAddress
                         Int
remotePort InputStream ByteString
readEnd OutputStream ByteString
writeEnd IO ()
cleanup forall a. IO a -> IO a
restore
            forall a. MVar a -> a -> IO ()
putMVar MVar TimeoutThread
thMVar TimeoutThread
th
            IO
  (SendFileHandler, ByteString, Int, ByteString, Int,
   InputStream ByteString, OutputStream ByteString, IO ())
go

        prep :: MVar TM.TimeoutThread
             -> SendFileHandler
             -> ByteString
             -> Int
             -> ByteString
             -> Int
             -> InputStream ByteString
             -> OutputStream ByteString
             -> IO ()
             -> (forall a . IO a -> IO a)
             -> IO ()
        prep :: MVar TimeoutThread
-> SendFileHandler
-> ByteString
-> Int
-> ByteString
-> Int
-> InputStream ByteString
-> OutputStream ByteString
-> IO ()
-> (forall a. IO a -> IO a)
-> IO ()
prep MVar TimeoutThread
thMVar SendFileHandler
sendFileHandler ByteString
localAddress Int
localPort ByteString
remoteAddress
             Int
remotePort InputStream ByteString
readEnd OutputStream ByteString
writeEnd IO ()
cleanup forall a. IO a -> IO a
restore =
          do
            IORef Bool
connClose <- forall a. a -> IO (IORef a)
newIORef Bool
False
            IORef Bool
newConn   <- forall a. a -> IO (IORef a)
newIORef Bool
True
            let twiddleTimeout :: (Int -> Int) -> IO ()
twiddleTimeout = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
                                   TimeoutThread
th <- forall a. MVar a -> IO a
readMVar MVar TimeoutThread
thMVar
                                   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! TimeoutThread -> (Int -> Int) -> IO ()
TM.modify TimeoutThread
th
            let cleanupTimeout :: IO ()
cleanupTimeout = forall a. MVar a -> IO a
readMVar MVar TimeoutThread
thMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TimeoutThread -> IO ()
TM.cancel

            let !psd :: PerSessionData
psd = IORef Bool
-> ((Int -> Int) -> IO ())
-> IORef Bool
-> SendFileHandler
-> ByteString
-> Int
-> ByteString
-> Int
-> InputStream ByteString
-> OutputStream ByteString
-> PerSessionData
PerSessionData IORef Bool
connClose
                                      (Int -> Int) -> IO ()
twiddleTimeout
                                      IORef Bool
newConn
                                      SendFileHandler
sendFileHandler
                                      ByteString
localAddress
                                      Int
localPort
                                      ByteString
remoteAddress
                                      Int
remotePort
                                      InputStream ByteString
readEnd
                                      OutputStream ByteString
writeEnd
            forall a. IO a -> IO a
restore (PerSessionData -> IO ()
session PerSessionData
psd)
                forall a b. IO a -> IO b -> IO a
`E.finally` IO ()
cleanup
                forall a b. IO a -> IO b -> IO a
`E.finally` IO ()
cleanupTimeout

    --------------------------------------------------------------------------
    session :: PerSessionData -> IO ()
session PerSessionData
psd = do
        Buffer
buffer <- Int -> IO Buffer
newBuffer Int
defaultChunkSize
        forall hookState.
Buffer
-> ServerHandler hookState
-> ServerConfig hookState
-> PerSessionData
-> IO ()
httpSession Buffer
buffer ServerHandler hookState
serverHandler ServerConfig hookState
serverConfig PerSessionData
psd

    --------------------------------------------------------------------------
    newLoop :: Int -> IO EventLoopCpu
newLoop Int
cpu = forall a. IO a -> IO a
E.mask_ forall a b. (a -> b) -> a -> b
$ do
        -- TODO(greg): move constant into config
        TimeoutManager
tm  <- Double -> Double -> IO ClockTime -> IO TimeoutManager
TM.initialize (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultTimeout) Double
2 IO ClockTime
getClockTime
        let threadLabel :: ByteString
threadLabel = [ByteString] -> ByteString
S.concat [ ByteString
"snap-server: accept loop #"
                                   , String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
cpu
                                   ]

        SnapThread
tid <- ByteString
-> Int -> ((forall a. IO a -> IO a) -> IO ()) -> IO SnapThread
Thread.forkOn ByteString
threadLabel Int
cpu forall a b. (a -> b) -> a -> b
$ TimeoutManager -> (forall a. IO a -> IO a) -> IO ()
loop TimeoutManager
tm
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! SnapThread -> TimeoutManager -> EventLoopCpu
EventLoopCpu SnapThread
tid TimeoutManager
tm

    --------------------------------------------------------------------------
    waitLoop :: EventLoopCpu -> IO ()
waitLoop (EventLoopCpu SnapThread
tid TimeoutManager
_) = SnapThread -> IO ()
Thread.wait SnapThread
tid

    --------------------------------------------------------------------------
    killLoop :: EventLoopCpu -> IO ()
killLoop EventLoopCpu
ev = forall a. IO a -> IO a
E.uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ do
        SnapThread -> IO ()
Thread.cancelAndWait SnapThread
tid
        TimeoutManager -> IO ()
TM.stop TimeoutManager
tm
      where
        tid :: SnapThread
tid = EventLoopCpu -> SnapThread
_acceptThread EventLoopCpu
ev
        tm :: TimeoutManager
tm  = EventLoopCpu -> TimeoutManager
_timeoutManager EventLoopCpu
ev

------------------------------------------------------------------------------
httpSession :: forall hookState .
               Buffer
            -> ServerHandler hookState
            -> ServerConfig hookState
            -> PerSessionData
            -> IO ()
httpSession :: forall hookState.
Buffer
-> ServerHandler hookState
-> ServerConfig hookState
-> PerSessionData
-> IO ()
httpSession !Buffer
buffer !ServerHandler hookState
serverHandler !ServerConfig hookState
config !PerSessionData
sessionData = IO ()
loop
  where
    --------------------------------------------------------------------------
    defaultTimeout :: Int
defaultTimeout          = forall hookState. ServerConfig hookState -> Int
_defaultTimeout ServerConfig hookState
config
    isSecure :: Bool
isSecure                = forall hookState. ServerConfig hookState -> Bool
_isSecure ServerConfig hookState
config
    localHostname :: ByteString
localHostname           = forall hookState. ServerConfig hookState -> ByteString
_localHostname ServerConfig hookState
config
    logAccess :: Request -> Response -> Word64 -> IO ()
logAccess               = forall hookState.
ServerConfig hookState -> Request -> Response -> Word64 -> IO ()
_logAccess ServerConfig hookState
config
    logError :: Builder -> IO ()
logError                = forall hookState. ServerConfig hookState -> Builder -> IO ()
_logError ServerConfig hookState
config
    newRequestHook :: NewRequestHook hookState
newRequestHook          = forall hookState.
ServerConfig hookState -> NewRequestHook hookState
_onNewRequest ServerConfig hookState
config
    parseHook :: ParseHook hookState
parseHook               = forall hookState. ServerConfig hookState -> ParseHook hookState
_onParse ServerConfig hookState
config
    userHandlerFinishedHook :: UserHandlerFinishedHook hookState
userHandlerFinishedHook = forall hookState.
ServerConfig hookState -> UserHandlerFinishedHook hookState
_onUserHandlerFinished ServerConfig hookState
config
    dataFinishedHook :: UserHandlerFinishedHook hookState
dataFinishedHook        = forall hookState.
ServerConfig hookState -> UserHandlerFinishedHook hookState
_onDataFinished ServerConfig hookState
config
    exceptionHook :: ExceptionHook hookState
exceptionHook           = forall hookState. ServerConfig hookState -> ExceptionHook hookState
_onException ServerConfig hookState
config
    escapeHook :: EscapeSnapHook hookState
escapeHook              = forall hookState.
ServerConfig hookState -> EscapeSnapHook hookState
_onEscape ServerConfig hookState
config

    --------------------------------------------------------------------------
    forceConnectionClose :: IORef Bool
forceConnectionClose    = PerSessionData -> IORef Bool
_forceConnectionClose PerSessionData
sessionData
    isNewConnection :: IORef Bool
isNewConnection         = PerSessionData -> IORef Bool
_isNewConnection PerSessionData
sessionData
    localAddress :: ByteString
localAddress            = PerSessionData -> ByteString
_localAddress PerSessionData
sessionData
    localPort :: Int
localPort               = PerSessionData -> Int
_localPort PerSessionData
sessionData
    remoteAddress :: ByteString
remoteAddress           = PerSessionData -> ByteString
_remoteAddress PerSessionData
sessionData
    remotePort :: Int
remotePort              = PerSessionData -> Int
_remotePort PerSessionData
sessionData
    readEnd :: InputStream ByteString
readEnd                 = PerSessionData -> InputStream ByteString
_readEnd PerSessionData
sessionData
    tickle :: (Int -> Int) -> IO ()
tickle Int -> Int
f                = PerSessionData -> (Int -> Int) -> IO ()
_twiddleTimeout PerSessionData
sessionData Int -> Int
f
    writeEnd :: OutputStream ByteString
writeEnd                = PerSessionData -> OutputStream ByteString
_writeEnd PerSessionData
sessionData
    sendfileHandler :: SendFileHandler
sendfileHandler         = PerSessionData -> SendFileHandler
_sendfileHandler PerSessionData
sessionData

    --------------------------------------------------------------------------
    mkBuffer :: IO (OutputStream Builder)
    mkBuffer :: IO (OutputStream Builder)
mkBuffer = IO Buffer -> OutputStream ByteString -> IO (OutputStream Builder)
Streams.unsafeBuilderStream (forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
buffer) OutputStream ByteString
writeEnd

    --------------------------------------------------------------------------
    -- Begin HTTP session processing.
    loop :: IO ()
    loop :: IO ()
loop = do
        -- peek first to ensure startHook gets generated at the right time.
        IO Bool
readEndAtEof forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless forall a b. (a -> b) -> a -> b
$ do
            IORef hookState
hookState <- NewRequestHook hookState
newRequestHook PerSessionData
sessionData forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (IORef a)
newIORef
            -- parse HTTP request
            Request
req <- IO Request
receiveRequest
            ParseHook hookState
parseHook IORef hookState
hookState Request
req
            ParseHook hookState
processRequest IORef hookState
hookState Request
req)

    ------------------------------------------------------------------------------
    readEndAtEof :: IO Bool
readEndAtEof = forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
readEnd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
                         (\ByteString
c -> if ByteString -> Bool
S.null ByteString
c
                                  then IO Bool
readEndAtEof
                                  else forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
c InputStream ByteString
readEnd forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
    {-# INLINE readEndAtEof #-}

    --------------------------------------------------------------------------
    -- Read the HTTP request from the socket, parse it, and pre-process it.
    receiveRequest :: IO Request
    receiveRequest :: IO Request
receiveRequest = {-# SCC "httpSession/receiveRequest" #-} do
        InputStream ByteString
readEnd' <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
mAX_HEADERS_SIZE InputStream ByteString
readEnd
        InputStream ByteString -> IO IRequest
parseRequest InputStream ByteString
readEnd' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IRequest -> IO Request
toRequest
    {-# INLINE receiveRequest #-}

    --------------------------------------------------------------------------
    toRequest :: IRequest -> IO Request
    toRequest :: IRequest -> IO Request
toRequest !IRequest
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.
        ByteString
host <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if Bool
isHttp11
                         then forall a. IO a
badRequestWithNoHost
                         else forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
localHostname)
                      forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
mbHost

        -- Call setupReadEnd, which handles transfer-encoding: chunked or
        -- content-length restrictions, etc
        !InputStream ByteString
readEnd' <- IO (InputStream ByteString)
setupReadEnd

        -- Parse an application/x-www-form-urlencoded form, if it was sent
        (!InputStream ByteString
readEnd'', Map ByteString [ByteString]
postParams) <- InputStream ByteString
-> IO (InputStream ByteString, Map ByteString [ByteString])
parseForm InputStream ByteString
readEnd'

        let allParams :: Map ByteString [ByteString]
allParams = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. [a] -> [a] -> [a]
(++) Map ByteString [ByteString]
queryParams Map ByteString [ByteString]
postParams

        -- Decide whether the connection should be closed after the response is
        -- sent (stored in the forceConnectionClose IORef).
        forall {a} {b} {a}.
(Num a, Num b, Eq a, Eq b, Eq a, IsString a, FoldCase a) =>
(a, b) -> Maybe a -> IO ()
checkConnectionClose HttpVersion
version forall a b. (a -> b) -> a -> b
$ StandardHeaders -> Maybe ByteString
getStdConnection StandardHeaders
stdHdrs

        -- The request is now ready for processing.
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString
-> ByteString
-> Int
-> ByteString
-> Int
-> ByteString
-> Bool
-> Headers
-> InputStream ByteString
-> Maybe Word64
-> Method
-> HttpVersion
-> [Cookie]
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> Map ByteString [ByteString]
-> Map ByteString [ByteString]
-> Map ByteString [ByteString]
-> Request
Request ByteString
host
                          ByteString
remoteAddress
                          Int
remotePort
                          ByteString
localAddress
                          Int
localPort
                          ByteString
localHost
                          Bool
isSecure
                          Headers
hdrs
                          InputStream ByteString
readEnd''
                          Maybe Word64
mbCL
                          Method
method
                          HttpVersion
version
                          [Cookie]
cookies
                          ByteString
pathInfo
                          ByteString
contextPath
                          ByteString
uri
                          ByteString
queryString
                          Map ByteString [ByteString]
allParams
                          Map ByteString [ByteString]
queryParams
                          Map ByteString [ByteString]
postParams

      where
        ----------------------------------------------------------------------
        !method :: Method
method       = IRequest -> Method
iMethod IRequest
ireq
        !version :: HttpVersion
version      = IRequest -> HttpVersion
iHttpVersion IRequest
ireq
        !stdHdrs :: StandardHeaders
stdHdrs      = IRequest -> StandardHeaders
iStdHeaders IRequest
ireq
        !hdrs :: Headers
hdrs         = IRequest -> Headers
iRequestHeaders IRequest
ireq

        !isHttp11 :: Bool
isHttp11     = HttpVersion
version forall a. Ord a => a -> a -> Bool
>= (Int
1, Int
1)

        !mbHost :: Maybe ByteString
mbHost       = StandardHeaders -> Maybe ByteString
getStdHost StandardHeaders
stdHdrs
        !localHost :: ByteString
localHost    = forall a. a -> Maybe a -> a
fromMaybe ByteString
localHostname Maybe ByteString
mbHost
        mbCL :: Maybe Word64
mbCL          = forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        StandardHeaders -> Maybe ByteString
getStdContentLength StandardHeaders
stdHdrs
        !isChunked :: Bool
isChunked    = (forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StandardHeaders -> Maybe ByteString
getStdTransferEncoding StandardHeaders
stdHdrs)
                            forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just CI ByteString
"chunked"
        cookies :: [Cookie]
cookies       = forall a. a -> Maybe a -> a
fromMaybe [] (StandardHeaders -> Maybe ByteString
getStdCookie StandardHeaders
stdHdrs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe [Cookie]
parseCookie)
        contextPath :: ByteString
contextPath   = ByteString
"/"
        !uri :: ByteString
uri          = IRequest -> ByteString
iRequestUri IRequest
ireq
        queryParams :: Map ByteString [ByteString]
queryParams   = ByteString -> Map ByteString [ByteString]
parseUrlEncoded ByteString
queryString
        emptyParams :: Map k a
emptyParams   = forall k a. Map k a
Map.empty

        ----------------------------------------------------------------------
        (ByteString
pathInfo, ByteString
queryString) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> ByteString
dropLeadingSlash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> ByteString -> ByteString
S.drop Int
1)
                                    forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (forall a. Eq a => a -> a -> Bool
== Char
'?') ByteString
uri

        ----------------------------------------------------------------------
        dropLeadingSlash :: ByteString -> ByteString
dropLeadingSlash ByteString
s = if ByteString -> Bool
S.null ByteString
s
                               then ByteString
s
                               else let !a :: Word8
a = ByteString -> Int -> Word8
S.unsafeIndex ByteString
s Int
0
                                    in if Word8
a forall a. Eq a => a -> a -> Bool
== Word8
47   -- 47 == '/'
                                         then Int -> ByteString -> ByteString
S.unsafeDrop Int
1 ByteString
s
                                         else ByteString
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 :: IO (InputStream ByteString)
setupReadEnd =
            if Bool
isChunked
              then InputStream ByteString -> IO (InputStream ByteString)
readChunkedTransferEncoding InputStream ByteString
readEnd
              else forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> b -> a
const IO (InputStream ByteString)
noContentLength)
                         (Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.takeBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Word64
mbCL InputStream ByteString
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 :: IO (InputStream ByteString)
noContentLength = do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Method
method forall a. Eq a => a -> a -> Bool
== Method
POST Bool -> Bool -> Bool
|| Method
method forall a. Eq a => a -> a -> Bool
== Method
PUT) forall a. IO a
return411
            forall c. [c] -> IO (InputStream c)
Streams.fromList []

        ----------------------------------------------------------------------
        return411 :: IO b
return411 = do
            let (Int
major, Int
minor) = HttpVersion
version
            let resp :: Builder
resp = forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"HTTP/"
                               , forall a. Show a => a -> Builder
fromShow Int
major
                               , Char -> Builder
char8 Char
'.'
                               , forall a. Show a => a -> Builder
fromShow Int
minor
                               , ByteString -> Builder
byteString ByteString
" 411 Length Required\r\n\r\n"
                               , ByteString -> Builder
byteString ByteString
"411 Length Required\r\n"
                               , Builder
flush
                               ]
            OutputStream Builder
writeEndB <- IO (OutputStream Builder)
mkBuffer
            forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
resp) OutputStream Builder
writeEndB
            forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream Builder
writeEndB
            forall e a. Exception e => e -> IO a
terminateSession LengthRequiredException
LengthRequiredException

        ----------------------------------------------------------------------
        parseForm :: InputStream ByteString
-> IO (InputStream ByteString, Map ByteString [ByteString])
parseForm InputStream ByteString
readEnd' = if Bool
hasForm
                               then IO (InputStream ByteString, Map ByteString [ByteString])
getForm
                               else forall (m :: * -> *) a. Monad m => a -> m a
return (InputStream ByteString
readEnd', forall k a. Map k a
emptyParams)
          where
            trimIt :: ByteString -> ByteString
trimIt  = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.spanEnd (forall a. Eq a => a -> a -> Bool
== Char
' ') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
';')
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
' ')
            mbCT :: Maybe ByteString
mbCT    = ByteString -> ByteString
trimIt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StandardHeaders -> Maybe ByteString
getStdContentType StandardHeaders
stdHdrs
            hasForm :: Bool
hasForm = Maybe ByteString
mbCT forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
"application/x-www-form-urlencoded"

            mAX_POST_BODY_SIZE :: Int64
mAX_POST_BODY_SIZE = Int64
1024 forall a. Num a => a -> a -> a
* Int64
1024

            getForm :: IO (InputStream ByteString, Map ByteString [ByteString])
getForm = do
                InputStream ByteString
readEnd'' <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan
                               Int64
mAX_POST_BODY_SIZE InputStream ByteString
readEnd'
                ByteString
contents  <- [ByteString] -> ByteString
S.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. InputStream a -> IO [a]
Streams.toList InputStream ByteString
readEnd''
                let postParams :: Map ByteString [ByteString]
postParams = ByteString -> Map ByteString [ByteString]
parseUrlEncoded ByteString
contents
                InputStream ByteString
finalReadEnd <- forall c. [c] -> IO (InputStream c)
Streams.fromList [ByteString
contents]
                forall (m :: * -> *) a. Monad m => a -> m a
return (InputStream ByteString
finalReadEnd, Map ByteString [ByteString]
postParams)

    ----------------------------------------------------------------------
    checkConnectionClose :: (a, b) -> Maybe a -> IO ()
checkConnectionClose (a, b)
version Maybe a
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 :: Maybe (CI a)
v = forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
connection
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (((a, b)
version forall a. Eq a => a -> a -> Bool
== (a
1, b
1) Bool -> Bool -> Bool
&& Maybe (CI a)
v forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just CI a
"close") Bool -> Bool -> Bool
||
              ((a, b)
version forall a. Eq a => a -> a -> Bool
== (a
1, b
0) Bool -> Bool -> Bool
&& Maybe (CI a)
v forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just CI a
"keep-alive")) forall a b. (a -> b) -> a -> b
$
              forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
forceConnectionClose Bool
True

    --------------------------------------------------------------------------
    {-# INLINE badRequestWithNoHost #-}
    badRequestWithNoHost :: IO a
    badRequestWithNoHost :: forall a. IO a
badRequestWithNoHost = do
        let msg :: Builder
msg = forall a. Monoid a => [a] -> a
mconcat [
                    ByteString -> Builder
byteString ByteString
"HTTP/1.1 400 Bad Request\r\n\r\n"
                  , ByteString -> Builder
byteString ByteString
"400 Bad Request: HTTP/1.1 request with no "
                  , ByteString -> Builder
byteString ByteString
"Host header\r\n"
                  , Builder
flush
                  ]
        OutputStream Builder
writeEndB <- IO (OutputStream Builder)
mkBuffer
        forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
msg) OutputStream Builder
writeEndB
        forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream Builder
writeEndB
        forall e a. Exception e => e -> IO a
terminateSession BadRequestException
BadRequestException

    --------------------------------------------------------------------------
    {-# INLINE checkExpect100Continue #-}
    checkExpect100Continue :: Request -> IO ()
checkExpect100Continue Request
req =
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"expect" Request
req forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
"100-continue") forall a b. (a -> b) -> a -> b
$ do
            let v :: ByteString
v = if Request -> HttpVersion
rqVersion Request
req forall a. Eq a => a -> a -> Bool
== (Int
1,Int
1) then ByteString
"HTTP/1.1" else ByteString
"HTTP/1.0"

            let hl :: Builder
hl = ByteString -> Builder
byteString ByteString
v                       forall a. Semigroup a => a -> a -> a
<>
                     ByteString -> Builder
byteString ByteString
" 100 Continue\r\n\r\n" forall a. Semigroup a => a -> a -> a
<>
                     Builder
flush
            OutputStream Builder
os <- IO (OutputStream Builder)
mkBuffer
            forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
hl) OutputStream Builder
os

    --------------------------------------------------------------------------
    {-# INLINE processRequest #-}
    processRequest :: ParseHook hookState
processRequest !IORef hookState
hookState !Request
req = {-# SCC "httpSession/processRequest" #-} do
        -- successfully parsed a request, so restart the timer
        (Int -> Int) -> IO ()
tickle forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
defaultTimeout

        -- check for Expect: 100-continue
        Request -> IO ()
checkExpect100Continue Request
req
        Bool
b <- IORef hookState -> Request -> IO Bool
runServerHandler IORef hookState
hookState Request
req
               forall a. IO a -> [Handler a] -> IO a
`E.catches` [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ IORef hookState -> EscapeSnap -> IO Bool
escapeSnapHandler IORef hookState
hookState
                           , forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$
                             forall a.
IORef hookState -> ByteString -> Request -> SomeException -> IO a
catchUserException IORef hookState
hookState ByteString
"user handler" Request
req
                           ]
        if Bool
b
          then do forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
isNewConnection Bool
False
                  -- the timer resets to its default value here.
                  IO ()
loop
          else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()

    --------------------------------------------------------------------------
    {-# INLINE runServerHandler #-}
    runServerHandler :: IORef hookState -> Request -> IO Bool
runServerHandler !IORef hookState
hookState !Request
req = {-# SCC "httpSession/runServerHandler" #-} do
        (Request
req0, Response
rsp0) <- ServerHandler hookState
serverHandler ServerConfig hookState
config PerSessionData
sessionData Request
req
        UserHandlerFinishedHook hookState
userHandlerFinishedHook IORef hookState
hookState Request
req Response
rsp0

        -- check whether we should close the connection after sending the
        -- response
        let v :: HttpVersion
v      = Request -> HttpVersion
rqVersion Request
req
        let is_1_0 :: Bool
is_1_0 = (HttpVersion
v forall a. Eq a => a -> a -> Bool
== (Int
1,Int
0))
        Bool
cc <- if Bool
is_1_0 Bool -> Bool -> Bool
&& (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Response -> Maybe Word64
rspContentLength Response
rsp0)
                then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Bool
True
                else forall a. IORef a -> IO a
readIORef IORef Bool
forceConnectionClose

        -- skip unread portion of request body if rspTransformingRqBody is not
        -- true
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Response -> Bool
rspTransformingRqBody Response
rsp0) forall a b. (a -> b) -> a -> b
$ forall a. InputStream a -> IO ()
Streams.skipToEof (Request -> InputStream ByteString
rqBody Request
req)

        !ByteString
date <- IO ByteString
getDateString
        Response
rsp1  <- Request -> Response -> IO Response
fixupResponse Request
req Response
rsp0
        let (!Headers
hdrs, !Bool
cc') = Bool -> ByteString -> Bool -> Headers -> (Headers, Bool)
addDateAndServerHeaders Bool
is_1_0 ByteString
date Bool
cc forall a b. (a -> b) -> a -> b
$
                            forall a. HasHeaders a => a -> Headers
headers Response
rsp1
        let rsp :: Response
rsp = forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders (forall a b. a -> b -> a
const Headers
hdrs) Response
rsp1
        forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
forceConnectionClose Bool
cc'
        Word64
bytesSent <- Request -> Response -> IO Word64
sendResponse Request
req Response
rsp forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch`
                     forall a.
IORef hookState -> ByteString -> Request -> SomeException -> IO a
catchUserException IORef hookState
hookState ByteString
"sending-response" Request
req
        UserHandlerFinishedHook hookState
dataFinishedHook IORef hookState
hookState Request
req Response
rsp
        Request -> Response -> Word64 -> IO ()
logAccess Request
req0 Response
rsp Word64
bytesSent
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Bool -> Bool
not Bool
cc'

    --------------------------------------------------------------------------
    addDateAndServerHeaders :: Bool -> ByteString -> Bool -> Headers -> (Headers, Bool)
addDateAndServerHeaders !Bool
is1_0 !ByteString
date !Bool
cc !Headers
hdrs =
        {-# SCC "addDateAndServerHeaders" #-}
        let (![(ByteString, ByteString)]
hdrs', !Bool
newcc) = forall {a}.
(Eq a, IsString a) =>
[(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go [(ByteString
"date",ByteString
date)] Bool
False Bool
cc
                                 forall a b. (a -> b) -> a -> b
$ Headers -> [(ByteString, ByteString)]
H.unsafeToCaseFoldedList Headers
hdrs
        in ([(ByteString, ByteString)] -> Headers
H.unsafeFromCaseFoldedList [(ByteString, ByteString)]
hdrs', Bool
newcc)
      where
        -- N.B.: here we know the date header has already been removed by
        -- "fixupResponse".
        go :: [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go ![(a, ByteString)]
l !Bool
seenServer !Bool
connClose [] =
            let !l1 :: [(a, ByteString)]
l1 = if Bool
seenServer then [(a, ByteString)]
l else ((a
"server", ByteString
sERVER_HEADER)forall a. a -> [a] -> [a]
:[(a, ByteString)]
l)
                !l2 :: [(a, ByteString)]
l2 = if Bool
connClose then ((a
"connection", ByteString
"close")forall a. a -> [a] -> [a]
:[(a, ByteString)]
l1) else [(a, ByteString)]
l1
            in ([(a, ByteString)]
l2, Bool
connClose)
        go [(a, ByteString)]
l Bool
_ Bool
c (x :: (a, ByteString)
x@(a
"server",ByteString
_):[(a, ByteString)]
xs) = [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go ((a, ByteString)
xforall a. a -> [a] -> [a]
:[(a, ByteString)]
l) Bool
True Bool
c [(a, ByteString)]
xs
        go [(a, ByteString)]
l Bool
seenServer Bool
c (x :: (a, ByteString)
x@(a
"connection", ByteString
v):[(a, ByteString)]
xs)
              | Bool
c = [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go [(a, ByteString)]
l Bool
seenServer Bool
c [(a, ByteString)]
xs
              | ByteString
v forall a. Eq a => a -> a -> Bool
== ByteString
"close" Bool -> Bool -> Bool
|| (Bool
is1_0 Bool -> Bool -> Bool
&& ByteString
v forall a. Eq a => a -> a -> Bool
/= ByteString
"keep-alive") =
                     [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go [(a, ByteString)]
l Bool
seenServer Bool
True [(a, ByteString)]
xs
              | Bool
otherwise = [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go ((a, ByteString)
xforall a. a -> [a] -> [a]
:[(a, ByteString)]
l) Bool
seenServer Bool
c [(a, ByteString)]
xs
        go [(a, ByteString)]
l Bool
seenServer Bool
c ((a, ByteString)
x:[(a, ByteString)]
xs) = [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go ((a, ByteString)
xforall a. a -> [a] -> [a]
:[(a, ByteString)]
l) Bool
seenServer Bool
c [(a, ByteString)]
xs

    --------------------------------------------------------------------------
    escapeSnapHandler :: IORef hookState -> EscapeSnap -> IO Bool
escapeSnapHandler IORef hookState
hookState (EscapeHttp EscapeHttpHandler
escapeHandler) = do
        EscapeSnapHook hookState
escapeHook IORef hookState
hookState
        IO (OutputStream Builder)
mkBuffer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EscapeHttpHandler
escapeHandler (Int -> Int) -> IO ()
tickle InputStream ByteString
readEnd
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    escapeSnapHandler IORef hookState
_ (TerminateConnection SomeException
e) = forall e a. Exception e => e -> IO a
terminateSession SomeException
e

    --------------------------------------------------------------------------
    catchUserException :: IORef hookState
                       -> ByteString
                       -> Request
                       -> SomeException
                       -> IO a
    catchUserException :: forall a.
IORef hookState -> ByteString -> Request -> SomeException -> IO a
catchUserException IORef hookState
hookState ByteString
phase Request
req SomeException
e = do
        Builder -> IO ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [
            ByteString -> Builder
byteString ByteString
"Exception leaked to httpSession during phase '"
          , ByteString -> Builder
byteString ByteString
phase
          , ByteString -> Builder
byteString ByteString
"': \n"
          , Request -> SomeException -> Builder
requestErrorMessage Request
req SomeException
e
          ]
        -- Note: the handler passed to httpSession needs to catch its own
        -- exceptions if it wants to avoid an ungracious exit here.
        forall a. IO a -> IO ()
eatException forall a b. (a -> b) -> a -> b
$ ExceptionHook hookState
exceptionHook IORef hookState
hookState SomeException
e
        forall e a. Exception e => e -> IO a
terminateSession SomeException
e

    --------------------------------------------------------------------------
    sendResponse :: Request -> Response -> IO Word64
    sendResponse :: Request -> Response -> IO Word64
sendResponse !Request
req !Response
rsp = {-# SCC "httpSession/sendResponse" #-} do
        let !v :: HttpVersion
v          = Request -> HttpVersion
rqVersion Request
req
        let !hdrs' :: Headers
hdrs'      = Response -> Headers -> Headers
renderCookies Response
rsp (forall a. HasHeaders a => a -> Headers
headers Response
rsp)
        let !code :: Int
code       = Response -> Int
rspStatus Response
rsp
        let body :: ResponseBody
body        = Response -> ResponseBody
rspBody Response
rsp
        let needChunked :: Bool
needChunked = Request -> Method
rqMethod Request
req forall a. Eq a => a -> a -> Bool
/= Method
HEAD
                            Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (Response -> Maybe Word64
rspContentLength Response
rsp)
                            Bool -> Bool -> Bool
&& Int
code forall a. Eq a => a -> a -> Bool
/= Int
204
                            Bool -> Bool -> Bool
&& Int
code forall a. Eq a => a -> a -> Bool
/= Int
304

        let (Headers
hdrs'', ResponseBody
body', Bool
shouldClose) = if Bool
needChunked
                                             then Request -> Headers -> ResponseBody -> (Headers, ResponseBody, Bool)
noCL Request
req Headers
hdrs' ResponseBody
body
                                             else (Headers
hdrs', ResponseBody
body, Bool
False)

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldClose forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
forceConnectionClose forall a b. (a -> b) -> a -> b
$! Bool
True
        let hdrPrim :: FixedPrim ()
hdrPrim       = HttpVersion -> Response -> Headers -> FixedPrim ()
mkHeaderPrim HttpVersion
v Response
rsp Headers
hdrs''
        let hlen :: Int
hlen          = forall a. FixedPrim a -> Int
size FixedPrim ()
hdrPrim
        let headerBuilder :: Builder
headerBuilder = forall a. FixedPrim a -> a -> Builder
primFixed FixedPrim ()
hdrPrim forall a b. (a -> b) -> a -> b
$! ()

        Word64
nBodyBytes <- case ResponseBody
body' of
                        Stream StreamProc
s ->
                            Builder -> Int -> Response -> StreamProc -> IO Word64
whenStream Builder
headerBuilder Int
hlen Response
rsp StreamProc
s
                        SendFile String
f Maybe (Word64, Word64)
Nothing ->
                            Builder -> Response -> String -> Word64 -> IO Word64
whenSendFile Builder
headerBuilder Response
rsp String
f Word64
0
                        -- ignore end length here because we know we had a
                        -- content-length, use that instead.
                        SendFile String
f (Just (Word64
st, Word64
_)) ->
                            Builder -> Response -> String -> Word64 -> IO Word64
whenSendFile Builder
headerBuilder Response
rsp String
f Word64
st
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Word64
nBodyBytes

    --------------------------------------------------------------------------
    noCL :: Request
         -> Headers
         -> ResponseBody
         -> (Headers, ResponseBody, Bool)
    noCL :: Request -> Headers -> ResponseBody -> (Headers, ResponseBody, Bool)
noCL Request
req Headers
hdrs ResponseBody
body =
        if HttpVersion
v forall a. Eq a => a -> a -> Bool
== (Int
1,Int
1)
          then let origBody :: StreamProc
origBody = ResponseBody -> StreamProc
rspBodyToEnum ResponseBody
body
                   body' :: StreamProc
body'    = \OutputStream Builder
os -> do
                                 OutputStream Builder
os' <- StreamProc
writeChunkedTransferEncoding OutputStream Builder
os
                                 StreamProc
origBody OutputStream Builder
os'
               in ( CI ByteString -> ByteString -> Headers -> Headers
H.set CI ByteString
"transfer-encoding" ByteString
"chunked" Headers
hdrs
                  , StreamProc -> ResponseBody
Stream StreamProc
body'
                  , Bool
False)
          else
            -- We've already noted that we have to close the socket earlier in
            -- runServerHandler.
            (Headers
hdrs, ResponseBody
body, Bool
True)
      where
        v :: HttpVersion
v = Request -> HttpVersion
rqVersion Request
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 :: Int
-> Response
-> OutputStream ByteString
-> IO (OutputStream ByteString)
limitRspBody Int
hlen Response
rsp OutputStream ByteString
os = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream ByteString
os) forall {a}. Integral a => a -> IO (OutputStream ByteString)
f forall a b. (a -> b) -> a -> b
$ Response -> Maybe Word64
rspContentLength Response
rsp
      where
        f :: a -> IO (OutputStream ByteString)
f a
cl = Int64 -> OutputStream ByteString -> IO (OutputStream ByteString)
Streams.giveExactly (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hlen forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
cl) OutputStream ByteString
os
    {-# INLINE limitRspBody #-}

    --------------------------------------------------------------------------
    whenStream :: Builder       -- ^ headers
               -> Int           -- ^ header length
               -> Response      -- ^ response
               -> StreamProc    -- ^ output body
               -> IO Word64      -- ^ returns number of bytes written
    whenStream :: Builder -> Int -> Response -> StreamProc -> IO Word64
whenStream Builder
headerString Int
hlen Response
rsp StreamProc
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 :: IO ()
t = if Response -> Bool
rspTransformingRqBody Response
rsp
                  then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()
                  else (Int -> Int) -> IO ()
tickle forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
defaultTimeout
        OutputStream ByteString
writeEnd0 <- forall a. OutputStream a -> IO (OutputStream a)
Streams.ignoreEof OutputStream ByteString
writeEnd
        (OutputStream ByteString
writeEnd1, IO Int64
getCount) <- OutputStream ByteString -> IO (OutputStream ByteString, IO Int64)
Streams.countOutput OutputStream ByteString
writeEnd0
        OutputStream ByteString
writeEnd2 <- Int
-> Response
-> OutputStream ByteString
-> IO (OutputStream ByteString)
limitRspBody Int
hlen Response
rsp OutputStream ByteString
writeEnd1
        OutputStream Builder
writeEndB <- IO Buffer -> OutputStream ByteString -> IO (OutputStream Builder)
Streams.unsafeBuilderStream (forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
buffer) OutputStream ByteString
writeEnd2 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                     forall a b. (a -> IO b) -> OutputStream b -> IO (OutputStream a)
Streams.contramapM (\Builder
x -> IO ()
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Builder
x)

        forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
headerString) OutputStream Builder
writeEndB
        OutputStream Builder
writeEnd' <- StreamProc
body OutputStream Builder
writeEndB
        forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream Builder
writeEnd'
        -- Just in case the user handler didn't.
        forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream ByteString
writeEnd1
        Int64
n <- IO Int64
getCount
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hlen
    {-# INLINE whenStream #-}

    --------------------------------------------------------------------------
    whenSendFile :: Builder     -- ^ headers
                 -> Response    -- ^ response
                 -> FilePath    -- ^ file to serve
                 -> Word64      -- ^ file start offset
                 -> IO Word64   -- ^ returns number of bytes written
    whenSendFile :: Builder -> Response -> String -> Word64 -> IO Word64
whenSendFile Builder
headerString Response
rsp String
filePath Word64
offset = do
        let !cl :: Word64
cl = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Response -> Maybe Word64
rspContentLength Response
rsp
        SendFileHandler
sendfileHandler Buffer
buffer Builder
headerString String
filePath Word64
offset Word64
cl
        forall (m :: * -> *) a. Monad m => a -> m a
return Word64
cl
    {-# INLINE whenSendFile #-}


--------------------------------------------------------------------------
mkHeaderLine :: HttpVersion -> Response -> FixedPrim ()
mkHeaderLine :: HttpVersion -> Response -> FixedPrim ()
mkHeaderLine HttpVersion
outVer Response
r =
    case Int
outCode of
        Int
200 | HttpVersion
outVer forall a. Eq a => a -> a -> Bool
== (Int
1, Int
1) ->
                  -- typo in bytestring here
                  forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
17 forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
"HTTP/1.1 200 OK\r\n")
        Int
200 | Bool
otherwise ->
                  forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
17 forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
"HTTP/1.0 200 OK\r\n")
        Int
_ -> forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
len forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> IO (Ptr Word8)
line)
  where
    outCode :: Int
outCode = Response -> Int
rspStatus Response
r

    v :: ByteString
v = if HttpVersion
outVer forall a. Eq a => a -> a -> Bool
== (Int
1,Int
1) then ByteString
"HTTP/1.1 " else ByteString
"HTTP/1.0 "

    outCodeStr :: ByteString
outCodeStr = String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
outCode
    space :: Ptr a -> IO (Ptr b)
space !Ptr a
op = do
        forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
op Int
0 (Word8
32 :: Word8)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
op Int
1

    line :: Ptr Word8 -> IO (Ptr Word8)
line = ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
v forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
outCodeStr forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {a} {b}. Ptr a -> IO (Ptr b)
space forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
reason
                  forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Ptr Word8 -> IO (Ptr Word8)
crlfPoke

    reason :: ByteString
reason = Response -> ByteString
rspStatusReason Response
r
    len :: Int
len = Int
12 forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
outCodeStr forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
reason


------------------------------------------------------------------------------
mkHeaderPrim :: HttpVersion -> Response -> Headers -> FixedPrim ()
mkHeaderPrim :: HttpVersion -> Response -> Headers -> FixedPrim ()
mkHeaderPrim HttpVersion
v Response
r Headers
hdrs = HttpVersion -> Response -> FixedPrim ()
mkHeaderLine HttpVersion
v Response
r FixedPrim () -> FixedPrim () -> FixedPrim ()
<+> Headers -> FixedPrim ()
headersToPrim Headers
hdrs


------------------------------------------------------------------------------
infixl 4 <+>
(<+>) :: FixedPrim () -> FixedPrim () -> FixedPrim ()
FixedPrim ()
p1 <+> :: FixedPrim () -> FixedPrim () -> FixedPrim ()
<+> FixedPrim ()
p2 = () -> ((), ())
ignore forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim ()
p1 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim ()
p2
  where
    ignore :: () -> ((), ())
ignore = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (,)


------------------------------------------------------------------------------
{-# INLINE headersToPrim #-}
headersToPrim :: Headers -> FixedPrim ()
headersToPrim :: Headers -> FixedPrim ()
headersToPrim Headers
hdrs = forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
len (forall a b. a -> b -> a
const Ptr Word8 -> IO ()
copy)
  where
    len :: Int
len = forall a. (a -> ByteString -> ByteString -> a) -> a -> Headers -> a
H.foldedFoldl' Int -> ByteString -> ByteString -> Int
f Int
0 Headers
hdrs forall a. Num a => a -> a -> a
+ Int
2
      where
        f :: Int -> ByteString -> ByteString -> Int
f Int
l ByteString
k ByteString
v = Int
l forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
k forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
v forall a. Num a => a -> a -> a
+ Int
4

    copy :: Ptr Word8 -> IO ()
copy = [(ByteString, ByteString)] -> Ptr Word8 -> IO ()
go forall a b. (a -> b) -> a -> b
$ Headers -> [(ByteString, ByteString)]
H.unsafeToCaseFoldedList Headers
hdrs

    go :: [(ByteString, ByteString)] -> Ptr Word8 -> IO ()
go []         !Ptr Word8
op = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> IO (Ptr Word8)
crlfPoke Ptr Word8
op
    go ((ByteString
k,ByteString
v):[(ByteString, ByteString)]
xs) !Ptr Word8
op = do
        !Ptr Word8
op'  <- ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
k Ptr Word8
op
        forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op' Int
0 (Word8
58 :: Word8)  -- colon
        forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op' Int
1 (Word8
32 :: Word8)  -- space
        !Ptr Word8
op''  <- ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
v forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op' Int
2
        Ptr Word8 -> IO (Ptr Word8)
crlfPoke Ptr Word8
op'' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(ByteString, ByteString)] -> Ptr Word8 -> IO ()
go [(ByteString, ByteString)]
xs


{-# INLINE cpBS #-}
cpBS :: ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS :: ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
s !Ptr Word8
op = forall a. ByteString -> (CStringLen -> IO a) -> IO a
S.unsafeUseAsCStringLen ByteString
s forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr, Int
clen) -> do
                let !cl :: Int
cl = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
clen
                forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
op (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
cstr) Int
cl
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op Int
cl

{-# INLINE crlfPoke #-}
crlfPoke :: Ptr Word8 -> IO (Ptr Word8)
crlfPoke :: Ptr Word8 -> IO (Ptr Word8)
crlfPoke !Ptr Word8
op = do
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op Int
0 (Word8
13 :: Word8)  -- cr
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op Int
1 (Word8
10 :: Word8)  -- lf
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op Int
2


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


------------------------------------------------------------------------------
snapServerVersion :: ByteString
snapServerVersion :: ByteString
snapServerVersion = String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ Version -> String
showVersion forall a b. (a -> b) -> a -> b
$ Version
V.version


------------------------------------------------------------------------------
terminateSession :: Exception e => e -> IO a
terminateSession :: forall e a. Exception e => e -> IO a
terminateSession = forall e a. Exception e => e -> IO a
E.throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> TerminateSessionException
TerminateSessionException forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> SomeException
SomeException


------------------------------------------------------------------------------
requestErrorMessage :: Request -> SomeException -> Builder
requestErrorMessage :: Request -> SomeException -> Builder
requestErrorMessage Request
req SomeException
e =
    forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"During processing of request from "
            , ByteString -> Builder
byteString forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqClientAddr Request
req
            , ByteString -> Builder
byteString ByteString
":"
            , forall a. Show a => a -> Builder
fromShow forall a b. (a -> b) -> a -> b
$ Request -> Int
rqClientPort Request
req
            , ByteString -> Builder
byteString ByteString
"\nrequest:\n"
            , forall a. Show a => a -> Builder
fromShow forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Request
req
            , ByteString -> Builder
byteString ByteString
"\n"
            , Builder
msgB
            ]
  where
    msgB :: Builder
msgB = forall a. Monoid a => [a] -> a
mconcat [
             ByteString -> Builder
byteString ByteString
"A web handler threw an exception. Details:\n"
           , forall a. Show a => a -> Builder
fromShow SomeException
e
           ]


------------------------------------------------------------------------------
-- | Convert 'Cookie' into 'ByteString' for output.
cookieToBS :: Cookie -> ByteString
cookieToBS :: Cookie -> ByteString
cookieToBS (Cookie ByteString
k ByteString
v Maybe UTCTime
mbExpTime Maybe ByteString
mbDomain Maybe ByteString
mbPath Bool
isSec Bool
isHOnly) = ByteString
cookie
  where
    cookie :: ByteString
cookie  = [ByteString] -> ByteString
S.concat [ByteString
k, ByteString
"=", ByteString
v, ByteString
path, ByteString
exptime, ByteString
domain, ByteString
secure, ByteString
hOnly]
    path :: ByteString
path    = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> ByteString -> ByteString
S.append ByteString
"; path=") Maybe ByteString
mbPath
    domain :: ByteString
domain  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> ByteString -> ByteString
S.append ByteString
"; domain=") Maybe ByteString
mbDomain
    exptime :: ByteString
exptime = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> ByteString -> ByteString
S.append ByteString
"; expires=" forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> ByteString
fmt) Maybe UTCTime
mbExpTime
    secure :: ByteString
secure  = if Bool
isSec then ByteString
"; Secure" else ByteString
""
    hOnly :: ByteString
hOnly   = if Bool
isHOnly then ByteString
"; HttpOnly" else ByteString
""
    fmt :: UTCTime -> ByteString
fmt     = String -> ByteString
S.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale
                                  String
"%a, %d-%b-%Y %H:%M:%S GMT"


------------------------------------------------------------------------------
renderCookies :: Response -> Headers -> Headers
renderCookies :: Response -> Headers -> Headers
renderCookies Response
r Headers
hdrs
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
cookies = Headers
hdrs
    | Bool
otherwise = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Headers
m ByteString
v -> ByteString -> ByteString -> Headers -> Headers
H.unsafeInsert ByteString
"set-cookie" ByteString
v Headers
m) Headers
hdrs [ByteString]
cookies

  where
    cookies :: [ByteString]
cookies = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cookie -> ByteString
cookieToBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Response -> Map ByteString Cookie
rspCookies Response
r

------------------------------------------------------------------------------
fromShow :: Show a => a -> Builder
fromShow :: forall a. Show a => a -> Builder
fromShow = String -> Builder
stringUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show