module Network.HTTP.Pony.Serve where
import Control.Exception (IOException)
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Catch (MonadMask)
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)
import Pipes.Network.TCP.Safe (HostPreference())
import Pipes.Network.TCP.Safe (fromSocket, toSocket, connect, connectSock
, closeSock)
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)
import Prelude hiding ((), log)
serveWithSocket :: (MonadSafe m, MonadCatch m) => (NS.Socket, NS.SockAddr)
-> (Producer ByteString m () -> m (Producer ByteString m ()))
-> m ()
serveWithSocket (s,_) =
let
pull = fromSocket s 4096
push = 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
liftIO (NSB.send s x)
push
in
serveWithPipe pull push
serveT :: (MonadSafe m, MonadMask n, MonadIO n)
=> (n () -> IO ())
-> HostPreference
-> NS.ServiceName
-> (Producer ByteString (SafeT n) ()
-> (SafeT n) (Producer ByteString (SafeT n) ()))
-> m ()
serveT exit host service app =
PipesNetwork.serve host service \socket -> do
liftIO NS.setSocketOption (fst socket) NS.NoDelay 1
exit runSafeT (serveWithSocket socket app)
serve, run :: (MonadSafe m) => HostPreference
-> NS.ServiceName
-> (Producer ByteString (SafeT IO) ()
-> (SafeT IO) (Producer ByteString (SafeT IO) ()))
-> m ()
serve = serveT id
run = serve