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
#if MIN_VERSION_conduit(1,1,0)
import Data.Streaming.Network (bindPortTCP)
#else
import Data.Conduit.Network (bindPort)
#define bindPortTCP bindPort
#endif
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
(bindPortTCP (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
(bindPortTCP (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 x y =
runSettingsConnectionMakerSecure x (go y)
where
go = fmap (\(a, b) -> (fmap (, False) a, b))
runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Bool), SockAddr) -> Application -> IO ()
runSettingsConnectionMakerSecure 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 . fst) $ \(conn', isSecure') ->
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 isSecure' 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
-> Bool
-> Settings
-> Application
-> IO ()
serveConnection conn ii addr isSecure' 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
let req = req' { isSecure = isSecure' }
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