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
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
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