{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Network.Wai.Handler.Warp.Run where
import Control.Arrow (first)
import Control.Exception (allowInterrupt)
import qualified Control.Exception
import qualified Data.ByteString as S
import Data.IORef (newIORef, readIORef)
import Data.Streaming.Network (bindPortTCP)
import Foreign.C.Error (Errno (..), eCONNABORTED)
import GHC.IO.Exception (IOErrorType (..), IOException (..))
import Network.Socket (
SockAddr,
Socket,
SocketOption (..),
close,
#if !WINDOWS
fdSocket,
#endif
getSocketName,
setSocketOption,
withSocketsDo,
)
#if MIN_VERSION_network(3,1,1)
import Network.Socket (gracefulClose)
#endif
import Network.Socket.BufferPool
import qualified Network.Socket.ByteString as Sock
import Network.Wai
import System.Environment (lookupEnv)
import System.IO.Error (ioeGetErrorType)
import qualified System.TimeManager as T
import System.Timeout (timeout)
import UnliftIO (toException)
import qualified UnliftIO
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.HTTP1 (http1)
import Network.Wai.Handler.Warp.HTTP2 (http2)
import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
import Network.Wai.Handler.Warp.Imports hiding (readInt)
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
#endif
socketConnection :: Settings -> Socket -> IO Connection
#if MIN_VERSION_network(3,1,1)
socketConnection :: Settings -> Socket -> IO Connection
socketConnection Settings
set Socket
s = do
#else
socketConnection _ s = do
#endif
BufferPool
bufferPool <- Int -> Int -> IO BufferPool
newBufferPool Int
2048 Int
16384
WriteBuffer
writeBuffer <- Int -> IO WriteBuffer
createWriteBuffer Int
16384
IORef WriteBuffer
writeBufferRef <- WriteBuffer -> IO (IORef WriteBuffer)
forall a. a -> IO (IORef a)
newIORef WriteBuffer
writeBuffer
IORef Bool
isH2 <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
SockAddr
mysa <- Socket -> IO SockAddr
getSocketName Socket
s
Connection -> IO Connection
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
Connection
{ connSendMany :: [ByteString] -> IO ()
connSendMany = Socket -> [ByteString] -> IO ()
Sock.sendMany Socket
s
, connSendAll :: ByteString -> IO ()
connSendAll = ByteString -> IO ()
sendall
, connSendFile :: SendFile
connSendFile = IORef WriteBuffer -> SendFile
sendfile IORef WriteBuffer
writeBufferRef
#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
== Int
0
then Socket -> IO ()
close Socket
s
else Socket -> Int -> IO ()
gracefulClose Socket
s Int
tm IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UnliftIO.catchAny` \(UnliftIO.SomeException e
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
, connClose = close s
#endif
, connRecv :: Recv
connRecv = Socket -> BufferPool -> Recv
receive' Socket
s BufferPool
bufferPool
, connRecvBuf :: RecvBuf
connRecvBuf = \Buffer
_ Int
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
, connWriteBuffer :: IORef WriteBuffer
connWriteBuffer = IORef WriteBuffer
writeBufferRef
, connHTTP2 :: IORef Bool
connHTTP2 = IORef Bool
isH2
, connMySockAddr :: SockAddr
connMySockAddr = SockAddr
mysa
}
where
receive' :: Socket -> BufferPool -> Recv
receive' Socket
sock BufferPool
pool = (IOException -> Recv) -> Recv -> Recv
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
UnliftIO.handleIO IOException -> Recv
handler (Recv -> Recv) -> Recv -> Recv
forall a b. (a -> b) -> a -> b
$ Socket -> BufferPool -> Recv
receive Socket
sock BufferPool
pool
where
handler :: UnliftIO.IOException -> IO ByteString
handler :: IOException -> Recv
handler IOException
e
| IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InvalidArgument = ByteString -> Recv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
| Bool
otherwise = IOException -> Recv
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO IOException
e
sendfile :: IORef WriteBuffer -> SendFile
sendfile IORef WriteBuffer
writeBufferRef FileId
fid Integer
offset Integer
len IO ()
hook [ByteString]
headers = do
WriteBuffer
writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
forall a. IORef a -> IO a
readIORef IORef WriteBuffer
writeBufferRef
Socket -> Buffer -> Int -> (ByteString -> IO ()) -> SendFile
sendFile
Socket
s
(WriteBuffer -> Buffer
bufBuffer WriteBuffer
writeBuffer)
(WriteBuffer -> Int
bufSize WriteBuffer
writeBuffer)
ByteString -> IO ()
sendall
FileId
fid
Integer
offset
Integer
len
IO ()
hook
[ByteString]
headers
sendall :: ByteString -> IO ()
sendall = Socket -> ByteString -> IO ()
sendAll' Socket
s
sendAll' :: Socket -> ByteString -> IO ()
sendAll' Socket
sock ByteString
bs =
(IOException -> Maybe InvalidRequest)
-> (InvalidRequest -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
UnliftIO.handleJust
( \IOException
e ->
if IOException -> IOErrorType
ioeGetErrorType IOException
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.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 Int
p = Settings -> Application -> IO ()
runSettings Settings
defaultSettings{settingsPort = p}
runEnv :: Port -> Application -> IO ()
runEnv :: Int -> Application -> IO ()
runEnv Int
p Application
app = do
Maybe [Char]
mp <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"PORT"
IO () -> ([Char] -> IO ()) -> Maybe [Char] -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Application -> IO ()
run Int
p Application
app) [Char] -> IO ()
runReadPort Maybe [Char]
mp
where
runReadPort :: String -> IO ()
runReadPort :: [Char] -> IO ()
runReadPort [Char]
sp = case ReadS Int
forall a. Read a => ReadS a
reads [Char]
sp of
((Int
p', [Char]
_) : [(Int, [Char])]
_) -> Int -> Application -> IO ()
run Int
p' Application
app
[(Int, [Char])]
_ -> [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid value in $PORT: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
sp
runSettings :: Settings -> Application -> IO ()
runSettings :: Settings -> Application -> IO ()
runSettings Settings
set 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 (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket
(Int -> HostPreference -> IO Socket
bindPortTCP (Settings -> Int
settingsPort Settings
set) (Settings -> HostPreference
settingsHost Settings
set))
Socket -> IO ()
close
( \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@Settings{settingsAccept :: Settings -> Socket -> IO (Socket, SockAddr)
settingsAccept = Socket -> IO (Socket, SockAddr)
accept'} Socket
socket 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
(Socket
s, SockAddr
sa) <- Socket -> IO (Socket, SockAddr)
accept' Socket
socket
Socket -> IO ()
setSocketCloseOnExec Socket
s
Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
NoDelay Int
1 IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UnliftIO.catchAny` \(UnliftIO.SomeException e
_) -> () -> IO ()
forall a. a -> IO a
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 a. a -> IO a
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 Settings
set IO (Connection, SockAddr)
getConn 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
(Connection
conn, SockAddr
sa) <- IO (Connection, SockAddr)
getConn
(IO Connection, SockAddr) -> IO (IO Connection, SockAddr)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> IO Connection
forall a. a -> IO a
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 Settings
x IO (IO Connection, SockAddr)
y =
Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> IO ()
runSettingsConnectionMakerSecure Settings
x ((IO Connection, SockAddr) -> (IO (Connection, Transport), SockAddr)
forall {a} {d}. (IO a, d) -> (IO (a, 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 a, d) -> (IO (a, Transport), d)
toTCP = (IO a -> IO (a, Transport)) -> (IO a, d) -> (IO (a, Transport), d)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((,Transport
TCP) (a -> (a, Transport)) -> IO a -> IO (a, 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 Settings
set IO (IO (Connection, Transport), SockAddr)
getConnMaker 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 :: forall a. Settings -> (InternalInfo -> IO a) -> IO a
withII Settings
set 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
$ \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
$ \Recv
dc ->
Int -> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
forall a. Int -> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
F.withFdCache Int
fdCacheDurationInSeconds ((([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a)
-> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \[Char] -> IO (Maybe Fd, IO ())
fdc ->
Int -> (([Char] -> IO FileInfo) -> IO a) -> IO a
forall a. Int -> (([Char] -> IO FileInfo) -> IO a) -> IO a
I.withFileInfoCache Int
fdFileInfoDurationInSeconds ((([Char] -> IO FileInfo) -> IO a) -> IO a)
-> (([Char] -> IO FileInfo) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \[Char] -> IO FileInfo
fic -> do
let ii :: InternalInfo
ii = Manager
-> Recv
-> ([Char] -> IO (Maybe Fd, IO ()))
-> ([Char] -> IO FileInfo)
-> InternalInfo
InternalInfo Manager
tm Recv
dc [Char] -> IO (Maybe Fd, IO ())
fdc [Char] -> 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
* Int
1000000
!fdFileInfoDurationInSeconds :: Int
fdFileInfoDurationInSeconds = Settings -> Int
settingsFileInfoCacheDuration Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
!timeoutInSeconds :: Int
timeoutInSeconds = Settings -> Int
settingsTimeout Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
withTimeoutManager :: (Manager -> IO c) -> IO c
withTimeoutManager Manager -> IO c
f = case Settings -> Maybe Manager
settingsManager Settings
set of
Just Manager
tm -> Manager -> IO c
f Manager
tm
Maybe Manager
Nothing ->
IO Manager -> (Manager -> IO ()) -> (Manager -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.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 Settings
set IO (IO (Connection, Transport), SockAddr)
getConnMaker Application
app Counter
counter 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 (m :: * -> *) a. MonadUnliftIO m => m a -> m a
UnliftIO.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
Maybe (IO (Connection, Transport), SockAddr)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (IO (Connection, Transport)
mkConn, 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 IOException (IO (Connection, Transport), SockAddr)
ex <- IO (IO (Connection, Transport), SockAddr)
-> IO (Either IOException (IO (Connection, Transport), SockAddr))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
UnliftIO.tryIO IO (IO (Connection, Transport), SockAddr)
getConnMaker
case Either IOException (IO (Connection, Transport), SockAddr)
ex of
Right (IO (Connection, Transport), SockAddr)
x -> Maybe (IO (Connection, Transport), SockAddr)
-> IO (Maybe (IO (Connection, Transport), SockAddr))
forall a. a -> IO a
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 IOException
e -> do
let eConnAborted :: CInt
eConnAborted = Errno -> CInt
getErrno Errno
eCONNABORTED
getErrno :: Errno -> CInt
getErrno (Errno CInt
cInt) = CInt
cInt
if IOException -> Maybe CInt
ioe_errno IOException
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
$ IOException -> SomeException
forall e. Exception e => e -> SomeException
toException IOException
e
Maybe (IO (Connection, Transport), SockAddr)
-> IO (Maybe (IO (Connection, Transport), SockAddr))
forall a. a -> IO a
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 Settings
set IO (Connection, Transport)
mkConn SockAddr
addr Application
app Counter
counter 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
$ \forall a. IO a -> IO a
unmask ->
(SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Control.Exception.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 (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.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 (Connection
conn, b
_) =
Connection -> IO ()
connClose Connection
conn IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UnliftIO.finally` do
WriteBuffer
writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
forall a. IORef a -> IO a
readIORef (IORef WriteBuffer -> IO WriteBuffer)
-> IORef WriteBuffer -> IO WriteBuffer
forall a b. (a -> b) -> a -> b
$ Connection -> IORef WriteBuffer
connWriteBuffer Connection
conn
WriteBuffer -> IO ()
bufFree WriteBuffer
writeBuffer
serve :: (IO () -> IO c) -> (Connection, Transport) -> IO c
serve IO () -> IO c
unmask (Connection
conn, Transport
transport) = IO Handle -> (Handle -> IO ()) -> (Handle -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket IO Handle
register Handle -> IO ()
cancel ((Handle -> IO c) -> IO c) -> (Handle -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \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 (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.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
$ \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 SockAddr
adr = Counter -> IO ()
increase Counter
counter IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
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 SockAddr
adr p
_ = Counter -> IO ()
decrease Counter
counter IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 Connection
conn InternalInfo
ii Handle
th SockAddr
origAddr Transport
transport Settings
settings Application
app = do
(Bool
h2, ByteString
bs) <-
if Transport -> Bool
isHTTP2 Transport
transport
then (Bool, ByteString) -> IO (Bool, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
"")
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
>= Int
4 Bool -> Bool -> Bool
&& ByteString
"PRI " ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
bs0
then (Bool, ByteString) -> IO (Bool, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
bs0)
else (Bool, ByteString) -> IO (Bool, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, ByteString
bs0)
if Settings -> Bool
settingsHTTP2Enabled Settings
settings Bool -> Bool -> Bool
&& Bool
h2
then do
Settings
-> InternalInfo
-> Connection
-> Transport
-> Application
-> SockAddr
-> Handle
-> ByteString
-> IO ()
http2 Settings
settings InternalInfo
ii Connection
conn Transport
transport Application
app SockAddr
origAddr Handle
th ByteString
bs
else do
Settings
-> InternalInfo
-> Connection
-> Transport
-> Application
-> SockAddr
-> Handle
-> ByteString
-> IO ()
http1 Settings
settings InternalInfo
ii Connection
conn Transport
transport Application
app SockAddr
origAddr Handle
th ByteString
bs
setSocketCloseOnExec :: Socket -> IO ()
#if WINDOWS
setSocketCloseOnExec _ = return ()
#else
setSocketCloseOnExec :: Socket -> IO ()
setSocketCloseOnExec 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 Settings
set Counter
counter =
case Settings -> Maybe Int
settingsGracefulShutdownTimeout Settings
set of
Maybe Int
Nothing ->
Counter -> IO ()
waitForZero Counter
counter
(Just 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 = Int
1000000