diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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)) diff --git a/base32.cabal b/base32.cabal --- a/base32.cabal +++ b/base32.cabal @@ -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 diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs --- a/src/Data/ByteString/Base32.hs +++ b/src/Data/ByteString/Base32.hs @@ -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 diff --git a/src/Data/ByteString/Base32/Hex.hs b/src/Data/ByteString/Base32/Hex.hs --- a/src/Data/ByteString/Base32/Hex.hs +++ b/src/Data/ByteString/Base32/Hex.hs @@ -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 diff --git a/src/Data/ByteString/Base32/Internal.hs b/src/Data/ByteString/Base32/Internal.hs --- a/src/Data/ByteString/Base32/Internal.hs +++ b/src/Data/ByteString/Base32/Internal.hs @@ -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, diff --git a/src/Data/ByteString/Base32/Internal/Head.hs b/src/Data/ByteString/Base32/Internal/Head.hs --- a/src/Data/ByteString/Base32/Internal/Head.hs +++ b/src/Data/ByteString/Base32/Internal/Head.hs @@ -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) diff --git a/src/Data/ByteString/Base32/Internal/Loop.hs b/src/Data/ByteString/Base32/Internal/Loop.hs --- a/src/Data/ByteString/Base32/Internal/Loop.hs +++ b/src/Data/ByteString/Base32/Internal/Loop.hs @@ -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))) diff --git a/src/Data/ByteString/Base32/Internal/Tables.hs b/src/Data/ByteString/Base32/Internal/Tables.hs --- a/src/Data/ByteString/Base32/Internal/Tables.hs +++ b/src/Data/ByteString/Base32/Internal/Tables.hs @@ -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 diff --git a/src/Data/ByteString/Base32/Internal/Utils.hs b/src/Data/ByteString/Base32/Internal/Utils.hs --- a/src/Data/ByteString/Base32/Internal/Utils.hs +++ b/src/Data/ByteString/Base32/Internal/Utils.hs @@ -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@ diff --git a/test/Internal.hs b/test/Internal.hs --- a/test/Internal.hs +++ b/test/Internal.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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" ] ]