diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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. diff --git a/lib/Data/ByteString/Base32.hs b/lib/Data/ByteString/Base32.hs --- a/lib/Data/ByteString/Base32.hs +++ b/lib/Data/ByteString/Base32.hs @@ -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'. diff --git a/lib/Data/ByteString/Base32/Internal.hs b/lib/Data/ByteString/Base32/Internal.hs --- a/lib/Data/ByteString/Base32/Internal.hs +++ b/lib/Data/ByteString/Base32/Internal.hs @@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide, prune #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -7,16 +8,30 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- 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 diff --git a/lib/Data/ByteString/Bech32.hs b/lib/Data/ByteString/Bech32.hs --- a/lib/Data/ByteString/Bech32.hs +++ b/lib/Data/ByteString/Bech32.hs @@ -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 diff --git a/lib/Data/ByteString/Bech32/Internal.hs b/lib/Data/ByteString/Bech32/Internal.hs --- a/lib/Data/ByteString/Bech32/Internal.hs +++ b/lib/Data/ByteString/Bech32/Internal.hs @@ -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) diff --git a/lib/Data/ByteString/Bech32m.hs b/lib/Data/ByteString/Bech32m.hs --- a/lib/Data/ByteString/Bech32m.hs +++ b/lib/Data/ByteString/Bech32m.hs @@ -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 diff --git a/ppad-bech32.cabal b/ppad-bech32.cabal --- a/ppad-bech32.cabal +++ b/ppad-bech32.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ] -