diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for base64 +## 0.4.2.1 + +* [Security fix]: reject non-canonical base64 encoded values - ([#25](https://github.com/emilypi/base64/pull/25)) + +* Perf improvements + ## 0.4.2 * Added support for `Data.ByteString.Short`, `Data.ByteString.Lazy`, `Data.Text.Short`, and `Data.Text.Lazy`. ([#17](https://github.com/emilypi/base64/pull/17)) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,13 +3,13 @@ [![Build Status](https://travis-ci.com/emilypi/base64.svg?branch=master)](https://travis-ci.com/emilypi/base64) [![Hackage](https://img.shields.io/hackage/v/base64.svg)](https://hackage.haskell.org/package/base64) -Base64 encoding and decodings. +Base64 encoding and decodings. For the companion optics and pattern synonyms, see [base64-lens](https://hackage.haskell.org/package/base64-lens). ### Summary -The following types are supported for both std, padded url-safe, and unpadded url-safe alphabets: +The following types are supported for both std, padded url-safe, and unpadded url-safe alphabets: - `Data.ByteString` - `Data.ByteString.Lazy` @@ -18,11 +18,11 @@ - `Data.Text.Lazy` - `Data.Text.Short` -Additionally this library has +Additionally this library has - Better performance than `base64-bytestring` for encode and decode. - Optics for handling more complex structures with Base64 representations via the `base64-lens` package - Checks for both validity and correctness of Base64 and Base64url encodings - -There are no dependencies aside from those bundled with GHC, and the ultra-minimal `ghc-byteorder`. +- Rejects non-canonical encodings that do not roundtrip in other base64 libraries like `ZE==`. +There are no dependencies aside from those bundled with GHC, and the `ghc-byteorder` re-export. diff --git a/base64.cabal b/base64.cabal --- a/base64.cabal +++ b/base64.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: base64 -version: 0.4.2 +version: 0.4.2.1 synopsis: Fast RFC 4648-compliant Base64 encoding description: RFC 4648-compliant padded and unpadded base64 and base64url encoding and decoding. This library provides @@ -15,7 +15,7 @@ copyright: (c) 2019-2020 Emily Pillmore category: Data build-type: Simple -extra-source-files: +extra-doc-files: CHANGELOG.md README.md @@ -103,7 +103,6 @@ , bytestring , criterion , deepseq - , memory , random-bytestring , text diff --git a/benchmarks/Base64Bench.hs b/benchmarks/Base64Bench.hs --- a/benchmarks/Base64Bench.hs +++ b/benchmarks/Base64Bench.hs @@ -20,8 +20,6 @@ import Criterion import Criterion.Main -import "memory" Data.ByteArray.Encoding as Mem -import Data.ByteString import "base64-bytestring" Data.ByteString.Base64 as Bos import "base64" Data.ByteString.Base64 as B64 import Data.ByteString.Random (random) @@ -33,77 +31,59 @@ [ env bs $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> bgroup "encode" [ bgroup "25" - [ bench "memory" $ whnf ctob bs25 - , bench "base64-bytestring" $ whnf Bos.encode bs25 + [ bench "base64-bytestring" $ whnf Bos.encode bs25 , bench "base64" $ whnf B64.encodeBase64' bs25 ] , bgroup "100" - [ bench "memory" $ whnf ctob bs100 - , bench "base64-bytestring" $ whnf Bos.encode bs100 + [ bench "base64-bytestring" $ whnf Bos.encode bs100 , bench "base64" $ whnf B64.encodeBase64' bs100 ] , bgroup "1k" - [ bench "memory" $ whnf ctob bs1k - , bench "base64-bytestring" $ whnf Bos.encode bs1k + [ bench "base64-bytestring" $ whnf Bos.encode bs1k , bench "base64" $ whnf B64.encodeBase64' bs1k ] , bgroup "10k" - [ bench "memory" $ whnf ctob bs10k - , bench "base64-bytestring" $ whnf Bos.encode bs10k + [ bench "base64-bytestring" $ whnf Bos.encode bs10k , bench "base64" $ whnf B64.encodeBase64' bs10k ] , bgroup "100k" - [ bench "memory" $ whnf ctob bs100k - , bench "base64-bytestring" $ whnf Bos.encode bs100k + [ bench "base64-bytestring" $ whnf Bos.encode bs100k , bench "base64" $ whnf B64.encodeBase64' bs100k ] , bgroup "1mm" - [ bench "memory" $ whnf ctob bs1mm - , bench "base64-bytestring" $ whnf Bos.encode bs1mm + [ bench "base64-bytestring" $ whnf Bos.encode bs1mm , bench "base64" $ whnf B64.encodeBase64' bs1mm ] ] , env bs' $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> bgroup "decode" [ bgroup "25" - [ bench "memory" $ whnf btoc bs25 - , bench "base64-bytestring" $ whnf Bos.decode bs25 + [ bench "base64-bytestring" $ whnf Bos.decode bs25 , bench "base64" $ whnf B64.decodeBase64 bs25 ] , bgroup "100" - [ bench "memory" $ whnf btoc bs100 - , bench "base64-bytestring" $ whnf Bos.decode bs100 + [ bench "base64-bytestring" $ whnf Bos.decode bs100 , bench "base64" $ whnf B64.decodeBase64 bs100 ] , bgroup "1k" - [ bench "memory" $ whnf btoc bs1k - , bench "base64-bytestring" $ whnf Bos.decode bs1k + [ bench "base64-bytestring" $ whnf Bos.decode bs1k , bench "base64" $ whnf B64.decodeBase64 bs1k ] , bgroup "10k" - [ bench "memory" $ whnf btoc bs10k - , bench "base64-bytestring" $ whnf Bos.decode bs10k + [ bench "base64-bytestring" $ whnf Bos.decode bs10k , bench "base64" $ whnf B64.decodeBase64 bs10k ] , bgroup "100k" - [ bench "memory" $ whnf btoc bs100k - , bench "base64-bytestring" $ whnf Bos.decode bs100k + [ bench "base64-bytestring" $ whnf Bos.decode bs100k , bench "base64" $ whnf B64.decodeBase64 bs100k ] , bgroup "1mm" - [ bench "memory" $ whnf btoc bs1mm - , bench "base64-bytestring" $ whnf Bos.decode bs1mm + [ bench "base64-bytestring" $ whnf Bos.decode bs1mm , bench "base64" $ whnf B64.decodeBase64 bs1mm ] ] ] where - ctob :: ByteString -> ByteString - ctob = Mem.convertToBase Mem.Base64 - - btoc :: ByteString -> Either String ByteString - btoc = Mem.convertFromBase Mem.Base64 - bs = do a <- random 25 b <- random 100 diff --git a/src/Data/ByteString/Base64.hs b/src/Data/ByteString/Base64.hs --- a/src/Data/ByteString/Base64.hs +++ b/src/Data/ByteString/Base64.hs @@ -55,13 +55,15 @@ -- See: -- decodeBase64 :: ByteString -> Either Text ByteString -decodeBase64 bs@(PS _ _ !l) +decodeBase64 bs@(PS _ _ l) + | l == 0 = Right bs | r == 1 = Left "Base64-encoded bytestring has invalid size" | r /= 0 = Left "Base64-encoded bytestring requires padding" | otherwise = unsafeDupablePerformIO $ decodeBase64_ dlen decodeB64Table bs where - (!q, !r) = divMod l 4 - !dlen = q * 3 + q = l `quot` 4 + r = l `rem` 4 + dlen = q * 3 {-# INLINE decodeBase64 #-} -- | Leniently decode an unpadded Base64-encoded 'ByteString' value. This function diff --git a/src/Data/ByteString/Base64/Internal/Head.hs b/src/Data/ByteString/Base64/Internal/Head.hs --- a/src/Data/ByteString/Base64/Internal/Head.hs +++ b/src/Data/ByteString/Base64/Internal/Head.hs @@ -44,13 +44,13 @@ encodeBase64_ :: EncodingTable -> ByteString -> ByteString -encodeBase64_ (EncodingTable !aptr !efp) (PS !sfp !soff !slen) = +encodeBase64_ (EncodingTable aptr efp) (PS sfp soff slen) = unsafeDupablePerformIO $ do dfp <- mallocPlainForeignPtrBytes dlen withForeignPtr dfp $ \dptr -> withForeignPtr sfp $ \sptr -> withForeignPtr efp $ \eptr -> do - let !end = plusPtr sptr (soff + slen) + let end = plusPtr sptr (soff + slen) innerLoop eptr (castPtr (plusPtr sptr soff)) @@ -58,8 +58,7 @@ end (loopTail dfp aptr dptr (castPtr end)) where - !dlen = 4 * ((slen + 2) `div` 3) -{-# inline encodeBase64_ #-} + dlen = 4 * ((slen + 2) `div` 3) encodeBase64Nopad_ :: EncodingTable -> ByteString -> ByteString encodeBase64Nopad_ (EncodingTable !aptr !efp) (PS !sfp !soff !slen) = @@ -77,7 +76,6 @@ (loopTailNoPad dfp aptr dptr (castPtr end)) where !dlen = 4 * ((slen + 2) `div` 3) -{-# inline encodeBase64Nopad_ #-} -- | The main decode function. Takes a padding flag, a decoding table, and -- the input value, producing either an error string on the left, or a @@ -94,8 +92,7 @@ -> ForeignPtr Word8 -> ByteString -> IO (Either Text ByteString) -decodeBase64_ _ _ (PS _ _ 0) = return $ Right mempty -decodeBase64_ !dlen !dtfp (PS !sfp !soff !slen) = +decodeBase64_ dlen dtfp (PS sfp soff slen) = withForeignPtr dtfp $ \dtable -> withForeignPtr sfp $ \sptr -> do dfp <- mallocPlainForeignPtrBytes dlen @@ -105,8 +102,7 @@ (plusPtr sptr soff) dptr (plusPtr sptr (soff + slen)) - (decodeTail dfp dtable sptr dptr) -{-# inline decodeBase64_ #-} + dfp decodeBase64Lenient_ :: ForeignPtr Word8 -> ByteString -> ByteString decodeBase64Lenient_ !dtfp (PS !sfp !soff !slen) = unsafeDupablePerformIO $ diff --git a/src/Data/ByteString/Base64/Internal/Tail.hs b/src/Data/ByteString/Base64/Internal/Tail.hs --- a/src/Data/ByteString/Base64/Internal/Tail.hs +++ b/src/Data/ByteString/Base64/Internal/Tail.hs @@ -15,14 +15,11 @@ module Data.ByteString.Base64.Internal.Tail ( loopTail , loopTailNoPad -, decodeTail ) where import Data.Bits import Data.ByteString.Internal import Data.ByteString.Base64.Internal.Utils -import Data.Text (Text) -import qualified Data.Text as T import Foreign.ForeignPtr import Foreign.Ptr @@ -47,8 +44,8 @@ | plusPtr src 1 == end = do !x <- peek @Word8 src - let !a = shiftR (x .&. 0xfc) 2 - !b = shiftL (x .&. 0x03) 4 + let !a = unsafeShiftR (x .&. 0xfc) 2 + !b = unsafeShiftL (x .&. 0x03) 4 poke @Word8 dst (aix a alpha) poke @Word8 (plusPtr dst 1) (aix b alpha) @@ -60,11 +57,11 @@ !x <- peek @Word8 src !y <- peek @Word8 (plusPtr src 1) - let !a = shiftR (x .&. 0xfc) 2 - !b = shiftL (x .&. 0x03) 4 + let !a = unsafeShiftR (x .&. 0xfc) 2 + !b = unsafeShiftL (x .&. 0x03) 4 - let !c = shiftR (y .&. 0xf0) 4 .|. b - !d = shiftL (y .&. 0x0f) 2 + let !c = unsafeShiftR (y .&. 0xf0) 4 .|. b + !d = unsafeShiftL (y .&. 0x0f) 2 poke @Word8 dst (aix a alpha) poke @Word8 (plusPtr dst 1) (aix c alpha) @@ -85,91 +82,28 @@ -> Ptr Word8 -> IO ByteString loopTailNoPad !dfp (Ptr !alpha) !dptr !end !src !dst - | src == end = return (PS dfp 0 (minusPtr dst dptr)) - | plusPtr src 1 == end = do - !x <- peek @Word8 src + | src == end = return (PS dfp 0 (minusPtr dst dptr)) + | plusPtr src 1 == end = do + !x <- peek @Word8 src - let !a = shiftR (x .&. 0xfc) 2 - !b = shiftL (x .&. 0x03) 4 + let !a = unsafeShiftR (x .&. 0xfc) 2 + !b = unsafeShiftL (x .&. 0x03) 4 - poke @Word8 dst (aix a alpha) - poke @Word8 (plusPtr dst 1) (aix b alpha) - return (PS dfp 0 (2 + (minusPtr dst dptr))) - | otherwise = do - !x <- peek @Word8 src - !y <- peek @Word8 (plusPtr src 1) + poke @Word8 dst (aix a alpha) + poke @Word8 (plusPtr dst 1) (aix b alpha) + return (PS dfp 0 (2 + (minusPtr dst dptr))) + | otherwise = do + !x <- peek @Word8 src + !y <- peek @Word8 (plusPtr src 1) - let !a = shiftR (x .&. 0xfc) 2 - !b = shiftL (x .&. 0x03) 4 + let !a = unsafeShiftR (x .&. 0xfc) 2 + !b = unsafeShiftL (x .&. 0x03) 4 - let !c = shiftR (y .&. 0xf0) 4 .|. b - !d = shiftL (y .&. 0x0f) 2 + let !c = unsafeShiftR (y .&. 0xf0) 4 .|. b + !d = unsafeShiftL (y .&. 0x0f) 2 - poke @Word8 dst (aix a alpha) - poke @Word8 (plusPtr dst 1) (aix c alpha) - poke @Word8 (plusPtr dst 2) (aix d alpha) - return (PS dfp 0 (3 + (minusPtr dst dptr))) + poke @Word8 dst (aix a alpha) + poke @Word8 (plusPtr dst 1) (aix c alpha) + poke @Word8 (plusPtr dst 2) (aix d alpha) + return (PS dfp 0 (3 + (minusPtr dst dptr))) {-# inline loopTailNoPad #-} - -decodeTail - :: ForeignPtr Word8 - -- ^ dst bytestring foreign ptr - -> Ptr Word8 - -- ^ decode table - -> Ptr Word8 - -- ^ original decode static pointer - -> Ptr Word8 - -- ^ original source pointer (for offset calculation) - -> Ptr Word8 - -- ^ dst ptr - -> Ptr Word8 - -- ^ src ptr - -> IO (Either Text ByteString) -decodeTail !dfp !dtable !sptr !dptr !dst !src = do - !w <- peek @Word8 src - !x <- peek @Word8 (plusPtr src 1) - !y <- peek @Word8 (plusPtr src 2) - !z <- peek @Word8 (plusPtr src 3) - - !a <- w32 <$> peekByteOff @Word8 dtable (fromIntegral w) - !b <- w32 <$> peekByteOff @Word8 dtable (fromIntegral x) - !c <- w32 <$> peekByteOff @Word8 dtable (fromIntegral y) - !d <- w32 <$> peekByteOff @Word8 dtable (fromIntegral z) - - if - | a == 0xff -> err src - | b == 0xff -> err (plusPtr src 1) - | c == 0xff -> err (plusPtr src 2) - | d == 0xff -> err (plusPtr src 3) - | a == 0x63 -> padErr src - | b == 0x63 -> padErr (plusPtr src 1) - | c == 0x63, d /= 0x63 -> padErr (plusPtr src 3) - | otherwise -> do - - let !ww = (unsafeShiftL a 18) - .|. (unsafeShiftL b 12) - .|. (unsafeShiftL c 6) - .|. d - - if - | c == 0x63, d == 0x63 -> do - poke @Word8 dst (fromIntegral (unsafeShiftR ww 16)) - return $ Right (PS dfp 0 (1 + (minusPtr dst dptr))) - | d == 0x63 -> do - poke @Word8 dst (fromIntegral (unsafeShiftR ww 16)) - poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR ww 8)) - return $ Right (PS dfp 0 (2 + (minusPtr dst dptr))) - | otherwise -> do - poke @Word8 dst (fromIntegral (unsafeShiftR ww 16)) - poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR ww 8)) - poke @Word8 (plusPtr dst 2) (fromIntegral ww) - return $ Right (PS dfp 0 (3 + (minusPtr dst dptr))) - where - err p = return . Left . T.pack - $ "invalid character at offset: " - ++ show (p `minusPtr` sptr) - - padErr p = return . Left . T.pack - $ "invalid padding at offset: " - ++ show (p `minusPtr` sptr) -{-# inline decodeTail #-} diff --git a/src/Data/ByteString/Base64/Internal/Utils.hs b/src/Data/ByteString/Base64/Internal/Utils.hs --- a/src/Data/ByteString/Base64/Internal/Utils.hs +++ b/src/Data/ByteString/Base64/Internal/Utils.hs @@ -14,10 +14,13 @@ module Data.ByteString.Base64.Internal.Utils ( EncodingTable(..) , aix +, mask_2bits +, mask_4bits , packTable , peekWord32BE , peekWord64BE , reChunkN +, validateLastPos , w32 , w64 , w32_16 @@ -26,7 +29,7 @@ ) where - +import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -75,6 +78,24 @@ w32_16 :: Word16 -> Word32 w32_16 = fromIntegral {-# INLINE w32_16 #-} + +-- | Mask bottom 2 bits +-- +mask_2bits :: Word8 +mask_2bits = 3 -- (1 << 2) - 1 +{-# INLINE mask_2bits #-} + +-- | Mask bottom 4 bits +-- +mask_4bits :: Word8 +mask_4bits = 15 -- (1 << 4) - 1 +{-# INLINE mask_4bits #-} + +-- | Validate some ptr index against some bitmask +-- +validateLastPos :: Word32 -> Word8 -> Bool +validateLastPos pos mask = (fromIntegral pos .&. mask) == 0 +{-# INLINE validateLastPos #-} -- | Allocate and fill @n@ bytes with some data -- diff --git a/src/Data/ByteString/Base64/Internal/W16/Loop.hs b/src/Data/ByteString/Base64/Internal/W16/Loop.hs --- a/src/Data/ByteString/Base64/Internal/W16/Loop.hs +++ b/src/Data/ByteString/Base64/Internal/W16/Loop.hs @@ -72,10 +72,9 @@ -> Ptr Word8 -- ^ dst pointer -> Ptr Word8 - -- ^ end of src ptr - -> (Ptr Word8 -> Ptr Word8 -> IO (Either Text ByteString)) + -> ForeignPtr Word8 -> IO (Either Text ByteString) -decodeLoop !dtable !sptr !dptr !end finish = go dptr sptr +decodeLoop !dtable !sptr !dptr !end !dfp = go dptr sptr where err p = return . Left . T.pack $ "invalid character at offset: " @@ -85,40 +84,91 @@ $ "invalid padding at offset: " ++ show (p `minusPtr` sptr) + canonErr p = return . Left . T.pack + $ "non-canonical encoding detected at offset: " + ++ show (p `minusPtr` sptr) + look :: Ptr Word8 -> IO Word32 look !p = do - !i <- peekByteOff @Word8 p 0 - !v <- peekByteOff @Word8 dtable (fromIntegral i) + i <- peekByteOff @Word8 p 0 + v <- peekByteOff @Word8 dtable (fromIntegral i) return (fromIntegral v) go !dst !src - | plusPtr src 4 >= end = finish 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 - if - | 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 + -- | 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 = (unsafeShiftL a 18) - .|. (unsafeShiftL b 12) - .|. (unsafeShiftL c 6) - .|. d + let !w = ((unsafeShiftL a 18) + .|. (unsafeShiftL b 12) + .|. (unsafeShiftL c 6) + .|. d) :: Word32 - poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) + poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) + poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR w 8)) + poke @Word8 (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 = ((unsafeShiftL a 18) + .|. (unsafeShiftL b 12) + .|. (unsafeShiftL c 6) + .|. d) :: Word32 + + poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) + + if c == 0x63 && d == 0x63 + then + if validateLastPos b mask_4bits + then return $ Right $ PS dfp 0 (1 + (dst `minusPtr` dptr)) + else canonErr (plusPtr src 1) + else if d == 0x63 + then if validateLastPos c mask_2bits + then do + poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR w 8)) + return $ Right $ PS dfp 0 (2 + (dst `minusPtr` dptr)) + else canonErr (plusPtr src 2) + else do poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR w 8)) poke @Word8 (plusPtr dst 2) (fromIntegral w) - go (plusPtr dst 3) (plusPtr src 4) + return $ Right $ PS dfp 0 (3 + (dst `minusPtr` dptr)) {-# inline decodeLoop #-} lenientLoop @@ -162,13 +212,13 @@ | otherwise -> look False bp $ \cp c -> look False cp $ \dp d -> do - let !w = (shiftL a 18) .|. (shiftL b 12) .|. (shiftL c 6) .|. d + let !w = (unsafeShiftL a 18) .|. (unsafeShiftL b 12) .|. (unsafeShiftL c 6) .|. d - poke @Word8 dst (fromIntegral (shiftR w 16)) + poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) if c == 0x63 then finalize (n + 1) else do - poke @Word8 (plusPtr dst 1) (fromIntegral (w `shiftR` 8)) + poke @Word8 (plusPtr dst 1) (fromIntegral (w `unsafeShiftR` 8)) if d == 0x63 then finalize (n + 2) else do diff --git a/src/Data/ByteString/Base64/Internal/W32/Loop.hs b/src/Data/ByteString/Base64/Internal/W32/Loop.hs --- a/src/Data/ByteString/Base64/Internal/W32/Loop.hs +++ b/src/Data/ByteString/Base64/Internal/W32/Loop.hs @@ -72,7 +72,7 @@ -- ^ dst pointer -> Ptr Word8 -- ^ end of src ptr - -> (Ptr Word8 -> Ptr Word8 -> IO (Either Text ByteString)) + -> ForeignPtr Word8 -> IO (Either Text ByteString) decodeLoop = W16.decodeLoop {-# INLINE decodeLoop #-} diff --git a/src/Data/ByteString/Base64/Internal/W64/Loop.hs b/src/Data/ByteString/Base64/Internal/W64/Loop.hs --- a/src/Data/ByteString/Base64/Internal/W64/Loop.hs +++ b/src/Data/ByteString/Base64/Internal/W64/Loop.hs @@ -80,7 +80,7 @@ -- ^ dst pointer -> Ptr Word8 -- ^ end of src ptr - -> (Ptr Word8 -> Ptr Word8 -> IO (Either Text ByteString)) + -> ForeignPtr Word8 -- ^ dst foreign ptr (for consing bs) -> IO (Either Text ByteString) decodeLoop = W16.decodeLoop diff --git a/src/Data/ByteString/Base64/URL.hs b/src/Data/ByteString/Base64/URL.hs --- a/src/Data/ByteString/Base64/URL.hs +++ b/src/Data/ByteString/Base64/URL.hs @@ -64,15 +64,16 @@ -- See: -- decodeBase64 :: ByteString -> Either Text ByteString -decodeBase64 bs@(PS _ _ !l) +decodeBase64 bs@(PS _ _ l) | l == 0 = Right bs | r == 0 = unsafeDupablePerformIO $ decodeBase64_ dlen decodeB64UrlTable bs | r == 2 = unsafeDupablePerformIO $ decodeBase64_ dlen decodeB64UrlTable (BS.append bs "==") | r == 3 = validateLastPad bs $ decodeBase64_ dlen decodeB64UrlTable (BS.append bs "=") | otherwise = Left "Base64-encoded bytestring has invalid size" where - (!q, !r) = divMod l 4 - !dlen = q * 3 + q = l `quot` 4 + r = l `rem` 4 + dlen = q * 3 {-# INLINE decodeBase64 #-} -- | Encode a 'ByteString' value as Base64url 'Text' without padding. Note that for Base64url, @@ -104,15 +105,16 @@ -- See: -- decodeBase64Unpadded :: ByteString -> Either Text ByteString -decodeBase64Unpadded bs@(PS _ _ !l) +decodeBase64Unpadded bs@(PS _ _ l) | l == 0 = Right bs | r == 0 = validateLastPad bs $ decodeBase64_ dlen decodeB64UrlTable bs | r == 2 = validateLastPad bs $ decodeBase64_ dlen decodeB64UrlTable (BS.append bs "==") | r == 3 = validateLastPad bs $ decodeBase64_ dlen decodeB64UrlTable (BS.append bs "=") | otherwise = Left "Base64-encoded bytestring has invalid size" where - (!q, !r) = divMod l 4 - !dlen = q * 3 + q = l `quot` 4 + r = l `rem` 4 + dlen = q * 3 {-# INLINE decodeBase64Unpadded #-} -- | Decode a padded Base64url-encoded 'ByteString' value. Input strings are @@ -125,14 +127,15 @@ -- See: -- decodeBase64Padded :: ByteString -> Either Text ByteString -decodeBase64Padded bs@(PS !_ _ !l) +decodeBase64Padded bs@(PS _ _ l) | l == 0 = Right bs | r == 1 = Left "Base64-encoded bytestring has invalid size" | r /= 0 = Left "Base64-encoded bytestring requires padding" | otherwise = unsafeDupablePerformIO $ decodeBase64_ dlen decodeB64UrlTable bs where - (!q, !r) = divMod l 4 - !dlen = q * 3 + q = l `quot` 4 + r = l `rem` 4 + dlen = q * 3 {-# INLINE decodeBase64Padded #-} -- | Leniently decode an unpadded Base64url-encoded 'ByteString'. This function diff --git a/test/Internal.hs b/test/Internal.hs --- a/test/Internal.hs +++ b/test/Internal.hs @@ -1,7 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -27,6 +29,7 @@ import "base64" Data.ByteString.Lazy.Base64.URL as LB64U import "base64" Data.ByteString.Short.Base64 as SB64 import "base64" Data.ByteString.Short.Base64.URL as SB64U +import Data.Proxy import Data.String import Data.Text (Text) import qualified Data.Text as T @@ -41,18 +44,37 @@ import "base64" Data.Text.Short.Encoding.Base64.URL as TS64U import Test.QuickCheck hiding (label) -import Test.QuickCheck.Instances +import Test.QuickCheck.Instances () -- ------------------------------------------------------------------ -- -- Test Harnesses -data B64 -data LB64 -data SB64 -data T64 -data TL64 -data TS64 +data Impl + = B64 + | LB64 + | SB64 + | T64 + | TL64 + | TS64 +b64 :: Proxy 'B64 +b64 = Proxy + +lb64 :: Proxy 'LB64 +lb64 = Proxy + +sb64 :: Proxy 'SB64 +sb64 = Proxy + +t64 :: Proxy 'T64 +t64 = Proxy + +tl64 :: Proxy 'TL64 +tl64 = Proxy + +ts64 :: Proxy 'TS64 +ts64 = Proxy + -- | This class provides the generic API definition for -- the base64 std alphabet -- @@ -62,7 +84,7 @@ , Arbitrary bs , CoArbitrary bs , IsString bs - ) => Harness a bs | a -> bs, bs -> a + ) => Harness (a :: Impl) bs | a -> bs, bs -> a where label :: String @@ -84,7 +106,7 @@ validateUrl :: bs -> Bool -instance Harness B64 BS.ByteString where +instance Harness 'B64 BS.ByteString where label = "ByteString" encode = B64.encodeBase64' @@ -101,7 +123,7 @@ correctUrl = B64U.isBase64Url validateUrl = B64U.isValidBase64Url -instance Harness LB64 LBS.ByteString where +instance Harness 'LB64 LBS.ByteString where label = "Lazy ByteString" encode = LB64.encodeBase64' @@ -118,7 +140,7 @@ correctUrl = LB64U.isBase64Url validateUrl = LB64U.isValidBase64Url -instance Harness SB64 SBS.ShortByteString where +instance Harness 'SB64 SBS.ShortByteString where label = "Short ByteString" encode = SB64.encodeBase64' @@ -135,7 +157,7 @@ correctUrl = SB64U.isBase64Url validateUrl = SB64U.isValidBase64Url -instance Harness T64 Text where +instance Harness 'T64 Text where label = "Text" encode = T64.encodeBase64 @@ -152,7 +174,7 @@ validateUrl = T64U.isValidBase64Url validate = T64.isValidBase64 -instance Harness TL64 TL.Text where +instance Harness 'TL64 TL.Text where label = "Lazy Text" encode = TL64.encodeBase64 @@ -169,7 +191,7 @@ validateUrl = TL64U.isValidBase64Url validate = TL64.isValidBase64 -instance Harness TS64 TS.ShortText where +instance Harness 'TS64 TS.ShortText where label = "Short Text" encode = TS64.encodeBase64 @@ -186,25 +208,27 @@ validateUrl = TS64U.isValidBase64Url validate = TS64.isValidBase64 -class Harness a cs => TextHarness a cs bs | a -> cs, bs -> cs, cs -> a, cs -> bs where +class Harness a cs + => TextHarness (a :: Impl) cs bs + | a -> cs, bs -> cs, cs -> a, cs -> bs where decodeWith_ :: (bs -> Either err cs) -> bs -> Either (Base64Error err) cs decodeUrlWith_ :: (bs -> Either err cs) -> bs -> Either (Base64Error err) cs decodeUrlPaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base64Error err) cs decodeUrlUnpaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base64Error err) cs -instance TextHarness T64 Text BS.ByteString where +instance TextHarness 'T64 Text BS.ByteString where decodeWith_ = T64.decodeBase64With decodeUrlWith_ = T64U.decodeBase64With decodeUrlPaddedWith_ = T64U.decodeBase64PaddedWith decodeUrlUnpaddedWith_ = T64U.decodeBase64UnpaddedWith -instance TextHarness TL64 TL.Text LBS.ByteString where +instance TextHarness 'TL64 TL.Text LBS.ByteString where decodeWith_ = TL64.decodeBase64With decodeUrlWith_ = TL64U.decodeBase64With decodeUrlPaddedWith_ = TL64U.decodeBase64PaddedWith decodeUrlUnpaddedWith_ = TL64U.decodeBase64UnpaddedWith -instance TextHarness TS64 TS.ShortText SBS.ShortByteString where +instance TextHarness 'TS64 TS.ShortText SBS.ShortByteString where decodeWith_ = TS64.decodeBase64With decodeUrlWith_ = TS64U.decodeBase64With decodeUrlPaddedWith_ = TS64U.decodeBase64PaddedWith diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -31,7 +31,6 @@ import "base64" Data.ByteString.Base64.URL as B64U import qualified "base64-bytestring" Data.ByteString.Base64 as Bos import qualified "base64-bytestring" Data.ByteString.Base64.URL as BosU -import Data.Proxy import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Text.Encoding.Base64.Error (Base64Error(..)) @@ -53,33 +52,33 @@ tests :: TestTree tests = testGroup "Base64 Tests" - [ mkTree (Proxy :: Proxy B64) + [ mkTree b64 [ mkPropTree , mkUnitTree BS.last BS.length ] - , mkTree (Proxy :: Proxy LB64) + , mkTree lb64 [ mkPropTree , mkUnitTree LBS.last (fromIntegral . LBS.length) ] - , mkTree (Proxy :: Proxy SB64) + , mkTree sb64 [ mkPropTree , mkUnitTree (BS.last . SBS.fromShort) SBS.length ] - , mkTree (Proxy :: Proxy T64) + , mkTree t64 [ mkPropTree , mkUnitTree (c2w . T.last) T.length - , mkDecodeTree T.decodeUtf8' (Proxy :: Proxy B64) + , mkDecodeTree T.decodeUtf8' b64 ] - , mkTree (Proxy :: Proxy TL64) + , mkTree tl64 [ mkPropTree , mkUnitTree (c2w . TL.last) (fromIntegral . TL.length) - , mkDecodeTree TL.decodeUtf8' (Proxy :: Proxy LB64) + , mkDecodeTree TL.decodeUtf8' lb64 ] - , mkTree (Proxy :: Proxy TS64) + , mkTree ts64 [ mkPropTree , mkUnitTree (c2w . T.last . TS.toText) TS.length , mkDecodeTree - (second TS.fromText . T.decodeUtf8' . SBS.fromShort) (Proxy :: Proxy SB64) + (second TS.fromText . T.decodeUtf8' . SBS.fromShort) sb64 ] ] @@ -348,30 +347,52 @@ -- offsetVectors :: forall a b proxy. Harness a b => proxy a -> TestTree offsetVectors _ = testGroup "Offset tests" - [ testCase "Invalid staggered padding" $ do - decodeUrl @a "=A==" @=? Left "invalid padding at offset: 0" - decodeUrl @a "P===" @=? Left "invalid padding at offset: 1" - , testCase "Invalid character coverage - final chunk" $ do - decodeUrl @a "%D==" @=? Left "invalid character at offset: 0" - decodeUrl @a "P%==" @=? Left "invalid character at offset: 1" - decodeUrl @a "PD%=" @=? Left "invalid character at offset: 2" - decodeUrl @a "PA=%" @=? Left "invalid character at offset: 3" - decodeUrl @a "PDw%" @=? Left "invalid character at offset: 3" - , testCase "Invalid character coverage - decode chunk" $ do - decodeUrl @a "%Dw_PDw_" @=? Left "invalid character at offset: 0" - decodeUrl @a "P%w_PDw_" @=? Left "invalid character at offset: 1" - decodeUrl @a "PD%_PDw_" @=? Left "invalid character at offset: 2" - decodeUrl @a "PDw%PDw_" @=? Left "invalid character at offset: 3" - , testCase "Invalid padding in body" $ do - decodeUrl @a "PD=_PDw_" @=? Left "invalid padding at offset: 2" - decodeUrl @a "PDw=PDw_" @=? Left "invalid padding at offset: 3" - , testCase "Padding fails everywhere but end" $ do - decode @a "=eAoeAo=" @=? Left "invalid padding at offset: 0" - decode @a "e=AoeAo=" @=? Left "invalid padding at offset: 1" - decode @a "eA=oeAo=" @=? Left "invalid padding at offset: 2" - decode @a "eAo=eAo=" @=? Left "invalid padding at offset: 3" - decode @a "eAoe=Ao=" @=? Left "invalid padding at offset: 4" - decode @a "eAoeA=o=" @=? Left "invalid padding at offset: 5" + [ testGroup "Invalid padding" + [ testCase "Invalid staggered padding" $ do + decodeUrl @a "=A==" @=? Left "invalid padding at offset: 0" + decodeUrl @a "P===" @=? Left "invalid padding at offset: 1" + , testCase "Invalid character coverage - final chunk" $ do + decodeUrl @a "%D==" @=? Left "invalid character at offset: 0" + decodeUrl @a "P%==" @=? Left "invalid character at offset: 1" + decodeUrl @a "PD%=" @=? Left "invalid character at offset: 2" + decodeUrl @a "PA=%" @=? Left "invalid character at offset: 3" + decodeUrl @a "PDw%" @=? Left "invalid character at offset: 3" + , testCase "Invalid character coverage - decode chunk" $ do + decodeUrl @a "%Dw_PDw_" @=? Left "invalid character at offset: 0" + decodeUrl @a "P%w_PDw_" @=? Left "invalid character at offset: 1" + decodeUrl @a "PD%_PDw_" @=? Left "invalid character at offset: 2" + decodeUrl @a "PDw%PDw_" @=? Left "invalid character at offset: 3" + , testCase "Invalid padding in body" $ do + decodeUrl @a "PD=_PDw_" @=? Left "invalid padding at offset: 2" + decodeUrl @a "PDw=PDw_" @=? Left "invalid padding at offset: 3" + , testCase "Padding fails everywhere but end" $ do + decode @a "=eAoeAo=" @=? Left "invalid padding at offset: 0" + decode @a "e=AoeAo=" @=? Left "invalid padding at offset: 1" + decode @a "eA=oeAo=" @=? Left "invalid padding at offset: 2" + decode @a "eAo=eAo=" @=? Left "invalid padding at offset: 3" + decode @a "eAoe=Ao=" @=? Left "invalid padding at offset: 4" + decode @a "eAoeA=o=" @=? Left "invalid padding at offset: 5" + ] + , testGroup "Non-canonical encodings fail and canonical encodings succeed" + [ testCase "roundtrip for d ~ ZA==" $ do + decode @a "ZE==" @=? Left "non-canonical encoding detected at offset: 1" + decode @a "ZK==" @=? Left "non-canonical encoding detected at offset: 1" + decode @a "ZA==" @=? Right "d" + , testCase "roundtrip for f` ~ ZmA=" $ do + decode @a "ZmC=" @=? Left "non-canonical encoding detected at offset: 2" + decode @a "ZmD=" @=? Left "non-canonical encoding detected at offset: 2" + decode @a "ZmA=" @=? Right "f`" + + , testCase "roundtrip for foo` ~ Zm9vYA==" $ do + decode @a "Zm9vYE==" @=? Left "non-canonical encoding detected at offset: 5" + decode @a "Zm9vYK==" @=? Left "non-canonical encoding detected at offset: 5" + decode @a "Zm9vYA==" @=? Right "foo`" + + , testCase "roundtrip for foob` ~ Zm9vYmA=" $ do + decode @a "Zm9vYmC=" @=? Left "non-canonical encoding detected at offset: 6" + decode @a "Zm9vYmD=" @=? Left "non-canonical encoding detected at offset: 6" + decode @a "Zm9vYmA=" @=? Right "foob`" + ] ] -- | Unit test trees for the `decode*With` family of text-valued functions