base64 0.4.2 → 0.4.2.1
raw patch · 14 files changed
+268/−232 lines, 14 filesdep −memorydep ~basePVP ok
version bump matches the API change (PVP)
Dependencies removed: memory
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- README.md +5/−5
- base64.cabal +2/−3
- benchmarks/Base64Bench.hs +12/−32
- src/Data/ByteString/Base64.hs +5/−3
- src/Data/ByteString/Base64/Internal/Head.hs +5/−9
- src/Data/ByteString/Base64/Internal/Tail.hs +25/−91
- src/Data/ByteString/Base64/Internal/Utils.hs +22/−1
- src/Data/ByteString/Base64/Internal/W16/Loop.hs +75/−25
- src/Data/ByteString/Base64/Internal/W32/Loop.hs +1/−1
- src/Data/ByteString/Base64/Internal/W64/Loop.hs +1/−1
- src/Data/ByteString/Base64/URL.hs +12/−9
- test/Internal.hs +42/−18
- test/Main.hs +55/−34
CHANGELOG.md view
@@ -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))
README.md view
@@ -3,13 +3,13 @@ [](https://travis-ci.com/emilypi/base64) [](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.
base64.cabal view
@@ -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
benchmarks/Base64Bench.hs view
@@ -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
src/Data/ByteString/Base64.hs view
@@ -55,13 +55,15 @@ -- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4> -- 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
src/Data/ByteString/Base64/Internal/Head.hs view
@@ -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 $
src/Data/ByteString/Base64/Internal/Tail.hs view
@@ -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 #-}
src/Data/ByteString/Base64/Internal/Utils.hs view
@@ -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 --
src/Data/ByteString/Base64/Internal/W16/Loop.hs view
@@ -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
src/Data/ByteString/Base64/Internal/W32/Loop.hs view
@@ -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 #-}
src/Data/ByteString/Base64/Internal/W64/Loop.hs view
@@ -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
src/Data/ByteString/Base64/URL.hs view
@@ -64,15 +64,16 @@ -- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4> -- 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: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4> -- 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: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4> -- 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
test/Internal.hs view
@@ -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
test/Main.hs view
@@ -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