module Pipes.Wai
(
producerRequestBody
, responseProducer
, responseRawProducer
, module Network.Wai
) where
import Network.Wai
import Pipes
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Control.Monad (unless)
import Network.HTTP.Types
import Blaze.ByteString.Builder (Builder)
import Data.IORef
import qualified Pipes.Prelude as CL
data Flush a = Chunk a | Flush
deriving (Eq, Ord, Show)
instance Functor Flush where
fmap f c = case c of
Chunk a -> Chunk $ f a
Flush -> Flush
producerRequestBody :: MonadIO m => Request -> Producer ByteString m ()
producerRequestBody req =
loop
where
go = liftIO (requestBody req)
loop = do
bs <- go
unless (S.null bs) $ do
yield bs
loop
responseProducer :: Status -> ResponseHeaders -> Producer (Flush Builder) IO () -> Response
responseProducer s hs src = responseStream s hs $ \send flush ->
runEffect $ for src $ \mbuilder -> case mbuilder of
Chunk b -> lift $ send b
Flush -> lift $ flush
responseRawProducer :: (MonadIO m, MonadIO n)
=> (Producer ByteString m () -> Consumer ByteString n () -> IO ())
-> Response
-> Response
responseRawProducer app = responseRaw app'
where
app' recv send =
app src sink
where
src = do
bs <- liftIO recv
unless (S.null bs) $ do
yield bs
src
sink = (await >>= liftIO . send) >> sink