module Network.Wai.Handler.Warp.Run where
import Control.Concurrent (threadDelay, forkIOWithUnmask)
import Control.Exception as E
import Control.Monad (forever, when, unless, void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
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.Sendfile
import Network.Socket (accept, SockAddr)
import qualified Network.Socket.ByteString as Sock
import Data.Monoid (mempty)
import qualified Network.HTTP.Types as H
import Network.Wai
import Network.Wai.Handler.Warp.Request
import Network.Wai.Handler.Warp.Response
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
#if SENDFILEFD
import Control.Applicative
import qualified Network.Wai.Handler.Warp.FdCache as F
#endif
bytesPerRead :: Int
bytesPerRead = 4096
socketConnection :: Socket -> Connection
socketConnection s = Connection
{ connSendMany = Sock.sendMany s
, connSendAll = Sock.sendAll s
, connSendFile = sendFile s
, connClose = sClose s
, connRecv = Sock.recv s bytesPerRead
}
sendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO ()
#if SENDFILEFD
sendFile s path off len act hdr cleaner = case fdCacher cleaner of
Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr
Just fdc -> do
(fd, fresher) <- F.getFd fdc path
sendfileFdWithHeader s fd (PartOfFile off len) (act>>fresher) hdr
#else
sendFile s path off len act hdr _ =
sendfileWithHeader s path (PartOfFile off len) act hdr
#endif
#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 getter app
where
getter = do
(conn, sa) <- accept socket
setSocketCloseOnExec conn
return (socketConnection 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 getConn app = do
#if SENDFILEFD
let duration = settingsFdCacheDuration set
fc <- case duration of
0 -> return Nothing
_ -> Just <$> F.initialize (duration * 1000000)
#endif
settingsBeforeMainLoop set
withTimeoutManager $ \tm -> mask_ . forever $ do
allowInterrupt
(mkConn, addr) <- getConnLoop
void $ forkIOWithUnmask $ \unmask ->
bracket mkConn connClose $ \conn ->
bracket (T.registerKillThread tm) T.cancel $ \th ->
#if SENDFILEFD
let cleaner = Cleaner th fc
#else
let cleaner = Cleaner th
#endif
in unmask .
handle onE .
bracket_ onOpen onClose $
serveConnection th set cleaner port app conn addr
where
getConnLoop = getConn `E.catch` \(e :: IOException) -> do
onE (toException e)
threadDelay 1000000
getConnLoop
onE = settingsOnException set
port = settingsPort 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 :: T.Handle
-> Settings
-> Cleaner
-> Port -> Application -> Connection -> SockAddr-> IO ()
serveConnection timeoutHandle settings cleaner port app conn remoteHost' = do
istatus <- newIORef False
respondOnException istatus settings cleaner conn remoteHost' $
runResourceT (serveConnection' istatus)
where
innerRunResourceT
| settingsResourceTPerRequest settings = lift . runResourceT
| otherwise = id
th = threadHandle cleaner
serveConnection' :: IORef Bool -> ResourceT IO ()
serveConnection' istatus = serveConnection'' istatus $ connSource conn th istatus
serveConnection'' istatus fromClient = do
(env, getSource) <- parseRequestInternal conn timeoutHandle port remoteHost' fromClient
case settingsIntercept settings env of
Nothing -> do
liftIO $ T.pause th
keepAlive <- innerRunResourceT $ do
res <- app env
liftIO $ do
T.resume th
writeIORef istatus False
sendResponse settings cleaner env conn res
requestBody env $$ CL.sinkNull
ResumableSource fromClient' _ <- liftIO getSource
when keepAlive $ serveConnection'' istatus fromClient'
Just intercept -> do
liftIO $ T.pause th
ResumableSource fromClient' _ <- liftIO getSource
intercept fromClient' conn
respondOnException :: IORef Bool -> Settings -> Cleaner -> Connection -> SockAddr -> IO () -> IO ()
respondOnException istatus settings cleaner conn remoteHost' io = io `E.catch` \e@(SomeException _) -> do
status <- readIORef istatus
when status $ do
_ <- runResourceT $ sendResponse settings cleaner blankRequest conn internalError
return ()
throwIO e
where
blankRequest = Request H.methodGet H.http10 mempty mempty mempty 0 [] False remoteHost' [] [] (return mempty) mempty (KnownLength 0)
internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"
connSource :: Connection -> T.Handle -> IORef Bool -> Source (ResourceT 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