{-# 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
(Int -> TerminateSessionException -> ShowS)
-> (TerminateSessionException -> String)
-> ([TerminateSessionException] -> ShowS)
-> Show TerminateSessionException
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
(Int -> BadRequestException -> ShowS)
-> (BadRequestException -> String)
-> ([BadRequestException] -> ShowS)
-> Show BadRequestException
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
(Int -> LengthRequiredException -> ShowS)
-> (LengthRequiredException -> String)
-> ([LengthRequiredException] -> ShowS)
-> Show LengthRequiredException
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 :: Snap a -> ServerHandler hookState
snapToServerHandler !Snap a
snap !ServerConfig hookState
serverConfig !PerSessionData
perSessionData !Request
req =
    Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
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 = ServerConfig hookState -> Builder -> IO ()
forall hookState. ServerConfig hookState -> Builder -> IO ()
_logError ServerConfig hookState
serverConfig (Builder -> IO ())
-> (ByteString -> Builder) -> ByteString -> IO ()
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 Int64 -> Int64 -> Int64
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 :: ServerHandler hookState
-> ServerConfig hookState -> AcceptFunc -> IO ()
httpAcceptLoop ServerHandler hookState
serverHandler ServerConfig hookState
serverConfig AcceptFunc
acceptFunc = IO ()
runLoops
  where
    --------------------------------------------------------------------------
    logError :: Builder -> IO ()
logError       = ServerConfig hookState -> Builder -> IO ()
forall hookState. ServerConfig hookState -> Builder -> IO ()
_logError ServerConfig hookState
serverConfig
    nLoops :: Int
nLoops         = ServerConfig hookState -> Int
forall hookState. ServerConfig hookState -> Int
_numAcceptLoops ServerConfig hookState
serverConfig
    defaultTimeout :: Int
defaultTimeout = ServerConfig hookState -> Int
forall hookState. ServerConfig hookState -> Int
_defaultTimeout ServerConfig hookState
serverConfig

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

    --------------------------------------------------------------------------
    runLoops :: IO ()
runLoops = IO [EventLoopCpu]
-> ([EventLoopCpu] -> IO ()) -> ([EventLoopCpu] -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket ((Int -> IO EventLoopCpu) -> [Int] -> IO [EventLoopCpu]
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)])
                         ((EventLoopCpu -> IO ()) -> [EventLoopCpu] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ EventLoopCpu -> IO ()
killLoop)
                         ((EventLoopCpu -> IO ()) -> [EventLoopCpu] -> IO ()
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 = IO
  (SendFileHandler, ByteString, Int, ByteString, Int,
   InputStream ByteString, OutputStream ByteString, IO ())
-> IO ()
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 =
            [ (AsyncException
 -> IO
      (SendFileHandler, ByteString, Int, ByteString, Int,
       InputStream ByteString, OutputStream ByteString, IO ()))
-> Handler
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((AsyncException
  -> IO
       (SendFileHandler, ByteString, Int, ByteString, Int,
        InputStream ByteString, OutputStream ByteString, IO ()))
 -> Handler
      (SendFileHandler, ByteString, Int, ByteString, Int,
       InputStream ByteString, OutputStream ByteString, IO ()))
-> (AsyncException
    -> IO
         (SendFileHandler, ByteString, Int, ByteString, Int,
          InputStream ByteString, OutputStream ByteString, IO ()))
-> Handler
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
forall a b. (a -> b) -> a -> b
$ \(AsyncException
e :: AsyncException) -> IO
  (SendFileHandler, ByteString, Int, ByteString, Int,
   InputStream ByteString, OutputStream ByteString, IO ())
-> IO
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
forall a. IO a -> IO a
loopRestore (AsyncException
-> IO
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
forall e a. Exception e => e -> IO a
E.throwIO (AsyncException
 -> IO
      (SendFileHandler, ByteString, Int, ByteString, Int,
       InputStream ByteString, OutputStream ByteString, IO ()))
-> AsyncException
-> IO
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
forall a b. (a -> b) -> a -> b
$! AsyncException
e)
            , (SomeException
 -> IO
      (SendFileHandler, ByteString, Int, ByteString, Int,
       InputStream ByteString, OutputStream ByteString, IO ()))
-> Handler
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException
  -> IO
       (SendFileHandler, ByteString, Int, ByteString, Int,
        InputStream ByteString, OutputStream ByteString, IO ()))
 -> Handler
      (SendFileHandler, ByteString, Int, ByteString, Int,
       InputStream ByteString, OutputStream ByteString, IO ()))
-> (SomeException
    -> IO
         (SendFileHandler, ByteString, Int, ByteString, Int,
          InputStream ByteString, OutputStream ByteString, IO ()))
-> Handler
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException)  -> SomeException -> IO ()
forall e. Exception e => e -> IO ()
logException SomeException
e IO ()
-> IO
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
-> IO
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
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
                                       IO
  (SendFileHandler, ByteString, Int, ByteString, Int,
   InputStream ByteString, OutputStream ByteString, IO ())
-> [Handler
      (SendFileHandler, ByteString, Int, ByteString, Int,
       InputStream ByteString, OutputStream ByteString, IO ())]
-> IO
     (SendFileHandler, ByteString, Int, ByteString, Int,
      InputStream ByteString, OutputStream ByteString, IO ())
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 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
remotePort
                                       ]
            MVar TimeoutThread
thMVar <- IO (MVar TimeoutThread)
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. IO a -> IO a) -> IO ()) -> IO TimeoutThread)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO TimeoutThread
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore ->
                    IO () -> IO ()
forall a. IO a -> IO ()
eatException (IO () -> IO ()) -> IO () -> IO ()
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
            MVar TimeoutThread -> TimeoutThread -> IO ()
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 <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
            IORef Bool
newConn   <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
            let twiddleTimeout :: (Int -> Int) -> IO ()
twiddleTimeout = IO ((Int -> Int) -> IO ()) -> (Int -> Int) -> IO ()
forall a. IO a -> a
unsafePerformIO (IO ((Int -> Int) -> IO ()) -> (Int -> Int) -> IO ())
-> IO ((Int -> Int) -> IO ()) -> (Int -> Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                   TimeoutThread
th <- MVar TimeoutThread -> IO TimeoutThread
forall a. MVar a -> IO a
readMVar MVar TimeoutThread
thMVar
                                   ((Int -> Int) -> IO ()) -> IO ((Int -> Int) -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (((Int -> Int) -> IO ()) -> IO ((Int -> Int) -> IO ()))
-> ((Int -> Int) -> IO ()) -> IO ((Int -> Int) -> IO ())
forall a b. (a -> b) -> a -> b
$! TimeoutThread -> (Int -> Int) -> IO ()
TM.modify TimeoutThread
th
            let cleanupTimeout :: IO ()
cleanupTimeout = MVar TimeoutThread -> IO TimeoutThread
forall a. MVar a -> IO a
readMVar MVar TimeoutThread
thMVar IO TimeoutThread -> (TimeoutThread -> IO ()) -> IO ()
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
            IO () -> IO ()
forall a. IO a -> IO a
restore (PerSessionData -> IO ()
session PerSessionData
psd)
                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.finally` IO ()
cleanup
                IO () -> IO () -> IO ()
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
        Buffer
-> ServerHandler hookState
-> ServerConfig hookState
-> PerSessionData
-> IO ()
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 = IO EventLoopCpu -> IO EventLoopCpu
forall a. IO a -> IO a
E.mask_ (IO EventLoopCpu -> IO EventLoopCpu)
-> IO EventLoopCpu -> IO EventLoopCpu
forall a b. (a -> b) -> a -> b
$ do
        -- TODO(greg): move constant into config
        TimeoutManager
tm  <- Double -> Double -> IO ClockTime -> IO TimeoutManager
TM.initialize (Int -> Double
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 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
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. IO a -> IO a) -> IO ()) -> IO SnapThread)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO SnapThread
forall a b. (a -> b) -> a -> b
$ TimeoutManager -> (forall a. IO a -> IO a) -> IO ()
loop TimeoutManager
tm
        EventLoopCpu -> IO EventLoopCpu
forall (m :: * -> *) a. Monad m => a -> m a
return (EventLoopCpu -> IO EventLoopCpu)
-> EventLoopCpu -> IO EventLoopCpu
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 = IO () -> IO ()
forall a. IO a -> IO a
E.uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
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 :: Buffer
-> ServerHandler hookState
-> ServerConfig hookState
-> PerSessionData
-> IO ()
httpSession !Buffer
buffer !ServerHandler hookState
serverHandler !ServerConfig hookState
config !PerSessionData
sessionData = IO ()
loop
  where
    --------------------------------------------------------------------------
    defaultTimeout :: Int
defaultTimeout          = ServerConfig hookState -> Int
forall hookState. ServerConfig hookState -> Int
_defaultTimeout ServerConfig hookState
config
    isSecure :: Bool
isSecure                = ServerConfig hookState -> Bool
forall hookState. ServerConfig hookState -> Bool
_isSecure ServerConfig hookState
config
    localHostname :: ByteString
localHostname           = ServerConfig hookState -> ByteString
forall hookState. ServerConfig hookState -> ByteString
_localHostname ServerConfig hookState
config
    logAccess :: Request -> Response -> Word64 -> IO ()
logAccess               = ServerConfig hookState -> Request -> Response -> Word64 -> IO ()
forall hookState.
ServerConfig hookState -> Request -> Response -> Word64 -> IO ()
_logAccess ServerConfig hookState
config
    logError :: Builder -> IO ()
logError                = ServerConfig hookState -> Builder -> IO ()
forall hookState. ServerConfig hookState -> Builder -> IO ()
_logError ServerConfig hookState
config
    newRequestHook :: NewRequestHook hookState
newRequestHook          = ServerConfig hookState -> NewRequestHook hookState
forall hookState.
ServerConfig hookState -> NewRequestHook hookState
_onNewRequest ServerConfig hookState
config
    parseHook :: ParseHook hookState
parseHook               = ServerConfig hookState -> ParseHook hookState
forall hookState. ServerConfig hookState -> ParseHook hookState
_onParse ServerConfig hookState
config
    userHandlerFinishedHook :: UserHandlerFinishedHook hookState
userHandlerFinishedHook = ServerConfig hookState -> UserHandlerFinishedHook hookState
forall hookState.
ServerConfig hookState -> UserHandlerFinishedHook hookState
_onUserHandlerFinished ServerConfig hookState
config
    dataFinishedHook :: UserHandlerFinishedHook hookState
dataFinishedHook        = ServerConfig hookState -> UserHandlerFinishedHook hookState
forall hookState.
ServerConfig hookState -> UserHandlerFinishedHook hookState
_onDataFinished ServerConfig hookState
config
    exceptionHook :: ExceptionHook hookState
exceptionHook           = ServerConfig hookState -> ExceptionHook hookState
forall hookState. ServerConfig hookState -> ExceptionHook hookState
_onException ServerConfig hookState
config
    escapeHook :: EscapeSnapHook hookState
escapeHook              = ServerConfig hookState -> EscapeSnapHook hookState
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 (Buffer -> IO Buffer
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 IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IO () -> Bool -> IO ()) -> IO () -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            IORef hookState
hookState <- NewRequestHook hookState
newRequestHook PerSessionData
sessionData IO hookState
-> (hookState -> IO (IORef hookState)) -> IO (IORef hookState)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= hookState -> IO (IORef hookState)
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 = InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
readEnd IO (Maybe ByteString) -> (Maybe ByteString -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   IO Bool -> (ByteString -> IO Bool) -> Maybe ByteString -> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
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 ByteString -> InputStream ByteString -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
c InputStream ByteString
readEnd IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
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' IO IRequest -> (IRequest -> IO Request) -> IO Request
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 <- IO ByteString
-> (ByteString -> IO ByteString)
-> Maybe ByteString
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if Bool
isHttp11
                         then IO ByteString
forall a. IO a
badRequestWithNoHost
                         else ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
localHostname)
                      ByteString -> IO ByteString
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 = ([ByteString] -> [ByteString] -> [ByteString])
-> Map ByteString [ByteString]
-> Map ByteString [ByteString]
-> Map ByteString [ByteString]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [ByteString] -> [ByteString] -> [ByteString]
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).
        (Int, Int) -> Maybe ByteString -> IO ()
forall a b s.
(Num a, Num b, Eq a, Eq b, Eq s, IsString s, FoldCase s) =>
(a, b) -> Maybe s -> IO ()
checkConnectionClose (Int, Int)
version (Maybe ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ StandardHeaders -> Maybe ByteString
getStdConnection StandardHeaders
stdHdrs

        -- The request is now ready for processing.
        Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$! ByteString
-> ByteString
-> Int
-> ByteString
-> Int
-> ByteString
-> Bool
-> Headers
-> InputStream ByteString
-> Maybe Word64
-> Method
-> (Int, Int)
-> [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
                          (Int, Int)
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 :: (Int, Int)
version      = IRequest -> (Int, Int)
iHttpVersion IRequest
ireq
        !stdHdrs :: StandardHeaders
stdHdrs      = IRequest -> StandardHeaders
iStdHeaders IRequest
ireq
        !hdrs :: Headers
hdrs         = IRequest -> Headers
iRequestHeaders IRequest
ireq

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

        !mbHost :: Maybe ByteString
mbHost       = StandardHeaders -> Maybe ByteString
getStdHost StandardHeaders
stdHdrs
        !localHost :: ByteString
localHost    = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
localHostname Maybe ByteString
mbHost
        mbCL :: Maybe Word64
mbCL          = ByteString -> Word64
forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat (ByteString -> Word64) -> Maybe ByteString -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        StandardHeaders -> Maybe ByteString
getStdContentLength StandardHeaders
stdHdrs
        !isChunked :: Bool
isChunked    = (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> Maybe ByteString -> Maybe (CI ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StandardHeaders -> Maybe ByteString
getStdTransferEncoding StandardHeaders
stdHdrs)
                            Maybe (CI ByteString) -> Maybe (CI ByteString) -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString -> Maybe (CI ByteString)
forall a. a -> Maybe a
Just CI ByteString
"chunked"
        cookies :: [Cookie]
cookies       = [Cookie] -> Maybe [Cookie] -> [Cookie]
forall a. a -> Maybe a -> a
fromMaybe [] (StandardHeaders -> Maybe ByteString
getStdCookie StandardHeaders
stdHdrs Maybe ByteString
-> (ByteString -> Maybe [Cookie]) -> Maybe [Cookie]
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   = Map k a
forall k a. Map k a
Map.empty

        ----------------------------------------------------------------------
        (ByteString
pathInfo, ByteString
queryString) = (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> ByteString
dropLeadingSlash ((ByteString, ByteString) -> (ByteString, ByteString))
-> ((ByteString, ByteString) -> (ByteString, ByteString))
-> (ByteString, ByteString)
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> ByteString -> ByteString
S.drop Int
1)
                                    ((ByteString, ByteString) -> (ByteString, ByteString))
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Char -> Char -> Bool
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 Word8 -> Word8 -> Bool
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 (InputStream ByteString -> IO (InputStream ByteString))
-> (Word64
    -> InputStream ByteString -> IO (InputStream ByteString))
-> Maybe Word64
-> InputStream ByteString
-> IO (InputStream ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO (InputStream ByteString)
-> InputStream ByteString -> IO (InputStream ByteString)
forall a b. a -> b -> a
const IO (InputStream ByteString)
noContentLength)
                         (Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.takeBytes (Int64 -> InputStream ByteString -> IO (InputStream ByteString))
-> (Word64 -> Int64)
-> Word64
-> InputStream ByteString
-> IO (InputStream ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int64
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
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
POST Bool -> Bool -> Bool
|| Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
PUT) IO ()
forall a. IO a
return411
            [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList []

        ----------------------------------------------------------------------
        return411 :: IO b
return411 = do
            let (Int
major, Int
minor) = (Int, Int)
version
            let resp :: Builder
resp = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"HTTP/"
                               , Int -> Builder
forall a. Show a => a -> Builder
fromShow Int
major
                               , Char -> Builder
char8 Char
'.'
                               , Int -> Builder
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
            Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
resp) OutputStream Builder
writeEndB
            Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write Maybe Builder
forall a. Maybe a
Nothing OutputStream Builder
writeEndB
            LengthRequiredException -> IO b
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 (InputStream ByteString, Map ByteString [ByteString])
-> IO (InputStream ByteString, Map ByteString [ByteString])
forall (m :: * -> *) a. Monad m => a -> m a
return (InputStream ByteString
readEnd', Map ByteString [ByteString]
forall k a. Map k a
emptyParams)
          where
            trimIt :: ByteString -> ByteString
trimIt  = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.spanEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';')
                          (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
            mbCT :: Maybe ByteString
mbCT    = ByteString -> ByteString
trimIt (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StandardHeaders -> Maybe ByteString
getStdContentType StandardHeaders
stdHdrs
            hasForm :: Bool
hasForm = Maybe ByteString
mbCT Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"application/x-www-form-urlencoded"

            mAX_POST_BODY_SIZE :: Int64
mAX_POST_BODY_SIZE = Int64
1024 Int64 -> Int64 -> Int64
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 ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputStream ByteString -> IO [ByteString]
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 <- [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList [ByteString
contents]
                (InputStream ByteString, Map ByteString [ByteString])
-> IO (InputStream ByteString, Map ByteString [ByteString])
forall (m :: * -> *) a. Monad m => a -> m a
return (InputStream ByteString
finalReadEnd, Map ByteString [ByteString]
postParams)

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

    --------------------------------------------------------------------------
    {-# INLINE badRequestWithNoHost #-}
    badRequestWithNoHost :: IO a
    badRequestWithNoHost :: IO a
badRequestWithNoHost = do
        let msg :: Builder
msg = [Builder] -> Builder
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
        Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
msg) OutputStream Builder
writeEndB
        Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write Maybe Builder
forall a. Maybe a
Nothing OutputStream Builder
writeEndB
        BadRequestException -> IO a
forall e a. Exception e => e -> IO a
terminateSession BadRequestException
BadRequestException

    --------------------------------------------------------------------------
    {-# INLINE checkExpect100Continue #-}
    checkExpect100Continue :: Request -> IO ()
checkExpect100Continue Request
req =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"expect" Request
req Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"100-continue") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let v :: ByteString
v = if Request -> (Int, Int)
rqVersion Request
req (Int, Int) -> (Int, Int) -> Bool
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                       Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                     ByteString -> Builder
byteString ByteString
" 100 Continue\r\n\r\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                     Builder
flush
            OutputStream Builder
os <- IO (OutputStream Builder)
mkBuffer
            Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
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 ((Int -> Int) -> IO ()) -> (Int -> Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
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
               IO Bool -> [Handler Bool] -> IO Bool
forall a. IO a -> [Handler a] -> IO a
`E.catches` [ (EscapeSnap -> IO Bool) -> Handler Bool
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((EscapeSnap -> IO Bool) -> Handler Bool)
-> (EscapeSnap -> IO Bool) -> Handler Bool
forall a b. (a -> b) -> a -> b
$ IORef hookState -> EscapeSnap -> IO Bool
escapeSnapHandler IORef hookState
hookState
                           , (SomeException -> IO Bool) -> Handler Bool
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO Bool) -> Handler Bool)
-> (SomeException -> IO Bool) -> Handler Bool
forall a b. (a -> b) -> a -> b
$
                             IORef hookState
-> ByteString -> Request -> SomeException -> IO Bool
forall a.
IORef hookState -> ByteString -> Request -> SomeException -> IO a
catchUserException IORef hookState
hookState ByteString
"user handler" Request
req
                           ]
        if Bool
b
          then do IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
isNewConnection Bool
False
                  -- the timer resets to its default value here.
                  IO ()
loop
          else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
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 :: (Int, Int)
v      = Request -> (Int, Int)
rqVersion Request
req
        let is_1_0 :: Bool
is_1_0 = ((Int, Int)
v (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1,Int
0))
        Bool
cc <- if Bool
is_1_0 Bool -> Bool -> Bool
&& (Maybe Word64 -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Word64 -> Bool) -> Maybe Word64 -> Bool
forall a b. (a -> b) -> a -> b
$ Response -> Maybe Word64
rspContentLength Response
rsp0)
                then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Bool
True
                else IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
forceConnectionClose

        -- skip unread portion of request body if rspTransformingRqBody is not
        -- true
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Response -> Bool
rspTransformingRqBody Response
rsp0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InputStream ByteString -> IO ()
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 (Headers -> (Headers, Bool)) -> Headers -> (Headers, Bool)
forall a b. (a -> b) -> a -> b
$
                            Response -> Headers
forall a. HasHeaders a => a -> Headers
headers Response
rsp1
        let rsp :: Response
rsp = (Headers -> Headers) -> Response -> Response
forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders (Headers -> Headers -> Headers
forall a b. a -> b -> a
const Headers
hdrs) Response
rsp1
        IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
forceConnectionClose Bool
cc'
        Word64
bytesSent <- Request -> Response -> IO Word64
sendResponse Request
req Response
rsp IO Word64 -> (SomeException -> IO Word64) -> IO Word64
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch`
                     IORef hookState
-> ByteString -> Request -> SomeException -> IO Word64
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
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
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) = [(ByteString, ByteString)]
-> Bool
-> Bool
-> [(ByteString, ByteString)]
-> ([(ByteString, ByteString)], Bool)
forall a.
(Eq a, IsString a) =>
[(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go [(ByteString
"date",ByteString
date)] Bool
False Bool
cc
                                 ([(ByteString, ByteString)] -> ([(ByteString, ByteString)], Bool))
-> [(ByteString, ByteString)] -> ([(ByteString, ByteString)], Bool)
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)(a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
:[(a, ByteString)]
l)
                !l2 :: [(a, ByteString)]
l2 = if Bool
connClose then ((a
"connection", ByteString
"close")(a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
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)
x(a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall 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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"close" Bool -> Bool -> Bool
|| (Bool
is1_0 Bool -> Bool -> Bool
&& ByteString
v ByteString -> ByteString -> Bool
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)
x(a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall 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)
x(a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall 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 IO (OutputStream Builder)
-> (OutputStream Builder -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EscapeHttpHandler
escapeHandler (Int -> Int) -> IO ()
tickle InputStream ByteString
readEnd
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    escapeSnapHandler IORef hookState
_ (TerminateConnection SomeException
e) = SomeException -> IO Bool
forall e a. Exception e => e -> IO a
terminateSession SomeException
e

    --------------------------------------------------------------------------
    catchUserException :: IORef hookState
                       -> ByteString
                       -> Request
                       -> SomeException
                       -> IO a
    catchUserException :: IORef hookState -> ByteString -> Request -> SomeException -> IO a
catchUserException IORef hookState
hookState ByteString
phase Request
req SomeException
e = do
        Builder -> IO ()
logError (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
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.
        IO () -> IO ()
forall a. IO a -> IO ()
eatException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExceptionHook hookState
exceptionHook IORef hookState
hookState SomeException
e
        SomeException -> IO a
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 :: (Int, Int)
v          = Request -> (Int, Int)
rqVersion Request
req
        let !hdrs' :: Headers
hdrs'      = Response -> Headers -> Headers
renderCookies Response
rsp (Response -> Headers
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 Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
/= Method
HEAD
                            Bool -> Bool -> Bool
&& Maybe Word64 -> Bool
forall a. Maybe a -> Bool
isNothing (Response -> Maybe Word64
rspContentLength Response
rsp)
                            Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
204
                            Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
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)

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldClose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
forceConnectionClose (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$! Bool
True
        let hdrPrim :: FixedPrim ()
hdrPrim       = (Int, Int) -> Response -> Headers -> FixedPrim ()
mkHeaderPrim (Int, Int)
v Response
rsp Headers
hdrs''
        let hlen :: Int
hlen          = FixedPrim () -> Int
forall a. FixedPrim a -> Int
size FixedPrim ()
hdrPrim
        let headerBuilder :: Builder
headerBuilder = FixedPrim () -> () -> Builder
forall a. FixedPrim a -> a -> Builder
primFixed FixedPrim ()
hdrPrim (() -> Builder) -> () -> Builder
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
        Word64 -> IO Word64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> IO Word64) -> Word64 -> IO Word64
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 (Int, Int)
v (Int, Int) -> (Int, Int) -> Bool
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 :: (Int, Int)
v = Request -> (Int, Int)
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 = IO (OutputStream ByteString)
-> (Word64 -> IO (OutputStream ByteString))
-> Maybe Word64
-> IO (OutputStream ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OutputStream ByteString -> IO (OutputStream ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream ByteString
os) Word64 -> IO (OutputStream ByteString)
forall a. Integral a => a -> IO (OutputStream ByteString)
f (Maybe Word64 -> IO (OutputStream ByteString))
-> Maybe Word64 -> IO (OutputStream ByteString)
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 (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hlen Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ a -> Int64
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 () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ()
                  else (Int -> Int) -> IO ()
tickle ((Int -> Int) -> IO ()) -> (Int -> Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
defaultTimeout
        OutputStream ByteString
writeEnd0 <- OutputStream ByteString -> IO (OutputStream ByteString)
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 (Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
buffer) OutputStream ByteString
writeEnd2 IO (OutputStream Builder)
-> StreamProc -> IO (OutputStream Builder)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                     (Builder -> IO Builder) -> StreamProc
forall a b. (a -> IO b) -> OutputStream b -> IO (OutputStream a)
Streams.contramapM (\Builder
x -> IO ()
t IO () -> IO Builder -> IO Builder
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
x)

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


--------------------------------------------------------------------------
mkHeaderLine :: HttpVersion -> Response -> FixedPrim ()
mkHeaderLine :: (Int, Int) -> Response -> FixedPrim ()
mkHeaderLine (Int, Int)
outVer Response
r =
    case Int
outCode of
        Int
200 | (Int, Int)
outVer (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1, Int
1) ->
                  -- typo in bytestring here
                  Int -> (() -> Ptr Word8 -> IO ()) -> FixedPrim ()
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
17 ((() -> Ptr Word8 -> IO ()) -> FixedPrim ())
-> (() -> Ptr Word8 -> IO ()) -> FixedPrim ()
forall a b. (a -> b) -> a -> b
$ (Ptr Word8 -> IO ()) -> () -> Ptr Word8 -> IO ()
forall a b. a -> b -> a
const (IO (Ptr Word8) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr Word8) -> IO ())
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO ()
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 ->
                  Int -> (() -> Ptr Word8 -> IO ()) -> FixedPrim ()
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
17 ((() -> Ptr Word8 -> IO ()) -> FixedPrim ())
-> (() -> Ptr Word8 -> IO ()) -> FixedPrim ()
forall a b. (a -> b) -> a -> b
$ (Ptr Word8 -> IO ()) -> () -> Ptr Word8 -> IO ()
forall a b. a -> b -> a
const (IO (Ptr Word8) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr Word8) -> IO ())
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO ()
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
_ -> Int -> (() -> Ptr Word8 -> IO ()) -> FixedPrim ()
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
len ((() -> Ptr Word8 -> IO ()) -> FixedPrim ())
-> (() -> Ptr Word8 -> IO ()) -> FixedPrim ()
forall a b. (a -> b) -> a -> b
$ (Ptr Word8 -> IO ()) -> () -> Ptr Word8 -> IO ()
forall a b. a -> b -> a
const (IO (Ptr Word8) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr Word8) -> IO ())
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO ()
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 (Int, Int)
outVer (Int, Int) -> (Int, Int) -> Bool
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 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
outCode
    space :: Ptr a -> IO (Ptr b)
space !Ptr a
op = do
        Ptr a -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
op Int
0 (Word8
32 :: Word8)
        Ptr b -> IO (Ptr b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr b -> IO (Ptr b)) -> Ptr b -> IO (Ptr b)
forall a b. (a -> b) -> a -> b
$! Ptr a -> Int -> Ptr 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 (Ptr Word8 -> IO (Ptr Word8))
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
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 (Ptr Word8 -> IO (Ptr Word8))
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Ptr Word8 -> IO (Ptr Word8)
forall a b. Ptr a -> IO (Ptr b)
space (Ptr Word8 -> IO (Ptr Word8))
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
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
                  (Ptr Word8 -> IO (Ptr Word8))
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
outCodeStr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
reason


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


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


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

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

    go :: [(ByteString, ByteString)] -> Ptr Word8 -> IO ()
go []         !Ptr Word8
op = IO (Ptr Word8) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr Word8) -> IO ()) -> IO (Ptr Word8) -> IO ()
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
        Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op' Int
0 (Word8
58 :: Word8)  -- colon
        Ptr Word8 -> Int -> Word8 -> IO ()
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 (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op' Int
2
        Ptr Word8 -> IO (Ptr Word8)
crlfPoke Ptr Word8
op'' IO (Ptr Word8) -> (Ptr Word8 -> IO ()) -> IO ()
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 = ByteString -> (CStringLen -> IO (Ptr Word8)) -> IO (Ptr Word8)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
S.unsafeUseAsCStringLen ByteString
s ((CStringLen -> IO (Ptr Word8)) -> IO (Ptr Word8))
-> (CStringLen -> IO (Ptr Word8)) -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr, Int
clen) -> do
                let !cl :: Int
cl = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
clen
                Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
op (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
cstr) Int
cl
                Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$! Ptr Word8 -> Int -> Ptr Word8
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
    Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op Int
0 (Word8
13 :: Word8)  -- cr
    Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op Int
1 (Word8
10 :: Word8)  -- lf
    Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$! Ptr Word8 -> Int -> Ptr Word8
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 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Version -> String
showVersion (Version -> String) -> Version -> String
forall a b. (a -> b) -> a -> b
$ Version
V.version


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


------------------------------------------------------------------------------
requestErrorMessage :: Request -> SomeException -> Builder
requestErrorMessage :: Request -> SomeException -> Builder
requestErrorMessage Request
req SomeException
e =
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"During processing of request from "
            , ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqClientAddr Request
req
            , ByteString -> Builder
byteString ByteString
":"
            , Int -> Builder
forall a. Show a => a -> Builder
fromShow (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> Int
rqClientPort Request
req
            , ByteString -> Builder
byteString ByteString
"\nrequest:\n"
            , String -> Builder
forall a. Show a => a -> Builder
fromShow (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> String
forall a. Show a => a -> String
show Request
req
            , ByteString -> Builder
byteString ByteString
"\n"
            , Builder
msgB
            ]
  where
    msgB :: Builder
msgB = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
             ByteString -> Builder
byteString ByteString
"A web handler threw an exception. Details:\n"
           , SomeException -> Builder
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    = ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> ByteString -> ByteString
S.append ByteString
"; path=") Maybe ByteString
mbPath
    domain :: ByteString
domain  = ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> ByteString -> ByteString
S.append ByteString
"; domain=") Maybe ByteString
mbDomain
    exptime :: ByteString
exptime = ByteString
-> (UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> ByteString -> ByteString
S.append ByteString
"; expires=" (ByteString -> ByteString)
-> (UTCTime -> ByteString) -> UTCTime -> ByteString
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 (String -> ByteString)
-> (UTCTime -> String) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
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
    | [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
cookies = Headers
hdrs
    | Bool
otherwise = (Headers -> ByteString -> Headers)
-> Headers -> [ByteString] -> Headers
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 = (Cookie -> ByteString) -> [Cookie] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cookie -> ByteString
cookieToBS ([Cookie] -> [ByteString])
-> (Map ByteString Cookie -> [Cookie])
-> Map ByteString Cookie
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ByteString Cookie -> [Cookie]
forall k a. Map k a -> [a]
Map.elems (Map ByteString Cookie -> [ByteString])
-> Map ByteString Cookie -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Response -> Map ByteString Cookie
rspCookies Response
r

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