{-# 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
= Int64
256 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1024
data EventLoopCpu = EventLoopCpu
{ EventLoopCpu -> SnapThread
_acceptThread :: SnapThread
, EventLoopCpu -> TimeoutManager
_timeoutManager :: TimeoutManager
}
httpAcceptLoop :: forall hookState .
ServerHandler hookState
-> ServerConfig hookState
-> AcceptFunc
-> 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
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
loop :: IO ()
loop :: IO ()
loop = do
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
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 #-}
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
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
!InputStream ByteString
readEnd' <- IO (InputStream ByteString)
setupReadEnd
(!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
(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
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
then Int -> ByteString -> ByteString
S.unsafeDrop Int
1 ByteString
s
else ByteString
s
{-# INLINE dropLeadingSlash #-}
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 #-}
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
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
(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
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
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
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
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
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
]
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
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
(Headers
hdrs, ResponseBody
body, Bool
True)
where
v :: (Int, Int)
v = Request -> (Int, Int)
rqVersion Request
req
{-# INLINE noCL #-}
limitRspBody :: Int
-> Response
-> OutputStream ByteString
-> 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
-> Int
-> Response
-> StreamProc
-> IO Word64
whenStream :: Builder -> Int -> Response -> StreamProc -> IO Word64
whenStream Builder
headerString Int
hlen Response
rsp StreamProc
body = do
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'
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
-> Response
-> FilePath
-> Word64
-> IO Word64
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 ()
(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) ->
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 ()
(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 ()
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)
Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op' Int
1 (Word8
32 :: Word8)
!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)
Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op Int
1 (Word8
10 :: Word8)
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
= [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
]
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