module Network.Wai.Handler.Warp.Run where
import Control.Concurrent (threadDelay, forkIOWithUnmask)
import qualified Control.Concurrent as Conc (yield)
import Control.Exception as E
import Control.Monad (forever, when, unless, void)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.Conduit
import Data.Conduit.Internal (ResumableSource (..))
import qualified Data.Conduit.List as CL
import Data.Conduit.Network (bindPort)
import Network (sClose, Socket)
import Network.Socket (accept, SockAddr)
import qualified Network.Socket.ByteString as Sock
import Network.Wai
import qualified Network.Wai.Handler.Warp.Date as D
import qualified Network.Wai.Handler.Warp.FdCache as F
import Network.Wai.Handler.Warp.Buffer
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 Data.IORef (IORef, newIORef, readIORef, writeIORef)
#if WINDOWS
import qualified Control.Concurrent.MVar as MV
import Network.Socket (withSocketsDo)
import Control.Concurrent (forkIO)
#else
import System.Posix.IO (FdOption(CloseOnExec), setFdOption)
import Network.Socket (fdSocket)
#endif
socketConnection :: Socket -> IO Connection
socketConnection s = do
buf <- allocateBuffer bufferSize
return Connection {
connSendMany = Sock.sendMany s
, connSendAll = Sock.sendAll s
, connSendFile = defaultSendFile s
, connClose = sClose s >> freeBuffer buf
, connRecv = receive s buf bufferSize
, connBuffer = buf
, 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 ()
#if WINDOWS
runSettings set app = withSocketsDo $ do
var <- MV.newMVar Nothing
let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing
void . forkIO $ bracket
(bindPort (settingsPort set) (settingsHost set))
(const clean)
(\s -> do
MV.modifyMVar_ var (\_ -> return $ Just s)
runSettingsSocket set s app)
forever (threadDelay maxBound) `finally` clean
#else
runSettings set app =
bracket
(bindPort (settingsPort set) (settingsHost set))
sClose
(\socket -> do
setSocketCloseOnExec socket
runSettingsSocket set socket app)
#endif
runSettingsSocket :: Settings -> Socket -> Application -> IO ()
runSettingsSocket set socket app =
runSettingsConnection set getConn app
where
getConn = do
(s, sa) <- accept socket
setSocketCloseOnExec s
conn <- socketConnection s
return (conn, sa)
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 set getConnMaker app = do
settingsBeforeMainLoop set
D.withDateCache $ \dc -> do
F.withFdCache (settingsFdCacheDuration set * 1000000) $ \fc -> do
withTimeoutManager $ \tm -> mask_ . forever $ do
allowInterrupt
(mkConn, addr) <- getConnLoop
void $ forkIOWithUnmask $ \unmask ->
bracket mkConn connClose $ \conn' ->
bracket (T.registerKillThread tm) T.cancel $ \th ->
let ii = InternalInfo th fc dc
conn = setSendFile conn' fc
in unmask .
handle (onE Nothing) .
bracket (onOpen addr) (const $ onClose addr) $ \goingon ->
when goingon $ serveConnection conn ii addr set app
where
getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do
onE Nothing (toException e)
threadDelay 1000000
getConnLoop
onE mreq e =
case fromException e of
Just (NotEnoughLines []) -> return ()
_ -> settingsOnException set mreq e
onOpen = settingsOnOpen set
onClose = settingsOnClose set
withTimeoutManager f =
case settingsManager set of
Nothing -> bracket
(T.initialize $ settingsTimeout set * 1000000)
T.stopManager
f
Just tm -> f tm
serveConnection :: Connection
-> InternalInfo
-> SockAddr
-> Settings
-> Application
-> IO ()
serveConnection conn ii addr settings app = do
istatus <- newIORef False
recvSendLoop istatus (connSource conn th istatus) `E.catch` \e -> do
sendErrorResponse istatus e
throwIO (e :: SomeException)
where
th = threadHandle ii
sendErrorResponse istatus e = do
status <- readIORef istatus
when status $ void $ mask $ \restore ->
sendResponse conn ii restore dummyreq defaultIndexRequestHeader Nothing (errorResponse e)
dummyreq = defaultRequest { remoteHost = addr }
errorResponse e = settingsOnExceptionResponse settings e
recvSendLoop istatus fromClient = do
(req, idxhdr, getSource, leftover') <- recvRequest settings conn ii addr fromClient
intercept' <- settingsIntercept settings req
case intercept' of
Nothing -> do
T.pause th
keepAlive <- mask $ \restore -> do
res <- restore $ app req
T.resume th
writeIORef istatus False
sendResponse conn ii restore req idxhdr leftover' res
Conc.yield
when keepAlive $ do
requestBody req $$ CL.sinkNull
ResumableSource fromClient' _ <- getSource
T.resume th
recvSendLoop istatus fromClient'
Just intercept -> do
T.pause th
ResumableSource fromClient' _ <- getSource
intercept fromClient' conn
connSource :: Connection -> T.Handle -> IORef Bool -> Source IO ByteString
connSource Connection { connRecv = recv } th istatus = src
where
src = do
bs <- liftIO recv
unless (S.null bs) $ do
liftIO $ do
writeIORef istatus True
when (S.length bs >= 2048) $ T.tickle th
yield bs
src
setSocketCloseOnExec :: Socket -> IO ()
#if WINDOWS
setSocketCloseOnExec _ = return ()
#else
setSocketCloseOnExec socket =
setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True
#endif