diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,57 @@ +See also http://pvp.haskell.org/faq + +# 1.2.1.0 + +* Bugfix for GHC 9.0.1 memory corruption bug ([#46](https://github.com/haskell/base64-bytestring/pull/46)) + * Thanks to [Fraser Tweedale](https://github.com/frasertweedale) and [Andrew Lelechenko](https://github.com/bodigrim) for logging and helping with this fix. + +# 1.2.0.1 + +* Package update: support for `bytestring >=0.11` + +# 1.2.0.0 + +* Security fix: reject non-canonical base64 encoded values - ([#38](https://github.com/haskell/base64-bytestring/pull/38)) fixing issue [#24](https://github.com/haskell/base64-bytestring/issues/24). + +* Security fix: reject bytestrings with improper padding that can be "completed" by the unpadded-Base64url workflow, and homogenize error messages ([#33](https://github.com/haskell/base64-bytestring/pull/33)) + +* Test coverage expanded to 98% of the library. All critical paths covered. + + +# 1.1.0.0 + +* `joinWith` has been removed ([#32](https://github.com/haskell/base64-bytestring/pull/32)) +* Bugfix: `decode` formerly allowed for padding chars to be interspersed in a valid base64-encoded string. This is now not the case, and it is fully spec-compliant as of [#31](https://github.com/haskell/base64-bytestring/pull/31) +* The default behavior for Base64url `decode` is now to support arbitrary padding. If you need strict padded or unpadded decode semantics, use `decodePadded` or `decodeUnpadded`. +* Added strict unpadded and padded decode functions for Base64url ([#30](https://github.com/haskell/base64-bytestring/pull/30)) +* Added unpadded encode for Base64url + ([#26](https://github.com/haskell/base64-bytestring/pull/26)). + +---- + +### 1.0.0.3 + +* Made performance more robust + ([#27](https://github.com/haskell/base64-bytestring/pull/27)). +* Improved documentation + ([#23](https://github.com/haskell/base64-bytestring/pull/23)). +* Improved the performance of decodeLenient a bit + ([#21](https://github.com/haskell/base64-bytestring/pull/21)). + +### 1.0.0.2 + +* Fixed a write past allocated memory in joinWith (potential security + issue). + +## 0.1.1.0 - 1.0.0.1 + +* Changelog not recorded for these versions. + +### 0.1.0.3 + +* Fixed: wrong encoding table on big-endian systems. +* Fixed: too big indices in encoding table construction. + +### 0.1.0.2 + +* Changelog not recorded up to this version. diff --git a/Data/ByteString/Base64.hs b/Data/ByteString/Base64.hs --- a/Data/ByteString/Base64.hs +++ b/Data/ByteString/Base64.hs @@ -8,19 +8,20 @@ -- Copyright : (c) 2010 Bryan O'Sullivan -- -- License : BSD-style --- Maintainer : bos@serpentine.com +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov -- Stability : experimental -- Portability : GHC -- -- Fast and efficient encoding and decoding of base64-encoded strings. - +-- +-- @since 0.1.0.0 module Data.ByteString.Base64 - ( - encode - , decode - , decodeLenient - , joinWith - ) where + ( encode + , decode + , decodeLenient + ) where import Data.ByteString.Base64.Internal import qualified Data.ByteString as B @@ -31,18 +32,23 @@ -- | Encode a string into base64 form. The result will always be a -- multiple of 4 bytes in length. encode :: ByteString -> ByteString -encode s = encodeWith (mkEncodeTable alphabet) s +encode s = encodeWith Padded (mkEncodeTable alphabet) s --- | Decode a base64-encoded string. This function strictly follows --- the specification in RFC 4648, --- . +-- | Decode a base64-encoded string. This function strictly follows +-- the specification in +-- . +-- +-- (Note: this means that even @"\\n"@ and @"\\r\\n"@ as line breaks are rejected +-- rather than ignored. If you are using this in the context of a +-- standard that overrules RFC 4648 such as HTTP multipart mime bodies, +-- consider using 'decodeLenient'.) decode :: ByteString -> Either String ByteString -decode s = decodeWithTable decodeFP s +decode s = decodeWithTable Padded decodeFP s -- | 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. +-- following the specification from +-- , and will not +-- generate parse errors no matter how poor its input. decodeLenient :: ByteString -> ByteString decodeLenient s = decodeLenientWithTable decodeFP s @@ -51,9 +57,19 @@ {-# NOINLINE alphabet #-} decodeFP :: ForeignPtr Word8 -PS decodeFP _ _ = B.pack $ - replicate 43 x ++ [62,x,x,x,63] ++ [52..61] ++ [x,x,x,done,x,x,x] ++ - [0..25] ++ [x,x,x,x,x,x] ++ [26..51] ++ replicate 133 x +#if MIN_VERSION_bytestring(0,11,0) +BS decodeFP _ = +#else +PS decodeFP _ _ = +#endif + B.pack $ replicate 43 x + ++ [62,x,x,x,63] + ++ [52..61] + ++ [x,x,x,done,x,x,x] + ++ [0..25] + ++ [x,x,x,x,x,x] + ++ [26..51] + ++ replicate 133 x {-# NOINLINE decodeFP #-} x :: Integral a => a 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 @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} -- | -- Module : Data.ByteString.Base64.Internal -- Copyright : (c) 2010 Bryan O'Sullivan @@ -12,21 +13,21 @@ -- Fast and efficient encoding and decoding of base64-encoded strings. module Data.ByteString.Base64.Internal - ( - encodeWith - , decodeWithTable - , decodeLenientWithTable - , mkEncodeTable - , joinWith - , done - , peek8, poke8, peek8_32 - , reChunkIn - ) where + ( encodeWith + , decodeWithTable + , decodeLenientWithTable + , mkEncodeTable + , done + , peek8, poke8, peek8_32 + , reChunkIn + , Padding(..) + , withBS + , mkBS + ) where import Data.Bits ((.|.), (.&.), shiftL, shiftR) import qualified Data.ByteString as B -import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy, - unsafeCreate) +import Data.ByteString.Internal (ByteString(..), mallocByteString) import Data.Word (Word8, Word16, Word32) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr) import Foreign.Ptr (Ptr, castPtr, minusPtr, plusPtr) @@ -42,216 +43,294 @@ peek8_32 :: Ptr Word8 -> IO Word32 peek8_32 = fmap fromIntegral . peek8 + +data Padding = Padded | Don'tCare | Unpadded deriving Eq + -- | Encode a string into base64 form. The result will always be a multiple -- of 4 bytes in length. -encodeWith :: EncodeTable -> ByteString -> ByteString -encodeWith (ET alfaFP encodeTable) (PS sfp soff slen) - | slen > maxBound `div` 4 = +encodeWith :: Padding -> EncodeTable -> ByteString -> ByteString +encodeWith !padding (ET alfaFP encodeTable) !bs = withBS bs go + where + go !sptr !slen + | slen > maxBound `div` 4 = error "Data.ByteString.Base64.encode: input too long" - | otherwise = unsafePerformIO $ do - let dlen = ((slen + 2) `div` 3) * 4 - dfp <- mallocByteString dlen - withForeignPtr alfaFP $ \aptr -> - withForeignPtr encodeTable $ \ep -> - withForeignPtr sfp $ \sptr -> do - let aidx n = peek8 (aptr `plusPtr` n) - sEnd = sptr `plusPtr` (slen + soff) - fill !dp !sp - | sp `plusPtr` 2 >= sEnd = complete (castPtr dp) sp - | otherwise = {-# SCC "encode/fill" #-} do - i <- peek8_32 sp - j <- peek8_32 (sp `plusPtr` 1) - k <- peek8_32 (sp `plusPtr` 2) - let w = (i `shiftL` 16) .|. (j `shiftL` 8) .|. k - enc = peekElemOff ep . fromIntegral - poke dp =<< enc (w `shiftR` 12) - poke (dp `plusPtr` 2) =<< enc (w .&. 0xfff) - fill (dp `plusPtr` 4) (sp `plusPtr` 3) - complete dp sp - | sp == sEnd = return () - | otherwise = {-# SCC "encode/complete" #-} do - let peekSP n f = (f . fromIntegral) `fmap` peek8 (sp `plusPtr` n) - twoMore = sp `plusPtr` 2 == sEnd - equals = 0x3d :: Word8 - {-# INLINE equals #-} - !a <- peekSP 0 ((`shiftR` 2) . (.&. 0xfc)) - !b <- peekSP 0 ((`shiftL` 4) . (.&. 0x03)) - !b' <- if twoMore - then peekSP 1 ((.|. b) . (`shiftR` 4) . (.&. 0xf0)) - else return b - poke8 dp =<< aidx a - poke8 (dp `plusPtr` 1) =<< aidx b' - !c <- if twoMore - then aidx =<< peekSP 1 ((`shiftL` 2) . (.&. 0x0f)) - else return equals - poke8 (dp `plusPtr` 2) c - poke8 (dp `plusPtr` 3) equals - withForeignPtr dfp $ \dptr -> - fill (castPtr dptr) (sptr `plusPtr` soff) - return $! PS dfp 0 dlen + | otherwise = do + let dlen = (slen + 2) `div` 3 * 4 + dfp <- mallocByteString dlen + withForeignPtr alfaFP $ \aptr -> + withForeignPtr encodeTable $ \ep -> do + let aidx n = peek8 (aptr `plusPtr` n) + sEnd = sptr `plusPtr` slen + finish !n = return $ mkBS dfp n + fill !dp !sp !n + | sp `plusPtr` 2 >= sEnd = complete (castPtr dp) sp n + | otherwise = {-# SCC "encode/fill" #-} do + i <- peek8_32 sp + j <- peek8_32 (sp `plusPtr` 1) + k <- peek8_32 (sp `plusPtr` 2) + let w = i `shiftL` 16 .|. j `shiftL` 8 .|. k + enc = peekElemOff ep . fromIntegral + poke dp =<< enc (w `shiftR` 12) + poke (dp `plusPtr` 2) =<< enc (w .&. 0xfff) + fill (dp `plusPtr` 4) (sp `plusPtr` 3) (n + 4) + complete dp sp n + | sp == sEnd = finish n + | otherwise = {-# SCC "encode/complete" #-} do + let peekSP m f = (f . fromIntegral) `fmap` peek8 (sp `plusPtr` m) + twoMore = sp `plusPtr` 2 == sEnd + equals = 0x3d :: Word8 + doPad = padding == Padded + {-# INLINE equals #-} + !a <- peekSP 0 ((`shiftR` 2) . (.&. 0xfc)) + !b <- peekSP 0 ((`shiftL` 4) . (.&. 0x03)) -data EncodeTable = ET (ForeignPtr Word8) (ForeignPtr Word16) + poke8 dp =<< aidx a + if twoMore + then do + !b' <- peekSP 1 ((.|. b) . (`shiftR` 4) . (.&. 0xf0)) + !c <- aidx =<< peekSP 1 ((`shiftL` 2) . (.&. 0x0f)) + poke8 (dp `plusPtr` 1) =<< aidx b' + poke8 (dp `plusPtr` 2) c + + if doPad + then poke8 (dp `plusPtr` 3) equals >> finish (n + 4) + else finish (n + 3) + else do + poke8 (dp `plusPtr` 1) =<< aidx b + + if doPad + then do + poke8 (dp `plusPtr` 2) equals + poke8 (dp `plusPtr` 3) equals + finish (n + 4) + else finish (n + 2) + + + withForeignPtr dfp (\dptr -> fill (castPtr dptr) sptr 0) + +data EncodeTable = ET !(ForeignPtr Word8) !(ForeignPtr Word16) + -- The encoding table is constructed such that the expansion of a 12-bit -- block to a 16-bit block can be done by a single Word16 copy from the -- correspoding table entry to the target address. The 16-bit blocks are -- stored in big-endian order, as the indices into the table are built in -- big-endian order. mkEncodeTable :: ByteString -> EncodeTable +#if MIN_VERSION_bytestring(0,11,0) +mkEncodeTable alphabet@(BS afp _) = + case table of BS fp _ -> ET afp (castForeignPtr fp) +#else mkEncodeTable alphabet@(PS afp _ _) = case table of PS fp _ _ -> ET afp (castForeignPtr fp) +#endif where ix = fromIntegral . B.index alphabet table = B.pack $ concat $ [ [ix j, ix k] | j <- [0..63], k <- [0..63] ] --- | Efficiently intersperse a terminator string into another at --- regular intervals, and terminate the input with it. +-- | Decode a base64-encoded string. This function strictly follows +-- the specification in . -- --- Examples: +-- This function takes the decoding table (for @base64@ or @base64url@) as +-- the first parameter. -- --- > joinWith "|" 2 "----" = "--|--|" +-- For validation of padding properties, see note: $Validation -- --- > joinWith "\r\n" 3 "foobarbaz" = "foo\r\nbar\r\nbaz\r\n" --- > joinWith "x" 3 "fo" = "fox" -joinWith :: ByteString -- ^ String to intersperse and end with - -> Int -- ^ Interval at which to intersperse, in bytes - -> ByteString -- ^ String to transform - -> ByteString -joinWith brk@(PS bfp boff blen) every bs@(PS sfp soff slen) - | every <= 0 = error "invalid interval" - | blen <= 0 = bs - | B.null bs = brk - | otherwise = - unsafeCreate dlen $ \dptr -> - withForeignPtr bfp $ \bptr -> do - withForeignPtr sfp $ \sptr -> do - let bp = bptr `plusPtr` boff - sp0 = sptr `plusPtr` soff - sLast = sp0 `plusPtr` (every * numBreaks) - loop !dp !sp - | sp == sLast = do - let n = sp0 `plusPtr` slen `minusPtr` sp - memcpy dp sp (fromIntegral n) - memcpy (dp `plusPtr` n) bp (fromIntegral blen) - | otherwise = do - memcpy dp sp (fromIntegral every) - let dp' = dp `plusPtr` every - memcpy dp' bp (fromIntegral blen) - loop (dp' `plusPtr` blen) (sp `plusPtr` every) - loop dptr sp0 - where dlast = slen + blen * numBreaks - dlen | slen `mod` every > 0 = dlast + blen - | otherwise = dlast - numBreaks = slen `div` every +decodeWithTable :: Padding -> ForeignPtr Word8 -> ByteString -> Either String ByteString +decodeWithTable padding !decodeFP bs + | B.length bs == 0 = Right B.empty + | otherwise = case padding of + Padded + | r == 0 -> withBS bs go + | r == 1 -> Left "Base64-encoded bytestring has invalid size" + | otherwise -> Left "Base64-encoded bytestring is unpadded or has invalid padding" + Don'tCare + | r == 0 -> withBS bs go + | r == 2 -> withBS (B.append bs (B.replicate 2 0x3d)) go + | r == 3 -> validateLastPad bs invalidPad $ withBS (B.append bs (B.replicate 1 0x3d)) go + | otherwise -> Left "Base64-encoded bytestring has invalid size" + Unpadded + | r == 0 -> validateLastPad bs noPad $ withBS bs go + | r == 2 -> validateLastPad bs noPad $ withBS (B.append bs (B.replicate 2 0x3d)) go + | r == 3 -> validateLastPad bs noPad $ withBS (B.append bs (B.replicate 1 0x3d)) go + | otherwise -> Left "Base64-encoded bytestring has invalid size" + where + !r = B.length bs `rem` 4 --- | Decode a base64-encoded string. This function strictly follows --- the specification in RFC 4648, --- . --- This function takes the decoding table (for @base64@ or @base64url@) as --- the first paramert. -decodeWithTable :: ForeignPtr Word8 -> ByteString -> Either String ByteString -decodeWithTable decodeFP (PS sfp soff slen) - | drem /= 0 = Left "invalid padding" - | dlen <= 0 = Right B.empty - | otherwise = unsafePerformIO $ do - dfp <- mallocByteString dlen - withForeignPtr decodeFP $ \ !decptr -> do - let finish dbytes = return . Right $! if dbytes > 0 - then PS dfp 0 dbytes - else B.empty - bail = return . Left - withForeignPtr sfp $ \ !sptr -> do - let sEnd = sptr `plusPtr` (slen + soff) - look p = do - ix <- fromIntegral `fmap` peek8 p - v <- peek8 (decptr `plusPtr` ix) - return $! fromIntegral v :: IO Word32 - fill !dp !sp !n - | sp >= sEnd = finish n - | otherwise = {-# SCC "decodeWithTable/fill" #-} do - a <- look sp - b <- look (sp `plusPtr` 1) - c <- look (sp `plusPtr` 2) - d <- look (sp `plusPtr` 3) - let w = (a `shiftL` 18) .|. (b `shiftL` 12) .|. - (c `shiftL` 6) .|. d - if a == done || b == done - then bail $ "invalid padding near offset " ++ - show (sp `minusPtr` sptr) - else if a .|. b .|. c .|. d == x - then bail $ "invalid base64 encoding near offset " ++ - show (sp `minusPtr` sptr) - else do - poke8 dp $ fromIntegral (w `shiftR` 16) - if c == done - then finish $ n + 1 - else do - poke8 (dp `plusPtr` 1) $ fromIntegral (w `shiftR` 8) - if d == done - then finish $! n + 2 - else do - poke8 (dp `plusPtr` 2) $ fromIntegral w - fill (dp `plusPtr` 3) (sp `plusPtr` 4) (n+3) - withForeignPtr dfp $ \dptr -> - fill dptr (sptr `plusPtr` soff) 0 - where (di,drem) = slen `divMod` 4 - dlen = di * 3 + noPad = "Base64-encoded bytestring required to be unpadded" + invalidPad = "Base64-encoded bytestring has invalid padding" + go !sptr !slen = do + dfp <- mallocByteString (slen `quot` 4 * 3) + withForeignPtr decodeFP (\ !decptr -> + withForeignPtr dfp (\dptr -> + decodeLoop decptr sptr dptr (sptr `plusPtr` slen) dfp)) + +decodeLoop + :: Ptr Word8 + -- ^ decoding table pointer + -> Ptr Word8 + -- ^ source pointer + -> Ptr Word8 + -- ^ destination pointer + -> Ptr Word8 + -- ^ source end pointer + -> ForeignPtr Word8 + -- ^ destination foreign pointer (used for finalizing string) + -> IO (Either String ByteString) +decodeLoop !dtable !sptr !dptr !end !dfp = go dptr sptr + where + err p = return . Left + $ "invalid character at offset: " + ++ show (p `minusPtr` sptr) + + padErr p = return . Left + $ "invalid padding at offset: " + ++ show (p `minusPtr` sptr) + + canonErr p = return . Left + $ "non-canonical encoding detected at offset: " + ++ show (p `minusPtr` sptr) + + look :: Ptr Word8 -> IO Word32 + look !p = do + !i <- peek p + !v <- peekElemOff dtable (fromIntegral i) + return (fromIntegral v) + + go !dst !src + | plusPtr src 4 >= end = do + !a <- look src + !b <- look (src `plusPtr` 1) + !c <- look (src `plusPtr` 2) + !d <- look (src `plusPtr` 3) + finalChunk dst src a b c d + + | otherwise = do + !a <- look src + !b <- look (src `plusPtr` 1) + !c <- look (src `plusPtr` 2) + !d <- look (src `plusPtr` 3) + decodeChunk dst src a b c d + + -- | Decodes chunks of 4 bytes at a time, recombining into + -- 3 bytes. Note that in the inner loop stage, no padding + -- characters are admissible. + -- + decodeChunk !dst !src !a !b !c !d + | a == 0x63 = padErr src + | b == 0x63 = padErr (plusPtr src 1) + | c == 0x63 = padErr (plusPtr src 2) + | d == 0x63 = padErr (plusPtr src 3) + | a == 0xff = err src + | b == 0xff = err (plusPtr src 1) + | c == 0xff = err (plusPtr src 2) + | d == 0xff = err (plusPtr src 3) + | otherwise = do + let !w = (shiftL a 18 + .|. shiftL b 12 + .|. shiftL c 6 + .|. d) :: Word32 + + poke8 dst (fromIntegral (shiftR w 16)) + poke8 (plusPtr dst 1) (fromIntegral (shiftR w 8)) + poke8 (plusPtr dst 2) (fromIntegral w) + go (plusPtr dst 3) (plusPtr src 4) + + -- | Decode the final 4 bytes in the string, recombining into + -- 3 bytes. Note that in this stage, we can have padding chars + -- but only in the final 2 positions. + -- + finalChunk !dst !src a b c d + | a == 0x63 = padErr src + | b == 0x63 = padErr (plusPtr src 1) + | c == 0x63 && d /= 0x63 = err (plusPtr src 3) -- make sure padding is coherent. + | a == 0xff = err src + | b == 0xff = err (plusPtr src 1) + | c == 0xff = err (plusPtr src 2) + | d == 0xff = err (plusPtr src 3) + | otherwise = do + let !w = (shiftL a 18 + .|. shiftL b 12 + .|. shiftL c 6 + .|. d) :: Word32 + + poke8 dst (fromIntegral (shiftR w 16)) + + if c == 0x63 && d == 0x63 + then + if sanityCheckPos b mask_4bits + then return $ Right $ mkBS dfp (1 + (dst `minusPtr` dptr)) + else canonErr (plusPtr src 1) + else if d == 0x63 + then + if sanityCheckPos c mask_2bits + then do + poke8 (plusPtr dst 1) (fromIntegral (shiftR w 8)) + return $ Right $ mkBS dfp (2 + (dst `minusPtr` dptr)) + else canonErr (plusPtr src 2) + else do + poke8 (plusPtr dst 1) (fromIntegral (shiftR w 8)) + poke8 (plusPtr dst 2) (fromIntegral w) + return $ Right $ mkBS dfp (3 + (dst `minusPtr` dptr)) + + -- | 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. --- This function takes the decoding table (for @base64@ or @base64url@) as --- the first paramert. +-- following the specification from +-- , and will not +-- generate parse errors no matter how poor its input. This function +-- takes the decoding table (for @base64@ or @base64url@) as the first +-- paramert. decodeLenientWithTable :: ForeignPtr Word8 -> ByteString -> ByteString -decodeLenientWithTable decodeFP (PS sfp soff slen) - | dlen <= 0 = B.empty - | otherwise = unsafePerformIO $ do - dfp <- mallocByteString dlen - withForeignPtr decodeFP $ \ !decptr -> - withForeignPtr sfp $ \ !sptr -> do - let finish dbytes - | dbytes > 0 = return (PS dfp 0 dbytes) - | otherwise = return B.empty - sEnd = sptr `plusPtr` (slen + soff) - fill !dp !sp !n - | sp >= sEnd = finish n - | otherwise = {-# SCC "decodeLenientWithTable/fill" #-} - let look :: Bool -> Ptr Word8 - -> (Ptr Word8 -> Word32 -> IO ByteString) - -> IO ByteString - {-# INLINE look #-} - look skipPad p0 f = go p0 - where - go p | p >= sEnd = f (sEnd `plusPtr` (-1)) done - | otherwise = {-# SCC "decodeLenient/look" #-} do - ix <- fromIntegral `fmap` peek8 p - v <- peek8 (decptr `plusPtr` ix) - if v == x || (v == done && skipPad) - then go (p `plusPtr` 1) - else f (p `plusPtr` 1) (fromIntegral v) - in look True sp $ \ !aNext !aValue -> - look True aNext $ \ !bNext !bValue -> - if aValue == done || bValue == done - then finish n - else - look False bNext $ \ !cNext !cValue -> - look False cNext $ \ !dNext !dValue -> do - let w = (aValue `shiftL` 18) .|. (bValue `shiftL` 12) .|. - (cValue `shiftL` 6) .|. dValue - poke8 dp $ fromIntegral (w `shiftR` 16) - if cValue == done - then finish (n + 1) - else do - poke8 (dp `plusPtr` 1) $ fromIntegral (w `shiftR` 8) - if dValue == done - then finish (n + 2) +decodeLenientWithTable !decodeFP !bs = withBS bs go + where + go !sptr !slen + | dlen <= 0 = return B.empty + | otherwise = do + dfp <- mallocByteString dlen + withForeignPtr decodeFP $ \ !decptr -> do + let finish dbytes + | dbytes > 0 = return $ mkBS dfp dbytes + | otherwise = return B.empty + sEnd = sptr `plusPtr` slen + fill !dp !sp !n + | sp >= sEnd = finish n + | otherwise = {-# SCC "decodeLenientWithTable/fill" #-} + let look :: Bool -> Ptr Word8 + -> (Ptr Word8 -> Word32 -> IO ByteString) + -> IO ByteString + {-# INLINE look #-} + look skipPad p0 f = go' p0 + where + go' p | p >= sEnd = f (sEnd `plusPtr` (-1)) done + | otherwise = {-# SCC "decodeLenient/look" #-} do + ix <- fromIntegral `fmap` peek8 p + v <- peek8 (decptr `plusPtr` ix) + if v == x || v == done && skipPad + then go' (p `plusPtr` 1) + else f (p `plusPtr` 1) (fromIntegral v) + in look True sp $ \ !aNext !aValue -> + look True aNext $ \ !bNext !bValue -> + if aValue == done || bValue == done + then finish n + else + look False bNext $ \ !cNext !cValue -> + look False cNext $ \ !dNext !dValue -> do + let w = aValue `shiftL` 18 .|. bValue `shiftL` 12 .|. + cValue `shiftL` 6 .|. dValue + poke8 dp $ fromIntegral (w `shiftR` 16) + if cValue == done + then finish (n + 1) else do - poke8 (dp `plusPtr` 2) $ fromIntegral w - fill (dp `plusPtr` 3) dNext (n+3) - withForeignPtr dfp $ \dptr -> - fill dptr (sptr `plusPtr` soff) 0 - where dlen = ((slen + 3) `div` 4) * 3 + poke8 (dp `plusPtr` 1) $ fromIntegral (w `shiftR` 8) + if dValue == done + then finish (n + 2) + else do + poke8 (dp `plusPtr` 2) $ fromIntegral w + fill (dp `plusPtr` 3) dNext (n+3) + withForeignPtr dfp $ \dptr -> fill dptr sptr 0 + where + !dlen = (slen + 3) `div` 4 * 3 x :: Integral a => a x = 255 @@ -282,3 +361,86 @@ in acc' : go zs' else -- suffix must be null fixup acc' zs + +-- $Validation +-- +-- This function checks that the last char of a bytestring is '=' +-- and, if true, fails with a message or completes some io action. +-- +-- This is necessary to check when decoding permissively (i.e. filling in padding chars). +-- Consider the following 4 cases of a string of length l: +-- +-- l = 0 mod 4: No pad chars are added, since the input is assumed to be good. +-- l = 1 mod 4: Never an admissible length in base64 +-- l = 2 mod 4: 2 padding chars are added. If padding chars are present in the last 4 chars of the string, +-- they will fail to decode as final quanta. +-- l = 3 mod 4: 1 padding char is added. In this case a string is of the form + . If adding the +-- pad char "completes" the string so that it is `l = 0 mod 4`, then this may possibly form corrupted data. +-- This case is degenerate and should be disallowed. +-- +-- Hence, permissive decodes should only fill in padding chars when it makes sense to add them. That is, +-- if an input is degenerate, it should never succeed when we add padding chars. We need the following invariant to hold: +-- +-- @ +-- B64U.decodeUnpadded <|> B64U.decodePadded ~ B64U.decodePadded +-- @ +-- +-- This means the only char we need to check is the last one, and only to disallow `l = 3 mod 4`. +-- +validateLastPad + :: ByteString + -- ^ input to validate + -> String + -- ^ error msg + -> Either String ByteString + -> Either String ByteString +validateLastPad !bs err !io + | B.last bs == 0x3d = Left err + | otherwise = io +{-# INLINE validateLastPad #-} + +-- | Sanity check an index against a bitmask to make sure +-- it's coherent. If pos & mask == 0, we're good. If not, we should fail. +-- +sanityCheckPos :: Word32 -> Word8 -> Bool +sanityCheckPos pos mask = fromIntegral pos .&. mask == 0 +{-# INLINE sanityCheckPos #-} + +-- | Mask 2 bits +-- +mask_2bits :: Word8 +mask_2bits = 3 -- (1 << 2) - 1 +{-# NOINLINE mask_2bits #-} + +-- | Mask 4 bits +-- +mask_4bits :: Word8 +mask_4bits = 15 -- (1 << 4) - 1 +{-# NOINLINE mask_4bits #-} + +-- | Back-compat shim for bytestring >=0.11. Constructs a +-- bytestring from a foreign ptr and a length. Offset is 0. +-- +mkBS :: ForeignPtr Word8 -> Int -> ByteString +#if MIN_VERSION_bytestring(0,11,0) +mkBS dfp n = BS dfp n +#else +mkBS dfp n = PS dfp 0 n +#endif +{-# INLINE mkBS #-} + +-- | Back-compat shim for bytestring >=0.11. Unwraps the foreign ptr of +-- a bytestring, executing an IO action as a function of the underlying +-- pointer and some starting length. +-- +-- Note: in `unsafePerformIO`. +-- +withBS :: ByteString -> (Ptr Word8 -> Int -> IO a) -> a +#if MIN_VERSION_bytestring(0,11,0) +withBS (BS !sfp !slen) f = unsafePerformIO $ + withForeignPtr sfp $ \p -> f p slen +#else +withBS (PS !sfp !soff !slen) f = unsafePerformIO $ + withForeignPtr sfp $ \p -> f (plusPtr p soff) slen +#endif +{-# INLINE withBS #-} diff --git a/Data/ByteString/Base64/Lazy.hs b/Data/ByteString/Base64/Lazy.hs --- a/Data/ByteString/Base64/Lazy.hs +++ b/Data/ByteString/Base64/Lazy.hs @@ -8,13 +8,16 @@ -- Copyright : (c) 2012 Ian Lynagh -- -- License : BSD-style --- Maintainer : bos@serpentine.com +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov -- Stability : experimental -- Portability : GHC -- -- Fast and efficient encoding and decoding of base64-encoded -- lazy bytestrings. - +-- +-- @since 1.0.0.0 module Data.ByteString.Base64.Lazy ( encode @@ -35,8 +38,8 @@ encode = L.fromChunks . map B64.encode . reChunkIn 3 . L.toChunks -- | Decode a base64-encoded string. This function strictly follows --- the specification in RFC 4648, --- . +-- the specification in +-- . 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 @@ -49,13 +52,13 @@ 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 +-- following the specification from +-- , 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 == '/' - + goodChar c = isDigit c || isAsciiUpper c || isAsciiLower c + || c == '+' || c == '/' diff --git a/Data/ByteString/Base64/URL.hs b/Data/ByteString/Base64/URL.hs --- a/Data/ByteString/Base64/URL.hs +++ b/Data/ByteString/Base64/URL.hs @@ -8,19 +8,23 @@ -- Copyright : (c) 2012 Deian Stefan -- -- License : BSD-style --- Maintainer : deian@cs.stanford.edu +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov -- Stability : experimental -- Portability : GHC -- -- Fast and efficient encoding and decoding of base64url-encoded strings. - +-- +-- @since 0.1.1.0 module Data.ByteString.Base64.URL - ( - encode - , decode - , decodeLenient - , joinWith - ) where + ( encode + , encodeUnpadded + , decode + , decodePadded + , decodeUnpadded + , decodeLenient + ) where import Data.ByteString.Base64.Internal import qualified Data.ByteString as B @@ -31,18 +35,40 @@ -- | Encode a string into base64url form. The result will always be a -- multiple of 4 bytes in length. encode :: ByteString -> ByteString -encode = encodeWith (mkEncodeTable alphabet) +encode = encodeWith Padded (mkEncodeTable alphabet) --- | Decode a base64url-encoded string. This function strictly follows --- the specification in RFC 4648, --- . +-- | Encode a string into unpadded base64url form. +-- +-- @since 1.1.0.0 +encodeUnpadded :: ByteString -> ByteString +encodeUnpadded = encodeWith Unpadded (mkEncodeTable alphabet) + +-- | Decode a base64url-encoded string applying padding if necessary. +-- This function follows the specification in +-- and in decode :: ByteString -> Either String ByteString -decode = decodeWithTable decodeFP +decode = decodeWithTable Don'tCare decodeFP +-- | Decode a padded base64url-encoded string, failing if input is improperly padded. +-- This function follows the specification in +-- and in +-- +-- @since 1.1.0.0 +decodePadded :: ByteString -> Either String ByteString +decodePadded = decodeWithTable Padded decodeFP + +-- | Decode a unpadded base64url-encoded string, failing if input is padded. +-- This function follows the specification in +-- and in +-- +-- @since 1.1.0.0 +decodeUnpadded :: ByteString -> Either String ByteString +decodeUnpadded = decodeWithTable Unpadded decodeFP + -- | Decode a base64url-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. +-- following the specification from +-- , and will not +-- generate parse errors no matter how poor its input. decodeLenient :: ByteString -> ByteString decodeLenient = decodeLenientWithTable decodeFP @@ -52,8 +78,20 @@ {-# NOINLINE alphabet #-} decodeFP :: ForeignPtr Word8 -PS decodeFP _ _ = B.pack $ replicate 45 x ++ [62,x,x] ++ [52..61] ++ [x,x, - x,done,x,x,x] ++ [0..25] ++ [x,x,x,x,63,x] ++ [26..51] ++ replicate 133 x +#if MIN_VERSION_bytestring(0,11,0) +BS decodeFP _ = +#else +PS decodeFP _ _ = +#endif + B.pack $ replicate 45 x + ++ [62,x,x] + ++ [52..61] + ++ [x,x,x,done,x,x,x] + ++ [0..25] + ++ [x,x,x,x,63,x] + ++ [26..51] + ++ replicate 133 x + {-# NOINLINE decodeFP #-} x :: Integral a => a diff --git a/Data/ByteString/Base64/URL/Lazy.hs b/Data/ByteString/Base64/URL/Lazy.hs --- a/Data/ByteString/Base64/URL/Lazy.hs +++ b/Data/ByteString/Base64/URL/Lazy.hs @@ -8,17 +8,23 @@ -- Copyright : (c) 2012 Ian Lynagh -- -- License : BSD-style --- Maintainer : bos@serpentine.com +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov -- Stability : experimental -- Portability : GHC -- -- Fast and efficient encoding and decoding of base64-encoded -- lazy bytestrings. - +-- +-- @since 1.0.0.0 module Data.ByteString.Base64.URL.Lazy ( encode + , encodeUnpadded , decode + , decodeUnpadded + , decodePadded , decodeLenient ) where @@ -34,9 +40,18 @@ encode :: L.ByteString -> L.ByteString encode = L.fromChunks . map B64.encode . reChunkIn 3 . L.toChunks +-- | Encode a string into unpadded base64url form. +-- +-- @since 1.1.0.0 +encodeUnpadded :: L.ByteString -> L.ByteString +encodeUnpadded = L.fromChunks + . map B64.encodeUnpadded + . reChunkIn 3 + . L.toChunks + -- | Decode a base64-encoded string. This function strictly follows --- the specification in RFC 4648, --- . +-- the specification in +-- . 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 @@ -48,9 +63,29 @@ Left err -> Left err Right b' -> Right $ L.fromChunks [b'] +-- | Decode a unpadded base64url-encoded string, failing if input is padded. +-- This function follows the specification in +-- and in +-- +-- @since 1.1.0.0 +decodeUnpadded :: L.ByteString -> Either String L.ByteString +decodeUnpadded bs = case B64.decodeUnpadded $ S.concat $ L.toChunks bs of + Right b -> Right $ L.fromChunks [b] + Left e -> Left e + +-- | Decode a padded base64url-encoded string, failing if input is improperly padded. +-- This function follows the specification in +-- and in +-- +-- @since 1.1.0.0 +decodePadded :: L.ByteString -> Either String L.ByteString +decodePadded bs = case B64.decodePadded $ S.concat $ L.toChunks bs of + Right b -> Right $ L.fromChunks [b] + Left e -> Left e + -- | Decode a base64-encoded string. This function is lenient in --- following the specification from RFC 4648, --- , and will not generate +-- following the specification from +-- , 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 @@ -58,4 +93,3 @@ where -- We filter out and '=' padding here, but B64.decodeLenient -- handles that goodChar c = isAlphaNum c || c == '-' || c == '_' - diff --git a/README.markdown b/README.markdown deleted file mode 100644 --- a/README.markdown +++ /dev/null @@ -1,37 +0,0 @@ -# Fast base64 support - -This package provides a Haskell library for working with base64-encoded -data quickly and efficiently, using the ByteString type. - - -# Performance - -This library is written in pure Haskell, and it's fast: - -* 250 MB/sec encoding - -* 200 MB/sec strict decoding (per RFC 4648) - -* 100 MB/sec lenient decoding - - -# Get involved! - -Please report bugs via the -[github issue tracker](https://github.com/bos/base64-bytestring). - -Master [git repository](https://github.com/bos/base64-bytestring): - -* `git clone git://github.com/bos/base64-bytestring.git` - -And a [Mercurial mirror](https://bitbucket.org/bos/base64-bytestring): - -* `hg clone https://bitbucket.org/bos/base64-bytestring` - -(You can create and contribute changes using either Mercurial or git.) - - -# Authors - -This library is written and maintained by Bryan O'Sullivan, -. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +# Base64 Support for ByteStrings [![Hackage version](https://img.shields.io/hackage/v/base64-bytestring.svg?label=Hackage)](https://hackage.haskell.org/package/base64-bytestring) [![Stackage version](https://www.stackage.org/package/base64-bytestring/badge/lts?label=Stackage)](https://www.stackage.org/package/base64-bytestring) [![Build Status](https://secure.travis-ci.org/haskell/base64-bytestring.svg?branch=master)](http://travis-ci.org/haskell/base64-bytestring) + +This package provides a Haskell library for working with base64-encoded +data quickly and efficiently, using the `ByteString` type. + +# Get involved! + +Please report bugs via the +[GitHub issue tracker](https://github.com/haskell/base64-bytestring). + +Master [Git repository](https://github.com/haskell/base64-bytestring): + +* `git clone git://github.com/haskell/base64-bytestring.git` + + +# Authors + +This library is written by [Bryan O'Sullivan](mailto:bos@serpentine.com). It +is maintained by [Herbert Valerio Riedel](mailto:hvr@gnu.org), [Mikhail +Glushenkov](mailto:mikhail.glushenkov@gmail.com), and [Emily Pillmore](mailto:emilypi@cohomolo.gy). diff --git a/base64-bytestring.cabal b/base64-bytestring.cabal --- a/base64-bytestring.cabal +++ b/base64-bytestring.cabal @@ -1,64 +1,91 @@ -name: base64-bytestring -version: 1.0.0.1 -synopsis: Fast base64 encoding and decoding for ByteStrings -description: Fast base64 encoding and decoding for ByteStrings -homepage: https://github.com/bos/base64-bytestring -bug-reports: https://github.com/bos/base64-bytestring/issues -license: BSD3 -license-file: LICENSE -author: Bryan O'Sullivan -maintainer: Bryan O'Sullivan -copyright: 2010-2012 Bryan O'Sullivan -category: Data -build-type: Simple -cabal-version: >=1.8 +cabal-version: 1.12 +name: base64-bytestring +version: 1.2.1.0 +synopsis: Fast base64 encoding and decoding for ByteStrings +description: + This package provides support for encoding and decoding binary data according to @base64@ (see also ) for strict and lazy ByteStrings + . + For a fuller-featured and better-performing Base64 library, see the package. +homepage: https://github.com/haskell/base64-bytestring +bug-reports: https://github.com/haskell/base64-bytestring/issues +license: BSD3 +license-file: LICENSE +author: Bryan O'Sullivan +maintainer: + Herbert Valerio Riedel , + Mikhail Glushenkov , + Emily Pillmore + +copyright: 2010-2020 Bryan O'Sullivan et al. +category: Data +build-type: Simple +tested-with: + GHC ==7.0.4 + || ==7.2.2 + || ==7.4.2 + || ==7.6.3 + || ==7.8.4 + || ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.5 + extra-source-files: - README.markdown - benchmarks/BM.hs - tests/Transcode.hs - tests/transcode.py + README.md + CHANGELOG.md + utils/Transcode.hs + utils/transcode.py library exposed-modules: Data.ByteString.Base64 - Data.ByteString.Base64.URL Data.ByteString.Base64.Lazy + Data.ByteString.Base64.URL Data.ByteString.Base64.URL.Lazy - - other-modules: - Data.ByteString.Base64.Internal + other-modules: Data.ByteString.Base64.Internal build-depends: - base == 4.*, - bytestring >= 0.9.0 + base >=4 && <5 + , bytestring >=0.9 && <0.12 - ghc-options: -Wall -funbox-strict-fields - ghc-prof-options: -auto-all + ghc-options: -Wall -funbox-strict-fields + default-language: Haskell2010 -test-suite tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Tests.hs +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Tests.hs + ghc-options: -Wall -threaded -rtsopts + build-depends: + base + , base64-bytestring + , bytestring + , HUnit + , QuickCheck + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 - ghc-options: - -Wall -threaded -rtsopts + default-language: Haskell2010 +benchmark benchmarks + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: BM.hs + ghc-options: -Wall -threaded -rtsopts build-depends: - QuickCheck, - HUnit, - base64-bytestring, - base, - containers, - bytestring, - test-framework, - test-framework-quickcheck2, - test-framework-hunit + base + , base64-bytestring + , bytestring + , criterion + , deepseq >=1.1 -source-repository head - type: git - location: git://github.com/bos/base64-bytestring + default-language: Haskell2010 source-repository head - type: mercurial - location: https://bitbucket.org/bos/base64-bytestring + type: git + location: git://github.com/haskell/base64-bytestring diff --git a/benchmarks/BM.hs b/benchmarks/BM.hs --- a/benchmarks/BM.hs +++ b/benchmarks/BM.hs @@ -1,53 +1,95 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +module Main +( main +) where +#if __GLASGOW_HASKELL__ > 702 +#if !MIN_VERSION_bytestring(0,10,0) import Control.DeepSeq (NFData(rnf)) +#endif + +import Criterion import Criterion.Main -import qualified Data.ByteString.Base64 as B -import qualified Data.ByteString.Base64.Lazy as L -import qualified Data.ByteString.Base64.URL as U -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Internal as L -strict name orig = - bgroup name [ - bgroup "normal" [ - bench "decode" $ whnf B.decode enc - , bench "decodeLenient" $ whnf B.decodeLenient enc - , bench "encode" $ whnf B.encode orig +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +#endif + +main :: IO () +main = +#if __GLASGOW_HASKELL__ < 704 + return () +#else + defaultMain + [ env bs $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> + bgroup "encode" + [ bgroup "25" + [ bench "base64" $ whnf B64.encode bs25 + ] + , bgroup "100" + [ bench "base64" $ whnf B64.encode bs100 + ] + , bgroup "1k" + [ bench "base64" $ whnf B64.encode bs1k + ] + , bgroup "10k" + [ bench "base64" $ whnf B64.encode bs10k + ] + , bgroup "100k" + [ bench "base64" $ whnf B64.encode bs100k + ] + , bgroup "1mm" + [ bench "base64" $ whnf B64.encode bs1mm + ] ] - , bgroup "url" [ - bench "decode" $ whnf U.decode enc - , bench "decodeLenient" $ whnf U.decodeLenient enc - , bench "encode" $ whnf U.encode orig + , env bs' $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> + bgroup "decode" + [ bgroup "25" + [ bench "base64" $ whnf B64.decode bs25 + ] + , bgroup "100" + [ bench "base64" $ whnf B64.decode bs100 + ] + , bgroup "1k" + [ bench "base64" $ whnf B64.decode bs1k + ] + , bgroup "10k" + [ bench "base64" $ whnf B64.decode bs10k + ] + , bgroup "100k" + [ bench "base64" $ whnf B64.decode bs100k + ] + , bgroup "1mm" + [ bench "base64" $ whnf B64.decode bs1mm + ] ] ] - where enc = U.encode orig + where + bss :: BS.ByteString + bss = "ab%de^ghi*" -instance NFData L.ByteString where - rnf L.Empty = () - rnf (L.Chunk _ ps) = rnf ps + bs = do + let !a = BS.concat $ replicate 3 bss + !b = BS.concat $ replicate 10 bss + !c = BS.concat $ replicate 100 bss + !d = BS.concat $ replicate 1000 bss + !e = BS.concat $ replicate 10000 bss + !f = BS.concat $ replicate 100000 bss + return (a,b,c,d,e,f) -lazy name orig = - bgroup name [ - bench "decode" $ nf L.decode enc - , bench "encode" $ nf L.encode orig - ] - where enc = L.encode orig + bs' = do + let !a = B64.encode (BS.concat $ replicate 3 bss) + !b = B64.encode (BS.concat $ replicate 10 bss) + !c = B64.encode (BS.concat $ replicate 100 bss) + !d = B64.encode (BS.concat $ replicate 1000 bss) + !e = B64.encode (BS.concat $ replicate 10000 bss) + !f = B64.encode (BS.concat $ replicate 100000 bss) + return (a,b,c,d,e,f) -main :: IO () -main = defaultMain [ - bgroup "lazy" [ - lazy "small" (L.fromChunks [input]) - , lazy "medium" (L.concat . replicate 16 . L.fromChunks . (:[]) . - B.concat $ replicate 8 input) - , lazy "large" (L.concat . replicate 1280 . L.fromChunks . (:[]) . - B.concat $ replicate 8 input) - ] - , bgroup "strict" [ - strict "small" input - , strict "medium" (B.concat (replicate 128 input)) - , strict "large" (B.concat (replicate 10240 input)) - ] - ] - where input = "abcdABCD0123[];'" +#if !MIN_VERSION_bytestring(0,10,0) +instance NFData BS.ByteString where + rnf bs = bs `seq` () +#endif +#endif diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where @@ -7,7 +9,7 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Providers.HUnit (testCase) -import Test.QuickCheck (Arbitrary(..), Positive(..)) +import Test.QuickCheck (Arbitrary(..)) import Control.Monad (liftM) import qualified Data.ByteString.Base64 as Base64 @@ -15,6 +17,7 @@ import qualified Data.ByteString.Base64.URL as Base64URL import qualified Data.ByteString.Base64.URL.Lazy as LBase64URL import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Data.ByteString.Char8 () import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L @@ -25,41 +28,112 @@ main :: IO () main = defaultMain tests -data Impl bs = Impl String - (bs -> bs) - (bs -> Either String bs) - (bs -> bs) +data Impl bs = Impl + { _label :: String + , _encode :: bs -> bs + , _decode :: bs -> Either String bs + , _lenient :: bs -> bs + } + +data UrlImpl bs = UrlImpl + { _labelUrl :: String + , _encodeUrl :: bs -> bs + , _decodeUrl :: bs -> Either String bs + , _encodeUrlNopad :: bs -> bs + , _decodeUrlNopad :: bs -> Either String bs + , _decodeUrlPad :: bs -> Either String bs + , _lenientUrl :: bs -> bs + } + tests :: [Test] -tests = [ - testGroup "joinWith" [ - testProperty "all_endsWith" joinWith_all_endsWith - , testProperty "endsWith" joinWith_endsWith +tests = + [ testGroup "property tests" + [ testsRegular b64impl + , testsRegular lb64impl + , testsURL b64uimpl + , testsURL lb64uimpl ] - , 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 + , testGroup "unit tests" + [ base64UrlUnitTests + , lazyBase64UrlUnitTests + ] ] + where + b64impl = Impl "Base64" Base64.encode Base64.decode Base64.decodeLenient + lb64impl = Impl "LBase64" LBase64.encode LBase64.decode LBase64.decodeLenient -testsRegular :: (IsString bs, AllRepresentations bs, Show bs, Eq bs, Arbitrary bs) => Impl bs -> Test + b64uimpl = UrlImpl + "Base64URL" + Base64URL.encode + Base64URL.decode + Base64URL.encodeUnpadded + Base64URL.decodeUnpadded + Base64URL.decodePadded + Base64URL.decodeLenient + + lb64uimpl = UrlImpl + "LBase64URL" + LBase64URL.encode + LBase64URL.decode + LBase64URL.encodeUnpadded + LBase64URL.decodeUnpadded + LBase64URL.decodePadded + 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 +testsURL + :: ( IsString bs + , AllRepresentations bs + , Show bs + , Eq bs + , Arbitrary bs + ) + => UrlImpl bs + -> Test +testsURL (UrlImpl l e d eu du dp dl) = testGroup l + [ testsWith base64url_testData (Impl "Arbitrary Padding" e d dl) + , testsWith base64url_testData (Impl "Required Padding" e dp dl) + , testsWith base64url_testData_nopad (Impl "No padding" eu du dl) + , testProperty "prop_url_pad_roundtrip" $ \bs -> Right bs == dp (e bs) + , testProperty "prop_url_nopad_roundtrip" $ \bs -> Right bs == du (eu bs) + , testProperty "prop_url_decode_invariant" $ \bs -> + ((du (eu bs)) == (d (e bs))) || ((dp (e bs)) == d (e bs)) + ] -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 encode decode - , testProperty "decodeEncode Lenient" $ - genericDecodeEncode encode - (liftM Right decodeLenient) - , testGroup "base64-string tests" (string_tests testData impl) +testsWith + :: ( IsString bs + , AllRepresentations bs + , Show bs + , Eq bs + , Arbitrary bs + ) + => [(bs, bs)] + -> Impl bs + -> Test +testsWith testData impl = testGroup label + [ testProperty "decodeEncode" $ + genericDecodeEncode encode decode + , testProperty "decodeEncode Lenient" $ + genericDecodeEncode encode (liftM Right lenient) + , testGroup "base64-string tests" (string_tests testData impl) ] + where + label = _label impl + encode = _encode impl + decode = _decode impl + lenient = _lenient impl instance Arbitrary ByteString where arbitrary = liftM B.pack arbitrary @@ -69,44 +143,38 @@ 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 - -chunksOf :: Int -> ByteString -> [ByteString] -chunksOf k s - | B.null s = [] - | otherwise = let (h,t) = B.splitAt k s - in h : chunksOf k t - -joinWith_all_endsWith :: ByteString -> Positive Int -> ByteString -> Bool -joinWith_all_endsWith brk (Positive int) str = - all (brk `B.isSuffixOf`) . chunksOf k . Base64.joinWith brk int $ str - where k = B.length brk + min int (B.length str) - -- | Decoding an encoded sintrg should produce the original string. -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' +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' -- -- Unit tests from base64-string -- Copyright (c) Ian Lynagh, 2005, 2007. -- -string_tests :: forall bs - . (IsString bs, AllRepresentations bs, Show bs, Eq bs) - => [(bs, bs)] -> Impl bs -> [Test] +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 + base64_string_test encode decode testData ++ base64_string_test encode decodeLenient' testData + where + decodeLenient' = liftM Right decodeLenient + base64_testData :: IsString bs => [(bs, bs)] base64_testData = [("", "") ,("\0", "AA==") @@ -137,29 +205,47 @@ ,("Ex\0am\255ple", "RXgAYW3_cGxl") ] +base64url_testData_nopad :: IsString bs => [(bs, bs)] +base64url_testData_nopad = [("", "") + ,("\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 :: (AllRepresentations bs, Eq bs, Show bs) - => (bs -> bs) - -> (bs -> Either String bs) - -> [(bs, bs)] -> [Test] +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 + | (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 + plain <- allRepresentations rawPlain + , let encoded_plain = enc plain ] ++ - [ 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 + [ 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 @@ -174,11 +260,238 @@ 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) + | 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 ] + , (prefix, suffix) <- tail splits + ] +base64UrlUnitTests :: Test +base64UrlUnitTests = testGroup "Base64URL unit tests" + [ testGroup "URL decodePadded" + [ padtest "<" "PA==" + , padtest "<<" "PDw=" + , padtest "<" "PDw_Pz4=" + , padtest "<>" "PDw_Pz4-" + ] + + , testGroup "URL decodeUnpadded" + [ nopadtest "<" "PA" + , nopadtest "<<" "PDw" + , nopadtest "<" "PDw_Pz4" + , nopadtest "<>" "PDw_Pz4-" + ] + + , testGroup "Padding validity" + [ testCase "Padding fails everywhere but end" $ do + Base64.decode "=eAoeAo=" @=? Left "invalid padding at offset: 0" + Base64.decode "e=AoeAo=" @=? Left "invalid padding at offset: 1" + Base64.decode "eA=oeAo=" @=? Left "invalid padding at offset: 2" + Base64.decode "eAo=eAo=" @=? Left "invalid padding at offset: 3" + Base64.decode "eAoe=Ao=" @=? Left "invalid padding at offset: 4" + Base64.decode "eAoeA=o=" @=? Left "invalid padding at offset: 5" + ] + , testGroup "Non-canonical encodings fail and canonical encodings succeed" + [ testCase "roundtrip for d ~ ZA==" $ do + Base64.decode "ZE==" @=? Left "non-canonical encoding detected at offset: 1" + Base64.decode "ZK==" @=? Left "non-canonical encoding detected at offset: 1" + Base64.decode "ZA==" @=? Right "d" + , testCase "roundtrip for f` ~ ZmA=" $ do + Base64.decode "ZmC=" @=? Left "non-canonical encoding detected at offset: 2" + Base64.decode "ZmD=" @=? Left "non-canonical encoding detected at offset: 2" + Base64.decode "ZmA=" @=? Right "f`" + + , testCase "roundtrip for foo` ~ Zm9vYA==" $ do + Base64.decode "Zm9vYE==" @=? Left "non-canonical encoding detected at offset: 5" + Base64.decode "Zm9vYK==" @=? Left "non-canonical encoding detected at offset: 5" + Base64.decode "Zm9vYA==" @=? Right "foo`" + + , testCase "roundtrip for foob` ~ Zm9vYmA=" $ do + Base64.decode "Zm9vYmC=" @=? Left "non-canonical encoding detected at offset: 6" + Base64.decode "Zm9vYmD=" @=? Left "non-canonical encoding detected at offset: 6" + Base64.decode "Zm9vYmA=" @=? Right "foob`" + ] + , testGroup "Base64URL padding case unit tests" + [ testCase "stress arbitarily padded URL strings" $ do + Base64URL.decode "P" @=? Left "Base64-encoded bytestring has invalid size" + Base64URL.decode "PA" @=? Right "<" + Base64URL.decode "PDw" @=? Right "<<" + Base64URL.decode "PDw_" @=? Right "<" "PDw_Pz4=" + , padtest "<>" "PDw_Pz4-" + ] + + , testGroup "URL decodeUnpadded" + [ nopadtest "<" "PA" + , nopadtest "<<" "PDw" + , nopadtest "<" "PDw_Pz4" + , nopadtest "<>" "PDw_Pz4-" + ] + + , testGroup "Padding validity" + [ testCase "Padding fails everywhere but end" $ do + LBase64.decode "=eAoeAo=" @=? Left "invalid padding at offset: 0" + LBase64.decode "e=AoeAo=" @=? Left "invalid padding at offset: 1" + LBase64.decode "eA=oeAo=" @=? Left "invalid padding at offset: 2" + LBase64.decode "eAo=eAo=" @=? Left "invalid padding at offset: 3" + LBase64.decode "eAoe=Ao=" @=? Left "invalid padding at offset: 4" + LBase64.decode "eAoeA=o=" @=? Left "invalid padding at offset: 5" + ] + + , testGroup "LBase64URL padding case unit tests" + [ testCase "stress arbitarily padded URL strings" $ do + LBase64URL.decode "P" @=? Left "Base64-encoded bytestring has invalid size" + LBase64URL.decode "PA" @=? Right "<" + LBase64URL.decode "PDw" @=? Right "<<" + LBase64URL.decode "PDw_" @=? Right "< case decode bs of - Left err -> putStrLn err - Right p -> B.putStr p - "decodeLenient" -> B.putStr (decodeLenient bs) - "encode" -> B.putStr (encode bs) - "read" -> B.putStr bs - case files of - [] -> B.getContents >>= xcode - fs -> mapM_ (\f -> B.readFile f >>= xcode) fs diff --git a/tests/transcode.py b/tests/transcode.py deleted file mode 100644 --- a/tests/transcode.py +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/env python - -import binascii, sys - -funcs = { - 'decode': binascii.a2b_base64, - 'encode': binascii.b2a_base64, - 'read': lambda x:x, - } - -f = funcs[sys.argv[1]] - -for n in sys.argv[2:]: - sys.stdout.write(f(open(n).read())) diff --git a/utils/Transcode.hs b/utils/Transcode.hs new file mode 100644 --- /dev/null +++ b/utils/Transcode.hs @@ -0,0 +1,16 @@ +import qualified Data.ByteString as B +import System.Environment +import Data.ByteString.Base64 + +main = do + (kind:files) <- getArgs + let xcode bs = case kind of + "decode" -> case decode bs of + Left err -> putStrLn err + Right p -> B.putStr p + "decodeLenient" -> B.putStr (decodeLenient bs) + "encode" -> B.putStr (encode bs) + "read" -> B.putStr bs + case files of + [] -> B.getContents >>= xcode + fs -> mapM_ (\f -> B.readFile f >>= xcode) fs diff --git a/utils/transcode.py b/utils/transcode.py new file mode 100644 --- /dev/null +++ b/utils/transcode.py @@ -0,0 +1,14 @@ +#!/usr/bin/env python + +import binascii, sys + +funcs = { + 'decode': binascii.a2b_base64, + 'encode': binascii.b2a_base64, + 'read': lambda x:x, + } + +f = funcs[sys.argv[1]] + +for n in sys.argv[2:]: + sys.stdout.write(f(open(n).read()))