{-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Pony.Serve where import Prelude hiding ((-), log) import Control.Exception (IOException) import qualified Control.Exception as E import Control.Monad.Catch (MonadCatch, MonadMask, finally, onException) import Control.Monad.IO.Class (MonadIO(..)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Monoid ((<>)) import qualified Network.Socket as NS import qualified Network.Socket.ByteString as NSB import Pipes (Effect, Producer, Consumer, runEffect, (>->), await, yield) import Pipes.Network.TCP.Safe (HostPreference()) import Pipes.Network.TCP.Safe (connect, connectSock, closeSock) import Pipes.Network.TCP.Safe (fromSocketTimeout, toSocketTimeout) import qualified Pipes.Network.TCP.Safe as PipesNetwork import Pipes.Safe (MonadSafe(), runSafeT, SafeT, tryP, throwM) import Network.HTTP.Pony.Helper ((-), shutdownSend, shutdownReceive) import Network.HTTP.Pony.ServeSafe (serveWithPipe) defaultTimeout :: Int defaultTimeout = 600 serveWithSocket :: (MonadSafe m, MonadCatch m) => (NS.Socket, NS.SockAddr) -> (Producer ByteString m () -> m (Producer ByteString m ())) -> m () serveWithSocket = serveWithSocketTimeout defaultTimeout serveWithSocketTimeout :: (MonadSafe m, MonadCatch m) => Int -> (NS.Socket, NS.SockAddr) -> (Producer ByteString m () -> m (Producer ByteString m ())) -> m () serveWithSocketTimeout timeout (s,_) = let pull = do fromSocketTimeout (timeout * 1000000) s 4096 push = toSocketTimeout (timeout * 1000000) s pushWithCallbackOnEmptyToShutdownSend = do x <- await if B.null x then do let cont = () <$ await r <- tryP (shutdownSend s) case r of Right _ -> cont Left e -> do cont throwM (e :: IOException) else do yield x pushWithCallbackOnEmptyToShutdownSend in let safePush = ( pushWithCallbackOnEmptyToShutdownSend >-> push ) `onException` ( do -- These shutdowns strictly speaking are not nessorary. -- But on mac there is an obscure kevent error. -- These are hacks to reduce the chance of that error. shutdownSend s shutdownReceive s ) in serveWithPipe pull safePush serveT_Timeout :: (MonadSafe m, MonadMask n, MonadIO n) => Int -> (n () -> IO ()) -> HostPreference -> NS.ServiceName -> (Producer ByteString (SafeT n) () -> (SafeT n) (Producer ByteString (SafeT n) ())) -> m () serveT_Timeout timeout exit host service app = PipesNetwork.serve host service - \socket -> do -- no-delay is specifically encouraged in HTTP/2 -- https://http2.github.io/faq/#will-i-need-tcpnodelay-for-my-http2-connections liftIO - do NS.setSocketOption (fst socket) NS.NoDelay 1 exit - runSafeT (serveWithSocketTimeout timeout socket app) serveT :: (MonadSafe m, MonadMask n, MonadIO n) => (n () -> IO ()) -> HostPreference -> NS.ServiceName -> (Producer ByteString (SafeT n) () -> (SafeT n) (Producer ByteString (SafeT n) ())) -> m () serveT = serveT_Timeout 600 serve, run :: (MonadSafe m) => HostPreference -> NS.ServiceName -> (Producer ByteString (SafeT IO) () -> (SafeT IO) (Producer ByteString (SafeT IO) ())) -> m () serve = serveT id run = serve