Skip to content

Commit c31bf76

Browse files
roconnor-blockstreamroconnor-blockstream
committed
Update Haskell reference code to support Bech32m.
1 parent d4cbb65 commit c31bf76

File tree

2 files changed

+112
-52
lines changed

2 files changed

+112
-52
lines changed

‎ref/haskell/src/Codec/Binary/Bech32.hs

Lines changed: 30 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -2,9 +2,11 @@ module Codec.Binary.Bech32
22
(
33
DecodeError(..)
44
, EncodeError(..)
5+
, Bech32Type(..)
56

67
, bech32Encode
78
, bech32Decode
9+
, bech32Spec
810
, toBase32
911
, toBase256
1012
, segwitEncode
@@ -72,24 +74,24 @@ bech32Polymod values = foldl' go 1 values .&. 0x3fffffff
7274
bech32HRPExpand :: HRP -> [Word5]
7375
bech32HRPExpand hrp = map (UnsafeWord5 . (.>>. 5)) (BS.unpack hrp) ++ [UnsafeWord5 0] ++ map word5 (BS.unpack hrp)
7476

75-
bech32CreateChecksum :: HRP -> [Word5] -> [Word5]
76-
bech32CreateChecksum hrp dat = [word5 (polymod .>>. i) | i <- [25,20..0]]
77+
bech32CreateChecksum :: Word -> HRP -> [Word5] -> [Word5]
78+
bech32CreateChecksum residue hrp dat = [word5 (polymod .>>. i) | i <- [25,20..0]]
7779
where
7880
values = bech32HRPExpand hrp ++ dat
79-
polymod = bech32Polymod (values ++ map UnsafeWord5 [0, 0, 0, 0, 0, 0]) `xor` 1
81+
polymod = bech32Polymod (values ++ map UnsafeWord5 [0, 0, 0, 0, 0, 0]) `xor` residue
8082

81-
bech32VerifyChecksum :: HRP -> [Word5] -> Bool
82-
bech32VerifyChecksum hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat) == 1
83+
bech32Residue :: HRP -> [Word5] -> Word
84+
bech32Residue hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat)
8385

8486
data EncodeError =
8587
ResultStringLengthExceeded
8688
| InvalidHumanReadablePart
8789
deriving (Show, Eq)
8890

89-
bech32Encode :: HRP -> [Word5] -> Either EncodeError BS.ByteString
90-
bech32Encode hrp dat = do
91+
bech32Encode :: Word -> HRP -> [Word5] -> Either EncodeError BS.ByteString
92+
bech32Encode residue hrp dat = do
9193
verify InvalidHumanReadablePart $ validHRP hrp
92-
let dat' = dat ++ bech32CreateChecksum hrp dat
94+
let dat' = dat ++ bech32CreateChecksum residue hrp dat
9395
rest = map (charset Arr.!) dat'
9496
result = BSC.concat [BSC.map toLower hrp, BSC.pack "1", BSC.pack rest]
9597
verify ResultStringLengthExceeded $ BS.length result <= 90
@@ -107,7 +109,7 @@ data DecodeError =
107109
| InvalidCharsetMap
108110
deriving (Show, Eq)
109111

110-
bech32Decode :: BS.ByteString -> Either DecodeError (HRP, [Word5])
112+
bech32Decode :: BS.ByteString -> Either DecodeError (Word, HRP, [Word5])
111113
bech32Decode bech32 = do
112114
verify Bech32StringLengthExceeded $ BS.length bech32 <= 90
113115
verify CaseInconsistency $ validCase bech32
@@ -116,8 +118,8 @@ bech32Decode bech32 = do
116118
hrp' <- maybeToRight InvalidHRP $ BSC.stripSuffix (BSC.pack "1") hrp
117119
verify InvalidHRP $ validHRP hrp'
118120
dat' <- maybeToRight InvalidCharsetMap . mapM charsetMap $ BSC.unpack dat
119-
verify ChecksumVerificationFail $ bech32VerifyChecksum hrp' dat'
120-
return (hrp', take (BS.length dat - 6) dat')
121+
let residue = bech32Residue hrp' dat'
122+
return (residue, hrp', take (BS.length dat - 6) dat')
121123
where
122124
validCase :: BS.ByteString -> Bool
123125
validCase b32 = BSC.map toUpper b32 == b32 || BSC.map toLower b32 == b32
@@ -158,26 +160,34 @@ toBase32 dat = map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5
158160
toBase256 :: [Word5] -> Maybe [Word8]
159161
toBase256 dat = fmap (map fromIntegral) $ convertBits (map fromWord5 dat) 5 8 noPadding
160162

161-
segwitCheck :: Word8 -> Data -> Bool
162-
segwitCheck witver witprog =
163-
witver <= 16 &&
163+
data Bech32Type = Bech32
164+
| Bech32m
165+
166+
bech32Spec :: Bech32Type -> Word
167+
bech32Spec Bech32 = 1
168+
bech32Spec Bech32m = 0x2bc830a3
169+
170+
segwitCheck :: Word8 -> Data -> Maybe Bech32Type
171+
segwitCheck witver witprog = do
172+
guard $ witver <= 16
164173
if witver == 0
165-
then length witprog == 20 || length witprog == 32
166-
else length witprog >= 2 && length witprog <= 40
174+
then guard (length witprog == 20 || length witprog == 32) >> return Bech32
175+
else guard (length witprog >= 2 && length witprog <= 40) >> return Bech32m
167176

168177
segwitDecode :: HRP -> BS.ByteString -> Maybe (Word8, Data)
169178
segwitDecode hrp addr = do
170-
(hrp', dat) <- rightToMaybe $ bech32Decode addr
179+
(residue, hrp', dat) <- rightToMaybe $ bech32Decode addr
171180
guard $ (hrp == hrp') && not (null dat)
172181
let (UnsafeWord5 witver : datBase32) = dat
173182
decoded <- toBase256 datBase32
174-
guard $ segwitCheck witver decoded
183+
b32type <- segwitCheck witver decoded
184+
guard $ bech32Spec b32type == residue
175185
return (witver, decoded)
176186

177187
segwitEncode :: HRP -> Word8 -> Data -> Maybe BS.ByteString
178188
segwitEncode hrp witver witprog = do
179-
guard $ segwitCheck witver witprog
180-
rightToMaybe $ bech32Encode hrp $ UnsafeWord5 witver : toBase32 witprog
189+
b32type <- segwitCheck witver witprog
190+
rightToMaybe $ bech32Encode (bech32Spec b32type) hrp $ UnsafeWord5 witver : toBase32 witprog
181191

182192
rightToMaybe :: Either l r -> Maybe r
183193
rightToMaybe = either (const Nothing) Just

‎ref/haskell/test/Spec.hs

Lines changed: 82 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,12 @@
1-
import Codec.Binary.Bech32 (DecodeError (..), EncodeError (..), bech32Decode, bech32Encode,
1+
import Codec.Binary.Bech32 (DecodeError (..), EncodeError (..), Bech32Type(..),
2+
bech32Decode, bech32Encode, bech32Spec,
23
segwitDecode, segwitEncode, word5)
34
import Control.Monad (forM_)
45
import Data.Bits (xor)
56
import qualified Data.ByteString as BS
67
import qualified Data.ByteString.Base16 as B16
78
import qualified Data.ByteString.Char8 as BSC
89
import Data.Char (toLower)
9-
import Data.Either (isLeft)
1010
import Data.Maybe (isJust, isNothing)
1111
import Data.Word (Word8)
1212
import Test.Tasty
@@ -15,38 +15,68 @@ import Test.Tasty.HUnit
1515
main :: IO ()
1616
main = defaultMain tests
1717

18-
validChecksums :: [BS.ByteString]
19-
validChecksums = map BSC.pack
20-
[ "A12UEL5L"
21-
, "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs"
22-
, "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw"
23-
, "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j"
24-
, "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w"
25-
]
18+
validChecksums :: [(Bech32Type, BS.ByteString)]
19+
validChecksums = [(b32type, BSC.pack string)
20+
| (b32type, string) <-
21+
[ (Bech32, "A12UEL5L")
22+
, (Bech32, "a12uel5l")
23+
, (Bech32, "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs")
24+
, (Bech32, "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw")
25+
, (Bech32, "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j")
26+
, (Bech32, "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w")
27+
, (Bech32m, "A1LQFN3A")
28+
, (Bech32m, "a1lqfn3a")
29+
, (Bech32m, "an83characterlonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11sg7hg6")
30+
, (Bech32m, "abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx")
31+
, (Bech32m, "11llllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllludsr8")
32+
, (Bech32m, "split1checkupstagehandshakeupstreamerranterredcaperredlc445v")
33+
] ]
2634

27-
invalidChecksums :: [BS.ByteString]
28-
invalidChecksums = map BSC.pack
29-
[ " 1nwldj5"
30-
, "\DEL1axkwrx"
31-
, "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx"
32-
, "pzry9x0s0muk"
33-
, "1pzry9x0s0muk"
34-
, "x1b4n0q5v"
35-
, "li1dgmt3"
36-
, "de1lg7wt\xFF"
37-
]
35+
invalidChecksums :: [(Bech32Type, BS.ByteString)]
36+
invalidChecksums = [(b32type, BSC.pack string)
37+
| (b32type, string) <-
38+
[ (Bech32, " 1nwldj5")
39+
, (Bech32, "\DEL1axkwrx")
40+
, (Bech32, "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx")
41+
, (Bech32, "pzry9x0s0muk")
42+
, (Bech32, "1pzry9x0s0muk")
43+
, (Bech32, "x1b4n0q5v")
44+
, (Bech32, "li1dgmt3")
45+
, (Bech32, "de1lg7wt\xFF")
46+
, (Bech32, "A1G7SGD8")
47+
, (Bech32, "10a06t8")
48+
, (Bech32, "1qzzfhee")
49+
, (Bech32m, " 1xj0phk")
50+
, (Bech32m, "\x79" ++ "1g6xzxy")
51+
, (Bech32m, "\x80" ++ "1vctc34")
52+
, (Bech32m, "an84characterslonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11d6pts4")
53+
, (Bech32m, "qyrz8wqd2c9m")
54+
, (Bech32m, "1qyrz8wqd2c9m")
55+
, (Bech32m, "y1b0jsk6g")
56+
, (Bech32m, "lt1igcx5c0")
57+
, (Bech32m, "in1muywd")
58+
, (Bech32m, "mm1crxm3i")
59+
, (Bech32m, "au1s5cgom")
60+
, (Bech32m, "M1VUXWEZ")
61+
, (Bech32m, "16plkw9")
62+
, (Bech32m, "1p2gdwpf")
63+
] ]
3864

3965
validAddresses :: [(BS.ByteString, BS.ByteString)]
4066
validAddresses = map mapTuple
4167
[ ("BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4", "0014751e76e8199196d454941c45d1b3a323f1433bd6")
4268
, ("tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7"
4369
,"00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262")
44-
, ("bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7k7grplx"
70+
, ("bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kt5nd6y"
4571
,"5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6")
46-
, ("BC1SW50QA3JX3S", "6002751e")
47-
, ("bc1zw508d6qejxtdg4y5r3zarvaryvg6kdaj", "5210751e76e8199196d454941c45d1b3a323")
72+
, ("BC1SW50QGDZ25J", "6002751e")
73+
, ("bc1zw508d6qejxtdg4y5r3zarvaryvaxxpcs", "5210751e76e8199196d454941c45d1b3a323")
4874
, ("tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy"
4975
,"0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433")
76+
, ("tb1pqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesf3hn0c"
77+
,"5120000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433")
78+
, ("bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqzk5jj0"
79+
,"512079be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798")
5080
]
5181
where
5282
mapTuple (a, b) = (BSC.pack a, BSC.pack b)
@@ -62,6 +92,20 @@ invalidAddresses = map BSC.pack
6292
, "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7"
6393
, "bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du"
6494
, "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv"
95+
, "tc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq5zuyut"
96+
, "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqh2y7hd"
97+
, "tb1z0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqglt7rf"
98+
, "BC1S0XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ54WELL"
99+
, "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kemeawh"
100+
, "tb1q0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq24jc47"
101+
, "bc1p38j9r5y49hruaue7wxjce0updqjuyyx0kh56v8s25huc6995vvpql3jow4"
102+
, "BC130XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ7ZWS8R"
103+
, "bc1pw5dgrnzv"
104+
, "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v8n0nx0muaewav253zgeav"
105+
, "BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P"
106+
, "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq47Zagq"
107+
, "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v07qwwzcrf"
108+
, "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vpggkg4j"
65109
, "bc1gmk9yu"
66110
]
67111

@@ -74,21 +118,23 @@ segwitScriptPubkey witver witprog = BS.pack $ witver' : (fromIntegral $ length w
74118

75119
tests :: TestTree
76120
tests = testGroup "Tests"
77-
[ testCase "Checksums" $ forM_ validChecksums $ \checksum -> do
121+
[ testCase "Checksums" $ forM_ validChecksums $ \(b32type, checksum) -> do
122+
let spec = bech32Spec b32type
78123
case bech32Decode checksum of
79124
Left err -> assertFailure (show checksum ++ ", " ++ show err)
80-
Right (resultHRP, resultData) -> do
125+
Right (residue, resultHRP, resultData) -> do
126+
assertEqual (show checksum ++ " spec") spec residue
81127
-- test that a corrupted checksum fails decoding.
82128
let (hrp, rest) = BSC.breakEnd (== '1') checksum
83129
Just (first, rest') = BS.uncons rest
84130
checksumCorrupted = (hrp `BS.snoc` (first `xor` 1)) `BS.append` rest'
85-
assertBool (show checksum ++ " corrupted") $ isLeft (bech32Decode checksumCorrupted)
131+
assertBool (show checksum ++ " corrupted") $ isCorrupted spec (bech32Decode checksumCorrupted)
86132
-- test that re-encoding the decoded checksum results in the same checksum.
87-
let checksumEncoded = bech32Encode resultHRP resultData
133+
let checksumEncoded = bech32Encode spec resultHRP resultData
88134
expectedChecksum = Right $ BSC.map toLower checksum
89135
assertEqual (show checksum ++ " re-encode") expectedChecksum checksumEncoded
90136
, testCase "Invalid checksums" $ forM_ invalidChecksums $
91-
\checksum -> assertBool (show checksum) (isLeft $ bech32Decode checksum)
137+
\(b32type, checksum) -> assertBool (show checksum) $ isCorrupted (bech32Spec b32type) (bech32Decode checksum)
92138
, testCase "Addresses" $ forM_ validAddresses $ \(address, hexscript) -> do
93139
let address' = BSC.map toLower address
94140
hrp = BSC.take 2 address'
@@ -102,7 +148,7 @@ tests = testGroup "Tests"
102148
assertBool (show address) (isNothing $ segwitDecode (BSC.pack "tb") address)
103149
, testCase "More Encoding/Decoding Cases" $ do
104150
assertBool "length > 90" $ isError ResultStringLengthExceeded $
105-
bech32Encode (BSC.pack "bc") (replicate 82 (word5 (1::Word8)))
151+
bech32Encode 1 (BSC.pack "bc") (replicate 82 (word5 (1::Word8)))
106152
assertBool "segwit version bounds" $ isNothing $
107153
segwitEncode (BSC.pack "bc") 17 []
108154
assertBool "segwit prog len version 0" $ isNothing $
@@ -111,13 +157,17 @@ tests = testGroup "Tests"
111157
segwitEncode (BSC.pack "bc") 1 (replicate 30 1)
112158
assertBool "segwit prog len version != 0" $ isNothing $
113159
segwitEncode (BSC.pack "bc") 1 (replicate 41 1)
114-
assertBool "empty HRP encode" $ isError InvalidHumanReadablePart $ bech32Encode (BSC.pack "") []
160+
assertBool "empty HRP encode" $ isError InvalidHumanReadablePart $ bech32Encode 1 (BSC.pack "") []
115161
assertBool "empty HRP decode" $ isError InvalidHRP $ bech32Decode (BSC.pack "10a06t8")
116162
assertEqual "hrp lowercased"
117163
(Right $ BSC.pack "hrp1g9xj8m")
118-
(bech32Encode (BSC.pack "HRP") [])
164+
(bech32Encode 1 (BSC.pack "HRP") [])
119165
]
120166

121167
isError :: Eq a => a -> Either a b -> Bool
122168
isError e' (Left e) = e == e'
123169
isError _ _ = False
170+
171+
isCorrupted :: Word -> Either x (Word, y, z) -> Bool
172+
isCorrupted _ (Left _) = True
173+
isCorrupted spec (Right (resultSpec, _, _)) = spec /= resultSpec

0 commit comments

Comments
 (0)