diff --git a/Data/ByteString/Base64/Internal.hs b/Data/ByteString/Base64/Internal.hs --- a/Data/ByteString/Base64/Internal.hs +++ b/Data/ByteString/Base64/Internal.hs @@ -20,6 +20,7 @@ , joinWith , done , peek8, poke8, peek8_32 + , reChunkIn ) where import Data.Bits ((.|.), (.&.), shiftL, shiftR) @@ -258,3 +259,27 @@ done :: Integral a => a done = 99 {-# INLINE done #-} + +-- This takes a list of ByteStrings, and returns a list in which each +-- (apart from possibly the last) has length that is a multiple of n +reChunkIn :: Int -> [ByteString] -> [ByteString] +reChunkIn _ [] = [] +reChunkIn _ [y] = [y] +reChunkIn n (y : ys) = case B.length y `divMod` n of + (_, 0) -> + y : reChunkIn n ys + (d, _) -> + case B.splitAt (d * n) y of + (prefix, suffix) -> prefix : fixup suffix ys + where fixup acc [] = [acc] + fixup acc (z : zs) = case B.splitAt (n - B.length acc) z of + (prefix, suffix) -> + let acc' = acc `B.append` prefix + in if B.length acc' == n + then let zs' = if B.null suffix + then zs + else suffix : zs + in acc' : reChunkIn n zs' + else -- suffix must be null + fixup acc' zs + diff --git a/Data/ByteString/Base64/Lazy.hs b/Data/ByteString/Base64/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Base64/Lazy.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +-- | +-- Module : Data.ByteString.Base64.Lazy +-- Copyright : (c) 2012 Ian Lynagh +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Fast and efficient encoding and decoding of base64-encoded +-- lazy bytestrings. + +module Data.ByteString.Base64.Lazy + ( + encode + , decode + , decodeLenient + ) where + +import Data.ByteString.Base64.Internal +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import Data.Char + +-- | Encode a string into base64 form. The result will always be a +-- multiple of 4 bytes in length. +encode :: L.ByteString -> L.ByteString +encode = L.fromChunks . map B64.encode . reChunkIn 3 . L.toChunks + +-- | Decode a base64-encoded string. This function strictly follows +-- the specification in RFC 4648, +-- . +decode :: L.ByteString -> Either String L.ByteString +decode b = -- Returning an Either type means that the entire result will + -- need to be in memory at once anyway, so we may as well + -- keep it simple and just convert to and from a strict byte + -- string + -- TODO: Use L.{fromStrict,toStrict} once we can rely on + -- a new enough bytestring + case B64.decode $ S.concat $ L.toChunks b of + Left err -> Left err + Right b' -> Right $ L.fromChunks [b'] + +-- | Decode a base64-encoded string. This function is lenient in +-- following the specification from RFC 4648, +-- , and will not generate +-- parse errors no matter how poor its input. +decodeLenient :: L.ByteString -> L.ByteString +decodeLenient = L.fromChunks . map B64.decodeLenient . reChunkIn 4 . L.toChunks + . LC.filter goodChar + where -- We filter out and '=' padding here, but B64.decodeLenient + -- handles that + goodChar c = isAlphaNum c || c == '+' || c == '/' + diff --git a/Data/ByteString/Base64/URL/Lazy.hs b/Data/ByteString/Base64/URL/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Base64/URL/Lazy.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +-- | +-- Module : Data.ByteString.Base64.URL.Lazy +-- Copyright : (c) 2012 Ian Lynagh +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Fast and efficient encoding and decoding of base64-encoded +-- lazy bytestrings. + +module Data.ByteString.Base64.URL.Lazy + ( + encode + , decode + , decodeLenient + ) where + +import Data.ByteString.Base64.Internal +import qualified Data.ByteString.Base64.URL as B64 +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import Data.Char + +-- | Encode a string into base64 form. The result will always be a +-- multiple of 4 bytes in length. +encode :: L.ByteString -> L.ByteString +encode = L.fromChunks . map B64.encode . reChunkIn 3 . L.toChunks + +-- | Decode a base64-encoded string. This function strictly follows +-- the specification in RFC 4648, +-- . +decode :: L.ByteString -> Either String L.ByteString +decode b = -- Returning an Either type means that the entire result will + -- need to be in memory at once anyway, so we may as well + -- keep it simple and just convert to and from a strict byte + -- string + -- TODO: Use L.{fromStrict,toStrict} once we can rely on + -- a new enough bytestring + case B64.decode $ S.concat $ L.toChunks b of + Left err -> Left err + Right b' -> Right $ L.fromChunks [b'] + +-- | Decode a base64-encoded string. This function is lenient in +-- following the specification from RFC 4648, +-- , and will not generate +-- parse errors no matter how poor its input. +decodeLenient :: L.ByteString -> L.ByteString +decodeLenient = L.fromChunks . map B64.decodeLenient . reChunkIn 4 . L.toChunks + . LC.filter goodChar + where -- We filter out and '=' padding here, but B64.decodeLenient + -- handles that + goodChar c = isAlphaNum c || c == '-' || c == '_' + diff --git a/base64-bytestring.cabal b/base64-bytestring.cabal --- a/base64-bytestring.cabal +++ b/base64-bytestring.cabal @@ -1,5 +1,5 @@ name: base64-bytestring -version: 0.1.2.0 +version: 1.0.0.0 synopsis: Fast base64 encoding and deconding for ByteStrings description: Fast base64 encoding and deconding for ByteStrings homepage: https://github.com/bos/base64-bytestring @@ -8,7 +8,7 @@ license-file: LICENSE author: Bryan O'Sullivan maintainer: Bryan O'Sullivan -copyright: 2010-2011 Bryan O'Sullivan +copyright: 2010-2012 Bryan O'Sullivan category: Data build-type: Simple cabal-version: >=1.8 @@ -23,6 +23,8 @@ exposed-modules: Data.ByteString.Base64 Data.ByteString.Base64.URL + Data.ByteString.Base64.Lazy + Data.ByteString.Base64.URL.Lazy other-modules: Data.ByteString.Base64.Internal diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where @@ -10,44 +10,65 @@ import Test.QuickCheck (Arbitrary(..), Positive(..)) import Control.Monad (liftM) -import qualified Data.ByteString.Base64 as Base64 -import qualified Data.ByteString.Base64.URL as Base64URL +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Base64.Lazy as LBase64 +import qualified Data.ByteString.Base64.URL as Base64URL +import qualified Data.ByteString.Base64.URL.Lazy as LBase64URL import Data.ByteString (ByteString) import Data.ByteString.Char8 () import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +import Data.String import Test.HUnit hiding (Test) main :: IO () main = defaultMain tests +data Impl bs = Impl String + (bs -> bs) + (bs -> Either String bs) + (bs -> bs) + tests :: [Test] tests = [ testGroup "joinWith" [ testProperty "all_endsWith" joinWith_all_endsWith , testProperty "endsWith" joinWith_endsWith ] - , testGroup "Base64" [ - testProperty "decodeEncode" $ - genericDecodeEncode Base64.encode Base64.decode - , testProperty "decodeEncode Lenient" $ - genericDecodeEncode Base64.encode - (liftM Right Base64.decodeLenient) - , testGroup "base64-string tests" base64_string_tests - ] - , testGroup "Base64URL" [ + , testsRegular $ Impl "Base64" Base64.encode Base64.decode Base64.decodeLenient + , testsRegular $ Impl "LBase64" LBase64.encode LBase64.decode LBase64.decodeLenient + , testsURL $ Impl "Base64URL" Base64URL.encode Base64URL.decode Base64URL.decodeLenient + , testsURL $ Impl "LBase64URL" LBase64URL.encode LBase64URL.decode LBase64URL.decodeLenient + ] + +testsRegular :: (IsString bs, AllRepresentations bs, Show bs, Eq bs, Arbitrary bs) => Impl bs -> Test +testsRegular = testsWith base64_testData + +testsURL :: (IsString bs, AllRepresentations bs, Show bs, Eq bs, Arbitrary bs) => Impl bs -> Test +testsURL = testsWith base64url_testData + +testsWith :: (IsString bs, AllRepresentations bs, Show bs, Eq bs, Arbitrary bs) + => [(bs, bs)] -> Impl bs -> Test +testsWith testData + impl@(Impl name encode decode decodeLenient) + = testGroup name [ testProperty "decodeEncode" $ - genericDecodeEncode Base64URL.encode Base64URL.decode + genericDecodeEncode encode decode , testProperty "decodeEncode Lenient" $ - genericDecodeEncode Base64URL.encode - (liftM Right Base64URL.decodeLenient) - , testGroup "base64-string tests" base64url_string_tests + genericDecodeEncode encode + (liftM Right decodeLenient) + , testGroup "base64-string tests" (string_tests testData impl) ] - ] instance Arbitrary ByteString where arbitrary = liftM B.pack arbitrary +-- Ideally the arbitrary instance would have arbitrary chunks as well as +-- arbitrary content +instance Arbitrary L.ByteString where + arbitrary = liftM L.pack arbitrary + joinWith_endsWith :: ByteString -> Positive Int -> ByteString -> Bool joinWith_endsWith brk (Positive int) str = brk `B.isSuffixOf` Base64.joinWith brk int str @@ -64,9 +85,10 @@ where k = B.length brk + min int (B.length str) -- | Decoding an encoded sintrg should produce the original string. -genericDecodeEncode :: (ByteString -> ByteString) - -> (ByteString -> Either String ByteString) - -> ByteString -> Bool +genericDecodeEncode :: (Arbitrary bs, Eq bs) + => (bs -> bs) + -> (bs -> Either String bs) + -> bs -> Bool genericDecodeEncode enc dec x = case dec (enc x) of Left _ -> False Right x' -> x == x' @@ -76,60 +98,87 @@ -- Copyright (c) Ian Lynagh, 2005, 2007. -- -base64_string_tests :: [Test] -base64_string_tests = - base64_string_test Base64.encode Base64.decode testData ++ - base64_string_test Base64.encode decodeURL testData - where decodeURL :: ByteString -> Either String ByteString - decodeURL = liftM Right Base64.decodeLenient - testData :: [(ByteString, ByteString)] - testData = [("", "") - ,("\0", "AA==") - ,("\255", "/w==") - ,("E", "RQ==") - ,("Ex", "RXg=") - ,("Exa", "RXhh") - ,("Exam", "RXhhbQ==") - ,("Examp", "RXhhbXA=") - ,("Exampl", "RXhhbXBs") - ,("Example", "RXhhbXBsZQ==") - ,("Ex\0am\254ple", "RXgAYW3+cGxl") - ,("Ex\0am\255ple", "RXgAYW3/cGxl") - ] +string_tests :: forall bs + . (IsString bs, AllRepresentations bs, Show bs, Eq bs) + => [(bs, bs)] -> Impl bs -> [Test] +string_tests testData (Impl _ encode decode decodeLenient) = + base64_string_test encode decode testData ++ + base64_string_test encode decodeLenient' testData + where decodeLenient' :: bs -> Either String bs + decodeLenient' = liftM Right decodeLenient --- | Same as the base64_string_tests but using the alternative alphabet -base64url_string_tests :: [Test] -base64url_string_tests = - base64_string_test Base64URL.encode Base64URL.decode testData ++ - base64_string_test Base64URL.encode decodeURL testData - where decodeURL :: ByteString -> Either String ByteString - decodeURL = liftM Right Base64URL.decodeLenient - testData :: [(ByteString, ByteString)] - testData = [("", "") - ,("\0", "AA==") - ,("\255", "_w==") - ,("E", "RQ==") - ,("Ex", "RXg=") - ,("Exa", "RXhh") - ,("Exam", "RXhhbQ==") - ,("Examp", "RXhhbXA=") - ,("Exampl", "RXhhbXBs") - ,("Example", "RXhhbXBsZQ==") - ,("Ex\0am\254ple", "RXgAYW3-cGxl") - ,("Ex\0am\255ple", "RXgAYW3_cGxl") - ] +base64_testData :: IsString bs => [(bs, bs)] +base64_testData = [("", "") + ,("\0", "AA==") + ,("\255", "/w==") + ,("E", "RQ==") + ,("Ex", "RXg=") + ,("Exa", "RXhh") + ,("Exam", "RXhhbQ==") + ,("Examp", "RXhhbXA=") + ,("Exampl", "RXhhbXBs") + ,("Example", "RXhhbXBsZQ==") + ,("Ex\0am\254ple", "RXgAYW3+cGxl") + ,("Ex\0am\255ple", "RXgAYW3/cGxl") + ] +base64url_testData :: IsString bs => [(bs, bs)] +base64url_testData = [("", "") + ,("\0", "AA==") + ,("\255", "_w==") + ,("E", "RQ==") + ,("Ex", "RXg=") + ,("Exa", "RXhh") + ,("Exam", "RXhhbQ==") + ,("Examp", "RXhhbXA=") + ,("Exampl", "RXhhbXBs") + ,("Example", "RXhhbXBsZQ==") + ,("Ex\0am\254ple", "RXgAYW3-cGxl") + ,("Ex\0am\255ple", "RXgAYW3_cGxl") + ] + -- | Generic test given encod enad decode funstions and a -- list of (plain, encoded) pairs -base64_string_test :: (ByteString -> ByteString) - -> (ByteString -> Either String ByteString) - -> [(ByteString, ByteString)] -> [Test] -base64_string_test enc dec testData = concat - [ [ testCase ("base64-string: Encode " ++ show plain) - (encoded_plain @?= encoded), - testCase ("base64-string: Decode " ++ show plain) - (decoded_encoded @?= Right plain) ] - | (plain, encoded) <- testData, +base64_string_test :: (AllRepresentations bs, Eq bs, Show bs) + => (bs -> bs) + -> (bs -> Either String bs) + -> [(bs, bs)] -> [Test] +base64_string_test enc dec testData = + [ testCase ("base64-string: Encode " ++ show plain) + (encoded_plain @?= rawEncoded) + | (rawPlain, rawEncoded) <- testData, + -- For lazy ByteStrings, we want to check not only ["foo"], but + -- also ["f","oo"], ["f", "o", "o"] and ["fo", "o"]. The + -- allRepresentations function gives us all representations of a + -- lazy ByteString. + plain <- allRepresentations rawPlain, let encoded_plain = enc plain - decoded_encoded = dec encoded + ] ++ + [ testCase ("base64-string: Decode " ++ show encoded) + (decoded_encoded @?= Right rawPlain) + | (rawPlain, rawEncoded) <- testData, + -- Again, we need to try all representations of lazy ByteStrings. + encoded <- allRepresentations rawEncoded, + let decoded_encoded = dec encoded ] + +class AllRepresentations a where + allRepresentations :: a -> [a] + +instance AllRepresentations ByteString where + allRepresentations bs = [bs] + +instance AllRepresentations L.ByteString where + -- TODO: Use L.toStrict instead of (B.concat . L.toChunks) once + -- we can rely on a new enough bytestring + allRepresentations = map L.fromChunks . allChunks . B.concat . L.toChunks + where allChunks b + | B.length b < 2 = [[b]] + | otherwise + = concat [ map (prefix :) (allChunks suffix) + | let splits = zip (B.inits b) (B.tails b) + -- We don't want the first split (empty prefix) + -- The last split (empty suffix) gives us the + -- [b] case (toChunks ignores an "" element). + , (prefix, suffix) <- tail splits ] +