{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Internal.Http.Server.Session
( httpAcceptLoop
, httpSession
, snapToServerHandler
, BadRequestException(..)
, LengthRequiredException(..)
, TerminateSessionException(..)
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Arrow (first, second)
import Control.Concurrent (MVar, newEmptyMVar, putMVar, readMVar)
import Control.Exception (AsyncException, Exception, Handler (..), SomeException (..))
import qualified Control.Exception as E
import Control.Monad (join, unless, void, when, (>=>))
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Unsafe as S
import qualified Data.CaseInsensitive as CI
import Data.Int (Int64)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe, isNothing)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mconcat)
#endif
import Data.Monoid ((<>))
import Data.Time.Format (formatTime)
import Data.Typeable (Typeable)
import Data.Version (showVersion)
import Data.Word (Word64, Word8)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (Ptr, castPtr, plusPtr)
import Foreign.Storable (pokeByteOff)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8)
import Data.ByteString.Builder.Extra (flush)
import Data.ByteString.Builder.Internal (Buffer, defaultChunkSize, newBuffer)
import Data.ByteString.Builder.Prim (FixedPrim, primFixed, (>$<), (>*<))
import Data.ByteString.Builder.Prim.Internal (fixedPrim, size)
import System.IO.Streams (InputStream, OutputStream)
import qualified System.IO.Streams as Streams
import qualified Paths_snap_server as V
import Snap.Core (EscapeSnap (..))
import Snap.Core (Snap, runSnap)
import Snap.Internal.Core (fixupResponse)
import Snap.Internal.Http.Server.Clock (getClockTime)
import Snap.Internal.Http.Server.Common (eatException)
import Snap.Internal.Http.Server.Date (getDateString)
import Snap.Internal.Http.Server.Parser (IRequest (..), getStdConnection, getStdContentLength, getStdContentType, getStdCookie, getStdHost, getStdTransferEncoding, parseCookie, parseRequest, parseUrlEncoded, readChunkedTransferEncoding, writeChunkedTransferEncoding)
import Snap.Internal.Http.Server.Thread (SnapThread)
import qualified Snap.Internal.Http.Server.Thread as Thread
import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager)
import qualified Snap.Internal.Http.Server.TimeoutManager as TM
import Snap.Internal.Http.Server.Types (AcceptFunc (..), PerSessionData (..), SendFileHandler, ServerConfig (..), ServerHandler)
import Snap.Internal.Http.Types (Cookie (..), HttpVersion, Method (..), Request (..), Response (..), ResponseBody (..), StreamProc, getHeader, headers, rspBodyToEnum, updateHeaders)
import Snap.Internal.Parsing (unsafeFromNat)
import Snap.Types.Headers (Headers)
import qualified Snap.Types.Headers as H
import System.IO.Unsafe (unsafePerformIO)
data TerminateSessionException = TerminateSessionException SomeException
deriving (Typeable, Int -> TerminateSessionException -> ShowS
[TerminateSessionException] -> ShowS
TerminateSessionException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TerminateSessionException] -> ShowS
$cshowList :: [TerminateSessionException] -> ShowS
show :: TerminateSessionException -> String
$cshow :: TerminateSessionException -> String
showsPrec :: Int -> TerminateSessionException -> ShowS
$cshowsPrec :: Int -> TerminateSessionException -> ShowS
Show)
instance Exception TerminateSessionException
data BadRequestException = BadRequestException
deriving (Typeable, Int -> BadRequestException -> ShowS
[BadRequestException] -> ShowS
BadRequestException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadRequestException] -> ShowS
$cshowList :: [BadRequestException] -> ShowS
show :: BadRequestException -> String
$cshow :: BadRequestException -> String
showsPrec :: Int -> BadRequestException -> ShowS
$cshowsPrec :: Int -> BadRequestException -> ShowS
Show)
instance Exception BadRequestException
data LengthRequiredException = LengthRequiredException
deriving (Typeable, Int -> LengthRequiredException -> ShowS
[LengthRequiredException] -> ShowS
LengthRequiredException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LengthRequiredException] -> ShowS
$cshowList :: [LengthRequiredException] -> ShowS
show :: LengthRequiredException -> String
$cshow :: LengthRequiredException -> String
showsPrec :: Int -> LengthRequiredException -> ShowS
$cshowsPrec :: Int -> LengthRequiredException -> ShowS
Show)
instance Exception LengthRequiredException
snapToServerHandler :: Snap a -> ServerHandler hookState
snapToServerHandler :: forall a hookState. Snap a -> ServerHandler hookState
snapToServerHandler !Snap a
snap !ServerConfig hookState
serverConfig !PerSessionData
perSessionData !Request
req =
forall a.
Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
runSnap Snap a
snap ByteString -> IO ()
logErr (Int -> Int) -> IO ()
tickle Request
req
where
logErr :: ByteString -> IO ()
logErr = forall hookState. ServerConfig hookState -> Builder -> IO ()
_logError ServerConfig hookState
serverConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString
tickle :: (Int -> Int) -> IO ()
tickle = PerSessionData -> (Int -> Int) -> IO ()
_twiddleTimeout PerSessionData
perSessionData
mAX_HEADERS_SIZE :: Int64
= Int64
256 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 :: forall hookState.
ServerHandler hookState
-> ServerConfig hookState -> AcceptFunc -> IO ()
httpAcceptLoop ServerHandler hookState
serverHandler ServerConfig hookState
serverConfig AcceptFunc
acceptFunc = IO ()
runLoops
where
logError :: Builder -> IO ()
logError = forall hookState. ServerConfig hookState -> Builder -> IO ()
_logError ServerConfig hookState
serverConfig
nLoops :: Int
nLoops = forall hookState. ServerConfig hookState -> Int
_numAcceptLoops ServerConfig hookState
serverConfig
defaultTimeout :: Int
defaultTimeout = forall hookState. ServerConfig hookState -> Int
_defaultTimeout ServerConfig hookState
serverConfig
logException :: Exception e => e -> IO ()
logException :: forall e. Exception e => e -> IO ()
logException e
e =
Builder -> IO ()
logError forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"got exception in httpAcceptFunc: "
, forall a. Show a => a -> Builder
fromShow e
e
]
runLoops :: IO ()
runLoops = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> IO EventLoopCpu
newLoop [Int
0 .. (Int
nLoops forall a. Num a => a -> a -> a
- Int
1)])
(forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ EventLoopCpu -> IO ()
killLoop)
(forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ EventLoopCpu -> IO ()
waitLoop)
loop :: TimeoutManager
-> (forall a. IO a -> IO a)
-> IO ()
loop :: TimeoutManager -> (forall a. IO a -> IO a) -> IO ()
loop TimeoutManager
tm forall a. IO a -> IO a
loopRestore = forall a. IO a -> IO ()
eatException IO
(SendFileHandler, ByteString, Int, ByteString, Int,
InputStream ByteString, OutputStream ByteString, IO ())
go
where
handlers :: [Handler
(SendFileHandler, ByteString, Int, ByteString, Int,
InputStream ByteString, OutputStream ByteString, IO ())]
handlers =
[ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(AsyncException
e :: AsyncException) -> forall a. IO a -> IO a
loopRestore (forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$! AsyncException
e)
, forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) -> forall e. Exception e => e -> IO ()
logException SomeException
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO
(SendFileHandler, ByteString, Int, ByteString, Int,
InputStream ByteString, OutputStream ByteString, IO ())
go
]
go :: IO
(SendFileHandler, ByteString, Int, ByteString, Int,
InputStream ByteString, OutputStream ByteString, IO ())
go = do
(SendFileHandler
sendFileHandler, ByteString
localAddress, Int
localPort, ByteString
remoteAddress,
Int
remotePort, InputStream ByteString
readEnd, OutputStream ByteString
writeEnd,
IO ()
cleanup) <- AcceptFunc
-> (forall a. IO a -> IO a)
-> IO
(SendFileHandler, ByteString, Int, ByteString, Int,
InputStream ByteString, OutputStream ByteString, IO ())
runAcceptFunc AcceptFunc
acceptFunc forall a. IO a -> IO a
loopRestore
forall a. IO a -> [Handler a] -> IO a
`E.catches` [Handler
(SendFileHandler, ByteString, Int, ByteString, Int,
InputStream ByteString, OutputStream ByteString, IO ())]
handlers
let threadLabel :: ByteString
threadLabel = [ByteString] -> ByteString
S.concat [ ByteString
"snap-server: client "
, ByteString
remoteAddress
, ByteString
":"
, String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
remotePort
]
MVar TimeoutThread
thMVar <- forall a. IO (MVar a)
newEmptyMVar
TimeoutThread
th <- TimeoutManager
-> ByteString
-> ((forall a. IO a -> IO a) -> IO ())
-> IO TimeoutThread
TM.register TimeoutManager
tm ByteString
threadLabel forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore ->
forall a. IO a -> IO ()
eatException forall a b. (a -> b) -> a -> b
$
MVar TimeoutThread
-> SendFileHandler
-> ByteString
-> Int
-> ByteString
-> Int
-> InputStream ByteString
-> OutputStream ByteString
-> IO ()
-> (forall a. IO a -> IO a)
-> IO ()
prep MVar TimeoutThread
thMVar SendFileHandler
sendFileHandler ByteString
localAddress Int
localPort ByteString
remoteAddress
Int
remotePort InputStream ByteString
readEnd OutputStream ByteString
writeEnd IO ()
cleanup forall a. IO a -> IO a
restore
forall a. MVar a -> a -> IO ()
putMVar MVar TimeoutThread
thMVar TimeoutThread
th
IO
(SendFileHandler, ByteString, Int, ByteString, Int,
InputStream ByteString, OutputStream ByteString, IO ())
go
prep :: MVar TM.TimeoutThread
-> SendFileHandler
-> ByteString
-> Int
-> ByteString
-> Int
-> InputStream ByteString
-> OutputStream ByteString
-> IO ()
-> (forall a . IO a -> IO a)
-> IO ()
prep :: MVar TimeoutThread
-> SendFileHandler
-> ByteString
-> Int
-> ByteString
-> Int
-> InputStream ByteString
-> OutputStream ByteString
-> IO ()
-> (forall a. IO a -> IO a)
-> IO ()
prep MVar TimeoutThread
thMVar SendFileHandler
sendFileHandler ByteString
localAddress Int
localPort ByteString
remoteAddress
Int
remotePort InputStream ByteString
readEnd OutputStream ByteString
writeEnd IO ()
cleanup forall a. IO a -> IO a
restore =
do
IORef Bool
connClose <- forall a. a -> IO (IORef a)
newIORef Bool
False
IORef Bool
newConn <- forall a. a -> IO (IORef a)
newIORef Bool
True
let twiddleTimeout :: (Int -> Int) -> IO ()
twiddleTimeout = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
TimeoutThread
th <- forall a. MVar a -> IO a
readMVar MVar TimeoutThread
thMVar
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! TimeoutThread -> (Int -> Int) -> IO ()
TM.modify TimeoutThread
th
let cleanupTimeout :: IO ()
cleanupTimeout = forall a. MVar a -> IO a
readMVar MVar TimeoutThread
thMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TimeoutThread -> IO ()
TM.cancel
let !psd :: PerSessionData
psd = IORef Bool
-> ((Int -> Int) -> IO ())
-> IORef Bool
-> SendFileHandler
-> ByteString
-> Int
-> ByteString
-> Int
-> InputStream ByteString
-> OutputStream ByteString
-> PerSessionData
PerSessionData IORef Bool
connClose
(Int -> Int) -> IO ()
twiddleTimeout
IORef Bool
newConn
SendFileHandler
sendFileHandler
ByteString
localAddress
Int
localPort
ByteString
remoteAddress
Int
remotePort
InputStream ByteString
readEnd
OutputStream ByteString
writeEnd
forall a. IO a -> IO a
restore (PerSessionData -> IO ()
session PerSessionData
psd)
forall a b. IO a -> IO b -> IO a
`E.finally` IO ()
cleanup
forall a b. IO a -> IO b -> IO a
`E.finally` IO ()
cleanupTimeout
session :: PerSessionData -> IO ()
session PerSessionData
psd = do
Buffer
buffer <- Int -> IO Buffer
newBuffer Int
defaultChunkSize
forall hookState.
Buffer
-> ServerHandler hookState
-> ServerConfig hookState
-> PerSessionData
-> IO ()
httpSession Buffer
buffer ServerHandler hookState
serverHandler ServerConfig hookState
serverConfig PerSessionData
psd
newLoop :: Int -> IO EventLoopCpu
newLoop Int
cpu = forall a. IO a -> IO a
E.mask_ forall a b. (a -> b) -> a -> b
$ do
TimeoutManager
tm <- Double -> Double -> IO ClockTime -> IO TimeoutManager
TM.initialize (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultTimeout) Double
2 IO ClockTime
getClockTime
let threadLabel :: ByteString
threadLabel = [ByteString] -> ByteString
S.concat [ ByteString
"snap-server: accept loop #"
, String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
cpu
]
SnapThread
tid <- ByteString
-> Int -> ((forall a. IO a -> IO a) -> IO ()) -> IO SnapThread
Thread.forkOn ByteString
threadLabel Int
cpu forall a b. (a -> b) -> a -> b
$ TimeoutManager -> (forall a. IO a -> IO a) -> IO ()
loop TimeoutManager
tm
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! SnapThread -> TimeoutManager -> EventLoopCpu
EventLoopCpu SnapThread
tid TimeoutManager
tm
waitLoop :: EventLoopCpu -> IO ()
waitLoop (EventLoopCpu SnapThread
tid TimeoutManager
_) = SnapThread -> IO ()
Thread.wait SnapThread
tid
killLoop :: EventLoopCpu -> IO ()
killLoop EventLoopCpu
ev = forall a. IO a -> IO a
E.uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ do
SnapThread -> IO ()
Thread.cancelAndWait SnapThread
tid
TimeoutManager -> IO ()
TM.stop TimeoutManager
tm
where
tid :: SnapThread
tid = EventLoopCpu -> SnapThread
_acceptThread EventLoopCpu
ev
tm :: TimeoutManager
tm = EventLoopCpu -> TimeoutManager
_timeoutManager EventLoopCpu
ev
httpSession :: forall hookState .
Buffer
-> ServerHandler hookState
-> ServerConfig hookState
-> PerSessionData
-> IO ()
httpSession :: forall hookState.
Buffer
-> ServerHandler hookState
-> ServerConfig hookState
-> PerSessionData
-> IO ()
httpSession !Buffer
buffer !ServerHandler hookState
serverHandler !ServerConfig hookState
config !PerSessionData
sessionData = IO ()
loop
where
defaultTimeout :: Int
defaultTimeout = forall hookState. ServerConfig hookState -> Int
_defaultTimeout ServerConfig hookState
config
isSecure :: Bool
isSecure = forall hookState. ServerConfig hookState -> Bool
_isSecure ServerConfig hookState
config
localHostname :: ByteString
localHostname = forall hookState. ServerConfig hookState -> ByteString
_localHostname ServerConfig hookState
config
logAccess :: Request -> Response -> Word64 -> IO ()
logAccess = forall hookState.
ServerConfig hookState -> Request -> Response -> Word64 -> IO ()
_logAccess ServerConfig hookState
config
logError :: Builder -> IO ()
logError = forall hookState. ServerConfig hookState -> Builder -> IO ()
_logError ServerConfig hookState
config
newRequestHook :: NewRequestHook hookState
newRequestHook = forall hookState.
ServerConfig hookState -> NewRequestHook hookState
_onNewRequest ServerConfig hookState
config
parseHook :: ParseHook hookState
parseHook = forall hookState. ServerConfig hookState -> ParseHook hookState
_onParse ServerConfig hookState
config
userHandlerFinishedHook :: UserHandlerFinishedHook hookState
userHandlerFinishedHook = forall hookState.
ServerConfig hookState -> UserHandlerFinishedHook hookState
_onUserHandlerFinished ServerConfig hookState
config
dataFinishedHook :: UserHandlerFinishedHook hookState
dataFinishedHook = forall hookState.
ServerConfig hookState -> UserHandlerFinishedHook hookState
_onDataFinished ServerConfig hookState
config
exceptionHook :: ExceptionHook hookState
exceptionHook = forall hookState. ServerConfig hookState -> ExceptionHook hookState
_onException ServerConfig hookState
config
escapeHook :: EscapeSnapHook hookState
escapeHook = forall hookState.
ServerConfig hookState -> EscapeSnapHook hookState
_onEscape ServerConfig hookState
config
forceConnectionClose :: IORef Bool
forceConnectionClose = PerSessionData -> IORef Bool
_forceConnectionClose PerSessionData
sessionData
isNewConnection :: IORef Bool
isNewConnection = PerSessionData -> IORef Bool
_isNewConnection PerSessionData
sessionData
localAddress :: ByteString
localAddress = PerSessionData -> ByteString
_localAddress PerSessionData
sessionData
localPort :: Int
localPort = PerSessionData -> Int
_localPort PerSessionData
sessionData
remoteAddress :: ByteString
remoteAddress = PerSessionData -> ByteString
_remoteAddress PerSessionData
sessionData
remotePort :: Int
remotePort = PerSessionData -> Int
_remotePort PerSessionData
sessionData
readEnd :: InputStream ByteString
readEnd = PerSessionData -> InputStream ByteString
_readEnd PerSessionData
sessionData
tickle :: (Int -> Int) -> IO ()
tickle Int -> Int
f = PerSessionData -> (Int -> Int) -> IO ()
_twiddleTimeout PerSessionData
sessionData Int -> Int
f
writeEnd :: OutputStream ByteString
writeEnd = PerSessionData -> OutputStream ByteString
_writeEnd PerSessionData
sessionData
sendfileHandler :: SendFileHandler
sendfileHandler = PerSessionData -> SendFileHandler
_sendfileHandler PerSessionData
sessionData
mkBuffer :: IO (OutputStream Builder)
mkBuffer :: IO (OutputStream Builder)
mkBuffer = IO Buffer -> OutputStream ByteString -> IO (OutputStream Builder)
Streams.unsafeBuilderStream (forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
buffer) OutputStream ByteString
writeEnd
loop :: IO ()
loop :: IO ()
loop = do
IO Bool
readEndAtEof forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless forall a b. (a -> b) -> a -> b
$ do
IORef hookState
hookState <- NewRequestHook hookState
newRequestHook PerSessionData
sessionData forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (IORef a)
newIORef
Request
req <- IO Request
receiveRequest
ParseHook hookState
parseHook IORef hookState
hookState Request
req
ParseHook hookState
processRequest IORef hookState
hookState Request
req)
readEndAtEof :: IO Bool
readEndAtEof = forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
readEnd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
(\ByteString
c -> if ByteString -> Bool
S.null ByteString
c
then IO Bool
readEndAtEof
else forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
c InputStream ByteString
readEnd forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
{-# INLINE readEndAtEof #-}
receiveRequest :: IO Request
receiveRequest :: IO Request
receiveRequest = {-# SCC "httpSession/receiveRequest" #-} do
InputStream ByteString
readEnd' <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
mAX_HEADERS_SIZE InputStream ByteString
readEnd
InputStream ByteString -> IO IRequest
parseRequest InputStream ByteString
readEnd' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IRequest -> IO Request
toRequest
{-# INLINE receiveRequest #-}
toRequest :: IRequest -> IO Request
toRequest :: IRequest -> IO Request
toRequest !IRequest
ireq = {-# SCC "httpSession/toRequest" #-} do
ByteString
host <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if Bool
isHttp11
then forall a. IO a
badRequestWithNoHost
else forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
localHostname)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
mbHost
!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 = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. [a] -> [a] -> [a]
(++) Map ByteString [ByteString]
queryParams Map ByteString [ByteString]
postParams
forall {a} {b} {a}.
(Num a, Num b, Eq a, Eq b, Eq a, IsString a, FoldCase a) =>
(a, b) -> Maybe a -> IO ()
checkConnectionClose HttpVersion
version forall a b. (a -> b) -> a -> b
$ StandardHeaders -> Maybe ByteString
getStdConnection StandardHeaders
stdHdrs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString
-> ByteString
-> Int
-> ByteString
-> Int
-> ByteString
-> Bool
-> Headers
-> InputStream ByteString
-> Maybe Word64
-> Method
-> HttpVersion
-> [Cookie]
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> Map ByteString [ByteString]
-> Map ByteString [ByteString]
-> Map ByteString [ByteString]
-> Request
Request ByteString
host
ByteString
remoteAddress
Int
remotePort
ByteString
localAddress
Int
localPort
ByteString
localHost
Bool
isSecure
Headers
hdrs
InputStream ByteString
readEnd''
Maybe Word64
mbCL
Method
method
HttpVersion
version
[Cookie]
cookies
ByteString
pathInfo
ByteString
contextPath
ByteString
uri
ByteString
queryString
Map ByteString [ByteString]
allParams
Map ByteString [ByteString]
queryParams
Map ByteString [ByteString]
postParams
where
!method :: Method
method = IRequest -> Method
iMethod IRequest
ireq
!version :: HttpVersion
version = IRequest -> HttpVersion
iHttpVersion IRequest
ireq
!stdHdrs :: StandardHeaders
stdHdrs = IRequest -> StandardHeaders
iStdHeaders IRequest
ireq
!hdrs :: Headers
hdrs = IRequest -> Headers
iRequestHeaders IRequest
ireq
!isHttp11 :: Bool
isHttp11 = HttpVersion
version forall a. Ord a => a -> a -> Bool
>= (Int
1, Int
1)
!mbHost :: Maybe ByteString
mbHost = StandardHeaders -> Maybe ByteString
getStdHost StandardHeaders
stdHdrs
!localHost :: ByteString
localHost = forall a. a -> Maybe a -> a
fromMaybe ByteString
localHostname Maybe ByteString
mbHost
mbCL :: Maybe Word64
mbCL = forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
StandardHeaders -> Maybe ByteString
getStdContentLength StandardHeaders
stdHdrs
!isChunked :: Bool
isChunked = (forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StandardHeaders -> Maybe ByteString
getStdTransferEncoding StandardHeaders
stdHdrs)
forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just CI ByteString
"chunked"
cookies :: [Cookie]
cookies = forall a. a -> Maybe a -> a
fromMaybe [] (StandardHeaders -> Maybe ByteString
getStdCookie StandardHeaders
stdHdrs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe [Cookie]
parseCookie)
contextPath :: ByteString
contextPath = ByteString
"/"
!uri :: ByteString
uri = IRequest -> ByteString
iRequestUri IRequest
ireq
queryParams :: Map ByteString [ByteString]
queryParams = ByteString -> Map ByteString [ByteString]
parseUrlEncoded ByteString
queryString
emptyParams :: Map k a
emptyParams = forall k a. Map k a
Map.empty
(ByteString
pathInfo, ByteString
queryString) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> ByteString
dropLeadingSlash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> ByteString -> ByteString
S.drop Int
1)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (forall a. Eq a => a -> a -> Bool
== Char
'?') ByteString
uri
dropLeadingSlash :: ByteString -> ByteString
dropLeadingSlash ByteString
s = if ByteString -> Bool
S.null ByteString
s
then ByteString
s
else let !a :: Word8
a = ByteString -> Int -> Word8
S.unsafeIndex ByteString
s Int
0
in if Word8
a forall a. Eq a => a -> a -> Bool
== Word8
47
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 forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> b -> a
const IO (InputStream ByteString)
noContentLength)
(Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.takeBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Word64
mbCL InputStream ByteString
readEnd
{-# INLINE setupReadEnd #-}
noContentLength :: IO (InputStream ByteString)
noContentLength :: IO (InputStream ByteString)
noContentLength = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Method
method forall a. Eq a => a -> a -> Bool
== Method
POST Bool -> Bool -> Bool
|| Method
method forall a. Eq a => a -> a -> Bool
== Method
PUT) forall a. IO a
return411
forall c. [c] -> IO (InputStream c)
Streams.fromList []
return411 :: IO b
return411 = do
let (Int
major, Int
minor) = HttpVersion
version
let resp :: Builder
resp = forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"HTTP/"
, forall a. Show a => a -> Builder
fromShow Int
major
, Char -> Builder
char8 Char
'.'
, forall a. Show a => a -> Builder
fromShow Int
minor
, ByteString -> Builder
byteString ByteString
" 411 Length Required\r\n\r\n"
, ByteString -> Builder
byteString ByteString
"411 Length Required\r\n"
, Builder
flush
]
OutputStream Builder
writeEndB <- IO (OutputStream Builder)
mkBuffer
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
resp) OutputStream Builder
writeEndB
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream Builder
writeEndB
forall e a. Exception e => e -> IO a
terminateSession LengthRequiredException
LengthRequiredException
parseForm :: InputStream ByteString
-> IO (InputStream ByteString, Map ByteString [ByteString])
parseForm InputStream ByteString
readEnd' = if Bool
hasForm
then IO (InputStream ByteString, Map ByteString [ByteString])
getForm
else forall (m :: * -> *) a. Monad m => a -> m a
return (InputStream ByteString
readEnd', forall k a. Map k a
emptyParams)
where
trimIt :: ByteString -> ByteString
trimIt = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.spanEnd (forall a. Eq a => a -> a -> Bool
== Char
' ') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
';')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
' ')
mbCT :: Maybe ByteString
mbCT = ByteString -> ByteString
trimIt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StandardHeaders -> Maybe ByteString
getStdContentType StandardHeaders
stdHdrs
hasForm :: Bool
hasForm = Maybe ByteString
mbCT forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
"application/x-www-form-urlencoded"
mAX_POST_BODY_SIZE :: Int64
mAX_POST_BODY_SIZE = Int64
1024 forall a. Num a => a -> a -> a
* Int64
1024
getForm :: IO (InputStream ByteString, Map ByteString [ByteString])
getForm = do
InputStream ByteString
readEnd'' <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan
Int64
mAX_POST_BODY_SIZE InputStream ByteString
readEnd'
ByteString
contents <- [ByteString] -> ByteString
S.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. InputStream a -> IO [a]
Streams.toList InputStream ByteString
readEnd''
let postParams :: Map ByteString [ByteString]
postParams = ByteString -> Map ByteString [ByteString]
parseUrlEncoded ByteString
contents
InputStream ByteString
finalReadEnd <- forall c. [c] -> IO (InputStream c)
Streams.fromList [ByteString
contents]
forall (m :: * -> *) a. Monad m => a -> m a
return (InputStream ByteString
finalReadEnd, Map ByteString [ByteString]
postParams)
checkConnectionClose :: (a, b) -> Maybe a -> IO ()
checkConnectionClose (a, b)
version Maybe a
connection = do
let v :: Maybe (CI a)
v = forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
connection
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (((a, b)
version forall a. Eq a => a -> a -> Bool
== (a
1, b
1) Bool -> Bool -> Bool
&& Maybe (CI a)
v forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just CI a
"close") Bool -> Bool -> Bool
||
((a, b)
version forall a. Eq a => a -> a -> Bool
== (a
1, b
0) Bool -> Bool -> Bool
&& Maybe (CI a)
v forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just CI a
"keep-alive")) forall a b. (a -> b) -> a -> b
$
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
forceConnectionClose Bool
True
{-# INLINE badRequestWithNoHost #-}
badRequestWithNoHost :: IO a
badRequestWithNoHost :: forall a. IO a
badRequestWithNoHost = do
let msg :: Builder
msg = forall a. Monoid a => [a] -> a
mconcat [
ByteString -> Builder
byteString ByteString
"HTTP/1.1 400 Bad Request\r\n\r\n"
, ByteString -> Builder
byteString ByteString
"400 Bad Request: HTTP/1.1 request with no "
, ByteString -> Builder
byteString ByteString
"Host header\r\n"
, Builder
flush
]
OutputStream Builder
writeEndB <- IO (OutputStream Builder)
mkBuffer
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
msg) OutputStream Builder
writeEndB
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream Builder
writeEndB
forall e a. Exception e => e -> IO a
terminateSession BadRequestException
BadRequestException
{-# INLINE checkExpect100Continue #-}
checkExpect100Continue :: Request -> IO ()
checkExpect100Continue Request
req =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"expect" Request
req forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
"100-continue") forall a b. (a -> b) -> a -> b
$ do
let v :: ByteString
v = if Request -> HttpVersion
rqVersion Request
req forall a. Eq a => a -> a -> Bool
== (Int
1,Int
1) then ByteString
"HTTP/1.1" else ByteString
"HTTP/1.0"
let hl :: Builder
hl = ByteString -> Builder
byteString ByteString
v forall a. Semigroup a => a -> a -> a
<>
ByteString -> Builder
byteString ByteString
" 100 Continue\r\n\r\n" forall a. Semigroup a => a -> a -> a
<>
Builder
flush
OutputStream Builder
os <- IO (OutputStream Builder)
mkBuffer
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
hl) OutputStream Builder
os
{-# INLINE processRequest #-}
processRequest :: ParseHook hookState
processRequest !IORef hookState
hookState !Request
req = {-# SCC "httpSession/processRequest" #-} do
(Int -> Int) -> IO ()
tickle forall a b. (a -> b) -> a -> b
$ 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
forall a. IO a -> [Handler a] -> IO a
`E.catches` [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ IORef hookState -> EscapeSnap -> IO Bool
escapeSnapHandler IORef hookState
hookState
, forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$
forall a.
IORef hookState -> ByteString -> Request -> SomeException -> IO a
catchUserException IORef hookState
hookState ByteString
"user handler" Request
req
]
if Bool
b
then do forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
isNewConnection Bool
False
IO ()
loop
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()
{-# INLINE runServerHandler #-}
runServerHandler :: IORef hookState -> Request -> IO Bool
runServerHandler !IORef hookState
hookState !Request
req = {-# SCC "httpSession/runServerHandler" #-} do
(Request
req0, Response
rsp0) <- ServerHandler hookState
serverHandler ServerConfig hookState
config PerSessionData
sessionData Request
req
UserHandlerFinishedHook hookState
userHandlerFinishedHook IORef hookState
hookState Request
req Response
rsp0
let v :: HttpVersion
v = Request -> HttpVersion
rqVersion Request
req
let is_1_0 :: Bool
is_1_0 = (HttpVersion
v forall a. Eq a => a -> a -> Bool
== (Int
1,Int
0))
Bool
cc <- if Bool
is_1_0 Bool -> Bool -> Bool
&& (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Response -> Maybe Word64
rspContentLength Response
rsp0)
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Bool
True
else forall a. IORef a -> IO a
readIORef IORef Bool
forceConnectionClose
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Response -> Bool
rspTransformingRqBody Response
rsp0) forall a b. (a -> b) -> a -> b
$ forall a. InputStream a -> IO ()
Streams.skipToEof (Request -> InputStream ByteString
rqBody Request
req)
!ByteString
date <- IO ByteString
getDateString
Response
rsp1 <- Request -> Response -> IO Response
fixupResponse Request
req Response
rsp0
let (!Headers
hdrs, !Bool
cc') = Bool -> ByteString -> Bool -> Headers -> (Headers, Bool)
addDateAndServerHeaders Bool
is_1_0 ByteString
date Bool
cc forall a b. (a -> b) -> a -> b
$
forall a. HasHeaders a => a -> Headers
headers Response
rsp1
let rsp :: Response
rsp = forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders (forall a b. a -> b -> a
const Headers
hdrs) Response
rsp1
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
forceConnectionClose Bool
cc'
Word64
bytesSent <- Request -> Response -> IO Word64
sendResponse Request
req Response
rsp forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch`
forall a.
IORef hookState -> ByteString -> Request -> SomeException -> IO a
catchUserException IORef hookState
hookState ByteString
"sending-response" Request
req
UserHandlerFinishedHook hookState
dataFinishedHook IORef hookState
hookState Request
req Response
rsp
Request -> Response -> Word64 -> IO ()
logAccess Request
req0 Response
rsp Word64
bytesSent
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Bool -> Bool
not Bool
cc'
addDateAndServerHeaders :: Bool -> ByteString -> Bool -> Headers -> (Headers, Bool)
addDateAndServerHeaders !Bool
is1_0 !ByteString
date !Bool
cc !Headers
hdrs =
{-# SCC "addDateAndServerHeaders" #-}
let (![(ByteString, ByteString)]
hdrs', !Bool
newcc) = forall {a}.
(Eq a, IsString a) =>
[(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go [(ByteString
"date",ByteString
date)] Bool
False Bool
cc
forall a b. (a -> b) -> a -> b
$ Headers -> [(ByteString, ByteString)]
H.unsafeToCaseFoldedList Headers
hdrs
in ([(ByteString, ByteString)] -> Headers
H.unsafeFromCaseFoldedList [(ByteString, ByteString)]
hdrs', Bool
newcc)
where
go :: [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go ![(a, ByteString)]
l !Bool
seenServer !Bool
connClose [] =
let !l1 :: [(a, ByteString)]
l1 = if Bool
seenServer then [(a, ByteString)]
l else ((a
"server", ByteString
sERVER_HEADER)forall a. a -> [a] -> [a]
:[(a, ByteString)]
l)
!l2 :: [(a, ByteString)]
l2 = if Bool
connClose then ((a
"connection", ByteString
"close")forall a. a -> [a] -> [a]
:[(a, ByteString)]
l1) else [(a, ByteString)]
l1
in ([(a, ByteString)]
l2, Bool
connClose)
go [(a, ByteString)]
l Bool
_ Bool
c (x :: (a, ByteString)
x@(a
"server",ByteString
_):[(a, ByteString)]
xs) = [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go ((a, ByteString)
xforall a. a -> [a] -> [a]
:[(a, ByteString)]
l) Bool
True Bool
c [(a, ByteString)]
xs
go [(a, ByteString)]
l Bool
seenServer Bool
c (x :: (a, ByteString)
x@(a
"connection", ByteString
v):[(a, ByteString)]
xs)
| Bool
c = [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go [(a, ByteString)]
l Bool
seenServer Bool
c [(a, ByteString)]
xs
| ByteString
v forall a. Eq a => a -> a -> Bool
== ByteString
"close" Bool -> Bool -> Bool
|| (Bool
is1_0 Bool -> Bool -> Bool
&& ByteString
v forall a. Eq a => a -> a -> Bool
/= ByteString
"keep-alive") =
[(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go [(a, ByteString)]
l Bool
seenServer Bool
True [(a, ByteString)]
xs
| Bool
otherwise = [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go ((a, ByteString)
xforall a. a -> [a] -> [a]
:[(a, ByteString)]
l) Bool
seenServer Bool
c [(a, ByteString)]
xs
go [(a, ByteString)]
l Bool
seenServer Bool
c ((a, ByteString)
x:[(a, ByteString)]
xs) = [(a, ByteString)]
-> Bool -> Bool -> [(a, ByteString)] -> ([(a, ByteString)], Bool)
go ((a, ByteString)
xforall a. a -> [a] -> [a]
:[(a, ByteString)]
l) Bool
seenServer Bool
c [(a, ByteString)]
xs
escapeSnapHandler :: IORef hookState -> EscapeSnap -> IO Bool
escapeSnapHandler IORef hookState
hookState (EscapeHttp EscapeHttpHandler
escapeHandler) = do
EscapeSnapHook hookState
escapeHook IORef hookState
hookState
IO (OutputStream Builder)
mkBuffer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EscapeHttpHandler
escapeHandler (Int -> Int) -> IO ()
tickle InputStream ByteString
readEnd
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
escapeSnapHandler IORef hookState
_ (TerminateConnection SomeException
e) = forall e a. Exception e => e -> IO a
terminateSession SomeException
e
catchUserException :: IORef hookState
-> ByteString
-> Request
-> SomeException
-> IO a
catchUserException :: forall a.
IORef hookState -> ByteString -> Request -> SomeException -> IO a
catchUserException IORef hookState
hookState ByteString
phase Request
req SomeException
e = do
Builder -> IO ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [
ByteString -> Builder
byteString ByteString
"Exception leaked to httpSession during phase '"
, ByteString -> Builder
byteString ByteString
phase
, ByteString -> Builder
byteString ByteString
"': \n"
, Request -> SomeException -> Builder
requestErrorMessage Request
req SomeException
e
]
forall a. IO a -> IO ()
eatException forall a b. (a -> b) -> a -> b
$ ExceptionHook hookState
exceptionHook IORef hookState
hookState SomeException
e
forall e a. Exception e => e -> IO a
terminateSession SomeException
e
sendResponse :: Request -> Response -> IO Word64
sendResponse :: Request -> Response -> IO Word64
sendResponse !Request
req !Response
rsp = {-# SCC "httpSession/sendResponse" #-} do
let !v :: HttpVersion
v = Request -> HttpVersion
rqVersion Request
req
let !hdrs' :: Headers
hdrs' = Response -> Headers -> Headers
renderCookies Response
rsp (forall a. HasHeaders a => a -> Headers
headers Response
rsp)
let !code :: Int
code = Response -> Int
rspStatus Response
rsp
let body :: ResponseBody
body = Response -> ResponseBody
rspBody Response
rsp
let needChunked :: Bool
needChunked = Request -> Method
rqMethod Request
req forall a. Eq a => a -> a -> Bool
/= Method
HEAD
Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (Response -> Maybe Word64
rspContentLength Response
rsp)
Bool -> Bool -> Bool
&& Int
code forall a. Eq a => a -> a -> Bool
/= Int
204
Bool -> Bool -> Bool
&& Int
code forall a. Eq a => a -> a -> Bool
/= Int
304
let (Headers
hdrs'', ResponseBody
body', Bool
shouldClose) = if Bool
needChunked
then Request -> Headers -> ResponseBody -> (Headers, ResponseBody, Bool)
noCL Request
req Headers
hdrs' ResponseBody
body
else (Headers
hdrs', ResponseBody
body, Bool
False)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldClose forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
forceConnectionClose forall a b. (a -> b) -> a -> b
$! Bool
True
let hdrPrim :: FixedPrim ()
hdrPrim = HttpVersion -> Response -> Headers -> FixedPrim ()
mkHeaderPrim HttpVersion
v Response
rsp Headers
hdrs''
let hlen :: Int
hlen = forall a. FixedPrim a -> Int
size FixedPrim ()
hdrPrim
let headerBuilder :: Builder
headerBuilder = forall a. FixedPrim a -> a -> Builder
primFixed FixedPrim ()
hdrPrim forall a b. (a -> b) -> a -> b
$! ()
Word64
nBodyBytes <- case ResponseBody
body' of
Stream StreamProc
s ->
Builder -> Int -> Response -> StreamProc -> IO Word64
whenStream Builder
headerBuilder Int
hlen Response
rsp StreamProc
s
SendFile String
f Maybe (Word64, Word64)
Nothing ->
Builder -> Response -> String -> Word64 -> IO Word64
whenSendFile Builder
headerBuilder Response
rsp String
f Word64
0
SendFile String
f (Just (Word64
st, Word64
_)) ->
Builder -> Response -> String -> Word64 -> IO Word64
whenSendFile Builder
headerBuilder Response
rsp String
f Word64
st
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Word64
nBodyBytes
noCL :: Request
-> Headers
-> ResponseBody
-> (Headers, ResponseBody, Bool)
noCL :: Request -> Headers -> ResponseBody -> (Headers, ResponseBody, Bool)
noCL Request
req Headers
hdrs ResponseBody
body =
if HttpVersion
v forall a. Eq a => a -> a -> Bool
== (Int
1,Int
1)
then let origBody :: StreamProc
origBody = ResponseBody -> StreamProc
rspBodyToEnum ResponseBody
body
body' :: StreamProc
body' = \OutputStream Builder
os -> do
OutputStream Builder
os' <- StreamProc
writeChunkedTransferEncoding OutputStream Builder
os
StreamProc
origBody OutputStream Builder
os'
in ( CI ByteString -> ByteString -> Headers -> Headers
H.set CI ByteString
"transfer-encoding" ByteString
"chunked" Headers
hdrs
, StreamProc -> ResponseBody
Stream StreamProc
body'
, Bool
False)
else
(Headers
hdrs, ResponseBody
body, Bool
True)
where
v :: HttpVersion
v = Request -> HttpVersion
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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream ByteString
os) forall {a}. Integral a => a -> IO (OutputStream ByteString)
f forall a b. (a -> b) -> a -> b
$ Response -> Maybe Word64
rspContentLength Response
rsp
where
f :: a -> IO (OutputStream ByteString)
f a
cl = Int64 -> OutputStream ByteString -> IO (OutputStream ByteString)
Streams.giveExactly (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hlen forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
cl) OutputStream ByteString
os
{-# INLINE limitRspBody #-}
whenStream :: Builder
-> 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()
else (Int -> Int) -> IO ()
tickle forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
defaultTimeout
OutputStream ByteString
writeEnd0 <- forall a. OutputStream a -> IO (OutputStream a)
Streams.ignoreEof OutputStream ByteString
writeEnd
(OutputStream ByteString
writeEnd1, IO Int64
getCount) <- OutputStream ByteString -> IO (OutputStream ByteString, IO Int64)
Streams.countOutput OutputStream ByteString
writeEnd0
OutputStream ByteString
writeEnd2 <- Int
-> Response
-> OutputStream ByteString
-> IO (OutputStream ByteString)
limitRspBody Int
hlen Response
rsp OutputStream ByteString
writeEnd1
OutputStream Builder
writeEndB <- IO Buffer -> OutputStream ByteString -> IO (OutputStream Builder)
Streams.unsafeBuilderStream (forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
buffer) OutputStream ByteString
writeEnd2 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall a b. (a -> IO b) -> OutputStream b -> IO (OutputStream a)
Streams.contramapM (\Builder
x -> IO ()
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Builder
x)
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
headerString) OutputStream Builder
writeEndB
OutputStream Builder
writeEnd' <- StreamProc
body OutputStream Builder
writeEndB
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream Builder
writeEnd'
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream ByteString
writeEnd1
Int64
n <- IO Int64
getCount
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hlen
{-# INLINE whenStream #-}
whenSendFile :: Builder
-> 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 = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Response -> Maybe Word64
rspContentLength Response
rsp
SendFileHandler
sendfileHandler Buffer
buffer Builder
headerString String
filePath Word64
offset Word64
cl
forall (m :: * -> *) a. Monad m => a -> m a
return Word64
cl
{-# INLINE whenSendFile #-}
mkHeaderLine :: HttpVersion -> Response -> FixedPrim ()
HttpVersion
outVer Response
r =
case Int
outCode of
Int
200 | HttpVersion
outVer forall a. Eq a => a -> a -> Bool
== (Int
1, Int
1) ->
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
17 forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
"HTTP/1.1 200 OK\r\n")
Int
200 | Bool
otherwise ->
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
17 forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
"HTTP/1.0 200 OK\r\n")
Int
_ -> forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
len forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> IO (Ptr Word8)
line)
where
outCode :: Int
outCode = Response -> Int
rspStatus Response
r
v :: ByteString
v = if HttpVersion
outVer forall a. Eq a => a -> a -> Bool
== (Int
1,Int
1) then ByteString
"HTTP/1.1 " else ByteString
"HTTP/1.0 "
outCodeStr :: ByteString
outCodeStr = String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
outCode
space :: Ptr a -> IO (Ptr b)
space !Ptr a
op = do
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
op Int
0 (Word8
32 :: Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
op Int
1
line :: Ptr Word8 -> IO (Ptr Word8)
line = ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
v forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
outCodeStr forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {a} {b}. Ptr a -> IO (Ptr b)
space forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
reason
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Ptr Word8 -> IO (Ptr Word8)
crlfPoke
reason :: ByteString
reason = Response -> ByteString
rspStatusReason Response
r
len :: Int
len = Int
12 forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
outCodeStr forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
reason
mkHeaderPrim :: HttpVersion -> Response -> Headers -> FixedPrim ()
HttpVersion
v Response
r Headers
hdrs = HttpVersion -> Response -> FixedPrim ()
mkHeaderLine HttpVersion
v Response
r FixedPrim () -> FixedPrim () -> FixedPrim ()
<+> Headers -> FixedPrim ()
headersToPrim Headers
hdrs
infixl 4 <+>
(<+>) :: FixedPrim () -> FixedPrim () -> FixedPrim ()
FixedPrim ()
p1 <+> :: FixedPrim () -> FixedPrim () -> FixedPrim ()
<+> FixedPrim ()
p2 = () -> ((), ())
ignore forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim ()
p1 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim ()
p2
where
ignore :: () -> ((), ())
ignore = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (,)
{-# INLINE headersToPrim #-}
headersToPrim :: Headers -> FixedPrim ()
Headers
hdrs = forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim Int
len (forall a b. a -> b -> a
const Ptr Word8 -> IO ()
copy)
where
len :: Int
len = forall a. (a -> ByteString -> ByteString -> a) -> a -> Headers -> a
H.foldedFoldl' Int -> ByteString -> ByteString -> Int
f Int
0 Headers
hdrs forall a. Num a => a -> a -> a
+ Int
2
where
f :: Int -> ByteString -> ByteString -> Int
f Int
l ByteString
k ByteString
v = Int
l forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
k forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
v forall a. Num a => a -> a -> a
+ Int
4
copy :: Ptr Word8 -> IO ()
copy = [(ByteString, ByteString)] -> Ptr Word8 -> IO ()
go forall a b. (a -> b) -> a -> b
$ Headers -> [(ByteString, ByteString)]
H.unsafeToCaseFoldedList Headers
hdrs
go :: [(ByteString, ByteString)] -> Ptr Word8 -> IO ()
go [] !Ptr Word8
op = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> IO (Ptr Word8)
crlfPoke Ptr Word8
op
go ((ByteString
k,ByteString
v):[(ByteString, ByteString)]
xs) !Ptr Word8
op = do
!Ptr Word8
op' <- ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
k Ptr Word8
op
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op' Int
0 (Word8
58 :: Word8)
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 forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op' Int
2
Ptr Word8 -> IO (Ptr Word8)
crlfPoke Ptr Word8
op'' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(ByteString, ByteString)] -> Ptr Word8 -> IO ()
go [(ByteString, ByteString)]
xs
{-# INLINE cpBS #-}
cpBS :: ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS :: ByteString -> Ptr Word8 -> IO (Ptr Word8)
cpBS ByteString
s !Ptr Word8
op = forall a. ByteString -> (CStringLen -> IO a) -> IO a
S.unsafeUseAsCStringLen ByteString
s forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr, Int
clen) -> do
let !cl :: Int
cl = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
clen
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
op (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
cstr) Int
cl
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op Int
cl
{-# INLINE crlfPoke #-}
crlfPoke :: Ptr Word8 -> IO (Ptr Word8)
crlfPoke :: Ptr Word8 -> IO (Ptr Word8)
crlfPoke !Ptr Word8
op = do
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op Int
0 (Word8
13 :: Word8)
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
op Int
1 (Word8
10 :: Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op Int
2
sERVER_HEADER :: ByteString
= [ByteString] -> ByteString
S.concat [ByteString
"Snap/", ByteString
snapServerVersion]
snapServerVersion :: ByteString
snapServerVersion :: ByteString
snapServerVersion = String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ Version -> String
showVersion forall a b. (a -> b) -> a -> b
$ Version
V.version
terminateSession :: Exception e => e -> IO a
terminateSession :: forall e a. Exception e => e -> IO a
terminateSession = forall e a. Exception e => e -> IO a
E.throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> TerminateSessionException
TerminateSessionException forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> SomeException
SomeException
requestErrorMessage :: Request -> SomeException -> Builder
requestErrorMessage :: Request -> SomeException -> Builder
requestErrorMessage Request
req SomeException
e =
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"During processing of request from "
, ByteString -> Builder
byteString forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqClientAddr Request
req
, ByteString -> Builder
byteString ByteString
":"
, forall a. Show a => a -> Builder
fromShow forall a b. (a -> b) -> a -> b
$ Request -> Int
rqClientPort Request
req
, ByteString -> Builder
byteString ByteString
"\nrequest:\n"
, forall a. Show a => a -> Builder
fromShow forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Request
req
, ByteString -> Builder
byteString ByteString
"\n"
, Builder
msgB
]
where
msgB :: Builder
msgB = forall a. Monoid a => [a] -> a
mconcat [
ByteString -> Builder
byteString ByteString
"A web handler threw an exception. Details:\n"
, forall a. Show a => a -> Builder
fromShow SomeException
e
]
cookieToBS :: Cookie -> ByteString
cookieToBS :: Cookie -> ByteString
cookieToBS (Cookie ByteString
k ByteString
v Maybe UTCTime
mbExpTime Maybe ByteString
mbDomain Maybe ByteString
mbPath Bool
isSec Bool
isHOnly) = ByteString
cookie
where
cookie :: ByteString
cookie = [ByteString] -> ByteString
S.concat [ByteString
k, ByteString
"=", ByteString
v, ByteString
path, ByteString
exptime, ByteString
domain, ByteString
secure, ByteString
hOnly]
path :: ByteString
path = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> ByteString -> ByteString
S.append ByteString
"; path=") Maybe ByteString
mbPath
domain :: ByteString
domain = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> ByteString -> ByteString
S.append ByteString
"; domain=") Maybe ByteString
mbDomain
exptime :: ByteString
exptime = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> ByteString -> ByteString
S.append ByteString
"; expires=" forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> ByteString
fmt) Maybe UTCTime
mbExpTime
secure :: ByteString
secure = if Bool
isSec then ByteString
"; Secure" else ByteString
""
hOnly :: ByteString
hOnly = if Bool
isHOnly then ByteString
"; HttpOnly" else ByteString
""
fmt :: UTCTime -> ByteString
fmt = String -> ByteString
S.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale
String
"%a, %d-%b-%Y %H:%M:%S GMT"
renderCookies :: Response -> Headers -> Headers
renderCookies :: Response -> Headers -> Headers
renderCookies Response
r Headers
hdrs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
cookies = Headers
hdrs
| Bool
otherwise = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Headers
m ByteString
v -> ByteString -> ByteString -> Headers -> Headers
H.unsafeInsert ByteString
"set-cookie" ByteString
v Headers
m) Headers
hdrs [ByteString]
cookies
where
cookies :: [ByteString]
cookies = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cookie -> ByteString
cookieToBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Response -> Map ByteString Cookie
rspCookies Response
r
fromShow :: Show a => a -> Builder
fromShow :: forall a. Show a => a -> Builder
fromShow = String -> Builder
stringUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show