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 qualified Network.HTTP.Types as H
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
#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 onClose $
serveConnection conn ii addr set app
where
getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do
onE Nothing (toException e)
threadDelay 1000000
getConnLoop
onE = settingsOnException set
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 =
recvSendLoop (connSource conn th) `onException` send500
where
th = threadHandle ii
send500 = void $ mask $ \restore ->
sendResponse conn ii restore dummyreq defaultIndexRequestHeader internalError
dummyreq = defaultRequest { remoteHost = addr }
internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"
recvSendLoop fromClient = do
(req, idxhdr, getSource) <- recvRequest conn ii addr fromClient
case settingsIntercept settings req of
Nothing -> do
T.pause th
keepAlive <- mask $ \restore -> do
res <- restore $ app req
T.resume th
sendResponse conn ii restore req idxhdr res
Conc.yield
requestBody req $$ CL.sinkNull
ResumableSource fromClient' _ <- getSource
when keepAlive $ recvSendLoop fromClient'
Just intercept -> do
T.pause th
ResumableSource fromClient' _ <- getSource
intercept fromClient' conn
connSource :: Connection -> T.Handle -> Source IO ByteString
connSource Connection { connRecv = recv } th = src
where
src = do
bs <- liftIO recv
unless (S.null bs) $ do
when (S.length bs >= 2048) $ liftIO $ T.tickle th
yield bs
src
setSocketCloseOnExec :: Socket -> IO ()
#if WINDOWS
setSocketCloseOnExec _ = return ()
#else
setSocketCloseOnExec socket =
setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True
#endif