diff --git a/Data/Conduit/Combinators.hs b/Data/Conduit/Combinators.hs --- a/Data/Conduit/Combinators.hs +++ b/Data/Conduit/Combinators.hs @@ -141,6 +141,14 @@ , concatMapAccum , intersperse + -- *** Binary base encoding + , encodeBase64 + , decodeBase64 + , encodeBase64URL + , decodeBase64URL + , encodeBase16 + , decodeBase16 + -- ** Monadic , mapM , mapME @@ -168,7 +176,12 @@ import Data.Builder import qualified Data.NonNull as NonNull import qualified Data.Traversable +import qualified Data.ByteString as S +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.URL as B64U import Control.Applicative ((<$>)) +import Control.Exception (assert) import Control.Category (Category (..)) import Control.Monad (unless, when, (>=>), liftM, forever) import Control.Monad.Base (MonadBase (liftBase)) @@ -190,7 +203,8 @@ import Prelude (Bool (..), Eq (..), Int, Maybe (..), Monad (..), Num (..), Ord (..), fromIntegral, maybe, - ($), Functor (..), Enum, seq, Show, Char, (||)) + ($), Functor (..), Enum, seq, Show, Char, (||), + mod, otherwise, Either (..)) import Data.Word (Word8) import qualified Prelude import System.IO (Handle) @@ -1371,6 +1385,101 @@ where go y = yield y >> concatMap (\z -> [x, z]) {-# INLINE intersperse #-} + +codeWith :: Monad m + => Int + -> (ByteString -> Either e ByteString) + -> Conduit ByteString m ByteString +codeWith size f = + loop + where + loop = await >>= maybe (return ()) push + + loopWith bs + | S.null bs = loop + | otherwise = await >>= maybe (finish bs) (pushWith bs) + + finish bs = + case f bs of + Left _ -> leftover bs + Right x -> yield x + + push bs = do + let (x, y) = S.splitAt (len - (len `mod` size)) bs + if S.null x + then loopWith y + else do + case f x of + Left _ -> leftover bs + Right x' -> yield x' >> loopWith y + where + len = olength bs + + pushWith bs1 bs2 | S.length bs1 + S.length bs2 < size = loopWith (S.append bs1 bs2) + pushWith bs1 bs2 = assertion1 $ assertion2 $ assertion3 $ + case f bs1' of + Left _ -> leftover bs2 >> leftover bs1 + Right toYield -> yield toYield >> push y + where + m = S.length bs1 `mod` size + (x, y) = S.splitAt (size - m) bs2 + bs1' = mappend bs1 x + + assertion1 = assert $ olength bs1 < size + assertion2 = assert $ olength bs1' `mod` size == 0 + assertion3 = assert $ olength bs1' > 0 + +-- | Apply base64-encoding to the stream. +-- +-- Since 1.0.0 +encodeBase64 :: Monad m => Conduit ByteString m ByteString +encodeBase64 = codeWith 3 (Right . B64.encode) +{-# INLINE encodeBase64 #-} + +-- | Apply base64-decoding to the stream. Will stop decoding on the first +-- invalid chunk. +-- +-- Since 1.0.0 +decodeBase64 :: Monad m => Conduit ByteString m ByteString +decodeBase64 = codeWith 4 B64.decode +{-# INLINE decodeBase64 #-} + +-- | Apply URL-encoding to the stream. +-- +-- Since 1.0.0 +encodeBase64URL :: Monad m => Conduit ByteString m ByteString +encodeBase64URL = codeWith 3 (Right . B64U.encode) +{-# INLINE encodeBase64URL #-} + +-- | Apply lenient base64URL-decoding to the stream. Will stop decoding on the +-- first invalid chunk. +-- +-- Since 1.0.0 +decodeBase64URL :: Monad m => Conduit ByteString m ByteString +decodeBase64URL = codeWith 4 B64U.decode +{-# INLINE decodeBase64URL #-} + +-- | Apply base16-encoding to the stream. +-- +-- Since 1.0.0 +encodeBase16 :: Monad m => Conduit ByteString m ByteString +encodeBase16 = map B16.encode +{-# INLINE encodeBase16 #-} + +-- | Apply base16-decoding to the stream. Will stop decoding on the first +-- invalid chunk. +-- +-- Since 1.0.0 +decodeBase16 :: Monad m => Conduit ByteString m ByteString +decodeBase16 = + codeWith 2 decode' + where + decode' x + | onull z = Right y + | otherwise = Left () + where + (y, z) = B16.decode x +{-# INLINE decodeBase16 #-} -- | Apply a monadic transformation to all values in a stream. -- diff --git a/Data/Conduit/Combinators/Unqualified.hs b/Data/Conduit/Combinators/Unqualified.hs --- a/Data/Conduit/Combinators/Unqualified.hs +++ b/Data/Conduit/Combinators/Unqualified.hs @@ -130,6 +130,14 @@ , concatMapAccumC , intersperseC + -- **** Binary base encoding + , encodeBase64C + , decodeBase64C + , encodeBase64URLC + , decodeBase64URLC + , encodeBase16C + , decodeBase16C + -- *** Monadic , mapMC , mapMCE @@ -160,7 +168,12 @@ import Data.Builder import qualified Data.NonNull as NonNull import qualified Data.Traversable +import qualified Data.ByteString as S +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.URL as B64U import Control.Applicative ((<$>)) +import Control.Exception (assert) import Control.Category (Category (..)) import Control.Monad (unless, when, (>=>), liftM, forever) import Control.Monad.Base (MonadBase (liftBase)) @@ -177,12 +190,13 @@ import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as VM import qualified Filesystem as F -import Filesystem.Path (FilePath) -import Filesystem.Path.CurrentOS (encodeString) +import Filesystem.Path (FilePath, ()) +import Filesystem.Path.CurrentOS (encodeString, decodeString) import Prelude (Bool (..), Eq (..), Int, Maybe (..), Monad (..), Num (..), Ord (..), fromIntegral, maybe, - ($), Functor (..), Enum, seq, Show, Char) + ($), Functor (..), Enum, seq, Show, Char, (||), + mod, otherwise, Either (..)) import Data.Word (Word8) import qualified Prelude import System.IO (Handle) @@ -193,7 +207,8 @@ import Data.Text (Text) import qualified System.Random.MWC as MWC import Data.Conduit.Combinators.Internal -import qualified System.PosixCompat.Files as Posix +import qualified System.PosixCompat.Files as PosixC +import qualified System.Posix.Directory as Dir -- END IMPORTS @@ -1131,6 +1146,51 @@ intersperseC :: Monad m => a -> Conduit a m a intersperseC = CC.intersperse {-# INLINE intersperseC #-} + +-- | Apply base64-encoding to the stream. +-- +-- Since 1.0.0 +encodeBase64C :: Monad m => Conduit ByteString m ByteString +encodeBase64C = CC.encodeBase64 +{-# INLINE encodeBase64C #-} + +-- | Apply base64-decoding to the stream. Will stop decoding on the first +-- invalid chunk. +-- +-- Since 1.0.0 +decodeBase64C :: Monad m => Conduit ByteString m ByteString +decodeBase64C = CC.decodeBase64 +{-# INLINE decodeBase64C #-} + +-- | Apply URL-encoding to the stream. +-- +-- Since 1.0.0 +encodeBase64URLC :: Monad m => Conduit ByteString m ByteString +encodeBase64URLC = CC.encodeBase64URL +{-# INLINE encodeBase64URLC #-} + +-- | Apply lenient base64URL-decoding to the stream. Will stop decoding on the +-- first invalid chunk. +-- +-- Since 1.0.0 +decodeBase64URLC :: Monad m => Conduit ByteString m ByteString +decodeBase64URLC = CC.decodeBase64URL +{-# INLINE decodeBase64URLC #-} + +-- | Apply base16-encoding to the stream. +-- +-- Since 1.0.0 +encodeBase16C :: Monad m => Conduit ByteString m ByteString +encodeBase16C = CC.encodeBase16 +{-# INLINE encodeBase16C #-} + +-- | Apply base16-decoding to the stream. Will stop decoding on the first +-- invalid chunk. +-- +-- Since 1.0.0 +decodeBase16C :: Monad m => Conduit ByteString m ByteString +decodeBase16C = CC.decodeBase16 +{-# INLINE decodeBase16C #-} -- | Apply a monadic transformation to all values in a stream. -- diff --git a/conduit-combinators.cabal b/conduit-combinators.cabal --- a/conduit-combinators.cabal +++ b/conduit-combinators.cabal @@ -1,5 +1,5 @@ name: conduit-combinators -version: 0.2.2 +version: 0.2.3 synopsis: Commonly used conduit functions, for both chunked and unchunked data description: Provides a replacement for Data.Conduit.List, as well as a convenient Conduit module. homepage: https://github.com/fpco/conduit-combinators @@ -32,6 +32,8 @@ , void , mwc-random , unix-compat + , base16-bytestring + , base64-bytestring >= 0.1.1.1 if os(windows) cpp-options: -DWINDOWS else @@ -54,6 +56,8 @@ , silently , bytestring , mwc-random + , base16-bytestring + , base64-bytestring ghc-options: -Wall source-repository head diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -24,7 +24,14 @@ import GHC.IO.Handle (hDuplicateTo) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L import System.Random.MWC (createSystemRandom) +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Base16.Lazy as B16L +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.Lazy as B64L +import qualified Data.ByteString.Base64.URL.Lazy as B64LU +import qualified Data.ByteString.Base64.URL as B64U main :: IO () main = hspec $ do @@ -443,6 +450,36 @@ prop "intersperse" $ \xs x -> runIdentity (yieldMany xs $$ intersperseC x =$ sinkList) `shouldBe` intersperse (x :: Int) xs + describe "binary base encoding" $ do + describe "encode/decode is idempotent" $ do + prop "64 non-url" $ \(map S.pack -> bss) -> + mconcat bss == runIdentity (yieldMany bss $$ encodeBase64C =$ decodeBase64C =$ foldC) + prop "64 url" $ \(map S.pack -> bss) -> + mconcat bss == runIdentity (yieldMany bss $$ encodeBase64URLC =$ decodeBase64URLC =$ foldC) + prop "16" $ \(map S.pack -> bss) -> + mconcat bss == runIdentity (yieldMany bss $$ encodeBase16C =$ decodeBase16C =$ foldC) + describe "encode is identical" $ do + prop "64 non-url" $ \(map S.pack -> bss) -> + B64.encode (mconcat bss) == runIdentity (yieldMany bss $$ encodeBase64C =$ foldC) + prop "64 url" $ \(map S.pack -> bss) -> + B64U.encode (mconcat bss) == runIdentity (yieldMany bss $$ encodeBase64URLC =$ foldC) + prop "16" $ \(map S.pack -> bss) -> + B16.encode (mconcat bss) == runIdentity (yieldMany bss $$ encodeBase16C =$ foldC) + describe "decode leftovers work" $ do + let test name encL dec decC = prop name $ \(L.toChunks . encL . L.pack -> bss) -> do + let invalid = "\0INVALID" + src = yieldMany bss >> yield invalid + sink = (,) <$> (decC =$ foldC) <*> foldC + expected = (dec $ mconcat bss, invalid) + actual <- src $$ sink + actual `shouldBe` expected + test "64 non-url" B64L.encode B64.decodeLenient decodeBase64C + test "64 url" B64LU.encode B64U.decodeLenient decodeBase64URLC + let b16Decode x = + case B16.decode x of + (y, "") -> y + _ -> error "FIXME!" + test "16" B16L.encode b16Decode decodeBase16C prop "mapM" $ \input -> runIdentity (yieldMany input $$ mapMC (return . succChar) =$ sinkList) `shouldBe` map succChar input