base16 0.1.3.0 → 0.2.0.0

raw patch · 14 files changed

+373/−169 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• base16.cabal +2/−1
• benchmarks/Base16Bench.hs +26/−26
• src/Data/ByteString/Base16.hs +11/−1
• src/Data/ByteString/Base16/Internal/Head.hs +24/−0
• src/Data/ByteString/Base16/Internal/Utils.hs +24/−0
• src/Data/ByteString/Base16/Internal/W16/Loop.hs +53/−8
• src/Data/ByteString/Base16/Internal/W32/Loop.hs +21/−35
• src/Data/ByteString/Base16/Internal/W64/Loop.hs +20/−89
• src/Data/ByteString/Lazy/Base16.hs +17/−1
• src/Data/Text/Encoding/Base16.hs +43/−4
• src/Data/Text/Encoding/Base16/Error.hs +32/−0
• src/Data/Text/Lazy/Encoding/Base16.hs +44/−3
• test/Base16Tests.hs +47/−1

@@ -1,5 +1,14 @@ # Revision history for base16 +## 0.2.0++* Add lenient decoders+* Fix bug in `Text` `decodeBase16` which failed on invalid UTF-8 values as a result of decoding+* Add `decodeBase16With` combinators++## 0.1.3++* Add lazy variants for `Text` and `ByteString` values  ## 0.1.2.1 -- 2020-02-17 

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               base16-version:            0.1.3.0+version:            0.2.0.0 synopsis:           RFC 4648-compliant Base16 encodings/decodings description:   RFC 4648-compliant Base16 encodings and decodings.@@ -31,6 +31,7 @@     Data.ByteString.Base16     Data.ByteString.Lazy.Base16     Data.Text.Encoding.Base16+    Data.Text.Encoding.Base16.Error     Data.Text.Lazy.Encoding.Base16    other-modules:

@@ -10,8 +10,8 @@ import Data.ByteString.Lazy (fromStrict) import "memory" Data.ByteArray.Encoding as Mem import Data.ByteString-import "base16" Data.ByteString.Lazy.Base16 as B16-import "base16-bytestring" Data.ByteString.Base16.Lazy as Bos+import "base16" Data.ByteString.Base16 as B16+import "base16-bytestring" Data.ByteString.Base16 as Bos import Data.ByteString.Random (random)  @@ -22,66 +22,66 @@       bgroup "encode"       [ bgroup "25"         [ bench "memory" $ whnf ctob bs25-        , bench "base16-bytestring" $ whnf Bos.encode bs25L-        , bench "base16" $ whnf B16.encodeBase16' bs25L+        , bench "base16-bytestring" $ whnf Bos.encode bs25+        , bench "base16" $ whnf B16.encodeBase16' bs25         ]       , bgroup "100"         [ bench "memory" $ whnf ctob bs100-        , bench "base16-bytestring" $ whnf Bos.encode bs100L-        , bench "base16" $ whnf B16.encodeBase16' bs100L+        , bench "base16-bytestring" $ whnf Bos.encode bs100+        , bench "base16" $ whnf B16.encodeBase16' bs100         ]       , bgroup "1k"         [ bench "memory" $ whnf ctob bs1k-        , bench "base16-bytestring" $ whnf Bos.encode bs1kL-        , bench "base16" $ whnf B16.encodeBase16' bs1kL+        , bench "base16-bytestring" $ whnf Bos.encode bs1k+        , bench "base16" $ whnf B16.encodeBase16' bs1k         ]       , bgroup "10k"         [ bench "memory" $ whnf ctob bs10k-        , bench "base16-bytestring" $ whnf Bos.encode bs10kL-        , bench "base16" $ whnf B16.encodeBase16' bs10kL+        , bench "base16-bytestring" $ whnf Bos.encode bs10k+        , bench "base16" $ whnf B16.encodeBase16' bs10k         ]       , bgroup "100k"         [ bench "memory" $ whnf ctob bs100k-        , bench "base16-bytestring" $ whnf Bos.encode bs100kL-        , bench "base16" $ whnf B16.encodeBase16' bs100kL+        , bench "base16-bytestring" $ whnf Bos.encode bs100k+        , bench "base16" $ whnf B16.encodeBase16' bs100k         ]       , bgroup "1mm"         [ bench "memory" $ whnf ctob bs1mm-        , bench "base16-bytestring" $ whnf Bos.encode bs1mmL-        , bench "base16" $ whnf B16.encodeBase16' bs1mmL+        , bench "base16-bytestring" $ whnf Bos.encode bs1mm+        , bench "base16" $ whnf B16.encodeBase16' bs1mm         ]       ]     , env bs' $ \ ~((bs25,bs100,bs1k,bs10k,bs100k,bs1mm),(bs25L,bs100L,bs1kL,bs10kL,bs100kL,bs1mmL)) ->       bgroup "decode"       [ bgroup "25"         [ bench "memory" $ whnf cfob bs25-        , bench "base16-bytestring" $ whnf Bos.decode bs25L-        , bench "base16" $ whnf B16.decodeBase16 bs25L+        , bench "base16-bytestring" $ whnf Bos.decode bs25+        , bench "base16" $ whnf B16.decodeBase16Lenient bs25         ]       , bgroup "100"         [ bench "memory" $ whnf cfob bs100-        , bench "base16-bytestring" $ whnf Bos.decode bs100L-        , bench "base16" $ whnf B16.decodeBase16 bs100L+        , bench "base16-bytestring" $ whnf Bos.decode bs100+        , bench "base16" $ whnf B16.decodeBase16Lenient bs100         ]       , bgroup "1k"         [ bench "memory" $ whnf cfob bs1k-        , bench "base16-bytestring" $ whnf Bos.decode bs1kL-        , bench "base16" $ whnf B16.decodeBase16 bs1kL+        , bench "base16-bytestring" $ whnf Bos.decode bs1k+        , bench "base16" $ whnf B16.decodeBase16Lenient bs1k         ]       , bgroup "10k"         [ bench "memory" $ whnf cfob bs10k-        , bench "base16-bytestring" $ whnf Bos.decode bs10kL-        , bench "base16" $ whnf B16.decodeBase16 bs10kL+        , bench "base16-bytestring" $ whnf Bos.decode bs10k+        , bench "base16" $ whnf B16.decodeBase16Lenient bs10k         ]       , bgroup "100k"         [ bench "memory" $ whnf cfob bs100k-        , bench "base16-bytestring" $ whnf Bos.decode bs100kL-        , bench "base16" $ whnf B16.decodeBase16 bs100kL+        , bench "base16-bytestring" $ whnf Bos.decode bs100k+        , bench "base16" $ whnf B16.decodeBase16Lenient bs100k         ]       , bgroup "1mm"         [ bench "memory" $ whnf cfob bs1mm-        , bench "base16-bytestring" $ whnf Bos.decode bs1mmL-        , bench "base16" $ whnf B16.decodeBase16 bs1mmL+        , bench "base16-bytestring" $ whnf Bos.decode bs1mm+        , bench "base16" $ whnf B16.decodeBase16Lenient bs1mm         ]       ]     ]

@@ -18,6 +18,7 @@ ( encodeBase16 , encodeBase16' , decodeBase16+, decodeBase16Lenient , isBase16 , isValidBase16 ) where@@ -48,13 +49,22 @@ encodeBase16' = encodeBase16_ {-# INLINE encodeBase16' #-} --- | Decode a padded Base16-encoded 'ByteString' value.+-- | Decode a Base16-encoded 'ByteString' value. -- -- See: <https://tools.ietf.org/html/rfc4648#section-8 RFC-4648 section 8> -- decodeBase16 :: ByteString -> Either Text ByteString decodeBase16 = decodeBase16_ {-# INLINE decodeBase16 #-}++-- | Decode a Base16-encoded 'ByteString' value leniently, using a+-- strategy that never fails+--+-- N.B.: this is not RFC 4648-compliant+--+decodeBase16Lenient :: ByteString -> ByteString+decodeBase16Lenient = decodeBase16Lenient_+{-# INLINE decodeBase16Lenient #-}  -- | Tell whether a 'ByteString' value is base16 encoded. --

@@ -6,11 +6,13 @@ module Data.ByteString.Base16.Internal.Head ( encodeBase16_ , decodeBase16_+, decodeBase16Lenient_ ) where   #include "MachDeps.h" +import Data.ByteString (empty) import Data.ByteString.Internal import Data.ByteString.Base16.Internal.Tables #if WORD_SIZE_IN_BITS == 32@@ -60,5 +62,27 @@           (castPtr dptr)           (castPtr (plusPtr sptr soff))           (plusPtr sptr (soff + slen))+          0   where     (!q, !r) = slen `divMod` 2++decodeBase16Lenient_ :: ByteString -> ByteString+decodeBase16Lenient_ (PS !sfp !soff !slen)+  | slen == 0 = empty+  | otherwise = unsafeDupablePerformIO $ do+    dfp <- mallocPlainForeignPtrBytes dlen+    withForeignPtr dfp $ \dptr ->+      withForeignPtr dtableHi $ \hi ->+      withForeignPtr dtableLo $ \lo ->+      withForeignPtr sfp $ \sptr ->+        lenientLoop+          dfp+          hi+          lo+          (castPtr dptr)+          (castPtr (plusPtr sptr soff))+          (plusPtr sptr (soff + slen))+          0+  where+    (!q, _) = slen `divMod` 2+    !dlen = q * 2

@@ -4,9 +4,13 @@ ( aix , w32 , w64+, reChunk , writeNPlainForeignPtrBytes ) where +import Data.ByteString (ByteString)+import qualified Data.ByteString as B+ import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable@@ -17,6 +21,7 @@  import System.IO.Unsafe + -- | Read 'Word8' index off alphabet addr -- aix :: Word8 -> Addr# -> Word8@@ -47,3 +52,22 @@   where     go !_ [] = return ()     go !p (x:xs) = poke p x >> go (plusPtr p 1) xs++-- | Form a list of chunks, and rechunk the list of bytestrings+-- into length multiples of 2+--+reChunk :: [ByteString] -> [ByteString]+reChunk [] = []+reChunk (c:cs) = case B.length c `divMod` 2 of+    (_, 0) -> c : reChunk cs+    (n, _) -> case B.splitAt (n * 2) c of+      ~(m, q) -> m : cont_ q cs+  where+    cont_ q [] = [q]+    cont_ q (a:as) = case B.splitAt 1 a of+      ~(x, y) -> let q' = B.append q x+        in if B.length q' == 2+          then+            let as' = if B.null y then as else y:as+            in q' : reChunk as'+          else cont_ q' as

@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -- |@@ -17,6 +18,7 @@ module Data.ByteString.Base16.Internal.W16.Loop ( innerLoop , decodeLoop+, lenientLoop ) where  @@ -71,9 +73,14 @@   -> Ptr Word8   -> Ptr Word8   -> Ptr Word8+  -> Int   -> IO (Either Text ByteString)-decodeLoop !dfp !hi !lo !dptr !sptr !end = go dptr sptr 0+decodeLoop !dfp !hi !lo !dptr !sptr !end !nn = go dptr sptr nn   where+    err !src = return . Left . T.pack+      $ "invalid character at offset: "+      ++ show (src `minusPtr` sptr)+     go !dst !src !n       | src == end = return (Right (PS dfp 0 n))       | otherwise = do@@ -83,10 +90,48 @@         !a <- peekByteOff hi (fromIntegral x)         !b <- peekByteOff lo (fromIntegral y) -        if a == 0xff || b == 0xff-        then return . Left . T.pack-          $ "invalid character at offset: "-          ++ show (src `minusPtr` sptr)-        else do-          poke dst (a .|. b)-          go (plusPtr dst 1) (plusPtr src 2) (n + 1)+        if+          | a == 0xff -> err src+          | b == 0xff -> err (plusPtr src 1)+          | otherwise -> do+            poke dst (a .|. b)+            go (plusPtr dst 1) (plusPtr src 2) (n + 1)+{-# INLINE decodeLoop #-}+++-- | Lenient lazy hex decoding loop optimized for 16-bit architectures.+-- When the 'Right' case is returned, a byte+--+lenientLoop+  :: ForeignPtr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Int+  -> IO ByteString+lenientLoop !dfp !hi !lo !dptr !sptr !end !nn = goHi dptr sptr nn+  where+    goHi !dst !src !n+      | src == end = return (PS dfp 0 n)+      | otherwise = do+        !x <- peek @Word8 src+        !a <- peekByteOff hi (fromIntegral x)++        if+          | a == 0xff -> goHi dst (plusPtr src 1) n+          | otherwise -> goLo dst (plusPtr src 1) a n++    goLo !dst !src !a !n+      | src == end = return (PS dfp 0 n)+      | otherwise = do+        !y <- peek @Word8 src+        !b <- peekByteOff lo (fromIntegral y)++        if+          | b == 0xff -> goLo dst (plusPtr src 1) a n+          | otherwise -> do+            poke dst (a .|. b)+            goHi (plusPtr dst 1) (plusPtr src 1) (n + 1)+{-# LANGUAGE lenientLoop #-}

@@ -17,12 +17,14 @@ module Data.ByteString.Base16.Internal.W32.Loop ( innerLoop , decodeLoop+, lenientLoop ) where   import Data.Bits import Data.ByteString.Internal import Data.ByteString.Base16.Internal.Utils+import qualified Data.ByteString.Base16.Internal.W16.Loop as W16 import Data.Text (Text) import qualified Data.Text as T @@ -47,22 +49,9 @@      !alphabet = "0123456789abcdef"# -    tailRound16 !dst !src-      | src == end = return ()-      | otherwise = do-        !t <- peek @Word8 src--        let !a = fromIntegral (lix (unsafeShiftR t 4))-            !b = fromIntegral (lix t)--        let !w = a .|. (unsafeShiftL b 8)--        poke @Word16 dst w--        tailRound16 (plusPtr dst 2) (plusPtr src 1)-     go !dst !src-      | plusPtr src 3 >= end = tailRound16 (castPtr dst) (castPtr src)+      | plusPtr src 3 >= end =+        W16.innerLoop (castPtr dst) (castPtr src) end       | otherwise = do #ifdef WORDS_BIGENDIAN         !t <- peek src@@ -86,6 +75,7 @@         poke @Word32 dst xx          go (plusPtr dst 4) (plusPtr src 2)+{-# INLINE innerLoop #-}  -- | Hex decoding loop optimized for 32-bit architectures --@@ -96,33 +86,17 @@   -> Ptr Word16   -> Ptr Word32   -> Ptr Word8+  -> Int   -> IO (Either Text ByteString)-decodeLoop !dfp !hi !lo !dptr !sptr !end = go dptr sptr 0+decodeLoop !dfp !hi !lo !dptr !sptr !end !nn = go dptr sptr nn   where     err !src = return . Left . T.pack       $ "invalid character at offset: "       ++ show (src `minusPtr` sptr) -    tailRound16 !dst !src !n-      | src == end = return (Right (PS dfp 0 n))-      | otherwise = do-        !x <- peek @Word8 src-        !y <- peek @Word8 (plusPtr src 1)--        !a <- peekByteOff hi (fromIntegral x)-        !b <- peekByteOff lo (fromIntegral y)--        if a == 0xff || b == 0xff-        then return . Left . T.pack-          $ "invalid character at offset: "-          ++ show (src `minusPtr` sptr)-        else do-          poke @Word8 dst (a .|. b)-          return (Right (PS dfp 0 (n + 1)))--     go !dst !src !n-      | plusPtr src 3 >= end = tailRound16 (castPtr dst) (castPtr src) n+      | plusPtr src 3 >= end =+        W16.decodeLoop dfp hi lo (castPtr dst) (castPtr src) end n       | otherwise = do #ifdef WORDS_BIGENDIAN         !t <- peek @Word32 src@@ -150,3 +124,15 @@             poke @Word16 dst zz             go (plusPtr dst 2) (plusPtr src 4) (n + 2) {-# INLINE decodeLoop #-}++lenientLoop+  :: ForeignPtr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Int+  -> IO ByteString+lenientLoop !dfp !hi !lo !dptr !sptr !end !nn =+  W16.lenientLoop dfp hi lo dptr sptr end nn

@@ -17,12 +17,14 @@ module Data.ByteString.Base16.Internal.W64.Loop ( innerLoop , decodeLoop+, lenientLoop ) where   import Data.Bits import Data.ByteString.Internal import Data.ByteString.Base16.Internal.Utils+import qualified Data.ByteString.Base16.Internal.W32.Loop as W32 import Data.Text (Text) import qualified Data.Text as T @@ -47,48 +49,9 @@      !alphabet = "0123456789abcdef"# -    tailRound16 !dst !src-      | src == end = return ()-      | otherwise = do-        !t <- peek @Word8 src--        let !a = fromIntegral (lix (unsafeShiftR t 4))-            !b = fromIntegral (lix t)--        let !w = a .|. (unsafeShiftL b 8)--        poke @Word16 dst w--        tailRound16 (plusPtr dst 2) (plusPtr src 1)--    tailRound32 !dst !src-      | plusPtr src 3 >= end = tailRound16 (castPtr dst) (castPtr src)-      | otherwise = do-#ifdef WORDS_BIGENDIAN-        !t <- peek src-#else-        !t <- byteSwap16 <$> peek @Word16 src-#endif-        let !a = unsafeShiftR t 12-            !b = unsafeShiftR t 8-            !c = unsafeShiftR t 4--        let !w = w32 (lix a)-            !x = w32 (lix b)-            !y = w32 (lix c)-            !z = w32 (lix t)--        let !xx = w-              .|. (unsafeShiftL x 8)-              .|. (unsafeShiftL y 16)-              .|. (unsafeShiftL z 24)--        poke @Word32 dst xx--        tailRound32 (plusPtr dst 4) (plusPtr src 2)-     go !dst !src-      | plusPtr src 7 >= end = tailRound32 (castPtr dst) (castPtr src)+      | plusPtr src 7 >= end =+        W32.innerLoop (castPtr dst) (castPtr src) end       | otherwise = do #ifdef WORDS_BIGENDIAN         !t <- peek src@@ -139,61 +102,17 @@   -> Ptr Word32   -> Ptr Word64   -> Ptr Word8+  -> Int   -> IO (Either Text ByteString)-decodeLoop !dfp !hi !lo !dptr !sptr !end = go dptr sptr 0+decodeLoop !dfp !hi !lo !dptr !sptr !end !nn = go dptr sptr nn   where     err !src = return . Left . T.pack       $ "invalid character at offset: "       ++ show (src `minusPtr` sptr) -    tailRound16 !dst !src !n-      | src == end = return (Right (PS dfp 0 n))-      | otherwise = do-        !x <- peek @Word8 src-        !y <- peek @Word8 (plusPtr src 1)--        !a <- peekByteOff @Word8 hi (fromIntegral x)-        !b <- peekByteOff @Word8 lo (fromIntegral y)--        if-          | a == 0xff -> err src-          | b == 0xff -> err (plusPtr src 1)-          | otherwise -> do-            poke dst (a .|. b)-            return (Right (PS dfp 0 (n + 1)))--    tailRound32 !dst !src !n-      | plusPtr src 3 >= end = tailRound16 (castPtr dst) (castPtr src) n-      | otherwise = do-#ifdef WORDS_BIGENDIAN-        !t <- peek @Word32 src-#else-        !t <- byteSwap32 <$> peek @Word32 src-#endif-        let !w = fromIntegral ((unsafeShiftR t 24) .&. 0xff)-            !x = fromIntegral ((unsafeShiftR t 16) .&. 0xff)-            !y = fromIntegral ((unsafeShiftR t 8) .&. 0xff)-            !z = (fromIntegral (t .&. 0xff))--        !a <- peekByteOff @Word8 hi w-        !b <- peekByteOff @Word8 lo x-        !c <- peekByteOff @Word8 hi y-        !d <- peekByteOff @Word8 lo z--        let !zz = fromIntegral (a .|. b)-               .|. (unsafeShiftL (fromIntegral (c .|. d)) 8)--        if-          | a == 0xff -> err src-          | b == 0xff -> err (plusPtr src 1)-          | c == 0xff -> err (plusPtr src 2)-          | d == 0xff -> err (plusPtr src 3)-          | otherwise -> do-            poke @Word16 dst zz-            tailRound16 (plusPtr dst 2) (plusPtr src 4) (n + 2)-     go !dst !src !n-      | plusPtr src 7 >= end = tailRound32 (castPtr dst) (castPtr src) n+      | plusPtr src 7 >= end =+        W32.decodeLoop dfp hi lo (castPtr dst) (castPtr src) end n       | otherwise = do #ifdef WORDS_BIGENDIAN         !tt <- peek @Word64 src@@ -236,3 +155,15 @@             poke @Word32 dst zz             go (plusPtr dst 4) (plusPtr src 8) (n + 4) {-# INLINE decodeLoop #-}++lenientLoop+  :: ForeignPtr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Ptr Word8+  -> Int+  -> IO ByteString+lenientLoop !dfp !hi !lo !dptr !sptr !end !nn =+  W32.lenientLoop dfp hi lo dptr sptr end nn

@@ -16,6 +16,7 @@ ( encodeBase16 , encodeBase16' , decodeBase16+, decodeBase16Lenient , isBase16 , isValidBase16 ) where@@ -23,9 +24,11 @@  import Prelude hiding (all, elem) -import Data.ByteString.Lazy (all, elem)+import qualified Data.ByteString as B+import Data.ByteString.Lazy (all, elem, fromChunks, toChunks) import Data.ByteString.Lazy.Internal (ByteString(..)) import qualified Data.ByteString.Base16.Internal.Head as B16+import Data.ByteString.Base16.Internal.Utils (reChunk) import Data.Either import qualified Data.Text as T import Data.Text.Lazy (Text)@@ -57,6 +60,19 @@ decodeBase16 Empty = Right Empty decodeBase16 (Chunk b bs) = Chunk <$> B16.decodeBase16_ b <*> decodeBase16 bs {-# INLINE decodeBase16 #-}++-- | Decode a Base16-encoded 'ByteString' value leniently, using a+-- strategy that never fails+--+-- N.B.: this is not RFC 4648-compliant. It may give you garbage if you're not careful!+--+decodeBase16Lenient :: ByteString -> ByteString+decodeBase16Lenient = fromChunks+  . fmap B16.decodeBase16Lenient_+  . reChunk+  . fmap (B.filter (flip elem "0123456789abcdef"))+  . toChunks+{-# INLINE decodeBase16Lenient #-}  -- | Tell whether a lazy 'ByteString' value is base16 encoded. --

@@ -14,14 +14,19 @@ module Data.Text.Encoding.Base16 ( encodeBase16 , decodeBase16+, decodeBase16With+, decodeBase16Lenient , isBase16 , isValidBase16 ) where  +import Data.Bifunctor (first)+import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16- import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding.Base16.Error (Base16Error(..)) import qualified Data.Text.Encoding as T  -- | Encode a 'Text' value in Base16 with padding.@@ -32,13 +37,47 @@ encodeBase16 = B16.encodeBase16 . T.encodeUtf8 {-# INLINE encodeBase16 #-} --- | Decode a padded Base16-encoded 'Text' value+-- | Decode a Base16-encoded lazy 'Text' value. -- -- See: <https://tools.ietf.org/html/rfc4648#section-8 RFC-4648 section 8> ---decodeBase16 :: Text -> Either Text Text-decodeBase16 = fmap T.decodeUtf8 . B16.decodeBase16 . T.encodeUtf8+decodeBase16 :: Text -> Either T.Text Text+decodeBase16 = fmap T.decodeLatin1 . B16.decodeBase16 . T.encodeUtf8 {-# INLINE decodeBase16 #-}++-- | Attempt to decode a lazy 'Text' value as Base16, converting from+-- 'ByteString' to 'Text' according to some encoding function. In practice,+-- This is something like 'decodeUtf8'', which may produce an error.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-8 RFC-4648 section 8>+--+-- Example:+--+-- @+-- 'decodeBase16With' 'T.decodeUtf8''+--   :: 'Text' -> 'Either' ('Base16Error' 'UnicodeException') 'Text'+-- @+--+decodeBase16With+    :: (ByteString -> Either err Text)+      -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'')+    -> Text+      -- ^ Input text to decode+    -> Either (Base16Error err) Text+decodeBase16With f t = case B16.decodeBase16 $ T.encodeUtf8 t of+  Left de -> Left $ DecodeError de+  Right a -> first ConversionError (f a)+{-# INLINE decodeBase16With #-}++-- | Decode a Base16-encoded lazy 'Text' value leniently, using a+-- strategy that never fails, catching unicode exceptions raised in the+-- process of converting to text values.+--+-- N.B.: this is not RFC 4648-compliant.+--+decodeBase16Lenient :: Text -> Text+decodeBase16Lenient = T.decodeLatin1 . B16.decodeBase16Lenient . T.encodeUtf8+{-# INLINE decodeBase16Lenient #-}  -- | Tell whether a 'Text' value is Base16-encoded. --

@@ -0,0 +1,32 @@+-- |+-- Module       : Data.Text.Encoding.Base16.Error+-- Copyright 	: (c) 2019 Emily Pillmore+-- License	: BSD-style+--+-- Maintainer	: Emily Pillmore <emilypi@cohomolo.gy>+-- Stability	: Experimental+-- Portability	: portable+--+-- This module contains the error types raised (not as exceptions!)+-- in the decoding process.+--+module Data.Text.Encoding.Base16.Error+( Base16Error(..)+) where+++import Data.Text (Text)++-- | This data type represents the type of decoding errors of+-- various kinds as they pertain to decoding 'Text' values.+-- Namely, to distinguish between decoding errors from opaque+-- unicode exceptions caught in the unicode decoding process.+--+data Base16Error e+  = DecodeError Text+    -- ^ The error associated with decoding failure+    -- as a result of the Base16 decoding process+  | ConversionError e+    -- ^ The error associated with the decoding failure+    -- as a result of the conversion process+  deriving (Eq, Show)

@@ -14,14 +14,18 @@ module Data.Text.Lazy.Encoding.Base16 ( encodeBase16 , decodeBase16+, decodeBase16With+, decodeBase16Lenient , isBase16 , isValidBase16 ) where  +import Data.Bifunctor (first)+import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Base16 as B16L- import qualified Data.Text as T+import Data.Text.Encoding.Base16.Error (Base16Error(..)) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy.Encoding as TL @@ -33,13 +37,50 @@ encodeBase16 = B16L.encodeBase16 . TL.encodeUtf8 {-# INLINE encodeBase16 #-} --- | Decode a padded Base16-encoded lazy 'Text' value+-- | Decode a Base16-encoded lazy 'Text' value. -- -- See: <https://tools.ietf.org/html/rfc4648#section-8 RFC-4648 section 8> -- decodeBase16 :: Text -> Either T.Text Text-decodeBase16 = fmap TL.decodeUtf8 . B16L.decodeBase16 . TL.encodeUtf8+decodeBase16 = fmap TL.decodeLatin1 . B16L.decodeBase16 . TL.encodeUtf8 {-# INLINE decodeBase16 #-}++-- | Attempt to decode a lazy 'Text' value as Base16, converting from+-- 'ByteString' to 'Text' according to some encoding function. In practice,+-- This is something like 'decodeUtf8'', which may produce an error.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-8 RFC-4648 section 8>+--+-- Example:+--+-- @+-- 'decodeBase16With' 'T.decodeUtf8''+--   :: 'Text' -> 'Either' ('Base16Error' 'UnicodeException') 'Text'+-- @+--+decodeBase16With+    :: (ByteString -> Either err Text)+      -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'')+    -> Text+      -- ^ Input text to decode+    -> Either (Base16Error err) Text+decodeBase16With f t = case B16L.decodeBase16 $ TL.encodeUtf8 t of+  Left de -> Left $ DecodeError de+  Right a -> first ConversionError (f a)+{-# INLINE decodeBase16With #-}++-- | Decode a Base16-encoded lazy 'Text' value leniently, using a+-- strategy that never fails.+--+-- /Warning/: in the conversion to unicode text, exceptions may be thrown.+-- Please use 'decodeBase16'' if you are unsure if you are working with+-- base16-encoded values, or if you expect garbage.+--+-- N.B.: this is not RFC 4648-compliant. It may give you garbage if you're not careful!+--+decodeBase16Lenient :: Text -> Text+decodeBase16Lenient = TL.decodeLatin1 . B16L.decodeBase16Lenient . TL.encodeUtf8+{-# INLINE decodeBase16Lenient #-}  -- | Tell whether a lazy 'Text' value is Base16-encoded. --

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeApplications #-}@@ -9,7 +10,7 @@  import Data.Bifunctor import Data.ByteString (ByteString)-import Data.ByteString.Lazy (fromStrict)+import Data.ByteString.Lazy (fromStrict, toStrict) import "base16" Data.ByteString.Base16 as B16 import "base16" Data.ByteString.Lazy.Base16 as B16L import "memory" Data.ByteArray.Encoding as Mem@@ -30,6 +31,7 @@     [ testVectors     , sanityTests     , alphabetTests+    , lenientTests     ]  testVectors :: TestTree@@ -157,12 +159,18 @@       , conforms 4       , conforms 5       , conforms 6+      , conforms 32+      , conforms 33+      , conforms 1001       ]     , testGroup "Lazy"       [ conformsL 0       , conformsL 4       , conformsL 5       , conformsL 6+      , conformsL 32+      , conformsL 33+      , conformsL 1001       ]     ]   where@@ -177,3 +185,41 @@       let b = B16L.encodeBase16' bs       assertBool ("failed validity: " ++ show b) $ B16L.isValidBase16 b       assertBool ("failed correctness: " ++ show b) $ B16L.isBase16 b++lenientTests :: TestTree+lenientTests = testGroup "Lenient Tests"+    [ testGroup "strict encode/lenient decode"+      [ testCaseB16 "" ""+      , testCaseB16 "f" "6+6"+      , testCaseB16 "fo" "6$6+6|f"+      , testCaseB16 "foo" "==========6$$66()*f6f"+      , testCaseB16 "foob" "66^%$&^6f6f62"+      , testCaseB16 "fooba" "666f()*#@6f#)(@*)6()*)2()61"+      , testCaseB16 "foobar" "6@6@6@f@6@f@6@2@6@1@7@2++++++++++++++++++++++++"+      ]+    , testGroup "lazy encode/decode"+      [ testCaseB16L "" ""+      , testCaseB16L "f" "6+++++++____++++++======*%$@#%#^*$^6"+      , testCaseB16L "fo" "6$6+6|f"+      , testCaseB16L "foo" "==========6$$66()*f6f"+      , testCaseB16L "foob" "66^%$&^6f6f62"+      , testCaseB16L "fooba" "666f()*#@6f#)(@*)6()*)2()61"+      , testCaseB16L "foobar" "6@6@6@f@6@f@6@2@6@1@7@2++++++++++++++++++++++++"+      ]+    ]+  where+    testCaseB16 s t =+      testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do+        let t0 = B16.decodeBase16 (B16.encodeBase16' s)+            t1 = B16.decodeBase16Lenient t++        step "compare decoding"+        t0 @=? Right t1++    testCaseB16L s t =+      testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do+        let t0 = fmap toStrict $ B16L.decodeBase16 (B16L.encodeBase16' s)+            t1 = Right . toStrict $ B16L.decodeBase16Lenient t++        step "compare decoding"+        t0 @=? t1