{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Network.Wai.Handler.Warp.Run where
import "iproute" Data.IP (toHostAddress, toHostAddress6)
import Control.Arrow (first)
import qualified Control.Concurrent as Conc (yield)
import Control.Exception as E
import qualified Data.ByteString as S
import Data.Char (chr)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Streaming.Network (bindPortTCP)
import Foreign.C.Error (Errno(..), eCONNABORTED)
import GHC.IO.Exception (IOException(..), IOErrorType(..))
import qualified Network.HTTP2 as H2
import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
#if MIN_VERSION_network(3,1,1)
import Network.Socket (gracefulClose)
#endif
import qualified Network.Socket.ByteString as Sock
import Network.Wai
import Network.Wai.Internal (ResponseReceived (ResponseReceived))
import System.Environment (lookupEnv)
import System.IO.Error (ioeGetErrorType)
import qualified System.TimeManager as T
import System.Timeout (timeout)
import Network.Wai.Handler.Warp.Buffer
import Network.Wai.Handler.Warp.Counter
import qualified Network.Wai.Handler.Warp.Date as D
import qualified Network.Wai.Handler.Warp.FdCache as F
import qualified Network.Wai.Handler.Warp.FileInfoCache as I
import Network.Wai.Handler.Warp.HTTP2 (http2)
import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
import Network.Wai.Handler.Warp.Header
import Network.Wai.Handler.Warp.Imports hiding (readInt)
import Network.Wai.Handler.Warp.ReadInt
import Network.Wai.Handler.Warp.Recv
import Network.Wai.Handler.Warp.Request
import Network.Wai.Handler.Warp.Response
import Network.Wai.Handler.Warp.SendFile
import Network.Wai.Handler.Warp.Settings
import Network.Wai.Handler.Warp.Types
#if WINDOWS
import Network.Wai.Handler.Warp.Windows
#else
import Network.Socket (fdSocket)
#endif
socketConnection :: Settings -> Socket -> IO Connection
#if MIN_VERSION_network(3,1,1)
socketConnection :: Settings -> Socket -> IO Connection
socketConnection set :: Settings
set s :: Socket
s = do
#else
socketConnection _ s = do
#endif
BufferPool
bufferPool <- IO BufferPool
newBufferPool
Buffer
writeBuf <- Int -> IO Buffer
allocateBuffer Int
bufferSize
let sendall :: ByteString -> IO ()
sendall = Socket -> ByteString -> IO ()
sendAll' Socket
s
IORef Bool
isH2 <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return $WConnection :: ([ByteString] -> IO ())
-> (ByteString -> IO ())
-> SendFile
-> IO ()
-> IO ()
-> Recv
-> RecvBuf
-> Buffer
-> Int
-> IORef Bool
-> Connection
Connection {
connSendMany :: [ByteString] -> IO ()
connSendMany = Socket -> [ByteString] -> IO ()
Sock.sendMany Socket
s
, connSendAll :: ByteString -> IO ()
connSendAll = ByteString -> IO ()
sendall
, connSendFile :: SendFile
connSendFile = Socket -> Buffer -> Int -> (ByteString -> IO ()) -> SendFile
sendFile Socket
s Buffer
writeBuf Int
bufferSize ByteString -> IO ()
sendall
#if MIN_VERSION_network(3,1,1)
, connClose :: IO ()
connClose = do
Bool
h2 <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
isH2
let tm :: Int
tm = if Bool
h2 then Settings -> Int
settingsGracefulCloseTimeout2 Settings
set
else Settings -> Int
settingsGracefulCloseTimeout1 Settings
set
if Int
tm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then
Socket -> IO ()
close Socket
s
else
Socket -> Int -> IO ()
gracefulClose Socket
s Int
tm IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(E.SomeException _) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
, connClose = close s
#endif
, connFree :: IO ()
connFree = Buffer -> IO ()
freeBuffer Buffer
writeBuf
, connRecv :: Recv
connRecv = Socket -> BufferPool -> Recv
receive Socket
s BufferPool
bufferPool
, connRecvBuf :: RecvBuf
connRecvBuf = Socket -> RecvBuf
receiveBuf Socket
s
, connWriteBuffer :: Buffer
connWriteBuffer = Buffer
writeBuf
, connBufferSize :: Int
connBufferSize = Int
bufferSize
, connHTTP2 :: IORef Bool
connHTTP2 = IORef Bool
isH2
}
where
sendAll' :: Socket -> ByteString -> IO ()
sendAll' sock :: Socket
sock bs :: ByteString
bs = (IOError -> Maybe InvalidRequest)
-> (InvalidRequest -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
E.handleJust
(\ e :: IOError
e -> if IOError -> IOErrorType
ioeGetErrorType IOError
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished
then InvalidRequest -> Maybe InvalidRequest
forall a. a -> Maybe a
Just InvalidRequest
ConnectionClosedByPeer
else Maybe InvalidRequest
forall a. Maybe a
Nothing)
InvalidRequest -> IO ()
forall e a. Exception e => e -> IO a
throwIO
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
Sock.sendAll Socket
sock ByteString
bs
run :: Port -> Application -> IO ()
run :: Int -> Application -> IO ()
run p :: Int
p = Settings -> Application -> IO ()
runSettings Settings
defaultSettings { settingsPort :: Int
settingsPort = Int
p }
runEnv :: Port -> Application -> IO ()
runEnv :: Int -> Application -> IO ()
runEnv p :: Int
p app :: Application
app = do
Maybe String
mp <- String -> IO (Maybe String)
lookupEnv "PORT"
IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Application -> IO ()
run Int
p Application
app) String -> IO ()
runReadPort Maybe String
mp
where
runReadPort :: String -> IO ()
runReadPort :: String -> IO ()
runReadPort sp :: String
sp = case ReadS Int
forall a. Read a => ReadS a
reads String
sp of
((p' :: Int
p', _):_) -> Int -> Application -> IO ()
run Int
p' Application
app
_ -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Invalid value in $PORT: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sp
runSettings :: Settings -> Application -> IO ()
runSettings :: Settings -> Application -> IO ()
runSettings set :: Settings
set app :: Application
app = IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
(Int -> HostPreference -> IO Socket
bindPortTCP (Settings -> Int
settingsPort Settings
set) (Settings -> HostPreference
settingsHost Settings
set))
Socket -> IO ()
close
(\socket :: Socket
socket -> do
Socket -> IO ()
setSocketCloseOnExec Socket
socket
Settings -> Socket -> Application -> IO ()
runSettingsSocket Settings
set Socket
socket Application
app)
runSettingsSocket :: Settings -> Socket -> Application -> IO ()
runSettingsSocket :: Settings -> Socket -> Application -> IO ()
runSettingsSocket set :: Settings
set socket :: Socket
socket app :: Application
app = do
Settings -> IO () -> IO ()
settingsInstallShutdownHandler Settings
set IO ()
closeListenSocket
Settings -> IO (Connection, SockAddr) -> Application -> IO ()
runSettingsConnection Settings
set IO (Connection, SockAddr)
getConn Application
app
where
getConn :: IO (Connection, SockAddr)
getConn = do
#if WINDOWS
(s, sa) <- windowsThreadBlockHack $ accept socket
#else
(s :: Socket
s, sa :: SockAddr
sa) <- Socket -> IO (Socket, SockAddr)
accept Socket
socket
#endif
Socket -> IO ()
setSocketCloseOnExec Socket
s
Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
NoDelay 1 IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(E.SomeException _) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Connection
conn <- Settings -> Socket -> IO Connection
socketConnection Settings
set Socket
s
(Connection, SockAddr) -> IO (Connection, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection
conn, SockAddr
sa)
closeListenSocket :: IO ()
closeListenSocket = Socket -> IO ()
close Socket
socket
runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
runSettingsConnection set :: Settings
set getConn :: IO (Connection, SockAddr)
getConn app :: Application
app = Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
runSettingsConnectionMaker Settings
set IO (IO Connection, SockAddr)
getConnMaker Application
app
where
getConnMaker :: IO (IO Connection, SockAddr)
getConnMaker = do
(conn :: Connection
conn, sa :: SockAddr
sa) <- IO (Connection, SockAddr)
getConn
(IO Connection, SockAddr) -> IO (IO Connection, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
conn, SockAddr
sa)
runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
runSettingsConnectionMaker x :: Settings
x y :: IO (IO Connection, SockAddr)
y =
Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> IO ()
runSettingsConnectionMakerSecure Settings
x ((IO Connection, SockAddr) -> (IO (Connection, Transport), SockAddr)
forall t d. (IO t, d) -> (IO (t, Transport), d)
toTCP ((IO Connection, SockAddr)
-> (IO (Connection, Transport), SockAddr))
-> IO (IO Connection, SockAddr)
-> IO (IO (Connection, Transport), SockAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IO Connection, SockAddr)
y)
where
toTCP :: (IO t, d) -> (IO (t, Transport), d)
toTCP = (IO t -> IO (t, Transport)) -> (IO t, d) -> (IO (t, Transport), d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((, Transport
TCP) (t -> (t, Transport)) -> IO t -> IO (t, Transport)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()
runSettingsConnectionMakerSecure :: Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> IO ()
runSettingsConnectionMakerSecure set :: Settings
set getConnMaker :: IO (IO (Connection, Transport), SockAddr)
getConnMaker app :: Application
app = do
Settings -> IO ()
settingsBeforeMainLoop Settings
set
Counter
counter <- IO Counter
newCounter
Settings -> (InternalInfo -> IO ()) -> IO ()
forall a. Settings -> (InternalInfo -> IO a) -> IO a
withII Settings
set ((InternalInfo -> IO ()) -> IO ())
-> (InternalInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> Counter
-> InternalInfo
-> IO ()
acceptConnection Settings
set IO (IO (Connection, Transport), SockAddr)
getConnMaker Application
app Counter
counter
withII :: Settings -> (InternalInfo -> IO a) -> IO a
withII :: Settings -> (InternalInfo -> IO a) -> IO a
withII set :: Settings
set action :: InternalInfo -> IO a
action =
(Manager -> IO a) -> IO a
forall c. (Manager -> IO c) -> IO c
withTimeoutManager ((Manager -> IO a) -> IO a) -> (Manager -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \tm :: Manager
tm ->
(Recv -> IO a) -> IO a
forall a. (Recv -> IO a) -> IO a
D.withDateCache ((Recv -> IO a) -> IO a) -> (Recv -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \dc :: Recv
dc ->
Int -> ((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
forall a. Int -> ((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
F.withFdCache Int
fdCacheDurationInSeconds (((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a)
-> ((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \fdc :: String -> IO (Maybe Fd, IO ())
fdc ->
Int -> ((String -> IO FileInfo) -> IO a) -> IO a
forall a. Int -> ((String -> IO FileInfo) -> IO a) -> IO a
I.withFileInfoCache Int
fdFileInfoDurationInSeconds (((String -> IO FileInfo) -> IO a) -> IO a)
-> ((String -> IO FileInfo) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \fic :: String -> IO FileInfo
fic -> do
let ii :: InternalInfo
ii = Manager
-> Recv
-> (String -> IO (Maybe Fd, IO ()))
-> (String -> IO FileInfo)
-> InternalInfo
InternalInfo Manager
tm Recv
dc String -> IO (Maybe Fd, IO ())
fdc String -> IO FileInfo
fic
InternalInfo -> IO a
action InternalInfo
ii
where
!fdCacheDurationInSeconds :: Int
fdCacheDurationInSeconds = Settings -> Int
settingsFdCacheDuration Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000000
!fdFileInfoDurationInSeconds :: Int
fdFileInfoDurationInSeconds = Settings -> Int
settingsFileInfoCacheDuration Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000000
!timeoutInSeconds :: Int
timeoutInSeconds = Settings -> Int
settingsTimeout Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000000
withTimeoutManager :: (Manager -> IO c) -> IO c
withTimeoutManager f :: Manager -> IO c
f = case Settings -> Maybe Manager
settingsManager Settings
set of
Just tm :: Manager
tm -> Manager -> IO c
f Manager
tm
Nothing -> IO Manager -> (Manager -> IO ()) -> (Manager -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
(Int -> IO Manager
T.initialize Int
timeoutInSeconds)
Manager -> IO ()
T.stopManager
Manager -> IO c
f
acceptConnection :: Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> Counter
-> InternalInfo
-> IO ()
acceptConnection :: Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> Counter
-> InternalInfo
-> IO ()
acceptConnection set :: Settings
set getConnMaker :: IO (IO (Connection, Transport), SockAddr)
getConnMaker app :: Application
app counter :: Counter
counter ii :: InternalInfo
ii = do
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
mask_ IO ()
acceptLoop
Settings -> Counter -> IO ()
gracefulShutdown Settings
set Counter
counter
where
acceptLoop :: IO ()
acceptLoop = do
IO ()
allowInterrupt
Maybe (IO (Connection, Transport), SockAddr)
mx <- IO (Maybe (IO (Connection, Transport), SockAddr))
acceptNewConnection
case Maybe (IO (Connection, Transport), SockAddr)
mx of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (mkConn :: IO (Connection, Transport)
mkConn, addr :: SockAddr
addr) -> do
Settings
-> IO (Connection, Transport)
-> SockAddr
-> Application
-> Counter
-> InternalInfo
-> IO ()
fork Settings
set IO (Connection, Transport)
mkConn SockAddr
addr Application
app Counter
counter InternalInfo
ii
IO ()
acceptLoop
acceptNewConnection :: IO (Maybe (IO (Connection, Transport), SockAddr))
acceptNewConnection = do
Either IOError (IO (Connection, Transport), SockAddr)
ex <- IO (IO (Connection, Transport), SockAddr)
-> IO (Either IOError (IO (Connection, Transport), SockAddr))
forall e a. Exception e => IO a -> IO (Either e a)
try IO (IO (Connection, Transport), SockAddr)
getConnMaker
case Either IOError (IO (Connection, Transport), SockAddr)
ex of
Right x :: (IO (Connection, Transport), SockAddr)
x -> Maybe (IO (Connection, Transport), SockAddr)
-> IO (Maybe (IO (Connection, Transport), SockAddr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IO (Connection, Transport), SockAddr)
-> IO (Maybe (IO (Connection, Transport), SockAddr)))
-> Maybe (IO (Connection, Transport), SockAddr)
-> IO (Maybe (IO (Connection, Transport), SockAddr))
forall a b. (a -> b) -> a -> b
$ (IO (Connection, Transport), SockAddr)
-> Maybe (IO (Connection, Transport), SockAddr)
forall a. a -> Maybe a
Just (IO (Connection, Transport), SockAddr)
x
Left e :: IOError
e -> do
let eConnAborted :: CInt
eConnAborted = Errno -> CInt
getErrno Errno
eCONNABORTED
getErrno :: Errno -> CInt
getErrno (Errno cInt :: CInt
cInt) = CInt
cInt
if IOError -> Maybe CInt
ioe_errno IOError
e Maybe CInt -> Maybe CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Maybe CInt
forall a. a -> Maybe a
Just CInt
eConnAborted
then IO (Maybe (IO (Connection, Transport), SockAddr))
acceptNewConnection
else do
Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException Settings
set Maybe Request
forall a. Maybe a
Nothing (SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
toException IOError
e
Maybe (IO (Connection, Transport), SockAddr)
-> IO (Maybe (IO (Connection, Transport), SockAddr))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO (Connection, Transport), SockAddr)
forall a. Maybe a
Nothing
fork :: Settings
-> IO (Connection, Transport)
-> SockAddr
-> Application
-> Counter
-> InternalInfo
-> IO ()
fork :: Settings
-> IO (Connection, Transport)
-> SockAddr
-> Application
-> Counter
-> InternalInfo
-> IO ()
fork set :: Settings
set mkConn :: IO (Connection, Transport)
mkConn addr :: SockAddr
addr app :: Application
app counter :: Counter
counter ii :: InternalInfo
ii = Settings -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsFork Settings
set (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \unmask :: forall a. IO a -> IO a
unmask ->
(SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException Settings
set Maybe Request
forall a. Maybe a
Nothing) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO (Connection, Transport)
-> ((Connection, Transport) -> IO ())
-> ((Connection, Transport) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Connection, Transport)
mkConn (Connection, Transport) -> IO ()
forall b. (Connection, b) -> IO ()
cleanUp ((IO () -> IO ()) -> (Connection, Transport) -> IO ()
forall c. (IO () -> IO c) -> (Connection, Transport) -> IO c
serve IO () -> IO ()
forall a. IO a -> IO a
unmask)
where
cleanUp :: (Connection, b) -> IO ()
cleanUp (conn :: Connection
conn, _) = Connection -> IO ()
connClose Connection
conn IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Connection -> IO ()
connFree Connection
conn
serve :: (IO () -> IO c) -> (Connection, Transport) -> IO c
serve unmask :: IO () -> IO c
unmask (conn :: Connection
conn, transport :: Transport
transport) = IO Handle -> (Handle -> IO ()) -> (Handle -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Handle
register Handle -> IO ()
cancel ((Handle -> IO c) -> IO c) -> (Handle -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \th :: Handle
th -> do
IO () -> IO c
unmask (IO () -> IO c)
-> ((Bool -> IO ()) -> IO ()) -> (Bool -> IO ()) -> IO c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
IO Bool -> (Bool -> IO ()) -> (Bool -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (SockAddr -> IO Bool
onOpen SockAddr
addr) (SockAddr -> Bool -> IO ()
forall p. SockAddr -> p -> IO ()
onClose SockAddr
addr) ((Bool -> IO ()) -> IO c) -> (Bool -> IO ()) -> IO c
forall a b. (a -> b) -> a -> b
$ \goingon :: Bool
goingon ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
goingon (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Transport
-> Settings
-> Application
-> IO ()
serveConnection Connection
conn InternalInfo
ii Handle
th SockAddr
addr Transport
transport Settings
set Application
app
where
register :: IO Handle
register = Manager -> IO () -> IO Handle
T.registerKillThread (InternalInfo -> Manager
timeoutManager InternalInfo
ii) (Connection -> IO ()
connClose Connection
conn)
cancel :: Handle -> IO ()
cancel = Handle -> IO ()
T.cancel
onOpen :: SockAddr -> IO Bool
onOpen adr :: SockAddr
adr = Counter -> IO ()
increase Counter
counter IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Settings -> SockAddr -> IO Bool
settingsOnOpen Settings
set SockAddr
adr
onClose :: SockAddr -> p -> IO ()
onClose adr :: SockAddr
adr _ = Counter -> IO ()
decrease Counter
counter IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Settings -> SockAddr -> IO ()
settingsOnClose Settings
set SockAddr
adr
serveConnection :: Connection
-> InternalInfo
-> T.Handle
-> SockAddr
-> Transport
-> Settings
-> Application
-> IO ()
serveConnection :: Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Transport
-> Settings
-> Application
-> IO ()
serveConnection conn :: Connection
conn ii :: InternalInfo
ii th :: Handle
th origAddr :: SockAddr
origAddr transport :: Transport
transport settings :: Settings
settings app :: Application
app = do
(h2 :: Bool
h2,bs :: ByteString
bs) <- if Transport -> Bool
isHTTP2 Transport
transport then
(Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, "")
else do
ByteString
bs0 <- Connection -> Recv
connRecv Connection
conn
if ByteString -> Int
S.length ByteString
bs0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 4 Bool -> Bool -> Bool
&& "PRI " ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
bs0 then
(Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
bs0)
else
(Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, ByteString
bs0)
IORef Bool
istatus <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
if Settings -> Bool
settingsHTTP2Enabled Settings
settings Bool -> Bool -> Bool
&& Bool
h2 then do
Int -> Recv
rawRecvN <- ByteString -> Recv -> RecvBuf -> IO (Int -> Recv)
makeReceiveN ByteString
bs (Connection -> Recv
connRecv Connection
conn) (Connection -> RecvBuf
connRecvBuf Connection
conn)
let recvN :: Int -> Recv
recvN = Handle -> IORef Bool -> Int -> (Int -> Recv) -> Int -> Recv
wrappedRecvN Handle
th IORef Bool
istatus (Settings -> Int
settingsSlowlorisSize Settings
settings) Int -> Recv
rawRecvN
sendBS :: ByteString -> IO ()
sendBS x :: ByteString
x = Connection -> ByteString -> IO ()
connSendAll Connection
conn ByteString
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
T.tickle Handle
th
IO ()
checkTLS
Connection -> Bool -> IO ()
setConnHTTP2 Connection
conn Bool
True
Settings
-> InternalInfo
-> Connection
-> Transport
-> SockAddr
-> (Int -> Recv)
-> (ByteString -> IO ())
-> Application
-> IO ()
http2 Settings
settings InternalInfo
ii Connection
conn Transport
transport SockAddr
origAddr Int -> Recv
recvN ByteString -> IO ()
sendBS Application
app
else do
Source
src <- Recv -> IO Source
mkSource (Connection -> Handle -> IORef Bool -> Int -> Recv
wrappedRecv Connection
conn Handle
th IORef Bool
istatus (Settings -> Int
settingsSlowlorisSize Settings
settings))
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
True
Source -> ByteString -> IO ()
leftoverSource Source
src ByteString
bs
SockAddr
addr <- Source -> IO SockAddr
getProxyProtocolAddr Source
src
Bool -> SockAddr -> IORef Bool -> Source -> IO ()
http1 Bool
True SockAddr
addr IORef Bool
istatus Source
src IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: SomeException
e ->
case () of
()
| Just NoKeepAliveRequest <- SomeException -> Maybe NoKeepAliveRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just (BadFirstLine _) <- SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> do
Bool
_ <- Request -> IORef Bool -> SomeException -> IO Bool
sendErrorResponse (SockAddr -> Request
dummyreq SockAddr
addr) IORef Bool
istatus SomeException
e
SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
e
where
getProxyProtocolAddr :: Source -> IO SockAddr
getProxyProtocolAddr src :: Source
src =
case Settings -> ProxyProtocol
settingsProxyProtocol Settings
settings of
ProxyProtocolNone ->
SockAddr -> IO SockAddr
forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
origAddr
ProxyProtocolRequired -> do
ByteString
seg <- Source -> Recv
readSource Source
src
Source -> ByteString -> IO SockAddr
parseProxyProtocolHeader Source
src ByteString
seg
ProxyProtocolOptional -> do
ByteString
seg <- Source -> Recv
readSource Source
src
if ByteString -> ByteString -> Bool
S.isPrefixOf "PROXY " ByteString
seg
then Source -> ByteString -> IO SockAddr
parseProxyProtocolHeader Source
src ByteString
seg
else do Source -> ByteString -> IO ()
leftoverSource Source
src ByteString
seg
SockAddr -> IO SockAddr
forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
origAddr
parseProxyProtocolHeader :: Source -> ByteString -> IO SockAddr
parseProxyProtocolHeader src :: Source
src seg :: ByteString
seg = do
let (header :: ByteString
header,seg' :: ByteString
seg') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x0d) ByteString
seg
maybeAddr :: Maybe SockAddr
maybeAddr = case Word8 -> ByteString -> [ByteString]
S.split 0x20 ByteString
header of
["PROXY","TCP4",clientAddr :: ByteString
clientAddr,_,clientPort :: ByteString
clientPort,_] ->
case [IPv4
x | (x :: IPv4
x, t :: String
t) <- ReadS IPv4
forall a. Read a => ReadS a
reads (ByteString -> String
decodeAscii ByteString
clientAddr), String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t] of
[a :: IPv4
a] -> SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just (PortNumber -> HostAddress -> SockAddr
SockAddrInet (ByteString -> PortNumber
forall a. Integral a => ByteString -> a
readInt ByteString
clientPort)
(IPv4 -> HostAddress
toHostAddress IPv4
a))
_ -> Maybe SockAddr
forall a. Maybe a
Nothing
["PROXY","TCP6",clientAddr :: ByteString
clientAddr,_,clientPort :: ByteString
clientPort,_] ->
case [IPv6
x | (x :: IPv6
x, t :: String
t) <- ReadS IPv6
forall a. Read a => ReadS a
reads (ByteString -> String
decodeAscii ByteString
clientAddr), String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t] of
[a :: IPv6
a] -> SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just (PortNumber
-> HostAddress -> HostAddress6 -> HostAddress -> SockAddr
SockAddrInet6 (ByteString -> PortNumber
forall a. Integral a => ByteString -> a
readInt ByteString
clientPort)
0
(IPv6 -> HostAddress6
toHostAddress6 IPv6
a)
0)
_ -> Maybe SockAddr
forall a. Maybe a
Nothing
("PROXY":"UNKNOWN":_) ->
SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just SockAddr
origAddr
_ ->
Maybe SockAddr
forall a. Maybe a
Nothing
case Maybe SockAddr
maybeAddr of
Nothing -> InvalidRequest -> IO SockAddr
forall e a. Exception e => e -> IO a
throwIO (String -> InvalidRequest
BadProxyHeader (ByteString -> String
decodeAscii ByteString
header))
Just a :: SockAddr
a -> do Source -> ByteString -> IO ()
leftoverSource Source
src (Int -> ByteString -> ByteString
S.drop 2 ByteString
seg')
SockAddr -> IO SockAddr
forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
a
decodeAscii :: ByteString -> String
decodeAscii = (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum) ([Word8] -> String)
-> (ByteString -> [Word8]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
S.unpack
shouldSendErrorResponse :: SomeException -> Bool
shouldSendErrorResponse se :: SomeException
se
| Just ConnectionClosedByPeer <- SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = Bool
False
| Bool
otherwise = Bool
True
sendErrorResponse :: Request -> IORef Bool -> SomeException -> IO Bool
sendErrorResponse req :: Request
req istatus :: IORef Bool
istatus e :: SomeException
e = do
Bool
status <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
istatus
if SomeException -> Bool
shouldSendErrorResponse SomeException
e Bool -> Bool -> Bool
&& Bool
status
then do
Settings
-> Connection
-> InternalInfo
-> Handle
-> Request
-> IndexedHeader
-> Recv
-> Response
-> IO Bool
sendResponse Settings
settings Connection
conn InternalInfo
ii Handle
th Request
req IndexedHeader
defaultIndexRequestHeader (ByteString -> Recv
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty) (SomeException -> Response
errorResponse SomeException
e)
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
dummyreq :: SockAddr -> Request
dummyreq addr :: SockAddr
addr = Request
defaultRequest { remoteHost :: SockAddr
remoteHost = SockAddr
addr }
errorResponse :: SomeException -> Response
errorResponse e :: SomeException
e = Settings -> SomeException -> Response
settingsOnExceptionResponse Settings
settings SomeException
e
http1 :: Bool -> SockAddr -> IORef Bool -> Source -> IO ()
http1 firstRequest :: Bool
firstRequest addr :: SockAddr
addr istatus :: IORef Bool
istatus src :: Source
src = do
(req :: Request
req, mremainingRef :: Maybe (IORef Int)
mremainingRef, idxhdr :: IndexedHeader
idxhdr, nextBodyFlush :: Recv
nextBodyFlush) <- Bool
-> Settings
-> Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Source
-> Transport
-> IO (Request, Maybe (IORef Int), IndexedHeader, Recv)
recvRequest Bool
firstRequest Settings
settings Connection
conn InternalInfo
ii Handle
th SockAddr
addr Source
src Transport
transport
Bool
keepAlive <- IORef Bool
-> Source
-> Request
-> Maybe (IORef Int)
-> IndexedHeader
-> Recv
-> IO Bool
processRequest IORef Bool
istatus Source
src Request
req Maybe (IORef Int)
mremainingRef IndexedHeader
idxhdr Recv
nextBodyFlush
IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: SomeException
e -> do
Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException Settings
settings (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) SomeException
e
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
keepAlive (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> SockAddr -> IORef Bool -> Source -> IO ()
http1 Bool
False SockAddr
addr IORef Bool
istatus Source
src
processRequest :: IORef Bool
-> Source
-> Request
-> Maybe (IORef Int)
-> IndexedHeader
-> Recv
-> IO Bool
processRequest istatus :: IORef Bool
istatus src :: Source
src req :: Request
req mremainingRef :: Maybe (IORef Int)
mremainingRef idxhdr :: IndexedHeader
idxhdr nextBodyFlush :: Recv
nextBodyFlush = do
Handle -> IO ()
T.pause Handle
th
IORef Bool
keepAliveRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef (Bool -> IO (IORef Bool)) -> Bool -> IO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. HasCallStack => String -> a
error "keepAliveRef not filled"
Either SomeException ResponseReceived
r <- IO ResponseReceived -> IO (Either SomeException ResponseReceived)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ResponseReceived -> IO (Either SomeException ResponseReceived))
-> IO ResponseReceived
-> IO (Either SomeException ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \res :: Response
res -> do
Handle -> IO ()
T.resume Handle
th
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
False
Bool
keepAlive <- Settings
-> Connection
-> InternalInfo
-> Handle
-> Request
-> IndexedHeader
-> Recv
-> Response
-> IO Bool
sendResponse Settings
settings Connection
conn InternalInfo
ii Handle
th Request
req IndexedHeader
idxhdr (Source -> Recv
readSource Source
src) Response
res
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
keepAliveRef Bool
keepAlive
ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
case Either SomeException ResponseReceived
r of
Right ResponseReceived -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Left e :: SomeException
e@(SomeException _)
| Just (ExceptionInsideResponseBody e' :: SomeException
e') <- SomeException -> Maybe ExceptionInsideResponseBody
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
e'
| Bool
otherwise -> do
Bool
keepAlive <- Request -> IORef Bool -> SomeException -> IO Bool
sendErrorResponse Request
req IORef Bool
istatus SomeException
e
Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException Settings
settings (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) SomeException
e
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
keepAliveRef Bool
keepAlive
Bool
keepAlive <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
keepAliveRef
IO ()
Conc.yield
if Bool
keepAlive
then
case Settings -> Maybe Int
settingsMaximumBodyFlush Settings
settings of
Nothing -> do
Recv -> IO ()
flushEntireBody Recv
nextBodyFlush
Handle -> IO ()
T.resume Handle
th
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just maxToRead :: Int
maxToRead -> do
let tryKeepAlive :: IO Bool
tryKeepAlive = do
Bool
isComplete <- Recv -> Int -> IO Bool
flushBody Recv
nextBodyFlush Int
maxToRead
if Bool
isComplete then do
Handle -> IO ()
T.resume Handle
th
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
case Maybe (IORef Int)
mremainingRef of
Just ref :: IORef Int
ref -> do
Int
remaining <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
if Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxToRead then
IO Bool
tryKeepAlive
else
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Nothing -> IO Bool
tryKeepAlive
else
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
checkTLS :: IO ()
checkTLS = case Transport
transport of
TCP -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tls :: Transport
tls -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Transport -> Bool
tls12orLater Transport
tls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ErrorCodeId -> ByteString -> IO ()
goaway Connection
conn ErrorCodeId
H2.InadequateSecurity "Weak TLS"
tls12orLater :: Transport -> Bool
tls12orLater tls :: Transport
tls = Transport -> Int
tlsMajorVersion Transport
tls Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 Bool -> Bool -> Bool
&& Transport -> Int
tlsMinorVersion Transport
tls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 3
goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()
goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()
goaway Connection{..} etype :: ErrorCodeId
etype debugmsg :: ByteString
debugmsg = ByteString -> IO ()
connSendAll ByteString
bytestream
where
einfo :: EncodeInfo
einfo = (Word8 -> Word8) -> Int -> EncodeInfo
H2.encodeInfo Word8 -> Word8
forall a. a -> a
id 0
frame :: FramePayload
frame = Int -> ErrorCodeId -> ByteString -> FramePayload
H2.GoAwayFrame 0 ErrorCodeId
etype ByteString
debugmsg
bytestream :: ByteString
bytestream = EncodeInfo -> FramePayload -> ByteString
H2.encodeFrame EncodeInfo
einfo FramePayload
frame
flushEntireBody :: IO ByteString -> IO ()
flushEntireBody :: Recv -> IO ()
flushEntireBody src :: Recv
src =
IO ()
loop
where
loop :: IO ()
loop = do
ByteString
bs <- Recv
src
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) IO ()
loop
flushBody :: IO ByteString
-> Int
-> IO Bool
flushBody :: Recv -> Int -> IO Bool
flushBody src :: Recv
src =
Int -> IO Bool
loop
where
loop :: Int -> IO Bool
loop toRead :: Int
toRead = do
ByteString
bs <- Recv
src
let toRead' :: Int
toRead' = Int
toRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
S.length ByteString
bs
case () of
()
| ByteString -> Bool
S.null ByteString
bs -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
| Int
toRead' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 -> Int -> IO Bool
loop Int
toRead'
| Bool
otherwise -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
wrappedRecv :: Connection -> T.Handle -> IORef Bool -> Int -> IO ByteString
wrappedRecv :: Connection -> Handle -> IORef Bool -> Int -> Recv
wrappedRecv Connection { connRecv :: Connection -> Recv
connRecv = Recv
recv } th :: Handle
th istatus :: IORef Bool
istatus slowlorisSize :: Int
slowlorisSize = do
ByteString
bs <- Recv
recv
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
True
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
slowlorisSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
ByteString -> Recv
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)
wrappedRecvN :: Handle -> IORef Bool -> Int -> (Int -> Recv) -> Int -> Recv
wrappedRecvN th :: Handle
th istatus :: IORef Bool
istatus slowlorisSize :: Int
slowlorisSize readN :: Int -> Recv
readN bufsize :: Int
bufsize = do
ByteString
bs <- Int -> Recv
readN Int
bufsize
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
True
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
slowlorisSize Bool -> Bool -> Bool
|| Int
bufsize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
slowlorisSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
ByteString -> Recv
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
setSocketCloseOnExec :: Socket -> IO ()
#if WINDOWS
setSocketCloseOnExec _ = return ()
#else
setSocketCloseOnExec :: Socket -> IO ()
setSocketCloseOnExec socket :: Socket
socket = do
#if MIN_VERSION_network(3,0,0)
CInt
fd <- Socket -> IO CInt
fdSocket Socket
socket
#else
let fd = fdSocket socket
#endif
Fd -> IO ()
F.setFileCloseOnExec (Fd -> IO ()) -> Fd -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fd
#endif
gracefulShutdown :: Settings -> Counter -> IO ()
gracefulShutdown :: Settings -> Counter -> IO ()
gracefulShutdown set :: Settings
set counter :: Counter
counter =
case Settings -> Maybe Int
settingsGracefulShutdownTimeout Settings
set of
Nothing ->
Counter -> IO ()
waitForZero Counter
counter
(Just seconds :: Int
seconds) ->
IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
seconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
microsPerSecond) (Counter -> IO ()
waitForZero Counter
counter))
where microsPerSecond :: Int
microsPerSecond = 1000000