ppad-bech32 0.2.5 → 0.2.6
raw patch · 8 files changed
+507/−193 lines, 8 filesdep +tasty-hunitPVP ok
version bump matches the API change (PVP)
Dependencies added: tasty-hunit
API changes (from Hackage documentation)
Files
- CHANGELOG +8/−0
- lib/Data/ByteString/Base32.hs +2/−96
- lib/Data/ByteString/Base32/Internal.hs +125/−2
- lib/Data/ByteString/Bech32.hs +8/−29
- lib/Data/ByteString/Bech32/Internal.hs +96/−33
- lib/Data/ByteString/Bech32m.hs +8/−28
- ppad-bech32.cabal +2/−1
- test/Main.hs +258/−4
CHANGELOG view
@@ -1,5 +1,13 @@ # Changelog +- 0.2.6 (2026-10-10)+ * Fixes several decoding bugs: inputs with fewer than six checksum+ characters are now rejected, bech32m decoding no longer accepts+ mixed-case input, and all-uppercase input is now accepted, per+ BIP173. 'verify' follows the same case rules.+ * Improves decoding performance by roughly 1.5x.+ * Adds the BIP173 and BIP350 test vectors to the test suite.+ - 0.2.5 (2026-05-16) * Improves bech32 encode/decode performance by about 2x.
lib/Data/ByteString/Base32.hs view
@@ -18,7 +18,7 @@ import qualified Data.Bits as B import Data.Bits ((.&.), (.|.)) import qualified Data.ByteString as BS-import Data.ByteString.Base32.Internal (enc_tab, dec_tab)+import Data.ByteString.Base32.Internal (enc_tab, dec_tab, encode_with) import qualified Data.ByteString.Internal as BI import Data.Word (Word8) import Foreign.ForeignPtr (withForeignPtr)@@ -38,101 +38,7 @@ encode :: BS.ByteString -- ^ base256-encoded bytestring -> BS.ByteString -- ^ base32-encoded bytestring-encode (BI.PS sfp soff l) = case enc_tab of- BI.PS tfp toff _ ->- let !outlen = (l * 8 + 4) `quot` 5- in BI.unsafeCreate outlen $ \dst ->- withForeignPtr sfp $ \sp0 ->- withForeignPtr tfp $ \tp0 -> do- let !sp = sp0 `plusPtr` soff :: Ptr Word8- !tp = tp0 `plusPtr` toff :: Ptr Word8- encode_loop sp tp dst l 0 0--encode_loop- :: Ptr Word8 -> Ptr Word8 -> Ptr Word8- -> Int -> Int -> Int -> IO ()-encode_loop !sp !tp !dst !len !i !j- | i + 5 <= len = do- a <- peekElemOff sp i- b <- peekElemOff sp (i + 1)- c <- peekElemOff sp (i + 2)- d <- peekElemOff sp (i + 3)- e <- peekElemOff sp (i + 4)- let !w0 = (a `B.shiftR` 3) .&. 0x1f- !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f- !w2 = (b `B.shiftR` 1) .&. 0x1f- !w3 = (b `B.shiftL` 4 .|. c `B.shiftR` 4) .&. 0x1f- !w4 = (c `B.shiftL` 1 .|. d `B.shiftR` 7) .&. 0x1f- !w5 = (d `B.shiftR` 2) .&. 0x1f- !w6 = (d `B.shiftL` 3 .|. e `B.shiftR` 5) .&. 0x1f- !w7 = e .&. 0x1f- peekElemOff tp (fi w0) >>= pokeElemOff dst j- peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)- peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)- peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)- peekElemOff tp (fi w4) >>= pokeElemOff dst (j + 4)- peekElemOff tp (fi w5) >>= pokeElemOff dst (j + 5)- peekElemOff tp (fi w6) >>= pokeElemOff dst (j + 6)- peekElemOff tp (fi w7) >>= pokeElemOff dst (j + 7)- encode_loop sp tp dst len (i + 5) (j + 8)- | otherwise = encode_tail sp tp dst len i j--encode_tail- :: Ptr Word8 -> Ptr Word8 -> Ptr Word8- -> Int -> Int -> Int -> IO ()-encode_tail !sp !tp !dst !len !i !j = case len - i of- 0 -> pure ()- 1 -> do- a <- peekElemOff sp i- let !w0 = (a `B.shiftR` 3) .&. 0x1f- !w1 = (a `B.shiftL` 2) .&. 0x1f- peekElemOff tp (fi w0) >>= pokeElemOff dst j- peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)- 2 -> do- a <- peekElemOff sp i- b <- peekElemOff sp (i + 1)- let !w0 = (a `B.shiftR` 3) .&. 0x1f- !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f- !w2 = (b `B.shiftR` 1) .&. 0x1f- !w3 = (b `B.shiftL` 4) .&. 0x1f- peekElemOff tp (fi w0) >>= pokeElemOff dst j- peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)- peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)- peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)- 3 -> do- a <- peekElemOff sp i- b <- peekElemOff sp (i + 1)- c <- peekElemOff sp (i + 2)- let !w0 = (a `B.shiftR` 3) .&. 0x1f- !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f- !w2 = (b `B.shiftR` 1) .&. 0x1f- !w3 = (b `B.shiftL` 4 .|. c `B.shiftR` 4) .&. 0x1f- !w4 = (c `B.shiftL` 1) .&. 0x1f- peekElemOff tp (fi w0) >>= pokeElemOff dst j- peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)- peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)- peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)- peekElemOff tp (fi w4) >>= pokeElemOff dst (j + 4)- 4 -> do- a <- peekElemOff sp i- b <- peekElemOff sp (i + 1)- c <- peekElemOff sp (i + 2)- d <- peekElemOff sp (i + 3)- let !w0 = (a `B.shiftR` 3) .&. 0x1f- !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f- !w2 = (b `B.shiftR` 1) .&. 0x1f- !w3 = (b `B.shiftL` 4 .|. c `B.shiftR` 4) .&. 0x1f- !w4 = (c `B.shiftL` 1 .|. d `B.shiftR` 7) .&. 0x1f- !w5 = (d `B.shiftR` 2) .&. 0x1f- !w6 = (d `B.shiftL` 3) .&. 0x1f- peekElemOff tp (fi w0) >>= pokeElemOff dst j- peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)- peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)- peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)- peekElemOff tp (fi w4) >>= pokeElemOff dst (j + 4)- peekElemOff tp (fi w5) >>= pokeElemOff dst (j + 5)- peekElemOff tp (fi w6) >>= pokeElemOff dst (j + 6)- _ -> pure () -- impossible: 0 <= len - i < 5+encode = encode_with enc_tab -- | Decode a 'ByteString', encoded as base32 using the bech32 character -- set, to a base256-encoded 'ByteString'.
lib/Data/ByteString/Base32/Internal.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide, prune #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- |@@ -7,16 +8,30 @@ -- License: MIT -- Maintainer: Jared Tobin <jared@ppad.tech> ----- Static rodata tables for the bech32 base32 charset, shared by--- 'Data.ByteString.Base32' and 'Data.ByteString.Bech32.Internal'.+-- Tables and the table-driven encoding loop for the bech32 base32+-- charset, shared by 'Data.ByteString.Base32' and+-- 'Data.ByteString.Bech32.Internal'. module Data.ByteString.Base32.Internal ( enc_tab , dec_tab+ , w5_tab+ , encode_with ) where +import qualified Data.Bits as B+import Data.Bits ((.&.), (.|.)) import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BI+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peekElemOff, pokeElemOff) +fi :: (Num a, Integral b) => b -> a+fi = fromIntegral+{-# INLINE fi #-}+ -- 32-byte encoding table: the bech32 character set. Maps a 5-bit -- value (0..31) to its bech32 character. ASCII-only with no embedded -- NUL, so the bytestring 'IsString' rule rewrites the literal to@@ -57,3 +72,111 @@ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40" {-# NOINLINE dec_tab #-}++-- 32-byte identity table: maps a 5-bit value to itself. Encoding+-- through it yields the 5-bit values themselves rather than their+-- bech32 characters.+w5_tab :: BS.ByteString+w5_tab = BS.pack [0 .. 31]+{-# NOINLINE w5_tab #-}++-- | Regroup a base256 'ByteString' into 5-bit values, mapping each+-- through the supplied 32-byte table.+encode_with+ :: BS.ByteString -- ^ 32-byte table+ -> BS.ByteString -- ^ base256-encoded bytestring+ -> BS.ByteString+encode_with (BI.PS tfp toff _) (BI.PS sfp soff l) =+ let !outlen = (l * 8 + 4) `quot` 5+ in BI.unsafeCreate outlen $ \dst ->+ withForeignPtr sfp $ \sp0 ->+ withForeignPtr tfp $ \tp0 -> do+ let !sp = sp0 `plusPtr` soff :: Ptr Word8+ !tp = tp0 `plusPtr` toff :: Ptr Word8+ encode_loop sp tp dst l 0 0++encode_loop+ :: Ptr Word8 -> Ptr Word8 -> Ptr Word8+ -> Int -> Int -> Int -> IO ()+encode_loop !sp !tp !dst !len !i !j+ | i + 5 <= len = do+ a <- peekElemOff sp i+ b <- peekElemOff sp (i + 1)+ c <- peekElemOff sp (i + 2)+ d <- peekElemOff sp (i + 3)+ e <- peekElemOff sp (i + 4)+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f+ !w2 = (b `B.shiftR` 1) .&. 0x1f+ !w3 = (b `B.shiftL` 4 .|. c `B.shiftR` 4) .&. 0x1f+ !w4 = (c `B.shiftL` 1 .|. d `B.shiftR` 7) .&. 0x1f+ !w5 = (d `B.shiftR` 2) .&. 0x1f+ !w6 = (d `B.shiftL` 3 .|. e `B.shiftR` 5) .&. 0x1f+ !w7 = e .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)+ peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)+ peekElemOff tp (fi w4) >>= pokeElemOff dst (j + 4)+ peekElemOff tp (fi w5) >>= pokeElemOff dst (j + 5)+ peekElemOff tp (fi w6) >>= pokeElemOff dst (j + 6)+ peekElemOff tp (fi w7) >>= pokeElemOff dst (j + 7)+ encode_loop sp tp dst len (i + 5) (j + 8)+ | otherwise = encode_tail sp tp dst len i j++encode_tail+ :: Ptr Word8 -> Ptr Word8 -> Ptr Word8+ -> Int -> Int -> Int -> IO ()+encode_tail !sp !tp !dst !len !i !j = case len - i of+ 0 -> pure ()+ 1 -> do+ a <- peekElemOff sp i+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2) .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ 2 -> do+ a <- peekElemOff sp i+ b <- peekElemOff sp (i + 1)+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f+ !w2 = (b `B.shiftR` 1) .&. 0x1f+ !w3 = (b `B.shiftL` 4) .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)+ peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)+ 3 -> do+ a <- peekElemOff sp i+ b <- peekElemOff sp (i + 1)+ c <- peekElemOff sp (i + 2)+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f+ !w2 = (b `B.shiftR` 1) .&. 0x1f+ !w3 = (b `B.shiftL` 4 .|. c `B.shiftR` 4) .&. 0x1f+ !w4 = (c `B.shiftL` 1) .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)+ peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)+ peekElemOff tp (fi w4) >>= pokeElemOff dst (j + 4)+ 4 -> do+ a <- peekElemOff sp i+ b <- peekElemOff sp (i + 1)+ c <- peekElemOff sp (i + 2)+ d <- peekElemOff sp (i + 3)+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f+ !w2 = (b `B.shiftR` 1) .&. 0x1f+ !w3 = (b `B.shiftL` 4 .|. c `B.shiftR` 4) .&. 0x1f+ !w4 = (c `B.shiftL` 1 .|. d `B.shiftR` 7) .&. 0x1f+ !w5 = (d `B.shiftR` 2) .&. 0x1f+ !w6 = (d `B.shiftL` 3) .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)+ peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)+ peekElemOff tp (fi w4) >>= pokeElemOff dst (j + 4)+ peekElemOff tp (fi w5) >>= pokeElemOff dst (j + 5)+ peekElemOff tp (fi w6) >>= pokeElemOff dst (j + 6)+ _ -> pure () -- impossible: 0 <= len - i < 5
lib/Data/ByteString/Bech32.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_HADDOCK prune #-}-{-# LANGUAGE ViewPatterns #-} -- | -- Module: Data.ByteString.Bech32@@ -20,17 +19,9 @@ , verify ) where -import Control.Monad (guard) import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Base32 as B32 import qualified Data.ByteString.Bech32.Internal as BI-import qualified Data.ByteString.Internal as BSI-import qualified Data.Char as C (toLower, isLower, isAlpha) -create_checksum :: BS.ByteString -> BS.ByteString -> BS.ByteString-create_checksum = BI.create_checksum BI.Bech32- -- | Encode a base256 human-readable part and input as bech32. -- -- >>> let Just bech32 = encode "bc" "my string"@@ -40,38 +31,26 @@ :: BS.ByteString -- ^ base256-encoded human-readable part -> BS.ByteString -- ^ base256-encoded data part -> Maybe BS.ByteString -- ^ bech32-encoded bytestring-encode (B8.map C.toLower -> hrp) (B32.encode -> dat) = do- guard (BI.valid_hrp hrp)- ws <- BI.as_word5 dat- let check = create_checksum hrp ws- res = BS.concat [hrp, BS.singleton 49, dat, BI.as_base32 check]- guard (BS.length res < 91)- pure res+encode = BI.encode BI.Bech32 -- | Decode a bech32-encoded 'ByteString' into its human-readable and data -- parts. --+-- All-uppercase input is accepted, and its human-readable part is+-- returned in lowercase. Mixed-case input produces 'Nothing'.+-- -- >>> decode "hi1df6x7cnfdcs8wctnyp5x2un9wed5st" -- Just ("hi","jtobin was here") -- >>> decode "hey1df6x7cnfdcs8wctnyp5x2un9wed5st" -- s/hi/hey -- Nothing decode- :: BS.ByteString -- ^ bech23-encoded bytestring+ :: BS.ByteString -- ^ bech32-encoded bytestring -> Maybe (BS.ByteString, BS.ByteString) -- ^ (hrp, data less checksum)-decode bs@(BSI.PS _ _ l) = do- guard (l <= 90)- guard (B8.all (\a -> if C.isAlpha a then C.isLower a else True) bs)- guard (verify bs)- sep <- BS.elemIndexEnd 0x31 bs- case BS.splitAt sep bs of- (hrp, raw) -> do- guard (BI.valid_hrp hrp)- guard (BS.length raw >= 6)- (_, BS.dropEnd 6 -> bech32dat) <- BS.uncons raw- dat <- B32.decode bech32dat- pure (hrp, dat)+decode = BI.decode BI.Bech32 -- | Verify that a bech32 string has a valid checksum.+--+-- All-uppercase input is accepted; mixed-case input is not. -- -- >>> verify "bc1d4ujqum5wf5kuecmu02w2" -- True
lib/Data/ByteString/Bech32/Internal.hs view
@@ -1,6 +1,5 @@ {-# OPTIONS_HADDOCK hide, prune #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} module Data.ByteString.Bech32.Internal (@@ -10,12 +9,17 @@ , create_checksum , verify , valid_hrp+ , encode+ , decode ) where +import Control.Monad (guard) import Data.Bits ((.&.), (.|.)) import qualified Data.Bits as B import qualified Data.ByteString as BS-import Data.ByteString.Base32.Internal (enc_tab, dec_tab)+import qualified Data.ByteString.Base32 as B32+import Data.ByteString.Base32.Internal+ (enc_tab, dec_tab, w5_tab, encode_with) import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Unsafe as BU import Data.Word (Word8, Word32)@@ -54,7 +58,7 @@ pure $! if ok then Just (BI.PS fp 0 l) else Nothing -- | Translate a 5-bit-value bytestring to its bech32 base32--- bytestring.+-- bytestring. Only the low 5 bits of each input byte are used. as_base32 :: BS.ByteString -> BS.ByteString as_base32 (BI.PS sfp soff l) = case enc_tab of BI.PS tfp toff _ ->@@ -67,33 +71,28 @@ | i == l = pure () | otherwise = do v <- peekElemOff sp i- c <- peekElemOff tp (fi v)+ c <- peekElemOff tp (fi (v .&. 0x1f)) pokeElemOff dst i c loop (i + 1) loop 0 polymod :: BS.ByteString -> Word32 polymod = BS.foldl' alg 1 where- generator :: Int -> Word32- generator = \case- 0 -> 0x3b6a57b2- 1 -> 0x26508e6d- 2 -> 0x1ea119fa- 3 -> 0x3d4233dd- 4 -> 0x2a1462b3- _ -> error "ppad-bech32: internal error (please report this as a bug!)"- alg !chk v = let !b = chk `B.shiftR` 25- c = (chk .&. 0x1ffffff) `B.shiftL` 5 `B.xor` fi v- in loop_gen 0 b c+ !c = (chk .&. 0x1ffffff) `B.shiftL` 5 `B.xor` fi v+ in c `B.xor` gen b 0 0x3b6a57b2+ `B.xor` gen b 1 0x26508e6d+ `B.xor` gen b 2 0x1ea119fa+ `B.xor` gen b 3 0x3d4233dd+ `B.xor` gen b 4 0x2a1462b3 - loop_gen i b !chk- | i > 4 = chk- | otherwise =- let sor | B.testBit (b `B.shiftR` i) 0 = generator i- | otherwise = 0- in loop_gen (succ i) b (chk `B.xor` sor)+ -- the generator 'g' if bit 'i' of 'b' is set, else zero+ gen :: Word32 -> Int -> Word32 -> Word32+ gen b i g+ | B.testBit b i = g+ | otherwise = 0+ {-# INLINE gen #-} valid_hrp :: BS.ByteString -> Bool valid_hrp hrp@(BI.PS _ _ l)@@ -146,16 +145,80 @@ pokeElemOff dst 4 (fi (pm `B.shiftR` 5) .&. 0x1f :: Word8) pokeElemOff dst 5 (fi pm .&. 0x1f :: Word8) +-- | Lowercase an all-uppercase string. Mixed-case strings (some+-- ASCII uppercase and some ASCII lowercase characters) are rejected,+-- per BIP173.+normalize_case :: BS.ByteString -> Maybe BS.ByteString+normalize_case bs+ | has_upper && BS.any is_lower bs = Nothing+ | has_upper = Just $! BS.map to_lower bs+ | otherwise = Just bs+ where+ has_upper = BS.any is_upper bs++is_upper :: Word8 -> Bool+is_upper c = c >= 0x41 && c <= 0x5A+{-# INLINE is_upper #-}++is_lower :: Word8 -> Bool+is_lower c = c >= 0x61 && c <= 0x7A+{-# INLINE is_lower #-}++to_lower :: Word8 -> Word8+to_lower c+ | is_upper c = c + 0x20+ | otherwise = c+{-# INLINE to_lower #-}++-- | Does a lowercase hrp and data part (5-bit values plus a 6-value+-- checksum, as bech32 characters) carry a valid checksum?+valid_checksum :: Encoding -> BS.ByteString -> BS.ByteString -> Bool+valid_checksum enc hrp dat+ | BS.length dat < 6 = False+ | otherwise = case as_word5 dat of+ Nothing -> False+ Just ws -> polymod (hrp_expand hrp <> ws) == case enc of+ Bech32 -> 1+ Bech32m -> _BECH32M_CONST++-- | Verify that a bech32 or bech32m string has a valid checksum.+-- All-uppercase input is accepted; mixed-case input is not. verify :: Encoding -> BS.ByteString -> Bool-verify enc b32 = case BS.elemIndexEnd 0x31 b32 of- Nothing -> False- Just idx ->- let (hrp, BU.unsafeDrop 1 -> dat) = BS.splitAt idx b32- w5s = as_word5 dat- in case w5s of- Nothing -> False- Just ws ->- let bs = hrp_expand hrp <> ws- in polymod bs == case enc of- Bech32 -> 1- Bech32m -> _BECH32M_CONST+verify enc b32 = case normalize_case b32 of+ Nothing -> False+ Just bs -> case BS.elemIndexEnd 0x31 bs of+ Nothing -> False+ Just idx ->+ let (hrp, BU.unsafeDrop 1 -> dat) = BS.splitAt idx bs+ in valid_checksum enc hrp dat++-- | Encode a human-readable part and base256 data as bech32 or+-- bech32m. The human-readable part is lowercased.+encode+ :: Encoding+ -> BS.ByteString -- ^ base256-encoded human-readable part+ -> BS.ByteString -- ^ base256-encoded data part+ -> Maybe BS.ByteString -- ^ bech32-encoded bytestring+encode enc (BS.map to_lower -> hrp) dat = do+ guard (valid_hrp hrp)+ let !ws = encode_with w5_tab dat+ guard (BS.length hrp + BS.length ws + 7 <= 90)+ let !chk = create_checksum enc hrp ws+ pure $! BS.concat [hrp, BS.singleton 0x31, as_base32 ws, as_base32 chk]++-- | Decode a bech32 or bech32m string into its (lowercase)+-- human-readable part and base256 data part. All-uppercase input+-- is accepted; mixed-case input is not.+decode+ :: Encoding+ -> BS.ByteString -- ^ bech32-encoded bytestring+ -> Maybe (BS.ByteString, BS.ByteString) -- ^ (hrp, data less checksum)+decode enc b32 = do+ guard (BS.length b32 <= 90)+ bs <- normalize_case b32+ sep <- BS.elemIndexEnd 0x31 bs+ let (hrp, BU.unsafeDrop 1 -> raw) = BS.splitAt sep bs+ guard (valid_hrp hrp)+ guard (valid_checksum enc hrp raw)+ dat <- B32.decode (BS.dropEnd 6 raw)+ pure (hrp, dat)
lib/Data/ByteString/Bech32m.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_HADDOCK prune #-}-{-# LANGUAGE ViewPatterns #-} -- | -- Module: Data.ByteString.Bech32m@@ -21,17 +20,9 @@ , verify ) where -import Control.Monad (guard) import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Base32 as B32 import qualified Data.ByteString.Bech32.Internal as BI-import qualified Data.ByteString.Internal as BSI-import qualified Data.Char as C (toLower) -create_checksum :: BS.ByteString -> BS.ByteString -> BS.ByteString-create_checksum = BI.create_checksum BI.Bech32m- -- | Encode a base256 human-readable part and input as bech32m. -- -- >>> let Just bech32m = encode "bc" "my string"@@ -41,37 +32,26 @@ :: BS.ByteString -- ^ base256-encoded human-readable part -> BS.ByteString -- ^ base256-encoded data part -> Maybe BS.ByteString -- ^ bech32m-encoded bytestring-encode (B8.map C.toLower -> hrp) (B32.encode -> dat) = do- guard (BI.valid_hrp hrp)- ws <- BI.as_word5 dat- let check = create_checksum hrp ws- res = BS.concat [hrp, BS.singleton 49, dat, BI.as_base32 check]- guard (BS.length res < 91)- pure res+encode = BI.encode BI.Bech32m -- | Decode a bech32m-encoded 'ByteString' into its human-readable and data -- parts. --+-- All-uppercase input is accepted, and its human-readable part is+-- returned in lowercase. Mixed-case input produces 'Nothing'.+-- -- >>> decode "hi1df6x7cnfdcs8wctnyp5x2un9m9ac4f" -- Just ("hi","jtobin was here") -- >>> decode "hey1df6x7cnfdcs8wctnyp5x2un9m9ac4f" -- s/hi/hey -- Nothing decode- :: BS.ByteString -- ^ bech23-encoded bytestring+ :: BS.ByteString -- ^ bech32m-encoded bytestring -> Maybe (BS.ByteString, BS.ByteString) -- ^ (hrp, data less checksum)-decode bs@(BSI.PS _ _ l) = do- guard (l <= 90)- guard (verify bs)- sep <- BS.elemIndexEnd 0x31 bs- case BS.splitAt sep bs of- (hrp, raw) -> do- guard (BI.valid_hrp hrp)- guard (BS.length raw >= 6)- (_, BS.dropEnd 6 -> bech32dat) <- BS.uncons raw- dat <- B32.decode bech32dat- pure (hrp, dat)+decode = BI.decode BI.Bech32m -- | Verify that a bech32m string has a valid checksum.+--+-- All-uppercase input is accepted; mixed-case input is not. -- -- >>> verify "bc1d4ujqum5wf5kuecwqlxtg" -- True
ppad-bech32.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-bech32-version: 0.2.5+version: 0.2.6 synopsis: bech32 and bech32m encoding/decoding, per BIPs 173 & 350. license: MIT license-file: LICENSE@@ -58,6 +58,7 @@ , bytestring , ppad-bech32 , tasty+ , tasty-hunit , tasty-quickcheck benchmark bech32-bench
test/Main.hs view
@@ -1,12 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+ module Main where import qualified Data.Char as C import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Bech32 as Bech32+import qualified Data.ByteString.Bech32.Internal as BI import qualified Data.ByteString.Bech32m as Bech32m import qualified Data.ByteString.Base32 as B32+import Data.Word (Word8) import Test.Tasty+import qualified Test.Tasty.HUnit as H import qualified Test.Tasty.QuickCheck as Q import qualified Reference.Bech32 as R @@ -19,6 +25,15 @@ data InvalidInput = InvalidInput BS.ByteString BS.ByteString deriving (Eq, Show) +-- | A list of 5-bit values.+newtype Word5s = Word5s [Word8]+ deriving (Eq, Show)++-- | A canonical base32 string with one character replaced by a byte+-- outside the bech32 character set.+newtype Corrupted = Corrupted BS.ByteString+ deriving (Eq, Show)+ instance Q.Arbitrary ValidInput where arbitrary = do h <- hrp@@ -40,6 +55,26 @@ b <- bytes 1024 pure (BS b) +instance Q.Arbitrary Word5s where+ arbitrary = do+ l <- Q.chooseInt (0, 100)+ Word5s <$> Q.vectorOf l (Q.choose (0, 31))++instance Q.Arbitrary Corrupted where+ arbitrary = do+ l <- Q.chooseInt (1, 100)+ b <- BS.pack <$> Q.vectorOf l Q.arbitrary+ let enc = B32.encode b+ i <- Q.chooseInt (0, BS.length enc - 1)+ c <- Q.elements non_charset+ pure (Corrupted (BS.take i enc <> BS.singleton c <> BS.drop (i + 1) enc))++charset :: BS.ByteString+charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"++non_charset :: [Word8]+non_charset = filter (\b -> not (BS.elem b charset)) [0 .. 255]+ hrp :: Q.Gen BS.ByteString hrp = do l <- Q.chooseInt (1, 83)@@ -58,6 +93,14 @@ v <- Q.vectorOf l Q.arbitrary pure (BS.pack v) +lower :: BS.ByteString -> BS.ByteString+lower = B8.map C.toLower++upper :: BS.ByteString -> BS.ByteString+upper = B8.map C.toUpper++-- properties -----------------------------------------------------------------+ matches_reference :: ValidInput -> Bool matches_reference (ValidInput h b) = let ref = R.bech32Encode h (R.toBase32 (BS.unpack b))@@ -66,23 +109,46 @@ bech32_decode_inverts_encode :: ValidInput -> Bool bech32_decode_inverts_encode (ValidInput h b) = case Bech32.encode h b of- Nothing -> error "generated faulty input"+ Nothing -> False Just enc -> case Bech32.decode enc of Nothing -> False Just (h', dat) -> h == h' && b == dat bech32m_decode_inverts_encode :: ValidInput -> Bool bech32m_decode_inverts_encode (ValidInput h b) = case Bech32m.encode h b of- Nothing -> error "generated faulty input"+ Nothing -> False Just enc -> case Bech32m.decode enc of Nothing -> False Just (h', dat) -> h == h' && b == dat +bech32_decode_inverts_encode_upper :: ValidInput -> Bool+bech32_decode_inverts_encode_upper (ValidInput h b) =+ case Bech32.encode h b of+ Nothing -> False+ Just (upper -> enc) ->+ Bech32.verify enc && Bech32.decode enc == Just (h, b)++bech32m_decode_inverts_encode_upper :: ValidInput -> Bool+bech32m_decode_inverts_encode_upper (ValidInput h b) =+ case Bech32m.encode h b of+ Nothing -> False+ Just (upper -> enc) ->+ Bech32m.verify enc && Bech32m.decode enc == Just (h, b)+ base32_decode_inverts_encode :: BS -> Bool base32_decode_inverts_encode (BS bs) = case B32.decode (B32.encode bs) of Nothing -> False Just b -> b == bs +base32_decode_matches_reference :: Word5s -> Bool+base32_decode_matches_reference (Word5s ws) =+ let ours = B32.decode (BI.as_base32 (BS.pack ws))+ ref = R.toBase256 (fmap R.word5 ws)+ in ours == fmap BS.pack ref++base32_decode_rejects_invalid_char :: Corrupted -> Bool+base32_decode_rejects_invalid_char (Corrupted bs) = B32.decode bs == Nothing+ bech32_invalid_input_fails_encode :: InvalidInput -> Bool bech32_invalid_input_fails_encode (InvalidInput h b) = case Bech32.encode h b of@@ -95,25 +161,213 @@ Nothing -> True Just _ -> False +-- vectors --------------------------------------------------------------------++-- BIP173 and BIP350 checksum test vectors. Each valid vector is+-- paired with whether its data part converts to bytes: the long+-- all-'l' bech32m vector has a valid checksum, but its data part+-- leaves nonzero padding bits, so 'decode' (which returns bytes)+-- rejects it.++bip173_valid :: [(BS.ByteString, Bool)]+bip173_valid = [+ ("A12UEL5L", True)+ , ("a12uel5l", True)+ , ("an83characterlonghumanreadablepartthatcontainsthenumber1\+ \andtheexcludedcharactersbio1tt5tgs", True)+ , ("abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw", True)+ , ("11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq\+ \qqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j", True)+ , ("split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w", True)+ , ("?1ezyfcl", True)+ ]++bip173_invalid :: [BS.ByteString]+bip173_invalid = [+ BS.cons 0x20 "1nwldj5"+ , BS.cons 0x7f "1axkwrx"+ , BS.cons 0x80 "1eym55h"+ , "an84characterslonghumanreadablepartthatcontainsthenumber\+ \1andtheexcludedcharactersbio1569pvx"+ , "pzry9x0s0muk"+ , "1pzry9x0s0muk"+ , "x1b4n0q5v"+ , "li1dgmt3"+ , BS.snoc "de1lg7wt" 0xff+ , "A1G7SGD8"+ , "10a06t8"+ , "1qzzfhee"+ ]++bip350_valid :: [(BS.ByteString, Bool)]+bip350_valid = [+ ("A1LQFN3A", True)+ , ("a1lqfn3a", True)+ , ("an83characterlonghumanreadablepartthatcontainsthetheexcl\+ \udedcharactersbioandnumber11sg7hg6", True)+ , ("abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx", True)+ , ("11llllllllllllllllllllllllllllllllllllllllllllllllllllll\+ \llllllllllllllllllllllllllllludsr8", False)+ , ("split1checkupstagehandshakeupstreamerranterredcaperredlc445v", True)+ , ("?1v759aa", True)+ ]++bip350_invalid :: [BS.ByteString]+bip350_invalid = [+ BS.cons 0x20 "1xj0phk"+ , BS.cons 0x7f "1g6xzxy"+ , BS.cons 0x80 "1vctc34"+ , "an84characterslonghumanreadablepartthatcontainsthetheexc\+ \ludedcharactersbioandnumber11d6pts4"+ , "qyrz8wqd2c9m"+ , "1qyrz8wqd2c9m"+ , "y1b0jsk6g"+ , "lt1igcx5c0"+ , "in1muywd"+ , "mm1crxm3i"+ , "au1s5cgom"+ , "M1VUXWEZ"+ , "16plkw9"+ , "1p2gdwpf"+ ]++valid_vector+ :: (BS.ByteString -> Bool)+ -> (BS.ByteString -> Maybe (BS.ByteString, BS.ByteString))+ -> (BS.ByteString -> BS.ByteString -> Maybe BS.ByteString)+ -> (BS.ByteString, Bool)+ -> TestTree+valid_vector ver dec enc (s, convertible) = H.testCase (show s) $ do+ H.assertBool "verify" (ver s)+ if convertible+ then H.assertEqual "decode/encode" (Just (lower s)) $ do+ (h, d) <- dec s+ enc h d+ else H.assertEqual "decode" Nothing (dec s)++invalid_vector+ :: (BS.ByteString -> Maybe (BS.ByteString, BS.ByteString))+ -> BS.ByteString+ -> TestTree+invalid_vector dec s = H.testCase (show s) $+ H.assertEqual mempty Nothing (dec s)++-- valid in the other encoding, so invalid in this one+cross_vector+ :: (BS.ByteString -> Bool)+ -> (BS.ByteString -> Maybe (BS.ByteString, BS.ByteString))+ -> (BS.ByteString, Bool)+ -> TestTree+cross_vector ver dec (s, _) = H.testCase (show s) $ do+ H.assertBool "verify" (not (ver s))+ H.assertEqual "decode" Nothing (dec s)++-- a string whose checksum is computed over an uppercase hrp, with a+-- lowercase data part+upper_hrp_checksum :: BI.Encoding -> BS.ByteString+upper_hrp_checksum enc =+ let h = "BC"+ ws = BS.pack [0 .. 7]+ in BS.concat+ [h, "1", BI.as_base32 ws, BI.as_base32 (BI.create_checksum enc h ws)]++mixed_case :: TestTree+mixed_case = testGroup "mixed case" [+ H.testCase "bech32 (mixed vector)" $ do+ let s = "A12uEL5L"+ H.assertBool "verify" (not (Bech32.verify s))+ H.assertEqual "decode" Nothing (Bech32.decode s)+ , H.testCase "bech32m (mixed vector)" $ do+ let s = "a1LQFN3A"+ H.assertBool "verify" (not (Bech32m.verify s))+ H.assertEqual "decode" Nothing (Bech32m.decode s)+ , H.testCase "bech32 (uppercase-hrp checksum)" $ do+ let s = upper_hrp_checksum BI.Bech32+ H.assertBool "verify" (not (Bech32.verify s))+ H.assertEqual "decode" Nothing (Bech32.decode s)+ , H.testCase "bech32m (uppercase-hrp checksum)" $ do+ let s = upper_hrp_checksum BI.Bech32m+ H.assertEqual "construction" "BC1qpzry9x8gchca4" s+ H.assertBool "verify" (not (Bech32m.verify s))+ H.assertEqual "decode" Nothing (Bech32m.decode s)+ , H.testCase "bech32 (uppercase hrp, lowercase data)" $ do+ let s = "HI1df6x7cnfdcs8wctnyp5x2un9wed5st"+ H.assertBool "verify" (not (Bech32.verify s))+ H.assertEqual "decode" Nothing (Bech32.decode s)+ , H.testCase "bech32m (uppercase hrp, lowercase data)" $ do+ let s = "HI1df6x7cnfdcs8wctnyp5x2un9m9ac4f"+ H.assertBool "verify" (not (Bech32m.verify s))+ H.assertEqual "decode" Nothing (Bech32m.decode s)+ ]++base32_rejects :: TestTree+base32_rejects = testGroup "base32 decode" [+ H.testCase "invalid tail lengths (1, 3, 6 mod 8)" $+ mapM_ (\s -> H.assertEqual (show s) Nothing (B32.decode s)) [+ "q", "qqq", "qqqqqq"+ , "qqqqqqqqq", "qqqqqqqqqqq", "qqqqqqqqqqqqqq"+ ]+ , H.testCase "nonzero padding bits" $+ mapM_ (\s -> H.assertEqual (show s) Nothing (B32.decode s)) [+ "qp", "qqqp", "qqqqp", "qqqqqqp"+ , "qqqqqqqqqp", "qqqqqqqqqqqp"+ ]+ , H.testCase "zero padding bits" $ do+ H.assertEqual "qq" (Just "\NUL") (B32.decode "qq")+ H.assertEqual "qy" (Just "\SOH") (B32.decode "qy")+ H.assertEqual "qqqqqqqqqy" (Just "\NUL\NUL\NUL\NUL\NUL\SOH")+ (B32.decode "qqqqqqqqqy")+ , H.testCase "invalid characters" $+ mapM_ (\s -> H.assertEqual (show s) Nothing (B32.decode s)) [+ "qqqqqqqb", "qqqqqqqi", "qqqqqqqo", "qqqqqqq1"+ , "Qqqqqqqq", "qqqq qqq", BS.snoc "qqqqqqq" 0x80+ , BS.snoc "qqqqqqq" 0xff, BS.snoc "qqqqqqqqq" 0x00+ , "qqqqqqqqqb"+ ]+ ]+ main :: IO () main = defaultMain $ testGroup "ppad-bech32" [ testGroup "base32" [ Q.testProperty "decode . encode ~ id" $ Q.withMaxSuccess 1000 base32_decode_inverts_encode+ , Q.testProperty "decode ~ reference" $+ Q.withMaxSuccess 1000 base32_decode_matches_reference+ , Q.testProperty "decode rejects invalid characters" $+ Q.withMaxSuccess 1000 base32_decode_rejects_invalid_char+ , base32_rejects ] , testGroup "bech32" [ Q.testProperty "Bech32.encode ~ R.bech32Encode" $ Q.withMaxSuccess 1000 matches_reference , Q.testProperty "decode . encode ~ id" $ Q.withMaxSuccess 1000 bech32_decode_inverts_encode+ , Q.testProperty "decode . upper . encode ~ id" $+ Q.withMaxSuccess 1000 bech32_decode_inverts_encode_upper , Q.testProperty "invalid bech32 input fails to encode" $ Q.withMaxSuccess 1000 bech32_invalid_input_fails_encode+ , testGroup "BIP173 valid vectors" $+ fmap (valid_vector Bech32.verify Bech32.decode Bech32.encode)+ bip173_valid+ , testGroup "BIP173 invalid vectors" $+ fmap (invalid_vector Bech32.decode) bip173_invalid+ , testGroup "BIP350 valid vectors (invalid as bech32)" $+ fmap (cross_vector Bech32.verify Bech32.decode) bip350_valid ] , testGroup "bech32m" [ Q.testProperty "decode . encode ~ id" $ Q.withMaxSuccess 1000 bech32m_decode_inverts_encode+ , Q.testProperty "decode . upper . encode ~ id" $+ Q.withMaxSuccess 1000 bech32m_decode_inverts_encode_upper , Q.testProperty "invalid bech32m input fails to encode" $- Q.withMaxSuccess 1000 bech32_invalid_input_fails_encode+ Q.withMaxSuccess 1000 bech32m_invalid_input_fails_encode+ , testGroup "BIP350 valid vectors" $+ fmap (valid_vector Bech32m.verify Bech32m.decode Bech32m.encode)+ bip350_valid+ , testGroup "BIP350 invalid vectors" $+ fmap (invalid_vector Bech32m.decode) bip350_invalid+ , testGroup "BIP173 valid vectors (invalid as bech32m)" $+ fmap (cross_vector Bech32m.verify Bech32m.decode) bip173_valid ]+ , mixed_case ]-