module Network.Wai.Handler.Warp.Run where
import Control.Arrow (first)
import Control.Concurrent (threadDelay)
import qualified Control.Concurrent as Conc (yield)
import Control.Exception as E
import Control.Monad (when, unless, void)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.Char (chr)
import Data.IP (toHostAddress, toHostAddress6)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Streaming.Network (bindPortTCP)
import Network (sClose, Socket)
import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6))
import qualified Network.Socket.ByteString as Sock
import Network.Wai
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 Network.Wai.Handler.Warp.HTTP2
import Network.Wai.Handler.Warp.Header
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 qualified Network.Wai.Handler.Warp.Timeout as T
import Network.Wai.Handler.Warp.Types
import Network.Wai.Internal (ResponseReceived (ResponseReceived))
import System.Environment (getEnvironment)
import System.IO.Error (isFullErrorType, ioeGetErrorType)
#if WINDOWS
import Network.Wai.Handler.Warp.Windows
#else
import System.Posix.IO (FdOption(CloseOnExec), setFdOption)
import Network.Socket (fdSocket)
#endif
socketConnection :: Socket -> IO Connection
socketConnection s = do
bufferPool <- newBufferPool
writeBuf <- allocateBuffer bufferSize
let sendall = Sock.sendAll s
return Connection {
connSendMany = Sock.sendMany s
, connSendAll = sendall
, connSendFile = sendFile s writeBuf bufferSize sendall
, connClose = sClose s >> freeBuffer writeBuf
, connRecv = receive s bufferPool
, connRecvBuf = receiveBuf s
, connWriteBuffer = writeBuf
, connBufferSize = bufferSize
}
#if __GLASGOW_HASKELL__ < 702
allowInterrupt :: IO ()
allowInterrupt = unblock $ return ()
#endif
run :: Port -> Application -> IO ()
run p = runSettings defaultSettings { settingsPort = p }
runEnv :: Port -> Application -> IO ()
runEnv p app = do
mp <- fmap (lookup "PORT") getEnvironment
maybe (run p app) runReadPort mp
where
runReadPort :: String -> IO ()
runReadPort sp = case reads sp of
((p', _):_) -> run p' app
_ -> fail $ "Invalid value in $PORT: " ++ sp
runSettings :: Settings -> Application -> IO ()
runSettings set app = withSocketsDo $
bracket
(bindPortTCP (settingsPort set) (settingsHost set))
sClose
(\socket -> do
setSocketCloseOnExec socket
runSettingsSocket set socket app)
runSettingsSocket :: Settings -> Socket -> Application -> IO ()
runSettingsSocket set socket app = do
settingsInstallShutdownHandler set closeListenSocket
runSettingsConnection set getConn app
where
getConn = do
#if WINDOWS
(s, sa) <- windowsThreadBlockHack $ accept socket
#else
(s, sa) <- accept socket
#endif
setSocketCloseOnExec s
conn <- socketConnection s
return (conn, sa)
closeListenSocket = sClose socket
runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app
where
getConnMaker = do
(conn, sa) <- getConn
return (return conn, sa)
runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
runSettingsConnectionMaker x y =
runSettingsConnectionMakerSecure x (go y)
where
go = fmap (first (fmap (, TCP)))
runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()
runSettingsConnectionMakerSecure set getConnMaker app = do
settingsBeforeMainLoop set
counter <- newCounter
D.withDateCache $ \dc ->
F.withFdCache fdCacheDurationInSeconds $ \fc ->
withTimeoutManager $ \tm ->
acceptConnection set getConnMaker app dc fc tm counter
where
fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
withTimeoutManager f = case settingsManager set of
Just tm -> f tm
Nothing -> bracket
(T.initialize $ settingsTimeout set * 1000000)
T.stopManager
f
acceptConnection :: Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> D.DateCache
-> Maybe F.MutableFdCache
-> T.Manager
-> Counter
-> IO ()
acceptConnection set getConnMaker app dc fc tm counter = do
void $ mask_ acceptLoop
gracefulShutdown counter
where
acceptLoop = do
allowInterrupt
mx <- acceptNewConnection
case mx of
Nothing -> return ()
Just (mkConn, addr) -> do
fork set mkConn addr app dc fc tm counter
acceptLoop
acceptNewConnection = do
ex <- try getConnMaker
case ex of
Right x -> return $ Just x
Left e -> do
settingsOnException set Nothing $ toException e
if isFullErrorType (ioeGetErrorType e) then do
threadDelay 1000000
acceptNewConnection
else
return Nothing
fork :: Settings
-> IO (Connection, Transport)
-> SockAddr
-> Application
-> D.DateCache
-> Maybe F.MutableFdCache
-> T.Manager
-> Counter
-> IO ()
fork set mkConn addr app dc fc tm counter = settingsFork set $ \ unmask ->
bracket mkConn closeConn $ \(conn, transport) ->
bracket (T.registerKillThread tm) T.cancel $ \th ->
let ii = InternalInfo th tm fc dc
in unmask .
handle (settingsOnException set Nothing) .
bracket (onOpen addr) (onClose addr) $ \goingon ->
when goingon $ serveConnection conn ii addr transport set app
where
closeConn (conn, _transport) = connClose conn
onOpen adr = increase counter >> settingsOnOpen set adr
onClose adr _ = decrease counter >> settingsOnClose set adr
serveConnection :: Connection
-> InternalInfo
-> SockAddr
-> Transport
-> Settings
-> Application
-> IO ()
serveConnection conn ii origAddr transport settings app = do
(h2,bs) <- if isHTTP2 transport then
return (True, "")
else do
bs0 <- connRecv conn
if S.length bs0 >= 4 && "PRI " `S.isPrefixOf` bs0 then
return (True, bs0)
else
return (False, bs0)
if h2 then do
recvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
http2 conn ii origAddr transport settings recvN app
else do
istatus <- newIORef False
src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
writeIORef istatus True
leftoverSource src bs
addr <- getProxyProtocolAddr src
http1 addr istatus src `E.catch` \e -> do
sendErrorResponse addr istatus e
throwIO (e :: SomeException)
where
getProxyProtocolAddr src =
case settingsProxyProtocol settings of
ProxyProtocolNone ->
return origAddr
ProxyProtocolRequired -> do
seg <- readSource src
parseProxyProtocolHeader src seg
ProxyProtocolOptional -> do
seg <- readSource src
if S.isPrefixOf "PROXY " seg
then parseProxyProtocolHeader src seg
else do leftoverSource src seg
return origAddr
parseProxyProtocolHeader src seg = do
let (header,seg') = S.break (== 0x0d) seg
maybeAddr = case S.split 0x20 header of
["PROXY","TCP4",clientAddr,_,clientPort,_] ->
case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of
[a] -> Just (SockAddrInet (readInt clientPort)
(toHostAddress a))
_ -> Nothing
["PROXY","TCP6",clientAddr,_,clientPort,_] ->
case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of
[a] -> Just (SockAddrInet6 (readInt clientPort)
0
(toHostAddress6 a)
0)
_ -> Nothing
("PROXY":"UNKNOWN":_) ->
Just origAddr
_ ->
Nothing
case maybeAddr of
Nothing -> throwIO (BadProxyHeader (decodeAscii header))
Just a -> do leftoverSource src (S.drop 2 seg')
return a
decodeAscii = map (chr . fromEnum) . S.unpack
th = threadHandle ii
sendErrorResponse addr istatus e = do
status <- readIORef istatus
when status $ void $
sendResponse
(settingsServerName settings)
conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e)
dummyreq addr = defaultRequest { remoteHost = addr }
errorResponse e = settingsOnExceptionResponse settings e
http1 addr istatus src = do
(req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest settings conn ii addr src
let req = req' { isSecure = isTransportSecure transport }
keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
`E.catch` \e -> do
sendErrorResponse addr istatus e
settingsOnException settings (Just req) e
return False
when keepAlive $ http1 addr istatus src
processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do
T.pause th
keepAliveRef <- newIORef $ error "keepAliveRef not filled"
_ <- app req $ \res -> do
T.resume th
writeIORef istatus False
keepAlive <- sendResponse
(settingsServerName settings)
conn ii req idxhdr (readSource src) res
writeIORef keepAliveRef keepAlive
return ResponseReceived
keepAlive <- readIORef keepAliveRef
Conc.yield
if not keepAlive then
return False
else
case settingsMaximumBodyFlush settings of
Nothing -> do
flushEntireBody nextBodyFlush
T.resume th
return True
Just maxToRead -> do
let tryKeepAlive = do
isComplete <- flushBody nextBodyFlush maxToRead
if isComplete then do
T.resume th
return True
else
return False
case mremainingRef of
Just ref -> do
remaining <- readIORef ref
if remaining <= maxToRead then
tryKeepAlive
else
return False
Nothing -> tryKeepAlive
flushEntireBody :: IO ByteString -> IO ()
flushEntireBody src =
loop
where
loop = do
bs <- src
unless (S.null bs) loop
flushBody :: IO ByteString
-> Int
-> IO Bool
flushBody src =
loop
where
loop toRead = do
bs <- src
let toRead' = toRead S.length bs
case () of
()
| S.null bs -> return True
| toRead' >= 0 -> loop toRead'
| otherwise -> return False
wrappedRecv :: Connection -> T.Handle -> IORef Bool -> Int -> IO ByteString
wrappedRecv Connection { connRecv = recv } th istatus slowlorisSize = do
bs <- recv
unless (S.null bs) $ do
writeIORef istatus True
when (S.length bs >= slowlorisSize) $ T.tickle th
return bs
setSocketCloseOnExec :: Socket -> IO ()
#if WINDOWS
setSocketCloseOnExec _ = return ()
#else
setSocketCloseOnExec socket =
setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True
#endif
gracefulShutdown :: Counter -> IO ()
gracefulShutdown counter = waitForZero counter