base32 0.2.0.0 → 0.2.1.0
raw patch · 11 files changed
+479/−519 lines, 11 filesdep ~basedep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, bytestring
API changes (from Hackage documentation)
+ Data.ByteString.Base32.Internal: decodeBase32_ :: Ptr Word8 -> ByteString -> IO (Either Text ByteString)
+ Data.ByteString.Base32.Internal: encodeBase32NoPad_ :: Addr# -> ByteString -> ByteString
+ Data.ByteString.Base32.Internal: encodeBase32_ :: Addr# -> ByteString -> ByteString
+ Data.ByteString.Base32.Internal: validateBase32 :: ByteString -> ByteString -> Bool
+ Data.ByteString.Base32.Internal: validateLastNPads :: Int -> ByteString -> IO (Either Text ByteString) -> Either Text ByteString
Files
- CHANGELOG.md +9/−0
- base32.cabal +3/−3
- src/Data/ByteString/Base32.hs +16/−20
- src/Data/ByteString/Base32/Hex.hs +16/−20
- src/Data/ByteString/Base32/Internal.hs +15/−10
- src/Data/ByteString/Base32/Internal/Head.hs +38/−38
- src/Data/ByteString/Base32/Internal/Loop.hs +15/−15
- src/Data/ByteString/Base32/Internal/Tables.hs +5/−6
- src/Data/ByteString/Base32/Internal/Utils.hs +14/−27
- test/Internal.hs +192/−217
- test/Main.hs +156/−163
CHANGELOG.md view
@@ -1,5 +1,14 @@ # Revision history for base32 +## 0.2.1.0++* Expose `Data.ByteString.Base32.Internal` API+* Use closed-form encoding/decoding length calculations, reducing branching and improving performance+* Update tests:+ * Migrate to using lower heap-footprint concrete dict passing+ * Support for 8.10.5 testing++ ## 0.2.0.0 * Bugfix: fix unpadded base32 encoding ([#4](https://github.com/emilypi/Base32/pull/4))
base32.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: base32-version: 0.2.0.0+version: 0.2.1.0 synopsis: Fast RFC 4648-compliant Base32 encoding description: RFC 4648-compliant Base32 encodings and decodings.@@ -20,7 +20,7 @@ README.md tested-with:- GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1+ GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.5 source-repository head type: git@@ -30,6 +30,7 @@ exposed-modules: Data.ByteString.Base32 Data.ByteString.Base32.Hex+ Data.ByteString.Base32.Internal Data.ByteString.Lazy.Base32 Data.ByteString.Lazy.Base32.Hex Data.ByteString.Short.Base32@@ -43,7 +44,6 @@ Data.Text.Short.Encoding.Base32.Hex other-modules:- Data.ByteString.Base32.Internal Data.ByteString.Base32.Internal.Head Data.ByteString.Base32.Internal.Loop Data.ByteString.Base32.Internal.Tables
src/Data/ByteString/Base32.hs view
@@ -17,14 +17,17 @@ -- internal and external validation for canonicity. -- module Data.ByteString.Base32-( encodeBase32+( -- * Encoding+ encodeBase32 , encodeBase32'-, decodeBase32 , encodeBase32Unpadded , encodeBase32Unpadded'+ -- * Decoding+, decodeBase32 , decodeBase32Unpadded , decodeBase32Padded -- , decodeBase32Lenient+ -- * Validation , isBase32 , isValidBase32 ) where@@ -33,7 +36,6 @@ import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..)) import Data.ByteString.Base32.Internal-import Data.ByteString.Base32.Internal.Head import Data.ByteString.Base32.Internal.Tables import Data.Either (isRight) import Data.Text (Text)@@ -89,16 +91,14 @@ decodeBase32 :: ByteString -> Either Text ByteString decodeBase32 bs@(PS _ _ !l) | l == 0 = Right bs- | r == 0 = unsafeDupablePerformIO $ decodeBase32_ dlen stdDecodeTable bs- | r == 2 = unsafeDupablePerformIO $ decodeBase32_ dlen stdDecodeTable (BS.append bs "======")- | r == 4 = validateLastNPads 2 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "====")- | r == 5 = validateLastNPads 3 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "===")- | r == 7 = validateLastNPads 5 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "=")+ | r == 0 = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable bs+ | r == 2 = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable (BS.append bs "======")+ | r == 4 = validateLastNPads 2 bs $ decodeBase32_ stdDecodeTable (BS.append bs "====")+ | r == 5 = validateLastNPads 3 bs $ decodeBase32_ stdDecodeTable (BS.append bs "===")+ | r == 7 = validateLastNPads 5 bs $ decodeBase32_ stdDecodeTable (BS.append bs "=") | otherwise = Left "Base32-encoded bytestring has invalid size" where !r = l `rem` 8- !q = l `quot` 8- !dlen = q * 5 {-# INLINE decodeBase32 #-} -- | Encode a 'ByteString' value as a Base32 'Text' value without padding.@@ -142,16 +142,14 @@ decodeBase32Unpadded :: ByteString -> Either Text ByteString decodeBase32Unpadded bs@(PS _ _ !l) | l == 0 = Right bs- | r == 0 = validateLastNPads 1 bs $ decodeBase32_ dlen stdDecodeTable bs- | r == 2 = unsafeDupablePerformIO $ decodeBase32_ dlen stdDecodeTable (BS.append bs "======")- | r == 4 = validateLastNPads 1 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "====")- | r == 5 = validateLastNPads 1 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "===")- | r == 7 = validateLastNPads 1 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "=")+ | r == 0 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable bs+ | r == 2 = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable (BS.append bs "======")+ | r == 4 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable (BS.append bs "====")+ | r == 5 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable (BS.append bs "===")+ | r == 7 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable (BS.append bs "=") | otherwise = Left "Base32-encoded bytestring has invalid size" where- !q = l `quot` 8 !r = l `rem` 8- !dlen = q * 5 {-# INLINE decodeBase32Unpadded #-} -- | Decode a padded Base32-encoded 'ByteString' value.@@ -173,11 +171,9 @@ | r == 3 = Left "Base32-encoded bytestring has invalid size" | r == 6 = Left "Base32-encoded bytestring has invalid size" | r /= 0 = Left "Base32-encoded bytestring requires padding"- | otherwise = unsafeDupablePerformIO $ decodeBase32_ dlen stdDecodeTable bs+ | otherwise = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable bs where- !q = l `quot` 8 !r = l `rem` 8- !dlen = q * 5 {-# INLINE decodeBase32Padded #-} -- -- | Leniently decode an unpadded Base32-encoded 'ByteString' value. This function
src/Data/ByteString/Base32/Hex.hs view
@@ -17,14 +17,17 @@ -- internal and external validation for canonicity. -- module Data.ByteString.Base32.Hex-( encodeBase32+( -- * Encoding+ encodeBase32 , encodeBase32'-, decodeBase32 , encodeBase32Unpadded , encodeBase32Unpadded'+ -- * Decoding+, decodeBase32 , decodeBase32Unpadded , decodeBase32Padded -- , decodeBase32Lenient+ -- * Validation , isBase32Hex , isValidBase32Hex ) where@@ -33,7 +36,6 @@ import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..)) import Data.ByteString.Base32.Internal-import Data.ByteString.Base32.Internal.Head import Data.ByteString.Base32.Internal.Tables import Data.Either (isRight) import Data.Text (Text)@@ -89,16 +91,14 @@ decodeBase32 :: ByteString -> Either Text ByteString decodeBase32 bs@(PS _ _ !l) | l == 0 = Right bs- | r == 0 = unsafeDupablePerformIO $ decodeBase32_ dlen hexDecodeTable bs- | r == 2 = unsafeDupablePerformIO $ decodeBase32_ dlen hexDecodeTable (BS.append bs "======")- | r == 4 = validateLastNPads 2 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "====")- | r == 5 = validateLastNPads 3 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "===")- | r == 7 = validateLastNPads 5 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "=")+ | r == 0 = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable bs+ | r == 2 = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable (BS.append bs "======")+ | r == 4 = validateLastNPads 2 bs $ decodeBase32_ hexDecodeTable (BS.append bs "====")+ | r == 5 = validateLastNPads 3 bs $ decodeBase32_ hexDecodeTable (BS.append bs "===")+ | r == 7 = validateLastNPads 5 bs $ decodeBase32_ hexDecodeTable (BS.append bs "=") | otherwise = Left "Base32-encoded bytestring has invalid size" where !r = l `rem` 8- !q = l `quot` 8- !dlen = q * 8 {-# INLINE decodeBase32 #-} -- | Encode a 'ByteString' value as a Base32hex 'Text' value without padding.@@ -142,16 +142,14 @@ decodeBase32Unpadded :: ByteString -> Either Text ByteString decodeBase32Unpadded bs@(PS _ _ !l) | l == 0 = Right bs- | r == 0 = validateLastNPads 1 bs $ decodeBase32_ dlen hexDecodeTable bs- | r == 2 = unsafeDupablePerformIO $ decodeBase32_ dlen hexDecodeTable (BS.append bs "======")- | r == 4 = validateLastNPads 1 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "====")- | r == 5 = validateLastNPads 1 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "===")- | r == 7 = validateLastNPads 1 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "=")+ | r == 0 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable bs+ | r == 2 = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable (BS.append bs "======")+ | r == 4 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable (BS.append bs "====")+ | r == 5 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable (BS.append bs "===")+ | r == 7 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable (BS.append bs "=") | otherwise = Left "Base32-encoded bytestring has invalid size" where- !q = l `quot` 8 !r = l `rem` 8- !dlen = q * 5 {-# INLINE decodeBase32Unpadded #-} -- | Decode a padded Base32hex-encoded 'ByteString' value.@@ -173,11 +171,9 @@ | r == 3 = Left "Base32-encoded bytestring has invalid size" | r == 6 = Left "Base32-encoded bytestring has invalid size" | r /= 0 = Left "Base32-encoded bytestring requires padding"- | otherwise = unsafeDupablePerformIO $ decodeBase32_ dlen hexDecodeTable bs+ | otherwise = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable bs where- !q = l `quot` 8 !r = l `rem` 8- !dlen = q * 5 {-# INLINE decodeBase32Padded #-} -- | Tell whether a 'ByteString' value is encoded in padded or unpadded Base32hex format
src/Data/ByteString/Base32/Internal.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -- |@@ -17,13 +16,17 @@ -- processes and tables. -- module Data.ByteString.Base32.Internal-( validateBase32+( encodeBase32_+, encodeBase32NoPad_+, decodeBase32_+, validateBase32 , validateLastNPads ) where import qualified Data.ByteString as BS import Data.ByteString.Internal+import Data.ByteString.Base32.Internal.Head import Data.Text (Text) import Foreign.ForeignPtr@@ -37,6 +40,8 @@ -- -------------------------------------------------------------------------- -- -- Validating Base32 +-- | Validate a base32-encoded bytestring against some alphabet.+-- validateBase32 :: ByteString -> ByteString -> Bool validateBase32 !alphabet bs@(PS _ _ l) | l == 0 = True@@ -76,16 +81,16 @@ -- This is necessary to check when decoding permissively (i.e. filling in padding chars). -- Consider the following 8 cases of a string of length l: ----- l = 0 mod 8: No pad chars are added, since the input is assumed to be good.--- l = 1 mod 8: Never an admissible length in base32--- l = 2 mod 8: 6 padding chars are added. If padding chars are present in the string, they will fail as to decode as final quanta--- l = 3 mod 8: Never an admissible length in base32--- l = 4 mod 8: 4 padding chars are added. If 2 padding chars are present in the string this can be "completed" in the sense that+-- - @l = 0 mod 8@: No pad chars are added, since the input is assumed to be good.+-- - @l = 1 mod 8@: Never an admissible length in base32+-- - @l = 2 mod 8@: 6 padding chars are added. If padding chars are present in the string, they will fail as to decode as final quanta+-- - @l = 3 mod 8@: Never an admissible length in base32+-- - @l = 4 mod 8@: 4 padding chars are added. If 2 padding chars are present in the string this can be "completed" in the sense that -- it now acts like a string `l == 2 mod 8` with 6 padding chars, and could potentially form corrupted data.--- l = 5 mod 8: 3 padding chars are added. If 3 padding chars are present in the string, this could form corrupted data like in the+-- - @l = 5 mod 8@: 3 padding chars are added. If 3 padding chars are present in the string, this could form corrupted data like in the -- previous case.--- l = 6 mod 8: Never an admissible length in base32--- l = 7 mod 8: 1 padding char is added. If 5 padding chars are present in the string, this could form corrupted data like the+-- - @l = 6 mod 8@: Never an admissible length in base32+-- - @l = 7 mod 8@: 1 padding char is added. If 5 padding chars are present in the string, this could form corrupted data like the -- previous cases. -- -- Hence, permissive decodes should only fill in padding chars when it makes sense to add them. That is,
src/Data/ByteString/Base32/Internal/Head.hs view
@@ -1,7 +1,6 @@+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-} module Data.ByteString.Base32.Internal.Head ( encodeBase32_ , encodeBase32NoPad_@@ -12,7 +11,6 @@ import Data.ByteString.Internal import Data.ByteString.Base32.Internal.Loop import Data.ByteString.Base32.Internal.Tail-import Data.ByteString.Base32.Internal.Utils import Data.Text (Text) import Foreign.Ptr@@ -25,52 +23,54 @@ import System.IO.Unsafe --- | Head of the base32 encoding loop - marshal data, assemble loops+-- | Head of the padded base32 encoding loop. --+-- This function takes an alphabet in the form of an unboxed 'Addr#',+-- allocates the correct number of bytes that will be written, and+-- executes the inner encoding loop against that data.+-- encodeBase32_ :: Addr# -> ByteString -> ByteString-encodeBase32_ !lut (PS !sfp !o !l) =- unsafeDupablePerformIO $ do- dfp <- mallocPlainForeignPtrBytes dlen- withForeignPtr dfp $ \dptr ->- withForeignPtr sfp $ \sptr -> do- let !end = plusPtr sptr (l + o)- innerLoop- lut- (castPtr dptr)- (plusPtr sptr o)- end- (loopTail lut dfp dptr end)+encodeBase32_ !lut (PS !sfp !o !l) = unsafeDupablePerformIO $ do+ dfp <- mallocPlainForeignPtrBytes dlen+ withForeignPtr dfp $ \dptr ->+ withForeignPtr sfp $ \sptr -> do+ let !end = plusPtr sptr (l + o)+ innerLoop lut+ (castPtr dptr) (plusPtr sptr o)+ end (loopTail lut dfp dptr end) where- !q = (l * 8) `quot` 5- !r = (l * 8) `rem` 5- !dlen = padCeilN 8 (q + if r == 0 then 0 else 1)+ !dlen = ceiling (fromIntegral @_ @Double l / 5) * 8 --- | Head of the unpadded base32 encoding loop - marshal data, assemble loops+-- | Head of the unpadded base32 encoding loop. --+-- This function takes an alphabet in the form of an unboxed 'Addr#',+-- allocates the correct number of bytes that will be written, and+-- executes the inner encoding loop against that data.+-- encodeBase32NoPad_ :: Addr# -> ByteString -> ByteString-encodeBase32NoPad_ !lut (PS !sfp !o !l) =- unsafeDupablePerformIO $ do- !dfp <- mallocPlainForeignPtrBytes dlen- withForeignPtr dfp $ \dptr ->- withForeignPtr sfp $ \sptr -> do- let !end = plusPtr sptr (l + o)- innerLoop lut- (castPtr dptr)- (plusPtr sptr o)- end- (loopTailNoPad lut dfp dptr end)+encodeBase32NoPad_ !lut (PS !sfp !o !l) = unsafeDupablePerformIO $ do+ !dfp <- mallocPlainForeignPtrBytes dlen+ withForeignPtr dfp $ \dptr ->+ withForeignPtr sfp $ \sptr -> do+ let !end = plusPtr sptr (l + o)+ innerLoop lut+ (castPtr dptr) (plusPtr sptr o)+ end (loopTailNoPad lut dfp dptr end) where- !q = (l * 8) `quot` 5- !r = (l * 8) `rem` 5- !dlen = padCeilN 8 (q + if r == 0 then 0 else 1)+ !dlen = ceiling (fromIntegral @_ @Double l / 5) * 8 --- | Head of the base32 decoding loop - marshal data, assemble loops+-- | Head of the base32 decoding loop. ---decodeBase32_ :: Int -> ForeignPtr Word8 -> ByteString -> IO (Either Text ByteString)-decodeBase32_ !dlen !dtfp (PS !sfp !soff !slen) =- withForeignPtr dtfp $ \(Ptr dtable) ->+-- This function takes a base32-decoding lookup table and base32-encoded+-- bytestring, allocates the correct number of bytes that will be written,+-- and executes the inner decoding loop against that data.+--+decodeBase32_ :: Ptr Word8 -> ByteString -> IO (Either Text ByteString)+decodeBase32_ (Ptr !dtable) (PS !sfp !soff !slen) = withForeignPtr sfp $ \sptr -> do dfp <- mallocPlainForeignPtrBytes dlen withForeignPtr dfp $ \dptr -> do let !end = plusPtr sptr (soff + slen) decodeLoop dtable dfp dptr (plusPtr sptr soff) end+ where+ !dlen = ceiling (fromIntegral @_ @Double slen / 1.6)
src/Data/ByteString/Base32/Internal/Loop.hs view
@@ -49,17 +49,17 @@ !d = lix (unsafeShiftR t 12) !e = lix (unsafeShiftR t 7) !f = lix (unsafeShiftR t 2)- !g = lix ((unsafeShiftL t 3) .|. (unsafeShiftR u 5))+ !g = lix (unsafeShiftL t 3 .|. unsafeShiftR u 5) !h = lix u let !w = a- .|. (unsafeShiftL b 8)- .|. (unsafeShiftL c 16)- .|. (unsafeShiftL d 24)- .|. (unsafeShiftL e 32)- .|. (unsafeShiftL f 40)- .|. (unsafeShiftL g 48)- .|. (unsafeShiftL h 56)+ .|. unsafeShiftL b 8+ .|. unsafeShiftL c 16+ .|. unsafeShiftL d 24+ .|. unsafeShiftL e 32+ .|. unsafeShiftL f 40+ .|. unsafeShiftL g 48+ .|. unsafeShiftL h 56 poke dst w go (plusPtr dst 8) (plusPtr src 5)@@ -194,13 +194,13 @@ | h == 0xff = err (plusPtr src 7) | otherwise = do - let !w = ((unsafeShiftL a 35)- .|. (unsafeShiftL b 30)- .|. (unsafeShiftL c 25)- .|. (unsafeShiftL d 20)- .|. (unsafeShiftL e 15)- .|. (unsafeShiftL f 10)- .|. (unsafeShiftL g 5)+ let !w = (unsafeShiftL a 35+ .|. unsafeShiftL b 30+ .|. unsafeShiftL c 25+ .|. unsafeShiftL d 20+ .|. unsafeShiftL e 15+ .|. unsafeShiftL f 10+ .|. unsafeShiftL g 5 .|. h) :: Word64 poke @Word32 (castPtr dst) (byteSwap32 (fromIntegral (unsafeShiftR w 8)))
src/Data/ByteString/Base32/Internal/Tables.hs view
@@ -8,13 +8,12 @@ import Data.ByteString.Base32.Internal.Utils -import Foreign.ForeignPtr- import GHC.Word+import GHC.Ptr (Ptr) -stdDecodeTable :: ForeignPtr Word8-stdDecodeTable = writeNPlainForeignPtrBytes @Word8 256+stdDecodeTable :: Ptr Word8+stdDecodeTable = writeNPlainPtrBytes @Word8 256 [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff@@ -34,8 +33,8 @@ ] {-# NOINLINE stdDecodeTable #-} -hexDecodeTable :: ForeignPtr Word8-hexDecodeTable = writeNPlainForeignPtrBytes @Word8 256+hexDecodeTable :: Ptr Word8+hexDecodeTable = writeNPlainPtrBytes @Word8 256 [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff
src/Data/ByteString/Base32/Internal/Utils.hs view
@@ -2,31 +2,28 @@ {-# LANGUAGE MagicHash #-} module Data.ByteString.Base32.Internal.Utils ( aix-, padCeilN , peekWord32BE , peekWord64BE , reChunkN , w32 , w64 , w64_32-, writeNPlainForeignPtrBytes+, writeNPlainPtrBytes ) where -import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Foreign.Ptr-import Foreign.ForeignPtr import Foreign.Storable import GHC.ByteOrder import GHC.Exts-import GHC.ForeignPtr import GHC.Word import System.IO.Unsafe+import Foreign.Marshal.Alloc (mallocBytes) -- | Read 'Word8' index off alphabet addr@@ -47,42 +44,32 @@ w64 = fromIntegral {-# INLINE w64 #-} -padCeilN :: Int -> Int -> Int-padCeilN !n !x- | r == 0 = x- | otherwise = (x - r) + n- where- r = x .&. (n - 1)-{-# INLINE padCeilN #-}- -- | Allocate and fill @n@ bytes with some data ---writeNPlainForeignPtrBytes- :: ( Storable a- , Storable b- )- => Int- -> [a]- -> ForeignPtr b-writeNPlainForeignPtrBytes !n as = unsafeDupablePerformIO $ do- fp <- mallocPlainForeignPtrBytes n- withForeignPtr fp $ \p -> go p as- return (castForeignPtr fp)+writeNPlainPtrBytes+ :: Storable a+ => Int+ -> [a]+ -> Ptr a+writeNPlainPtrBytes !n as = unsafeDupablePerformIO $ do+ p <- mallocBytes n+ go p as+ return p where go !_ [] = return () go !p (x:xs) = poke p x >> go (plusPtr p 1) xs-{-# INLINE writeNPlainForeignPtrBytes #-}+{-# INLINE writeNPlainPtrBytes #-} peekWord32BE :: Ptr Word32 -> IO Word32 peekWord32BE p = case targetByteOrder of LittleEndian -> byteSwap32 <$> peek p- BigEndian -> peek p+ BigEndian -> peek p {-# inline peekWord32BE #-} peekWord64BE :: Ptr Word64 -> IO Word64 peekWord64BE p = case targetByteOrder of LittleEndian -> byteSwap64 <$> peek p- BigEndian -> peek p+ BigEndian -> peek p {-# inline peekWord64BE #-} -- | Rechunk a list of bytestrings in multiples of @n@
test/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-}@@ -17,250 +18,224 @@ -- -- This module contains internal test harnesses for `base32` ---module Internal where+module Internal+( Harness(..)+, TextHarness(..)+, b32+, lb32+, sb32+, t32+, tl32+, ts32+, tt32+, ttl32+, tts32+) where +import Test.QuickCheck hiding (label)+import Data.Text import qualified Data.ByteString as BS-import "base32" Data.ByteString.Base32 as B32-import "base32" Data.ByteString.Base32.Hex as B32H+import qualified Data.ByteString.Base32 as B32+import qualified Data.ByteString.Base32.Hex as B32H import qualified Data.ByteString.Lazy as LBS-import "base32" Data.ByteString.Lazy.Base32 as BL32-import "base32" Data.ByteString.Lazy.Base32.Hex as BL32H+import qualified Data.ByteString.Lazy.Base32 as BL32+import qualified Data.ByteString.Lazy.Base32.Hex as BL32H import qualified Data.ByteString.Short as SBS-import "base32" Data.ByteString.Short.Base32 as BS32-import "base32" Data.ByteString.Short.Base32.Hex as BS32H-import Data.Proxy-import Data.String-import Data.Text (Text)+import qualified Data.ByteString.Short.Base32 as BS32+import qualified Data.ByteString.Short.Base32.Hex as BS32H import qualified Data.Text as T-import "base32" Data.Text.Encoding.Base32 as T32-import "base32" Data.Text.Encoding.Base32.Error (Base32Error)-import "base32" Data.Text.Encoding.Base32.Hex as T32H+import qualified Data.Text.Encoding.Base32 as T32+import qualified Data.Text.Encoding.Base32.Hex as T32H+import Data.Text.Encoding.Base32.Error import qualified Data.Text.Lazy as TL-import "base32" Data.Text.Lazy.Encoding.Base32 as TL32-import "base32" Data.Text.Lazy.Encoding.Base32.Hex as TL32H+import qualified Data.Text.Lazy.Encoding.Base32 as TL32+import qualified Data.Text.Lazy.Encoding.Base32.Hex as TL32H import qualified Data.Text.Short as TS-import "base32" Data.Text.Short.Encoding.Base32 as TS32-import "base32" Data.Text.Short.Encoding.Base32.Hex as TS32H--import Test.QuickCheck hiding (label)+import qualified Data.Text.Short.Encoding.Base32 as TS32+import qualified Data.Text.Short.Encoding.Base32.Hex as TS32H -- ------------------------------------------------------------------ -- -- Test Harnesses -data Impl- = B32- | BL32- | BS32- | T32- | TL32- | TS32 -b32 :: Proxy 'B32-b32 = Proxy -bl32 :: Proxy 'BL32-bl32 = Proxy--bs32 :: Proxy 'BS32-bs32 = Proxy--t32 :: Proxy 'T32-t32 = Proxy--tl32 :: Proxy 'TL32-tl32 = Proxy--ts32 :: Proxy 'TS32-ts32 = Proxy- -- | This class provides the generic API definition for -- the base32 std alphabet ---class- ( Eq bs- , Show bs- , Arbitrary bs- , CoArbitrary bs- , IsString bs- ) => Harness (a :: Impl) bs | a -> bs, bs -> a- where-- label :: String-- encode :: bs -> bs- encodeNopad :: bs -> bs- encodeHex :: bs -> bs- encodeHexNopad :: bs -> bs-- decode :: bs -> Either Text bs- decodeHex :: bs -> Either Text bs- decodePad :: bs -> Either Text bs- decodeHexPad :: bs -> Either Text bs- decodeNopad :: bs -> Either Text bs- decodeHexNopad :: bs -> Either Text bs-- correct :: bs -> Bool- correctHex :: bs -> Bool-- validate :: bs -> Bool- validateHex :: bs -> Bool---instance Harness 'B32 BS.ByteString where- label = "ByteString"-- encode = B32.encodeBase32'- encodeNopad = B32.encodeBase32Unpadded'-- decode = B32.decodeBase32- decodePad = B32.decodeBase32Padded- decodeNopad = B32.decodeBase32Unpadded- correct = B32.isBase32- validate = B32.isValidBase32-- encodeHex = B32H.encodeBase32'- encodeHexNopad = B32H.encodeBase32Unpadded'- decodeHex = B32H.decodeBase32- decodeHexPad = B32H.decodeBase32Padded- decodeHexNopad = B32H.decodeBase32Unpadded- correctHex = B32H.isBase32Hex- validateHex = B32H.isValidBase32Hex--instance Harness 'BL32 LBS.ByteString where- label = "Lazy ByteString"-- encode = BL32.encodeBase32'- encodeNopad = BL32.encodeBase32Unpadded'-- decode = BL32.decodeBase32- decodePad = BL32.decodeBase32Padded- decodeNopad = BL32.decodeBase32Unpadded- correct = BL32.isBase32- validate = BL32.isValidBase32-- encodeHex = BL32H.encodeBase32'- encodeHexNopad = BL32H.encodeBase32Unpadded'- decodeHex = BL32H.decodeBase32- decodeHexPad = BL32H.decodeBase32Padded- decodeHexNopad = BL32H.decodeBase32Unpadded- correctHex = BL32H.isBase32Hex- validateHex = BL32H.isValidBase32Hex--instance Harness 'BS32 SBS.ShortByteString where- label = "Short ByteString"-- encode = BS32.encodeBase32'- encodeNopad = BS32.encodeBase32Unpadded'-- decode = BS32.decodeBase32- decodePad = BS32.decodeBase32Padded- decodeNopad = BS32.decodeBase32Unpadded- correct = BS32.isBase32- validate = BS32.isValidBase32-- encodeHex = BS32H.encodeBase32'- encodeHexNopad = BS32H.encodeBase32Unpadded'- decodeHex = BS32H.decodeBase32- decodeHexPad = BS32H.decodeBase32Padded- decodeHexNopad = BS32H.decodeBase32Unpadded- correctHex = BS32H.isBase32Hex- validateHex = BS32H.isValidBase32Hex--instance Harness 'T32 T.Text where- label = "Text"-- encode = T32.encodeBase32- encodeNopad = T32.encodeBase32Unpadded- decode = T32.decodeBase32- decodeNopad = T32.decodeBase32Unpadded- decodePad = T32.decodeBase32Padded- correct = T32.isBase32-- encodeHex = T32H.encodeBase32- encodeHexNopad = T32H.encodeBase32Unpadded- decodeHex = T32H.decodeBase32- decodeHexPad = T32H.decodeBase32Padded- decodeHexNopad = T32H.decodeBase32Unpadded-- correctHex = T32H.isBase32Hex- validateHex = T32H.isValidBase32Hex- validate = T32.isValidBase32--instance Harness 'TL32 TL.Text where- label = "Lazy Text"-- encode = TL32.encodeBase32- encodeNopad = TL32.encodeBase32Unpadded- decode = TL32.decodeBase32- decodeNopad = TL32.decodeBase32Unpadded- decodePad = TL32.decodeBase32Padded- correct = TL32.isBase32+data Harness bs = Harness+ { label :: String+ , encode :: bs -> bs+ , encodeNopad :: bs -> bs+ , encodeHex :: bs -> bs+ , encodeHexNopad :: bs -> bs+ , decode :: bs -> Either Text bs+ , decodeHex :: bs -> Either Text bs+ , decodePad :: bs -> Either Text bs+ , decodeHexPad :: bs -> Either Text bs+ , decodeNopad :: bs -> Either Text bs+ , decodeHexNopad :: bs -> Either Text bs+ , correct :: bs -> Bool+ , correctHex :: bs -> Bool+ , validate :: bs -> Bool+ , validateHex :: bs -> Bool+ } - encodeHex = TL32H.encodeBase32- encodeHexNopad = TL32H.encodeBase32Unpadded- decodeHex = TL32H.decodeBase32- decodeHexPad = TL32H.decodeBase32Padded- decodeHexNopad = TL32H.decodeBase32Unpadded+b32 :: Harness BS.ByteString+b32 = Harness+ { label = "ByteString"+ , encode = B32.encodeBase32'+ , encodeNopad = B32.encodeBase32Unpadded'+ , decode = B32.decodeBase32+ , decodePad = B32.decodeBase32Padded+ , decodeNopad = B32.decodeBase32Unpadded+ , correct = B32.isBase32+ , validate = B32.isValidBase32+ , encodeHex = B32H.encodeBase32'+ , encodeHexNopad = B32H.encodeBase32Unpadded'+ , decodeHex = B32H.decodeBase32+ , decodeHexPad = B32H.decodeBase32Padded+ , decodeHexNopad = B32H.decodeBase32Unpadded+ , correctHex = B32H.isBase32Hex+ , validateHex = B32H.isValidBase32Hex+ } - correctHex = TL32H.isBase32Hex- validateHex = TL32H.isValidBase32Hex- validate = TL32.isValidBase32+lb32 :: Harness LBS.ByteString+lb32 = Harness+ { label = "Lazy ByteString"+ , encode = BL32.encodeBase32'+ , encodeNopad = BL32.encodeBase32Unpadded'+ , decode = BL32.decodeBase32+ , decodePad = BL32.decodeBase32Padded+ , decodeNopad = BL32.decodeBase32Unpadded+ , correct = BL32.isBase32+ , validate = BL32.isValidBase32+ , encodeHex = BL32H.encodeBase32'+ , encodeHexNopad = BL32H.encodeBase32Unpadded'+ , decodeHex = BL32H.decodeBase32+ , decodeHexPad = BL32H.decodeBase32Padded+ , decodeHexNopad = BL32H.decodeBase32Unpadded+ , correctHex = BL32H.isBase32Hex+ , validateHex = BL32H.isValidBase32Hex+ } -instance Harness 'TS32 TS.ShortText where- label = "Short Text"+sb32 :: Harness SBS.ShortByteString+sb32 = Harness+ { label = "Short ByteString"+ , encode = BS32.encodeBase32'+ , encodeNopad = BS32.encodeBase32Unpadded'+ , decode = BS32.decodeBase32+ , decodePad = BS32.decodeBase32Padded+ , decodeNopad = BS32.decodeBase32Unpadded+ , correct = BS32.isBase32+ , validate = BS32.isValidBase32+ , encodeHex = BS32H.encodeBase32'+ , encodeHexNopad = BS32H.encodeBase32Unpadded'+ , decodeHex = BS32H.decodeBase32+ , decodeHexPad = BS32H.decodeBase32Padded+ , decodeHexNopad = BS32H.decodeBase32Unpadded+ , correctHex = BS32H.isBase32Hex+ , validateHex = BS32H.isValidBase32Hex+ } - encode = TS32.encodeBase32- encodeNopad = TS32.encodeBase32Unpadded- decode = TS32.decodeBase32- decodeNopad = TS32.decodeBase32Unpadded- decodePad = TS32.decodeBase32Padded- correct = TS32.isBase32+t32 :: Harness T.Text+t32 = Harness+ { label = "Text"+ , encode = T32.encodeBase32+ , encodeNopad = T32.encodeBase32Unpadded+ , decode = T32.decodeBase32+ , decodePad = T32.decodeBase32Padded+ , decodeNopad = T32.decodeBase32Unpadded+ , correct = T32.isBase32+ , validate = T32.isValidBase32+ , encodeHex = T32H.encodeBase32+ , encodeHexNopad = T32H.encodeBase32Unpadded+ , decodeHex = T32H.decodeBase32+ , decodeHexPad = T32H.decodeBase32Padded+ , decodeHexNopad = T32H.decodeBase32Unpadded+ , correctHex = T32H.isBase32Hex+ , validateHex = T32H.isValidBase32Hex+ } - encodeHex = TS32H.encodeBase32- encodeHexNopad = TS32H.encodeBase32Unpadded- decodeHex = TS32H.decodeBase32- decodeHexPad = TS32H.decodeBase32Padded- decodeHexNopad = TS32H.decodeBase32Unpadded+tl32 :: Harness TL.Text+tl32 = Harness+ { label = "Lazy Text"+ , encode = TL32.encodeBase32+ , encodeNopad = TL32.encodeBase32Unpadded+ , decode = TL32.decodeBase32+ , decodePad = TL32.decodeBase32Padded+ , decodeNopad = TL32.decodeBase32Unpadded+ , correct = TL32.isBase32+ , validate = TL32.isValidBase32+ , encodeHex = TL32H.encodeBase32+ , encodeHexNopad = TL32H.encodeBase32Unpadded+ , decodeHex = TL32H.decodeBase32+ , decodeHexPad = TL32H.decodeBase32Padded+ , decodeHexNopad = TL32H.decodeBase32Unpadded+ , correctHex = TL32H.isBase32Hex+ , validateHex = TL32H.isValidBase32Hex+ } - correctHex = TS32H.isBase32Hex- validateHex = TS32H.isValidBase32Hex- validate = TS32.isValidBase32+ts32 :: Harness TS.ShortText+ts32 = Harness+ { label = "Short Lazy Text"+ , encode = TS32.encodeBase32+ , encodeNopad = TS32.encodeBase32Unpadded+ , decode = TS32.decodeBase32+ , decodePad = TS32.decodeBase32Padded+ , decodeNopad = TS32.decodeBase32Unpadded+ , correct = TS32.isBase32+ , validate = TS32.isValidBase32+ , encodeHex = TS32H.encodeBase32+ , encodeHexNopad = TS32H.encodeBase32Unpadded+ , decodeHex = TS32H.decodeBase32+ , decodeHexPad = TS32H.decodeBase32Padded+ , decodeHexNopad = TS32H.decodeBase32Unpadded+ , correctHex = TS32H.isBase32Hex+ , validateHex = TS32H.isValidBase32Hex+ } -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 (Base32Error err) cs- decodePaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs- decodeUnpaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs- decodeHexWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs- decodeHexPaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs- decodeHexUnpaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs+-- -------------------------------------------------------------------- --+-- Text-specific harness +data TextHarness bs cs = TextHarness+ { decodeWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs+ , decodePaddedWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs+ , decodeUnpaddedWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs+ , decodeHexWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs+ , decodeHexPaddedWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs+ , decodeHexUnpaddedWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs+ } -instance TextHarness 'T32 Text BS.ByteString where- decodeWith_ = T32.decodeBase32With- decodePaddedWith_ = T32.decodeBase32PaddedWith- decodeUnpaddedWith_ = T32.decodeBase32UnpaddedWith- decodeHexWith_ = T32H.decodeBase32With- decodeHexPaddedWith_ = T32H.decodeBase32PaddedWith- decodeHexUnpaddedWith_ = T32H.decodeBase32UnpaddedWith+tt32 :: TextHarness BS.ByteString Text+tt32 = TextHarness+ { decodeWith_ = T32.decodeBase32With+ , decodePaddedWith_ = T32.decodeBase32PaddedWith+ , decodeUnpaddedWith_ = T32.decodeBase32UnpaddedWith+ , decodeHexWith_ = T32H.decodeBase32With+ , decodeHexPaddedWith_ = T32H.decodeBase32PaddedWith+ , decodeHexUnpaddedWith_ = T32H.decodeBase32UnpaddedWith+ } -instance TextHarness 'TL32 TL.Text LBS.ByteString where- decodeWith_ = TL32.decodeBase32With- decodePaddedWith_ = TL32.decodeBase32PaddedWith- decodeUnpaddedWith_ = TL32.decodeBase32UnpaddedWith- decodeHexWith_ = TL32H.decodeBase32With- decodeHexPaddedWith_ = TL32H.decodeBase32PaddedWith- decodeHexUnpaddedWith_ = TL32H.decodeBase32UnpaddedWith+ttl32 :: TextHarness LBS.ByteString TL.Text+ttl32 = TextHarness+ { decodeWith_ = TL32.decodeBase32With+ , decodePaddedWith_ = TL32.decodeBase32PaddedWith+ , decodeUnpaddedWith_ = TL32.decodeBase32UnpaddedWith+ , decodeHexWith_ = TL32H.decodeBase32With+ , decodeHexPaddedWith_ = TL32H.decodeBase32PaddedWith+ , decodeHexUnpaddedWith_ = TL32H.decodeBase32UnpaddedWith+ } -instance TextHarness 'TS32 TS.ShortText SBS.ShortByteString where- decodeWith_ = TS32.decodeBase32With- decodePaddedWith_ = TS32.decodeBase32PaddedWith- decodeUnpaddedWith_ = TS32.decodeBase32UnpaddedWith- decodeHexWith_ = TS32H.decodeBase32With- decodeHexPaddedWith_ = TS32H.decodeBase32PaddedWith- decodeHexUnpaddedWith_ = TS32H.decodeBase32UnpaddedWith+tts32 :: TextHarness SBS.ShortByteString TS.ShortText+tts32 = TextHarness+ { decodeWith_ = TS32.decodeBase32With+ , decodePaddedWith_ = TS32.decodeBase32PaddedWith+ , decodeUnpaddedWith_ = TS32.decodeBase32UnpaddedWith+ , decodeHexWith_ = TS32H.decodeBase32With+ , decodeHexPaddedWith_ = TS32H.decodeBase32PaddedWith+ , decodeHexUnpaddedWith_ = TS32H.decodeBase32UnpaddedWith+ } -- ------------------------------------------------------------------ -- -- Quickcheck instances@@ -302,7 +277,7 @@ instance Arbitrary TS.ShortText where arbitrary = TS.fromText <$> arbitrary- shrink xs = fmap TS.fromText $ shrink (TS.toText xs)+ shrink xs = TS.fromText <$> shrink (TS.toText xs) instance CoArbitrary TS.ShortText where coarbitrary = coarbitrary . TS.toText
test/Main.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RecordWildCards #-} -- | -- Module : Main -- Copyright : (c) 2019-2020 Emily Pillmore@@ -20,8 +22,6 @@ ) where -import Prelude hiding (length)- import Data.Bifunctor (second) import qualified "memory" Data.ByteArray.Encoding as Mem import qualified Data.ByteString as BS@@ -30,6 +30,7 @@ import "base32" Data.ByteString.Base32.Hex as B32H import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short as SBS+import Data.String (IsString) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Text.Encoding.Base32.Error (Base32Error(..))@@ -44,7 +45,9 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck hiding (label) + main :: IO () main = defaultMain tests @@ -55,60 +58,60 @@ [ mkPropTree , mkUnitTree ]- , mkTree bl32+ , mkTree lb32 [ mkPropTree , mkUnitTree ]- , mkTree bs32+ , mkTree sb32 [ mkPropTree , mkUnitTree ] , mkTree t32 [ mkPropTree , mkUnitTree- , mkDecodeTree T.decodeUtf8' b32+ , mkDecodeTree T.decodeUtf8' tt32 b32 ] , mkTree tl32 [ mkPropTree , mkUnitTree- , mkDecodeTree TL.decodeUtf8' bl32+ , mkDecodeTree TL.decodeUtf8' ttl32 lb32 ] , mkTree ts32 [ mkPropTree , mkUnitTree , mkDecodeTree- (second TS.fromText . T.decodeUtf8' . SBS.fromShort) bs32+ (second TS.fromText . T.decodeUtf8' . SBS.fromShort) tts32 sb32 ] ] -- ---------------------------------------------------------------- -- -- Test tree generation +type C a = (Arbitrary a, IsString a, Eq a, Show a)+ -- | Make a test tree for a given label -- mkTree- :: forall a b proxy- . Harness a b- => proxy a- -> [proxy a -> TestTree]+ :: C a+ => Harness a+ -> [Harness a -> TestTree] -> TestTree-mkTree a = testGroup (label @a) . fmap ($ a)+mkTree a = testGroup (label a) . fmap ($ a) -- | Make a test group with some name, lifting a test tree up to the correct -- type information via some Harness -- mkTests- :: forall a b proxy- . Harness a b+ :: C a => String- -> [proxy a -> TestTree]- -> proxy a+ -> [Harness a -> TestTree]+ -> Harness a -> TestTree mkTests context ts = testGroup context . (<*>) ts . pure -- | Make property tests for a given harness instance ---mkPropTree :: forall a b proxy. Harness a b => proxy a -> TestTree+mkPropTree :: C a => Harness a -> TestTree mkPropTree = mkTests "Property Tests" [ prop_roundtrip , prop_correctness@@ -118,11 +121,7 @@ -- | Make unit tests for a given harness instance ---mkUnitTree- :: forall a b proxy- . Harness a b- => proxy a- -> TestTree+mkUnitTree :: C a => Harness a -> TestTree mkUnitTree = mkTests "Unit tests" [ rfcVectors , offsetVectors@@ -132,24 +131,21 @@ -- | Make unit tests for textual 'decode*With' functions -- mkDecodeTree- :: forall t a b c e proxy- . ( TextHarness a b c- , Harness t c- , Show e- )- => (c -> Either e b)- -> proxy t- -> proxy a+ :: (C s, C t, Show e)+ => (s -> Either e t)+ -> TextHarness s t+ -> Harness s+ -> Harness t -> TestTree-mkDecodeTree utf8 t = mkTests "Decoding tests"- [ decodeWithVectors utf8 t+mkDecodeTree utf8 s t = mkTests "Decoding tests"+ [ decodeWithVectors utf8 s t ] -- ---------------------------------------------------------------- -- -- Property tests -prop_roundtrip :: forall a b proxy. Harness a b => proxy a -> TestTree-prop_roundtrip _ = testGroup "prop_roundtrip"+prop_roundtrip :: C a => Harness a -> TestTree+prop_roundtrip Harness{..} = testGroup "prop_roundtrip" [ testProperty "prop_std_roundtrip" $ \(bs :: b) -> Right (encode bs) == decode (encode (encode bs)) , testProperty "prop_hex_roundtrip" $ \(bs :: b) ->@@ -159,8 +155,8 @@ == decodeHexNopad (encodeHexNopad (encodeHexNopad bs)) ] -prop_correctness :: forall a b proxy. Harness a b => proxy a -> TestTree-prop_correctness _ = testGroup "prop_validity"+prop_correctness :: C a => Harness a -> TestTree+prop_correctness Harness{..} = testGroup "prop_validity" [ testProperty "prop_std_valid" $ \(bs :: b) -> validate (encode bs) , testProperty "prop_hex_valid" $ \(bs :: b) ->@@ -171,8 +167,8 @@ correctHex (encodeHex bs) ] -prop_padding_invariants :: forall a b proxy. Harness a b => proxy a -> TestTree-prop_padding_invariants _ = testGroup "prop_padding_invariants"+prop_padding_invariants :: C a => Harness a -> TestTree+prop_padding_invariants Harness{..} = testGroup "prop_padding_invariants" [ testProperty "prop_hex_nopad_roundtrip" $ \(bs :: b) -> Right (encodeHexNopad bs) == decodeHexNopad (encodeHexNopad (encodeHexNopad bs))@@ -219,8 +215,8 @@ -- | RFC 4328 test vectors ---rfcVectors :: forall a b proxy. Harness a b => proxy a -> TestTree-rfcVectors _ = testGroup "RFC 4648 Test Vectors"+rfcVectors :: C a => Harness a -> TestTree+rfcVectors Harness{..} = testGroup "RFC 4648 Test Vectors" [ testGroup "std alphabet" [ testCaseStd "" "" , testCaseStd "f" "MY======"@@ -244,7 +240,7 @@ testCaseStd s t = testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do step "encode is sound"- t @=? encode @a s+ t @=? encode s step "decode is sound" Right s @=? decode (encode s)@@ -252,7 +248,7 @@ testCaseHex s t = testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do step "encode is sound"- t @=? encodeHex @a s+ t @=? encodeHex s step "decode is sound" Right s @=? decodeHexPad t@@ -260,206 +256,203 @@ -- | Unit test trees for the `decode*With` family of text-valued functions -- decodeWithVectors- :: forall t a b c e proxy- . ( TextHarness a c b- , Harness t b- , Show e- )- => (b -> Either e c)+ :: (C s, C t, Show e)+ => (s -> Either e t) -- ^ utf8- -> proxy t+ -> TextHarness s t+ -> Harness s -- ^ witness to the bytestring-ey dictionaries- -> proxy a+ -> Harness t -- ^ witness to the text dictionaries -> TestTree-decodeWithVectors utf8 _ _ = testGroup "DecodeWith* unit tests"+decodeWithVectors utf8 TextHarness{..} s t = testGroup "DecodeWith* unit tests" [ testGroup "decodeWith negative tests" [ testCase "decodeWith non-utf8 inputs on decodeUtf8" $ do- case decodeWith_ @a utf8 "\1079743" of+ case decodeWith_ utf8 "\1079743" of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeWith valid utf8 inputs on decodeUtf8" $ do- case decodeWith_ @a utf8 (encode @t "\1079743") of+ case decodeWith_ utf8 (encode s "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeHexWith non-utf8 inputs on decodeUtf8" $ do- case decodeHexWith_ @a utf8 "\1079743" of+ case decodeHexWith_ utf8 "\1079743" of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodePaddedWith non-utf8 inputs on decodeUtf8" $ do- case decodePaddedWith_ @a utf8 "\1079743" of+ case decodePaddedWith_ utf8 "\1079743" of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodePaddedWith valid utf8 inputs on decodeUtf8" $ do- case decodePaddedWith_ @a utf8 (encode @t "\1079743") of+ case decodePaddedWith_ utf8 (encode s "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeUnpaddedWith non-utf8 inputs on decodeUtf8" $ do- case decodeUnpaddedWith_ @a utf8 "\1079743" of+ case decodeUnpaddedWith_ utf8 "\1079743" of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeUnpaddedWith valid utf8 inputs on decodeUtf8" $ do- case decodeUnpaddedWith_ @a utf8 (encodeNopad @t "\1079743") of+ case decodeUnpaddedWith_ utf8 (encodeNopad s "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeHexWith valid utf8 inputs on decodeUtf8" $ do- case decodeHexWith_ @a utf8 (encodeHex @t "\1079743") of+ case decodeHexWith_ utf8 (encodeHex s "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeHexPaddedWith non-utf8 inputs on decodeUtf8" $ do- case decodeHexPaddedWith_ @a utf8 "\1079743" of+ case decodeHexPaddedWith_ utf8 "\1079743" of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeHexPaddedWith valid utf8 inputs on decodeUtf8" $ do- case decodeHexPaddedWith_ @a utf8 (encodeHex @t "\1079743") of+ case decodeHexPaddedWith_ utf8 (encodeHex s "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeHexUnpaddedWith non-utf8 inputs on decodeUtf8" $ do- case decodeHexUnpaddedWith_ @a utf8 "\1079743" of+ case decodeHexUnpaddedWith_ utf8 "\1079743" of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeHexUnpaddedWith valid utf8 inputs on decodeUtf8" $ do- case decodeHexUnpaddedWith_ @a utf8 (encodeHexNopad @t "\1079743") of+ case decodeHexUnpaddedWith_ utf8 (encodeHexNopad s "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" ] , testGroup "decodeWith positive tests" [ testCase "decodeWith utf8 inputs on decodeUtf8" $ do- a <- either (assertFailure . show) pure $ decode @a "MZXW6YTBOI======"- b <- either (assertFailure . show) pure $ decodeWith_ @a utf8 "MZXW6YTBOI======"+ a <- either (assertFailure . show) pure $ decode t "MZXW6YTBOI======"+ b <- either (assertFailure . show) pure $ decodeWith_ utf8 "MZXW6YTBOI======" a @=? b , testCase "decodePaddedWith utf8 inputs on decodeUtf8" $ do- a <- either (assertFailure . show) pure $ decodePad @a "MZXW6YTBOI======"- b <- either (assertFailure . show) pure $ decodePaddedWith_ @a utf8 "MZXW6YTBOI======"+ a <- either (assertFailure . show) pure $ decodePad t "MZXW6YTBOI======"+ b <- either (assertFailure . show) pure $ decodePaddedWith_ utf8 "MZXW6YTBOI======" a @=? b , testCase "decodeUnpaddedWith utf8 inputs on decodeUtf8" $ do- a <- either (assertFailure . show) pure $ decodeNopad @a "MZXW6YTBOI"- b <- either (assertFailure . show) pure $ decodeUnpaddedWith_ @a utf8 "MZXW6YTBOI"+ a <- either (assertFailure . show) pure $ decodeNopad t "MZXW6YTBOI"+ b <- either (assertFailure . show) pure $ decodeUnpaddedWith_ utf8 "MZXW6YTBOI" a @=? b , testCase "decodeHexWith utf8 inputs on decodeUtf8" $ do- a <- either (assertFailure . show) pure $ decodeHex @a "CPNMUOJ1E8======"- b <- either (assertFailure . show) pure $ decodeHexWith_ @a utf8 "CPNMUOJ1E8======"+ a <- either (assertFailure . show) pure $ decodeHex t "CPNMUOJ1E8======"+ b <- either (assertFailure . show) pure $ decodeHexWith_ utf8 "CPNMUOJ1E8======" a @=? b , testCase "decodeHexPaddedWith utf8 inputs on decodeUtf8" $ do- a <- either (assertFailure . show) pure $ decodeHexPad @a "CPNMUOJ1E8======"- b <- either (assertFailure . show) pure $ decodeHexPaddedWith_ @a utf8 "CPNMUOJ1E8======"+ a <- either (assertFailure . show) pure $ decodeHexPad t "CPNMUOJ1E8======"+ b <- either (assertFailure . show) pure $ decodeHexPaddedWith_ utf8 "CPNMUOJ1E8======" a @=? b , testCase "decodeHexUnpaddedWith utf8 inputs on decodeUtf8" $ do- a <- either (assertFailure . show) pure $ decodeHexNopad @a "CPNMUOJ1"- b <- either (assertFailure . show) pure $ decodeHexUnpaddedWith_ @a utf8 "CPNMUOJ1"+ a <- either (assertFailure . show) pure $ decodeHexNopad t "CPNMUOJ1"+ b <- either (assertFailure . show) pure $ decodeHexUnpaddedWith_ utf8 "CPNMUOJ1" a @=? b ] ] -- | Validity unit tests for the URL workflow ---validityTests :: forall a b proxy. Harness a b => proxy a -> TestTree-validityTests _ = testGroup "Validity and correctness unit tests"+validityTests :: C a => Harness a -> TestTree+validityTests Harness{..} = testGroup "Validity and correctness unit tests" [ testGroup "Validity unit tests" [ testCase "Hex padding tests" $ do- not (validateHex @a "C") @? "C"- validateHex @a "CO" @? "CO"- validateHex @a "CPNG" @? "CPNG"- validateHex @a "CPNMU" @? "CPNMU"- validateHex @a "CPNMUOG" @? "CPNMUOG"- validateHex @a "CPNMUOJ1" @? "CPNMUOJ1"- validateHex @a "CPNMUOJ1E8" @? "CPNMUOJ1E8"- validateHex @a "CO======" @? "CO======"- validateHex @a "CPNG====" @? "CPNG===="- validateHex @a "CPNMU===" @? "CPNMU==="- validateHex @a "CPNMUOG=" @? "CPNMUOG="- validateHex @a "CPNMUOJ1" @? "CPNMUOJ1"- validateHex @a "CPNMUOJ1E8======" @? "CPNMUOJ1E8======"+ not (validateHex "C") @? "C"+ validateHex "CO" @? "CO"+ validateHex "CPNG" @? "CPNG"+ validateHex "CPNMU" @? "CPNMU"+ validateHex "CPNMUOG" @? "CPNMUOG"+ validateHex "CPNMUOJ1" @? "CPNMUOJ1"+ validateHex "CPNMUOJ1E8" @? "CPNMUOJ1E8"+ validateHex "CO======" @? "CO======"+ validateHex "CPNG====" @? "CPNG===="+ validateHex "CPNMU===" @? "CPNMU==="+ validateHex "CPNMUOG=" @? "CPNMUOG="+ validateHex "CPNMUOJ1" @? "CPNMUOJ1"+ validateHex "CPNMUOJ1E8======" @? "CPNMUOJ1E8======" , testCase "Std padding tests" $ do- not (validate @a "M") @? "M"- validate @a "MY" @? "MY"- validate @a "MZXQ" @? "MZXQ"- validate @a "MZXW6" @? "MZXW6"- validate @a "MZXW6YQ" @? "MZXW6YQ"- validate @a "MZXW6YTB" @? "MZXW6YTB"- validate @a "MZXW6YTBOI" @? "MZXW6YTBOI"- validate @a "MY======" @? "MY======"- validate @a "MZXQ====" @? "MZXQ===="- validate @a "MZXW6===" @? "MZXW6==="- validate @a "MZXW6YQ=" @? "MZXW6YQ="- validate @a "MZXW6YTB" @? "MZXW6YTB"- validate @a "MZXW6YTBOI======" @? "MZXW6YTBOI======"+ not (validate "M") @? "M"+ validate "MY" @? "MY"+ validate "MZXQ" @? "MZXQ"+ validate "MZXW6" @? "MZXW6"+ validate "MZXW6YQ" @? "MZXW6YQ"+ validate "MZXW6YTB" @? "MZXW6YTB"+ validate "MZXW6YTBOI" @? "MZXW6YTBOI"+ validate "MY======" @? "MY======"+ validate "MZXQ====" @? "MZXQ===="+ validate "MZXW6===" @? "MZXW6==="+ validate "MZXW6YQ=" @? "MZXW6YQ="+ validate "MZXW6YTB" @? "MZXW6YTB"+ validate "MZXW6YTBOI======" @? "MZXW6YTBOI======" ] , testGroup "Correctness unit tests" [ testCase "Hex tests" $ do- not (correctHex @a "C") @? "C"- correctHex @a "CO" @? "CO"- correctHex @a "CPNG" @? "CPNG"- correctHex @a "CPNMU" @? "CPNMU"- correctHex @a "CPNMUOG" @? "CPNMUOG"- correctHex @a "CPNMUOJ1" @? "CPNMUOJ1"- correctHex @a "CPNMUOJ1E8" @? "CPNMUOJ1E8"- correctHex @a "CO======" @? "CO======"- correctHex @a "CPNG====" @? "CPNG===="- correctHex @a "CPNMU===" @? "CPNMU==="- correctHex @a "CPNMUOG=" @? "CPNMUOG="- correctHex @a "CPNMUOJ1" @? "CPNMUOJ1"- correctHex @a "CPNMUOJ1E8======" @? "CPNMUOJ1E8======"+ not (correctHex "C") @? "C"+ correctHex "CO" @? "CO"+ correctHex "CPNG" @? "CPNG"+ correctHex "CPNMU" @? "CPNMU"+ correctHex "CPNMUOG" @? "CPNMUOG"+ correctHex "CPNMUOJ1" @? "CPNMUOJ1"+ correctHex "CPNMUOJ1E8" @? "CPNMUOJ1E8"+ correctHex "CO======" @? "CO======"+ correctHex "CPNG====" @? "CPNG===="+ correctHex "CPNMU===" @? "CPNMU==="+ correctHex "CPNMUOG=" @? "CPNMUOG="+ correctHex "CPNMUOJ1" @? "CPNMUOJ1"+ correctHex "CPNMUOJ1E8======" @? "CPNMUOJ1E8======" , testCase "Std tests" $ do- not (correct @a "M") @? "M"- correct @a "MY" @? "MY"- correct @a "MZXQ" @? "MZXQ"- correct @a "MZXW6" @? "MZXW6"- correct @a "MZXW6YQ" @? "MZXW6YQ"- correct @a "MZXW6YTB" @? "MZXW6YTB"- correct @a "MZXW6YTBOI" @? "MZXW6YTBOI"- correct @a "MY======" @? "MY======"- correct @a "MZXQ====" @? "MZXQ===="- correct @a "MZXW6===" @? "MZXW6==="- correct @a "MZXW6YQ=" @? "MZXW6YQ="- correct @a "MZXW6YTB" @? "MZXW6YTB"- correct @a "MZXW6YTBOI======" @? "MZXW6YTBOI======"+ not (correct "M") @? "M"+ correct "MY" @? "MY"+ correct "MZXQ" @? "MZXQ"+ correct "MZXW6" @? "MZXW6"+ correct "MZXW6YQ" @? "MZXW6YQ"+ correct "MZXW6YTB" @? "MZXW6YTB"+ correct "MZXW6YTBOI" @? "MZXW6YTBOI"+ correct "MY======" @? "MY======"+ correct "MZXQ====" @? "MZXQ===="+ correct "MZXW6===" @? "MZXW6==="+ correct "MZXW6YQ=" @? "MZXW6YQ="+ correct "MZXW6YTB" @? "MZXW6YTB"+ correct "MZXW6YTBOI======" @? "MZXW6YTBOI======" ] ] -- | Offset test vectors. This stresses the invalid char + incorrect padding -- offset error messages ---offsetVectors :: forall a b proxy. Harness a b => proxy a -> TestTree-offsetVectors _ = testGroup "Offset tests"+offsetVectors :: C a => Harness a -> TestTree+offsetVectors Harness{..} = testGroup "Offset tests" [ testGroup "Hex - Invalid padding" [ testCase "Invalid staggered padding" $ do- decodeHex @a "=PNMUOJ1E8======" @?= Left "invalid padding at offset: 0"- decodeHex @a "C=NMUOJ1E8======" @?= Left "invalid padding at offset: 1"- decodeHex @a "CP=MUOJ1E8======" @?= Left "invalid padding at offset: 2"- decodeHex @a "CPN=UOJ1E8======" @?= Left "invalid padding at offset: 3"- decodeHex @a "CPNM=OJ1E8======" @?= Left "invalid padding at offset: 4"- decodeHex @a "CPNMU=J1E8======" @?= Left "invalid padding at offset: 5"- decodeHex @a "CPNMUO=1E8======" @?= Left "invalid padding at offset: 6"- decodeHex @a "CPNMUOJ=E8======" @?= Left "invalid padding at offset: 7"+ decodeHex "=PNMUOJ1E8======" @?= Left "invalid padding at offset: 0"+ decodeHex "C=NMUOJ1E8======" @?= Left "invalid padding at offset: 1"+ decodeHex "CP=MUOJ1E8======" @?= Left "invalid padding at offset: 2"+ decodeHex "CPN=UOJ1E8======" @?= Left "invalid padding at offset: 3"+ decodeHex "CPNM=OJ1E8======" @?= Left "invalid padding at offset: 4"+ decodeHex "CPNMU=J1E8======" @?= Left "invalid padding at offset: 5"+ decodeHex "CPNMUO=1E8======" @?= Left "invalid padding at offset: 6"+ decodeHex "CPNMUOJ=E8======" @?= Left "invalid padding at offset: 7" , testCase "Invalid character coverage" $ do- decodeHex @a "%PNMUOJ1E8======" @?= Left "invalid character at offset: 0"- decodeHex @a "C%NMUOJ1E8======" @?= Left "invalid character at offset: 1"- decodeHex @a "CP%MUOJ1E8======" @?= Left "invalid character at offset: 2"- decodeHex @a "CPN%UOJ1E8======" @?= Left "invalid character at offset: 3"- decodeHex @a "CPNM%OJ1E8======" @?= Left "invalid character at offset: 4"- decodeHex @a "CPNMU%J1E8======" @?= Left "invalid character at offset: 5"- decodeHex @a "CPNMUO%1E8======" @?= Left "invalid character at offset: 6"- decodeHex @a "CPNMUOJ%E8======" @?= Left "invalid character at offset: 7"+ decodeHex "%PNMUOJ1E8======" @?= Left "invalid character at offset: 0"+ decodeHex "C%NMUOJ1E8======" @?= Left "invalid character at offset: 1"+ decodeHex "CP%MUOJ1E8======" @?= Left "invalid character at offset: 2"+ decodeHex "CPN%UOJ1E8======" @?= Left "invalid character at offset: 3"+ decodeHex "CPNM%OJ1E8======" @?= Left "invalid character at offset: 4"+ decodeHex "CPNMU%J1E8======" @?= Left "invalid character at offset: 5"+ decodeHex "CPNMUO%1E8======" @?= Left "invalid character at offset: 6"+ decodeHex "CPNMUOJ%E8======" @?= Left "invalid character at offset: 7" ] , testGroup "Std - Invalid padding" [ testCase "Invalid staggered padding" $ do- decode @a "=ZXW6YTBOI======" @?= Left "invalid padding at offset: 0"- decode @a "M=XW6YTBOI======" @?= Left "invalid padding at offset: 1"- decode @a "MZ=W6YTBOI======" @?= Left "invalid padding at offset: 2"- decode @a "MZX=6YTBOI======" @?= Left "invalid padding at offset: 3"- decode @a "MZXW=YTBOI======" @?= Left "invalid padding at offset: 4"- decode @a "MZXW6=TBOI======" @?= Left "invalid padding at offset: 5"- decode @a "MZXW6Y=BOI======" @?= Left "invalid padding at offset: 6"- decode @a "MZXW6YT=OI======" @?= Left "invalid padding at offset: 7"+ decode "=ZXW6YTBOI======" @?= Left "invalid padding at offset: 0"+ decode "M=XW6YTBOI======" @?= Left "invalid padding at offset: 1"+ decode "MZ=W6YTBOI======" @?= Left "invalid padding at offset: 2"+ decode "MZX=6YTBOI======" @?= Left "invalid padding at offset: 3"+ decode "MZXW=YTBOI======" @?= Left "invalid padding at offset: 4"+ decode "MZXW6=TBOI======" @?= Left "invalid padding at offset: 5"+ decode "MZXW6Y=BOI======" @?= Left "invalid padding at offset: 6"+ decode "MZXW6YT=OI======" @?= Left "invalid padding at offset: 7" , testCase "Invalid character coverage" $ do- decode @a "%ZXW6YTBOI======" @?= Left "invalid character at offset: 0"- decode @a "M%XW6YTBOI======" @?= Left "invalid character at offset: 1"- decode @a "MZ%W6YTBOI======" @?= Left "invalid character at offset: 2"- decode @a "MZX%6YTBOI======" @?= Left "invalid character at offset: 3"- decode @a "MZXW%YTBOI======" @?= Left "invalid character at offset: 4"- decode @a "MZXW6%TBOI======" @?= Left "invalid character at offset: 5"- decode @a "MZXW6Y%BOI======" @?= Left "invalid character at offset: 6"- decode @a "MZXW6YT%OI======" @?= Left "invalid character at offset: 7"+ decode "%ZXW6YTBOI======" @?= Left "invalid character at offset: 0"+ decode "M%XW6YTBOI======" @?= Left "invalid character at offset: 1"+ decode "MZ%W6YTBOI======" @?= Left "invalid character at offset: 2"+ decode "MZX%6YTBOI======" @?= Left "invalid character at offset: 3"+ decode "MZXW%YTBOI======" @?= Left "invalid character at offset: 4"+ decode "MZXW6%TBOI======" @?= Left "invalid character at offset: 5"+ decode "MZXW6Y%BOI======" @?= Left "invalid character at offset: 6"+ decode "MZXW6YT%OI======" @?= Left "invalid character at offset: 7" ] ]