commit f2f222199acbc13ddfadd2efaa50d2e9f0277e90
parent 6799a096bbd4d257d11e86b19f1e13137ae2eedd
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 14 Dec 2024 05:11:04 -0330
test: check against reference
Diffstat:
3 files changed, 201 insertions(+), 1 deletion(-)
diff --git a/ppad-bech32.cabal b/ppad-bech32.cabal
@@ -37,12 +37,16 @@ test-suite bech32-tests
default-language: Haskell2010
hs-source-dirs: test
main-is: Main.hs
+ other-modules:
+ Reference.Bech32
ghc-options:
-rtsopts -Wall -O2
build-depends:
base
+ , array
+ , bytestring
, ppad-bech32
, tasty
, tasty-quickcheck
diff --git a/test/Main.hs b/test/Main.hs
@@ -1,3 +1,38 @@
module Main where
-main = pure ()
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Bech32 as Bech32
+import Test.Tasty
+import qualified Test.Tasty.QuickCheck as Q
+import qualified Reference.Bech32 as R
+
+data Input = Input BS.ByteString BS.ByteString
+ deriving (Eq, Show)
+
+instance Q.Arbitrary Input where
+ arbitrary = do
+ h <- hrp
+ b <- bytes (83 - BS.length h)
+ pure (Input h b)
+
+hrp :: Q.Gen BS.ByteString
+hrp = do
+ l <- Q.chooseInt (1, 83)
+ v <- Q.vectorOf l (Q.choose (33, 126))
+ pure (BS.pack v)
+
+bytes :: Int -> Q.Gen BS.ByteString
+bytes k = do
+ l <- Q.chooseInt (0, k)
+ v <- Q.vectorOf l Q.arbitrary
+ pure (BS.pack v)
+
+matches :: Input -> Bool
+matches (Input h b) =
+ let ref = R.bech32Encode h (R.toBase32 (BS.unpack b))
+ our = Bech32.encode h b
+ in ref == our
+
+main :: IO ()
+main = defaultMain $
+ Q.testProperty "encoding matches reference" matches
diff --git a/test/Reference/Bech32.hs b/test/Reference/Bech32.hs
@@ -0,0 +1,161 @@
+-- official BIP173 reference
+-- https://github.com/sipa/bech32/tree/master/ref/haskell
+module Reference.Bech32
+ ( bech32Encode
+ , bech32Decode
+ , toBase32
+ , toBase256
+ , segwitEncode
+ , segwitDecode
+ , Word5()
+ , word5
+ , fromWord5
+ ) where
+
+import Control.Monad (guard)
+import qualified Data.Array as Arr
+import Data.Bits (Bits, unsafeShiftL, unsafeShiftR, (.&.), (.|.), xor, testBit)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
+import Data.Char (toLower, toUpper)
+import Data.Foldable (foldl')
+import Data.Functor.Identity (Identity, runIdentity)
+import Data.Ix (Ix(..))
+import Data.Word (Word8)
+
+type HRP = BS.ByteString
+type Data = [Word8]
+
+(.>>.), (.<<.) :: Bits a => a -> Int -> a
+(.>>.) = unsafeShiftR
+(.<<.) = unsafeShiftL
+
+newtype Word5 = UnsafeWord5 Word8
+ deriving (Eq, Ord)
+
+instance Ix Word5 where
+ range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n)
+ index (UnsafeWord5 m, UnsafeWord5 n) (UnsafeWord5 i) = index (m, n) i
+ inRange (m,n) i = m <= i && i <= n
+
+word5 :: Integral a => a -> Word5
+word5 x = UnsafeWord5 ((fromIntegral x) .&. 31)
+{-# INLINE word5 #-}
+{-# SPECIALIZE INLINE word5 :: Word8 -> Word5 #-}
+
+fromWord5 :: Num a => Word5 -> a
+fromWord5 (UnsafeWord5 x) = fromIntegral x
+{-# INLINE fromWord5 #-}
+{-# SPECIALIZE INLINE fromWord5 :: Word5 -> Word8 #-}
+
+charset :: Arr.Array Word5 Char
+charset = Arr.listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
+
+charsetMap :: Char -> Maybe Word5
+charsetMap c | inRange (Arr.bounds inv) upperC = inv Arr.! upperC
+ | otherwise = Nothing
+ where
+ upperC = toUpper c
+ inv = Arr.listArray ('0', 'Z') (repeat Nothing) Arr.// (map swap (Arr.assocs charset))
+ swap (a, b) = (toUpper b, Just a)
+
+bech32Polymod :: [Word5] -> Word
+bech32Polymod values = foldl' go 1 values .&. 0x3fffffff
+ where
+ go chk value = foldl' xor chk' [g | (g, i) <- zip generator [25..], testBit chk i]
+ where
+ generator = [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3]
+ chk' = chk .<<. 5 `xor` (fromWord5 value)
+
+bech32HRPExpand :: HRP -> [Word5]
+bech32HRPExpand hrp = map (UnsafeWord5 . (.>>. 5)) (BS.unpack hrp) ++ [UnsafeWord5 0] ++ map word5 (BS.unpack hrp)
+
+bech32CreateChecksum :: HRP -> [Word5] -> [Word5]
+bech32CreateChecksum hrp dat = [word5 (polymod .>>. i) | i <- [25,20..0]]
+ where
+ values = bech32HRPExpand hrp ++ dat
+ polymod = bech32Polymod (values ++ map UnsafeWord5 [0, 0, 0, 0, 0, 0]) `xor` 1
+
+bech32VerifyChecksum :: HRP -> [Word5] -> Bool
+bech32VerifyChecksum hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat) == 1
+
+bech32Encode :: HRP -> [Word5] -> Maybe BS.ByteString
+bech32Encode hrp dat = do
+ guard $ checkHRP hrp
+ let dat' = dat ++ bech32CreateChecksum hrp dat
+ rest = map (charset Arr.!) dat'
+ result = BSC.concat [BSC.map toLower hrp, BSC.pack "1", BSC.pack rest]
+ guard $ BS.length result <= 90
+ return result
+
+checkHRP :: BS.ByteString -> Bool
+checkHRP hrp = not (BS.null hrp) && BS.all (\char -> char >= 33 && char <= 126) hrp
+
+bech32Decode :: BS.ByteString -> Maybe (HRP, [Word5])
+bech32Decode bech32 = do
+ guard $ BS.length bech32 <= 90
+ guard $ BSC.map toUpper bech32 == bech32 || BSC.map toLower bech32 == bech32
+ let (hrp, dat) = BSC.breakEnd (== '1') $ BSC.map toLower bech32
+ guard $ BS.length dat >= 6
+ hrp' <- BSC.stripSuffix (BSC.pack "1") hrp
+ guard $ checkHRP hrp'
+ dat' <- mapM charsetMap $ BSC.unpack dat
+ guard $ bech32VerifyChecksum hrp' dat'
+ return (hrp', take (BS.length dat - 6) dat')
+
+type Pad f = Int -> Int -> Word -> [[Word]] -> f [[Word]]
+
+yesPadding :: Pad Identity
+yesPadding _ 0 _ result = return result
+yesPadding _ _ padValue result = return $ [padValue] : result
+{-# INLINE yesPadding #-}
+
+noPadding :: Pad Maybe
+noPadding frombits bits padValue result = do
+ guard $ bits < frombits && padValue == 0
+ return result
+{-# INLINE noPadding #-}
+
+-- Big endian conversion of a bytestring from base 2^frombits to base 2^tobits.
+-- frombits and twobits must be positive and 2^frombits and 2^tobits must be smaller than the size of Word.
+-- Every value in dat must be strictly smaller than 2^frombits.
+convertBits :: Functor f => [Word] -> Int -> Int -> Pad f -> f [Word]
+convertBits dat frombits tobits pad = fmap (concat . reverse) $ go dat 0 0 []
+ where
+ go [] acc bits result =
+ let padValue = (acc .<<. (tobits - bits)) .&. maxv
+ in pad frombits bits padValue result
+ go (value:dat') acc bits result = go dat' acc' (bits' `rem` tobits) (result':result)
+ where
+ acc' = (acc .<<. frombits) .|. fromIntegral value
+ bits' = bits + frombits
+ result' = [(acc' .>>. b) .&. maxv | b <- [bits'-tobits,bits'-2*tobits..0]]
+ maxv = (1 .<<. tobits) - 1
+{-# INLINE convertBits #-}
+
+toBase32 :: [Word8] -> [Word5]
+toBase32 dat = map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5 yesPadding
+
+toBase256 :: [Word5] -> Maybe [Word8]
+toBase256 dat = fmap (map fromIntegral) $ convertBits (map fromWord5 dat) 5 8 noPadding
+
+segwitCheck :: Word8 -> Data -> Bool
+segwitCheck witver witprog =
+ witver <= 16 &&
+ if witver == 0
+ then length witprog == 20 || length witprog == 32
+ else length witprog >= 2 && length witprog <= 40
+
+segwitDecode :: HRP -> BS.ByteString -> Maybe (Word8, Data)
+segwitDecode hrp addr = do
+ (hrp', dat) <- bech32Decode addr
+ guard $ (hrp == hrp') && not (null dat)
+ let (UnsafeWord5 witver : datBase32) = dat
+ decoded <- toBase256 datBase32
+ guard $ segwitCheck witver decoded
+ return (witver, decoded)
+
+segwitEncode :: HRP -> Word8 -> Data -> Maybe BS.ByteString
+segwitEncode hrp witver witprog = do
+ guard $ segwitCheck witver witprog
+ bech32Encode hrp $ UnsafeWord5 witver : toBase32 witprog
