module Network.Wai.Handler.Warp.Run where
import Control.Arrow (first)
import Control.Concurrent (threadDelay, forkIOWithUnmask)
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.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Streaming.Network (bindPortTCP)
import Network (sClose, Socket)
import Network.Socket (accept, withSocketsDo, SockAddr)
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.Header
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.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
readBuf <- allocateBuffer bufferSize
writeBuf <- allocateBuffer bufferSize
return Connection {
connSendMany = Sock.sendMany s
, connSendAll = Sock.sendAll s
, connSendFile = defaultSendFile s
, connClose = sClose s >> freeBuffer readBuf >> freeBuffer writeBuf
, connRecv = receive s readBuf bufferSize
, connReadBuffer = readBuf
, connWriteBuffer = writeBuf
, connBufferSize = bufferSize
, connSendFileOverride = Override s
}
#if __GLASGOW_HASKELL__ < 702
allowInterrupt :: IO ()
allowInterrupt = unblock $ return ()
#endif
run :: Port -> Application -> IO ()
run p = runSettings defaultSettings { settingsPort = p }
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 (, False)))
runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Bool), 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
onE :: Settings -> Maybe Request -> SomeException -> IO ()
onE set mreq e = case fromException e of
Just (NotEnoughLines []) -> return ()
_ -> settingsOnException set mreq e
acceptConnection :: Settings
-> IO (IO (Connection, Bool), 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
onE set Nothing $ toException e
if isFullErrorType (ioeGetErrorType e) then do
threadDelay 1000000
acceptNewConnection
else
return Nothing
fork :: Settings
-> IO (Connection, Bool)
-> SockAddr
-> Application
-> D.DateCache
-> Maybe F.MutableFdCache
-> T.Manager
-> Counter
-> IO ()
fork set mkConn addr app dc fc tm counter = void $ forkIOWithUnmask $ \unmask ->
bracket mkConn closeConn $ \(conn0, isSecure') ->
bracket (T.registerKillThread tm) T.cancel $ \th ->
let ii = InternalInfo th fc dc
conn = setSendFile conn0 fc
in unmask .
handle (onE set Nothing) .
bracket (onOpen addr) (onClose addr) $ \goingon ->
when goingon $ serveConnection conn ii addr isSecure' set app
where
closeConn (conn, _isSecure) = connClose conn
onOpen adr = increase counter >> settingsOnOpen set adr
onClose adr _ = decrease counter >> settingsOnClose set adr
serveConnection :: Connection
-> InternalInfo
-> SockAddr
-> Bool
-> Settings
-> Application
-> IO ()
serveConnection conn ii addr isSecure' settings app = do
istatus <- newIORef False
src <- mkSource (connSource conn th istatus)
recvSendLoop istatus src `E.catch` \e -> do
sendErrorResponse istatus e
throwIO (e :: SomeException)
where
th = threadHandle ii
sendErrorResponse istatus e = do
status <- readIORef istatus
when status $ void $
sendResponse
(settingsServerName settings)
conn ii dummyreq defaultIndexRequestHeader (return S.empty) (errorResponse e)
dummyreq = defaultRequest { remoteHost = addr }
errorResponse e = settingsOnExceptionResponse settings e
recvSendLoop istatus fromClient = do
(req', idxhdr) <- recvRequest settings conn ii addr fromClient
let req = req' { isSecure = isSecure' }
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 fromClient) res
writeIORef keepAliveRef keepAlive
return ResponseReceived
keepAlive <- readIORef keepAliveRef
Conc.yield
when keepAlive $ do
flushBody $ requestBody req
T.resume th
recvSendLoop istatus fromClient
flushBody :: IO ByteString -> IO ()
flushBody src =
loop
where
loop = do
bs <- src
unless (S.null bs) loop
connSource :: Connection -> T.Handle -> IORef Bool -> IO ByteString
connSource Connection { connRecv = recv } th istatus = do
bs <- recv
unless (S.null bs) $ do
writeIORef istatus True
when (S.length bs >= 2048) $ 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 = do
threadDelay 10000000
noConnections <- isZero counter
unless noConnections $ gracefulShutdown counter