diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,23 @@ 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)) diff --git a/Data/ByteString/Base64.hs b/Data/ByteString/Base64.hs --- a/Data/ByteString/Base64.hs +++ b/Data/ByteString/Base64.hs @@ -8,7 +8,9 @@ -- 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 -- @@ -36,7 +38,7 @@ -- the specification in -- . -- --- (Note: this means that even @"\n", "\r\n"@ as line breaks are rejected +-- (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'.) @@ -55,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,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} -- | -- Module : Data.ByteString.Base64.Internal @@ -20,6 +21,8 @@ , peek8, poke8, peek8_32 , reChunkIn , Padding(..) + , withBS + , mkBS ) where import Data.Bits ((.|.), (.&.), shiftL, shiftR) @@ -28,7 +31,7 @@ import Data.Word (Word8, Word16, Word32) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr) import Foreign.Ptr (Ptr, castPtr, minusPtr, plusPtr) -import Foreign.Storable (peek, peekElemOff, poke, peekByteOff) +import Foreign.Storable (peek, peekElemOff, poke) import System.IO.Unsafe (unsafePerformIO) peek8 :: Ptr Word8 -> IO Word8 @@ -46,65 +49,65 @@ -- | Encode a string into base64 form. The result will always be a multiple -- of 4 bytes in length. encodeWith :: Padding -> EncodeTable -> ByteString -> ByteString -encodeWith !padding (ET alfaFP encodeTable) (PS sfp soff slen) - | slen > maxBound `div` 4 = +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) - finish !n = return (PS dfp 0 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)) + | 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)) - poke8 dp =<< aidx a + 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 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 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) + 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 `plusPtr` soff) 0 + withForeignPtr dfp (\dptr -> fill (castPtr dptr) sptr 0) data EncodeTable = ET !(ForeignPtr Word8) !(ForeignPtr Word16) @@ -114,58 +117,54 @@ -- 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] ] -- | Decode a base64-encoded string. This function strictly follows --- the specification in --- . +-- the specification in . +-- -- This function takes the decoding table (for @base64@ or @base64url@) as --- the first paramert. +-- the first parameter. +-- +-- For validation of padding properties, see note: $Validation +-- decodeWithTable :: Padding -> ForeignPtr Word8 -> ByteString -> Either String ByteString -decodeWithTable _ _ (PS _ _ 0) = Right B.empty -decodeWithTable padding decodeFP bs@(PS !fp !o !l) = unsafePerformIO $ - case padding of - Padded - | r == 1 -> err "Base64-encoded bytestring has invalid size" - | r /= 0 -> err "Base64-encoded bytestring required to be padded" - | otherwise -> go bs - Don'tCare - | r == 0 -> go bs - | r == 2 -> go (B.append bs (B.replicate 2 0x3d)) - | r == 3 -> go (B.append bs (B.replicate 1 0x3d)) - | otherwise -> err "Base64-encoded bytestring has invalid size" - Unpadded - | r == 0 -> validateUnpadded (go bs) - | r == 2 -> validateUnpadded (go (B.append bs (B.replicate 2 0x3d))) - | r == 3 -> validateUnpadded (go (B.append bs (B.replicate 1 0x3d))) - | otherwise -> err "Base64-encoded bytestring has invalid size" +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 - err = return . Left - - (q, r) = (B.length bs) `divMod` 4 - - dlen = q * 3 - - validateUnpadded io = withForeignPtr fp $ \p -> do - let !end = l + o - a <- peek (plusPtr p (end - 1)) - b <- peek (plusPtr p (end - 2)) + !r = B.length bs `rem` 4 - let !pad = 0x3d :: Word8 - if a == pad || b == pad - then err "Base64-encoded bytestring required to be unpadded" - else io + noPad = "Base64-encoded bytestring required to be unpadded" + invalidPad = "Base64-encoded bytestring has invalid padding" - go (PS !sfp !soff !slen) = do - dfp <- mallocByteString dlen - withForeignPtr decodeFP $ \ !decptr -> - withForeignPtr sfp $ \sptr -> - withForeignPtr dfp $ \dptr -> - decodeLoop decptr (plusPtr sptr soff) dptr (sptr `plusPtr` (slen + soff)) dfp + 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 @@ -185,14 +184,18 @@ $ "invalid character at offset: " ++ show (p `minusPtr` sptr) - padErr p = return . Left + 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 <- peekByteOff p 0 :: IO Word8 - !v <- peekByteOff dtable (fromIntegral i) :: IO Word8 + !i <- peek p + !v <- peekElemOff dtable (fromIntegral i) return (fromIntegral v) go !dst !src @@ -224,9 +227,9 @@ | 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) + let !w = (shiftL a 18 + .|. shiftL b 12 + .|. shiftL c 6 .|. d) :: Word32 poke8 dst (fromIntegral (shiftR w 16)) @@ -247,23 +250,29 @@ | 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) + 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 return $ Right $ PS dfp 0 (1 + (dst `minusPtr` dptr)) + 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 do - poke8 (plusPtr dst 1) (fromIntegral (shiftR w 8)) - return $ Right $ PS dfp 0 (2 + (dst `minusPtr` dptr)) + 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 $ PS dfp 0 (3 + (dst `minusPtr` dptr)) + return $ Right $ mkBS dfp (3 + (dst `minusPtr` dptr)) -- | Decode a base64-encoded string. This function is lenient in @@ -273,54 +282,55 @@ -- 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 @@ -351,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,7 +8,9 @@ -- Copyright : (c) 2012 Ian Lynagh -- -- License : BSD-style --- Maintainer : bos@serpentine.com +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov -- Stability : experimental -- Portability : GHC -- 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,7 +8,9 @@ -- 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 -- @@ -76,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,7 +8,9 @@ -- Copyright : (c) 2012 Ian Lynagh -- -- License : BSD-style --- Maintainer : bos@serpentine.com +-- Maintainer : Emily Pillmore , +-- Herbert Valerio Riedel , +-- Mikhail Glushenkov -- Stability : experimental -- Portability : GHC -- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,20 +1,8 @@ -# Fast base64 support [![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) +# 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. - -# 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 @@ -28,5 +16,5 @@ # Authors This library is written by [Bryan O'Sullivan](mailto:bos@serpentine.com). It -is maintained by [Herbert Valerio Riedel](mailto:hvr@gnu.org) and [Mikhail -Glushenkov](mailto:mikhail.glushenkov@gmail.com). +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,24 +1,39 @@ -cabal-version: 1.12 -name: base64-bytestring -version: 1.1.0.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. -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==8.10.1, GHC==8.8.3, GHC==8.6.5, - GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, - GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, - GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 +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.md CHANGELOG.md @@ -28,58 +43,46 @@ 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.11 - - ghc-options: -Wall -funbox-strict-fields + base >=4 && <5 + , bytestring >=0.9 && <0.12 + 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 - - ghc-options: - -Wall -threaded -rtsopts - +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Tests.hs + ghc-options: -Wall -threaded -rtsopts build-depends: - QuickCheck, - HUnit, - base64-bytestring, - base, - containers, - bytestring, - split, - test-framework, - test-framework-quickcheck2, - test-framework-hunit + base + , base64-bytestring + , bytestring + , HUnit + , QuickCheck + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 default-language: Haskell2010 benchmark benchmarks - type: exitcode-stdio-1.0 - hs-source-dirs: benchmarks - main-is: BM.hs - - ghc-options: - -Wall -threaded -rtsopts - + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: BM.hs + ghc-options: -Wall -threaded -rtsopts build-depends: - base, - bytestring, - containers, - deepseq, - base64-bytestring, - criterion + base + , base64-bytestring + , bytestring + , criterion + , deepseq >=1.1 default-language: Haskell2010 diff --git a/benchmarks/BM.hs b/benchmarks/BM.hs --- a/benchmarks/BM.hs +++ b/benchmarks/BM.hs @@ -1,72 +1,95 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} - -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.Base64.URL.Lazy as LU -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy as L +module Main +( main +) where +#if __GLASGOW_HASKELL__ > 702 #if !MIN_VERSION_bytestring(0,10,0) import Control.DeepSeq (NFData(rnf)) -import qualified Data.ByteString.Lazy.Internal as L #endif -strict :: String -> B.ByteString -> Benchmark -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 - ] - , bgroup "url" [ - bench "decode" $ whnf U.decode enc - , bench "decodeLenient" $ whnf U.decodeLenient enc - , bench "encode" $ whnf U.encode orig - , bench "encodeUnpadded" $ whnf U.encodeUnpadded orig - ] - ] - where enc = U.encode orig +import Criterion +import Criterion.Main -#if !MIN_VERSION_bytestring(0,10,0) -instance NFData L.ByteString where - rnf L.Empty = () - rnf (L.Chunk _ ps) = rnf ps +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 #endif -lazy :: String -> L.ByteString -> Benchmark -lazy name orig = - bgroup name [ - bgroup "normal" [ - bench "decode" $ nf L.decode enc - , bench "decodeLenient" $ nf L.decodeLenient enc - , bench "encode" $ nf L.encode orig +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" $ nf LU.decode enc - , bench "decodeLenient" $ nf LU.decodeLenient enc - , bench "encode" $ nf LU.encode orig - , bench "encodeUnpadded" $ whnf LU.encodeUnpadded 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 = L.encode orig + where + bss :: BS.ByteString + bss = "ab%de^ghi*" -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[];'" + 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) + + 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) + +#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 @@ -36,24 +36,52 @@ , _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 "property tests" - [ 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 "Base64URLPadded" Base64URL.encode Base64URL.decodePadded Base64URL.decodeLenient - , testsURLNopad $ Impl "Base64URLUnpadded" Base64URL.encodeUnpadded Base64URL.decodeUnpadded Base64URL.decodeLenient - , testsURL $ Impl "LBase64URL" LBase64URL.encode LBase64URL.decode LBase64URL.decodeLenient - , testsURL $ Impl "LBase64URLPadded" LBase64URL.encode LBase64URL.decodePadded LBase64URL.decodeLenient - , testsURLNopad $ Impl "LBase64URLUnpadded" LBase64URL.encodeUnpadded LBase64URL.decodeUnpadded LBase64URL.decodeLenient + [ testsRegular b64impl + , testsRegular lb64impl + , testsURL b64uimpl + , testsURL lb64uimpl ] , testGroup "unit tests" [ base64UrlUnitTests , lazyBase64UrlUnitTests ] ] + where + b64impl = Impl "Base64" Base64.encode Base64.decode Base64.decodeLenient + lb64impl = Impl "LBase64" LBase64.encode LBase64.decode LBase64.decodeLenient + 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 @@ -72,20 +100,17 @@ , Eq bs , Arbitrary bs ) - => Impl bs - -> Test -testsURL = testsWith base64url_testData - -testsURLNopad - :: ( IsString bs - , AllRepresentations bs - , Show bs - , Eq bs - , Arbitrary bs - ) - => Impl bs + => UrlImpl bs -> Test -testsURLNopad = testsWith base64url_testData_nopad +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 @@ -149,6 +174,7 @@ where decodeLenient' = liftM Right decodeLenient + base64_testData :: IsString bs => [(bs, bs)] base64_testData = [("", "") ,("\0", "AA==") @@ -272,7 +298,26 @@ 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" @@ -342,7 +387,7 @@ Right s else do assertEqual "Unpadded required: padding fails" u $ - Left "Base64-encoded bytestring required to be padded" + Left "Base64-encoded bytestring is unpadded or has invalid padding" assertEqual "Unpadded required: unpadding succeeds" v $ Right s @@ -446,7 +491,7 @@ Right s else do assertEqual "Unpadded required: padding fails" u $ - Left "Base64-encoded bytestring required to be padded" + Left "Base64-encoded bytestring is unpadded or has invalid padding" assertEqual "Unpadded required: unpadding succeeds" v $ Right s