-- | Serve {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Pony.Serve where import Control.Monad.IO.Class (MonadIO(..)) import Data.ByteString.Char8 (ByteString) import qualified Network.Socket as NS import Pipes (Producer, Consumer, runEffect, (>->)) import Pipes.Attoparsec (ParsingError(..)) import Pipes.Network.TCP.Safe (HostPreference()) import Pipes.Network.TCP.Safe (fromSocket, toSocket) import qualified Pipes.Network.TCP.Safe as PipesNetwork import Pipes.Safe (MonadSafe(), runSafeT) import qualified Network.HTTP.Pony.Builder as Builder import Network.HTTP.Pony.Helper ((-), shutdownSend, shutdownReceive) import qualified Network.HTTP.Pony.Parser as Parser import Network.HTTP.Pony.Type (Application, App, Middleware, Request, Response) import Prelude hiding ((-), log) -- http :: (Monad m) => Application m ByteString ByteString a b -- -> (Producer ByteString m a -> m (Producer ByteString m ())) http :: (Monad m) => Middleware m (Producer ByteString m a) (Producer ByteString m ()) (Request ByteString m a) (Response ByteString m b) http app pull = do maybeRequest <- Parser.parseMessage pull (pure ()) case maybeRequest of Just (Right request) -> do response <- app request pure - Builder.message response >> pure () _ -> pure - pure () -- Just (Left err) -> pure - pure - err -- _ -> pure Nothing serveWithPipe :: (Monad m) => Producer ByteString m a -> Consumer ByteString m b -> (Producer ByteString m a -> m (Producer ByteString m b)) -> m () serveWithPipe pull push pipe = do r <- pipe pull runEffect - r >-> push pure () serveWithSocket :: (MonadIO m) => (NS.Socket, NS.SockAddr) -> (Producer ByteString m () -> m (Producer ByteString m ())) -> m () serveWithSocket (s,_) = let pull = fromSocket s 4096 >> shutdownReceive s push = toSocket s >> shutdownSend s in serveWithPipe pull push run :: (MonadSafe m) => HostPreference -> NS.ServiceName -> (Producer ByteString IO () -> IO (Producer ByteString IO ())) -> m () run host service app = PipesNetwork.serve host service - \socket -> do serveWithSocket socket app -- pure () -- r <- serveWithSocket socket app -- case r of -- Nothing -> pure () -- Just err -> pure () -- log - view packed - show err