Conduit.hs

-- | A light-weight wrapper around @Network.Wai@ to provide easy conduit support.
module Network.Wai.Conduit
    ( -- * Request body
      sourceRequestBody
      -- * Response body
    , responseSource
    , responseRawSource
      -- * Re-export
    , module Network.Wai
    ) where

import Network.Wai
import Data.Conduit
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 Data.Conduit.List as CL

-- | Stream the request body.
--
-- Since 3.0.0
sourceRequestBody :: MonadIO m => Request -> Source m ByteString
sourceRequestBody req =
    loop
  where
    go = liftIO (requestBody req)

    loop = do
        bs <- go
        unless (S.null bs) $ do
            yield bs
            loop

-- | Create an HTTP response out of a @Source@.
--
-- Since 3.0.0
responseSource :: Status -> ResponseHeaders -> Source IO (Flush Builder) -> Response
responseSource s hs src = responseStream s hs $ \send flush ->
    src $$ CL.mapM_ (\mbuilder ->
        case mbuilder of
            Chunk b -> send b
            Flush -> flush)

-- | Create a raw response using a @Source@ and @Sink@ to represent the input
-- and output, respectively.
--
-- Since 3.0.0
responseRawSource :: (MonadIO m, MonadIO n)
                  => (Source m ByteString -> Sink ByteString n () -> IO ())
                  -> Response
                  -> Response
responseRawSource app backup =
    responseRaw app' backup
  where
    app' recv send =
        app src sink
      where
        src = do
            bs <- liftIO recv
            unless (S.null bs) $ do
                yield bs
                src
        sink = CL.mapM_ $ liftIO . send