diff --git a/Data/Conduit/Blaze.hs b/Data/Conduit/Blaze.hs --- a/Data/Conduit/Blaze.hs +++ b/Data/Conduit/Blaze.hs @@ -9,8 +9,17 @@ module Data.Conduit.Blaze ( + -- * Conduits from builders to bytestrings + builderToByteString + , unsafeBuilderToByteString + , builderToByteStringWith + + -- ** Flush + , builderToByteStringFlush + , builderToByteStringWithFlush + -- * Buffers - Buffer + , Buffer -- ** Status information , freeSize @@ -30,19 +39,11 @@ , BufferAllocStrategy , allNewBuffersStrategy , reuseBufferStrategy - - -- * Conduits from builders to bytestrings - , builderToByteString - , unsafeBuilderToByteString - , builderToByteStringWith - - -- ** Flush - , builderToByteStringFlush - , builderToByteStringWithFlush ) where -import Data.Conduit hiding (Pipe (Done)) -import Control.Monad (liftM) +import Data.Conduit hiding (Source, Conduit, Sink, Pipe) +import Control.Monad (unless) +import Control.Monad.Trans.Class (lift) import qualified Data.ByteString as S @@ -52,14 +53,14 @@ -- | Incrementally execute builders and pass on the filled chunks as -- bytestrings. -builderToByteString :: MonadUnsafeIO m => Conduit Builder m S.ByteString +builderToByteString :: MonadUnsafeIO m => GInfConduit Builder m S.ByteString builderToByteString = builderToByteStringWith (allNewBuffersStrategy defaultBufferSize) -- | -- -- Since 0.0.2 -builderToByteStringFlush :: MonadUnsafeIO m => Conduit (Flush Builder) m (Flush S.ByteString) +builderToByteStringFlush :: MonadUnsafeIO m => GInfConduit (Flush Builder) m (Flush S.ByteString) builderToByteStringFlush = builderToByteStringWithFlush (allNewBuffersStrategy defaultBufferSize) @@ -72,7 +73,7 @@ -- as control is returned from the inner sink! unsafeBuilderToByteString :: MonadUnsafeIO m => IO Buffer -- action yielding the inital buffer. - -> Conduit Builder m S.ByteString + -> GInfConduit Builder m S.ByteString unsafeBuilderToByteString = builderToByteStringWith . reuseBufferStrategy @@ -82,15 +83,12 @@ -- INV: All bytestrings passed to the inner sink are non-empty. builderToByteStringWith :: MonadUnsafeIO m => BufferAllocStrategy - -> Conduit Builder m S.ByteString -builderToByteStringWith (ioBuf0, nextBuf) = conduitState - ioBuf0 - (push nextBuf) - close + -> GInfConduit Builder m S.ByteString +builderToByteStringWith = + mapOutputMaybe unChunk . mapInput Chunk unChunk . builderToByteStringWithFlush where - close ioBuf = unsafeLiftIO $ do - buf <- ioBuf - return $ maybe [] return $ unsafeFreezeNonEmptyBuffer buf + unChunk Flush = Nothing + unChunk (Chunk y) = Just y -- | -- @@ -98,61 +96,48 @@ builderToByteStringWithFlush :: MonadUnsafeIO m => BufferAllocStrategy - -> Conduit (Flush Builder) m (Flush S.ByteString) -builderToByteStringWithFlush (ioBuf0, nextBuf) = conduitState - ioBuf0 - push' - close + -> GInfConduit (Flush Builder) m (Flush S.ByteString) +builderToByteStringWithFlush (ioBufInit, nextBuf) = + loop ioBufInit where - close ioBuf = unsafeLiftIO $ do - buf <- ioBuf - return $ maybe [] (return . Chunk) $ unsafeFreezeNonEmptyBuffer buf + loop ioBuf = do + awaitE >>= either (close ioBuf) (cont' ioBuf) - push' :: MonadUnsafeIO m - => IO Buffer - -> Flush Builder - -> m (ConduitStateResult (IO Buffer) input (Flush S.ByteString)) - push' ioBuf Flush = do - StateProducing ioBuf' chunks <- push nextBuf ioBuf flush - let myFold bs rest - | S.null bs = rest - | otherwise = Chunk bs : rest - chunks' = foldr myFold [Flush] chunks - return $ StateProducing ioBuf' chunks' - push' ioBuf (Chunk builder) = (liftM . fmap) Chunk (push nextBuf ioBuf builder) + cont' ioBuf Flush = push ioBuf flush $ \ioBuf' -> yield Flush >> loop ioBuf' + cont' ioBuf (Chunk builder) = push ioBuf builder loop -push :: MonadUnsafeIO m - => (Int -> Buffer -> IO (IO Buffer)) - -> IO Buffer - -> Builder - -> m (ConduitStateResult (IO Buffer) input S.ByteString) -push nextBuf ioBuf0 x = unsafeLiftIO $ do - (ioBuf', front) <- go (unBuilder x (buildStep finalStep)) ioBuf0 id - return $ StateProducing ioBuf' $ front [] - where - finalStep !(BufRange pf _) = return $ Done pf () + close ioBuf r = do + buf <- lift $ unsafeLiftIO $ ioBuf + maybe (return ()) (yield . Chunk) (unsafeFreezeNonEmptyBuffer buf) + return r - go bStep ioBuf front = do - !buf <- ioBuf - signal <- (execBuildStep bStep buf) - case signal of - Done op' _ -> return (return $ updateEndOfSlice buf op', front) - BufferFull minSize op' bStep' -> do - let buf' = updateEndOfSlice buf op' - {-# INLINE cont #-} - cont front' = do - -- sequencing the computation of the next buffer - -- construction here ensures that the reference to the - -- foreign pointer `fp` is lost as soon as possible. - ioBuf' <- nextBuf minSize buf' - go bStep' ioBuf' front' - case unsafeFreezeNonEmptyBuffer buf' of - Nothing -> cont front - Just bs -> cont (front . (bs:)) - InsertByteString op' bs bStep' -> do - let buf' = updateEndOfSlice buf op' - bsk = maybe id (:) $ unsafeFreezeNonEmptyBuffer buf' - bsk' = if S.null bs then id else (bs:) - front' = front . bsk . bsk' - ioBuf' <- nextBuf 1 buf' - go bStep' ioBuf' front' + push ioBuf0 x continue = do + go (unBuilder x (buildStep finalStep)) ioBuf0 + where + finalStep !(BufRange pf _) = return $ Done pf () + + go bStep ioBuf = do + !buf <- lift $ unsafeLiftIO $ ioBuf + signal <- lift $ unsafeLiftIO $ execBuildStep bStep buf + case signal of + Done op' _ -> continue $ return $ updateEndOfSlice buf op' + BufferFull minSize op' bStep' -> do + let buf' = updateEndOfSlice buf op' + {-# INLINE cont #-} + cont = do + -- sequencing the computation of the next buffer + -- construction here ensures that the reference to the + -- foreign pointer `fp` is lost as soon as possible. + ioBuf' <- lift $ unsafeLiftIO $ nextBuf minSize buf' + go bStep' ioBuf' + case unsafeFreezeNonEmptyBuffer buf' of + Nothing -> return () + Just bs -> yield (Chunk bs) + cont + InsertByteString op' bs bStep' -> do + let buf' = updateEndOfSlice buf op' + case unsafeFreezeNonEmptyBuffer buf' of + Nothing -> return () + Just bs' -> yield $ Chunk bs' + unless (S.null bs) $ yield $ Chunk bs + lift (unsafeLiftIO $ nextBuf 1 buf') >>= go bStep' diff --git a/blaze-builder-conduit.cabal b/blaze-builder-conduit.cabal --- a/blaze-builder-conduit.cabal +++ b/blaze-builder-conduit.cabal @@ -1,5 +1,5 @@ Name: blaze-builder-conduit -Version: 0.4.0.2 +Version: 0.5.0 Synopsis: Convert streams of builders to streams of bytestrings. Description: Convert streams of builders to streams of bytestrings. License: BSD3 @@ -20,7 +20,7 @@ , bytestring >= 0.9 , text >= 0.11 , blaze-builder >= 0.2.1.4 && < 0.4 - , conduit >= 0.4 && < 0.5 + , conduit >= 0.5 && < 0.6 ghc-options: -Wall test-suite test diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -17,7 +17,7 @@ import Data.ByteString.Lazy.Char8 () main :: IO () -main = hspecX $ do +main = hspec $ do describe "blaze" $ do prop "idempotent to toLazyByteString" $ \bss' -> runST $ do let bss = map S.pack bss' @@ -53,3 +53,11 @@ outBss <- src C.$= builderToByteStringFlush C.$$ CL.consume if bss == outBss then return () else error (show (bss, outBss)) return $ bss == outBss + it "large flush input" $ do + let lbs = L.pack $ concat $ replicate 100000 [0..255] + chunks = map (C.Chunk . fromByteString) (L.toChunks lbs) + src = CL.sourceList chunks + bss <- src C.$$ builderToByteStringFlush C.=$ CL.consume + let unFlush (C.Chunk x) = [x] + unFlush C.Flush = [] + L.fromChunks (concatMap unFlush bss) @?= lbs