bech32

Fast Haskell bech32, bech32m encoding/decoding (docs.ppad.tech/bech32).
git clone git://git.ppad.tech/bech32.git
Log | Files | Refs | README | LICENSE

Main.hs (12765B)

      1 {-# LANGUAGE OverloadedStrings #-}
      2 {-# LANGUAGE ViewPatterns #-}
      3 
      4 module Main where
      5 
      6 import qualified Data.Char as C
      7 import qualified Data.ByteString as BS
      8 import qualified Data.ByteString.Char8 as B8
      9 import qualified Data.ByteString.Bech32 as Bech32
     10 import qualified Data.ByteString.Bech32.Internal as BI
     11 import qualified Data.ByteString.Bech32m as Bech32m
     12 import qualified Data.ByteString.Base32 as B32
     13 import Data.Word (Word8)
     14 import Test.Tasty
     15 import qualified Test.Tasty.HUnit as H
     16 import qualified Test.Tasty.QuickCheck as Q
     17 import qualified Reference.Bech32 as R
     18 
     19 newtype BS = BS BS.ByteString
     20   deriving (Eq, Show)
     21 
     22 data ValidInput = ValidInput BS.ByteString BS.ByteString
     23   deriving (Eq, Show)
     24 
     25 data InvalidInput = InvalidInput BS.ByteString BS.ByteString
     26   deriving (Eq, Show)
     27 
     28 -- | A list of 5-bit values.
     29 newtype Word5s = Word5s [Word8]
     30   deriving (Eq, Show)
     31 
     32 -- | A canonical base32 string with one character replaced by a byte
     33 --   outside the bech32 character set.
     34 newtype Corrupted = Corrupted BS.ByteString
     35   deriving (Eq, Show)
     36 
     37 instance Q.Arbitrary ValidInput where
     38   arbitrary = do
     39     h <- hrp
     40     let l = 83 - BS.length h
     41         a = l * 5 `quot` 8
     42     b <- bytes a
     43     pure (ValidInput h b)
     44 
     45 instance Q.Arbitrary InvalidInput where
     46   arbitrary = do
     47     h <- invalid_hrp
     48     let l = 83 - BS.length h
     49         a = l * 5 `quot` 8
     50     b <- bytes a
     51     pure (InvalidInput h b)
     52 
     53 instance Q.Arbitrary BS where
     54   arbitrary = do
     55     b <- bytes 1024
     56     pure (BS b)
     57 
     58 instance Q.Arbitrary Word5s where
     59   arbitrary = do
     60     l <- Q.chooseInt (0, 100)
     61     Word5s <$> Q.vectorOf l (Q.choose (0, 31))
     62 
     63 instance Q.Arbitrary Corrupted where
     64   arbitrary = do
     65     l <- Q.chooseInt (1, 100)
     66     b <- BS.pack <$> Q.vectorOf l Q.arbitrary
     67     let enc = B32.encode b
     68     i <- Q.chooseInt (0, BS.length enc - 1)
     69     c <- Q.elements non_charset
     70     pure (Corrupted (BS.take i enc <> BS.singleton c <> BS.drop (i + 1) enc))
     71 
     72 charset :: BS.ByteString
     73 charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
     74 
     75 non_charset :: [Word8]
     76 non_charset = filter (\b -> not (BS.elem b charset)) [0 .. 255]
     77 
     78 hrp :: Q.Gen BS.ByteString
     79 hrp = do
     80   l <- Q.chooseInt (1, 83)
     81   v <- Q.vectorOf l (Q.choose (33, 126))
     82   pure (B8.map C.toLower (BS.pack v))
     83 
     84 invalid_hrp :: Q.Gen BS.ByteString
     85 invalid_hrp = do
     86   l <- Q.oneof [pure 0, Q.chooseInt (84, 100)]
     87   v <- Q.vectorOf l (Q.oneof [Q.choose (0, 32), Q.choose (127, 255)])
     88   pure (B8.map C.toLower (BS.pack v))
     89 
     90 bytes :: Int -> Q.Gen BS.ByteString
     91 bytes k = do
     92   l <- Q.chooseInt (0, k)
     93   v <- Q.vectorOf l Q.arbitrary
     94   pure (BS.pack v)
     95 
     96 lower :: BS.ByteString -> BS.ByteString
     97 lower = B8.map C.toLower
     98 
     99 upper :: BS.ByteString -> BS.ByteString
    100 upper = B8.map C.toUpper
    101 
    102 -- properties -----------------------------------------------------------------
    103 
    104 matches_reference :: ValidInput -> Bool
    105 matches_reference (ValidInput h b) =
    106   let ref = R.bech32Encode h (R.toBase32 (BS.unpack b))
    107       our = Bech32.encode h b
    108   in  ref == our
    109 
    110 bech32_decode_inverts_encode :: ValidInput -> Bool
    111 bech32_decode_inverts_encode (ValidInput h b) = case Bech32.encode h b of
    112   Nothing -> False
    113   Just enc -> case Bech32.decode enc of
    114     Nothing -> False
    115     Just (h', dat) -> h == h' && b == dat
    116 
    117 bech32m_decode_inverts_encode :: ValidInput -> Bool
    118 bech32m_decode_inverts_encode (ValidInput h b) = case Bech32m.encode h b of
    119   Nothing -> False
    120   Just enc -> case Bech32m.decode enc of
    121     Nothing -> False
    122     Just (h', dat) -> h == h' && b == dat
    123 
    124 bech32_decode_inverts_encode_upper :: ValidInput -> Bool
    125 bech32_decode_inverts_encode_upper (ValidInput h b) =
    126   case Bech32.encode h b of
    127     Nothing -> False
    128     Just (upper -> enc) ->
    129       Bech32.verify enc && Bech32.decode enc == Just (h, b)
    130 
    131 bech32m_decode_inverts_encode_upper :: ValidInput -> Bool
    132 bech32m_decode_inverts_encode_upper (ValidInput h b) =
    133   case Bech32m.encode h b of
    134     Nothing -> False
    135     Just (upper -> enc) ->
    136       Bech32m.verify enc && Bech32m.decode enc == Just (h, b)
    137 
    138 base32_decode_inverts_encode :: BS -> Bool
    139 base32_decode_inverts_encode (BS bs) = case B32.decode (B32.encode bs) of
    140   Nothing -> False
    141   Just b  -> b == bs
    142 
    143 base32_decode_matches_reference :: Word5s -> Bool
    144 base32_decode_matches_reference (Word5s ws) =
    145   let ours = B32.decode (BI.as_base32 (BS.pack ws))
    146       ref  = R.toBase256 (fmap R.word5 ws)
    147   in  ours == fmap BS.pack ref
    148 
    149 base32_decode_rejects_invalid_char :: Corrupted -> Bool
    150 base32_decode_rejects_invalid_char (Corrupted bs) = B32.decode bs == Nothing
    151 
    152 bech32_invalid_input_fails_encode :: InvalidInput -> Bool
    153 bech32_invalid_input_fails_encode (InvalidInput h b) =
    154   case Bech32.encode h b of
    155     Nothing -> True
    156     Just _ -> False
    157 
    158 bech32m_invalid_input_fails_encode :: InvalidInput -> Bool
    159 bech32m_invalid_input_fails_encode (InvalidInput h b) =
    160   case Bech32m.encode h b of
    161     Nothing -> True
    162     Just _ -> False
    163 
    164 -- vectors --------------------------------------------------------------------
    165 
    166 -- BIP173 and BIP350 checksum test vectors. Each valid vector is
    167 -- paired with whether its data part converts to bytes: the long
    168 -- all-'l' bech32m vector has a valid checksum, but its data part
    169 -- leaves nonzero padding bits, so 'decode' (which returns bytes)
    170 -- rejects it.
    171 
    172 bip173_valid :: [(BS.ByteString, Bool)]
    173 bip173_valid = [
    174     ("A12UEL5L", True)
    175   , ("a12uel5l", True)
    176   , ("an83characterlonghumanreadablepartthatcontainsthenumber1\
    177         \andtheexcludedcharactersbio1tt5tgs", True)
    178   , ("abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw", True)
    179   , ("11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq\
    180         \qqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j", True)
    181   , ("split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w", True)
    182   , ("?1ezyfcl", True)
    183   ]
    184 
    185 bip173_invalid :: [BS.ByteString]
    186 bip173_invalid = [
    187     BS.cons 0x20 "1nwldj5"
    188   , BS.cons 0x7f "1axkwrx"
    189   , BS.cons 0x80 "1eym55h"
    190   , "an84characterslonghumanreadablepartthatcontainsthenumber\
    191       \1andtheexcludedcharactersbio1569pvx"
    192   , "pzry9x0s0muk"
    193   , "1pzry9x0s0muk"
    194   , "x1b4n0q5v"
    195   , "li1dgmt3"
    196   , BS.snoc "de1lg7wt" 0xff
    197   , "A1G7SGD8"
    198   , "10a06t8"
    199   , "1qzzfhee"
    200   ]
    201 
    202 bip350_valid :: [(BS.ByteString, Bool)]
    203 bip350_valid = [
    204     ("A1LQFN3A", True)
    205   , ("a1lqfn3a", True)
    206   , ("an83characterlonghumanreadablepartthatcontainsthetheexcl\
    207         \udedcharactersbioandnumber11sg7hg6", True)
    208   , ("abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx", True)
    209   , ("11llllllllllllllllllllllllllllllllllllllllllllllllllllll\
    210         \llllllllllllllllllllllllllllludsr8", False)
    211   , ("split1checkupstagehandshakeupstreamerranterredcaperredlc445v", True)
    212   , ("?1v759aa", True)
    213   ]
    214 
    215 bip350_invalid :: [BS.ByteString]
    216 bip350_invalid = [
    217     BS.cons 0x20 "1xj0phk"
    218   , BS.cons 0x7f "1g6xzxy"
    219   , BS.cons 0x80 "1vctc34"
    220   , "an84characterslonghumanreadablepartthatcontainsthetheexc\
    221       \ludedcharactersbioandnumber11d6pts4"
    222   , "qyrz8wqd2c9m"
    223   , "1qyrz8wqd2c9m"
    224   , "y1b0jsk6g"
    225   , "lt1igcx5c0"
    226   , "in1muywd"
    227   , "mm1crxm3i"
    228   , "au1s5cgom"
    229   , "M1VUXWEZ"
    230   , "16plkw9"
    231   , "1p2gdwpf"
    232   ]
    233 
    234 valid_vector
    235   :: (BS.ByteString -> Bool)
    236   -> (BS.ByteString -> Maybe (BS.ByteString, BS.ByteString))
    237   -> (BS.ByteString -> BS.ByteString -> Maybe BS.ByteString)
    238   -> (BS.ByteString, Bool)
    239   -> TestTree
    240 valid_vector ver dec enc (s, convertible) = H.testCase (show s) $ do
    241   H.assertBool "verify" (ver s)
    242   if   convertible
    243   then H.assertEqual "decode/encode" (Just (lower s)) $ do
    244          (h, d) <- dec s
    245          enc h d
    246   else H.assertEqual "decode" Nothing (dec s)
    247 
    248 invalid_vector
    249   :: (BS.ByteString -> Maybe (BS.ByteString, BS.ByteString))
    250   -> BS.ByteString
    251   -> TestTree
    252 invalid_vector dec s = H.testCase (show s) $
    253   H.assertEqual mempty Nothing (dec s)
    254 
    255 -- valid in the other encoding, so invalid in this one
    256 cross_vector
    257   :: (BS.ByteString -> Bool)
    258   -> (BS.ByteString -> Maybe (BS.ByteString, BS.ByteString))
    259   -> (BS.ByteString, Bool)
    260   -> TestTree
    261 cross_vector ver dec (s, _) = H.testCase (show s) $ do
    262   H.assertBool "verify" (not (ver s))
    263   H.assertEqual "decode" Nothing (dec s)
    264 
    265 -- a string whose checksum is computed over an uppercase hrp, with a
    266 -- lowercase data part
    267 upper_hrp_checksum :: BI.Encoding -> BS.ByteString
    268 upper_hrp_checksum enc =
    269   let h  = "BC"
    270       ws = BS.pack [0 .. 7]
    271   in  BS.concat
    272         [h, "1", BI.as_base32 ws, BI.as_base32 (BI.create_checksum enc h ws)]
    273 
    274 mixed_case :: TestTree
    275 mixed_case = testGroup "mixed case" [
    276     H.testCase "bech32 (mixed vector)" $ do
    277       let s = "A12uEL5L"
    278       H.assertBool "verify" (not (Bech32.verify s))
    279       H.assertEqual "decode" Nothing (Bech32.decode s)
    280   , H.testCase "bech32m (mixed vector)" $ do
    281       let s = "a1LQFN3A"
    282       H.assertBool "verify" (not (Bech32m.verify s))
    283       H.assertEqual "decode" Nothing (Bech32m.decode s)
    284   , H.testCase "bech32 (uppercase-hrp checksum)" $ do
    285       let s = upper_hrp_checksum BI.Bech32
    286       H.assertBool "verify" (not (Bech32.verify s))
    287       H.assertEqual "decode" Nothing (Bech32.decode s)
    288   , H.testCase "bech32m (uppercase-hrp checksum)" $ do
    289       let s = upper_hrp_checksum BI.Bech32m
    290       H.assertEqual "construction" "BC1qpzry9x8gchca4" s
    291       H.assertBool "verify" (not (Bech32m.verify s))
    292       H.assertEqual "decode" Nothing (Bech32m.decode s)
    293   , H.testCase "bech32 (uppercase hrp, lowercase data)" $ do
    294       let s = "HI1df6x7cnfdcs8wctnyp5x2un9wed5st"
    295       H.assertBool "verify" (not (Bech32.verify s))
    296       H.assertEqual "decode" Nothing (Bech32.decode s)
    297   , H.testCase "bech32m (uppercase hrp, lowercase data)" $ do
    298       let s = "HI1df6x7cnfdcs8wctnyp5x2un9m9ac4f"
    299       H.assertBool "verify" (not (Bech32m.verify s))
    300       H.assertEqual "decode" Nothing (Bech32m.decode s)
    301   ]
    302 
    303 base32_rejects :: TestTree
    304 base32_rejects = testGroup "base32 decode" [
    305     H.testCase "invalid tail lengths (1, 3, 6 mod 8)" $
    306       mapM_ (\s -> H.assertEqual (show s) Nothing (B32.decode s)) [
    307           "q", "qqq", "qqqqqq"
    308         , "qqqqqqqqq", "qqqqqqqqqqq", "qqqqqqqqqqqqqq"
    309         ]
    310   , H.testCase "nonzero padding bits" $
    311       mapM_ (\s -> H.assertEqual (show s) Nothing (B32.decode s)) [
    312           "qp", "qqqp", "qqqqp", "qqqqqqp"
    313         , "qqqqqqqqqp", "qqqqqqqqqqqp"
    314         ]
    315   , H.testCase "zero padding bits" $ do
    316       H.assertEqual "qq" (Just "\NUL") (B32.decode "qq")
    317       H.assertEqual "qy" (Just "\SOH") (B32.decode "qy")
    318       H.assertEqual "qqqqqqqqqy" (Just "\NUL\NUL\NUL\NUL\NUL\SOH")
    319         (B32.decode "qqqqqqqqqy")
    320   , H.testCase "invalid characters" $
    321       mapM_ (\s -> H.assertEqual (show s) Nothing (B32.decode s)) [
    322           "qqqqqqqb", "qqqqqqqi", "qqqqqqqo", "qqqqqqq1"
    323         , "Qqqqqqqq", "qqqq qqq", BS.snoc "qqqqqqq" 0x80
    324         , BS.snoc "qqqqqqq" 0xff, BS.snoc "qqqqqqqqq" 0x00
    325         , "qqqqqqqqqb"
    326         ]
    327   ]
    328 
    329 main :: IO ()
    330 main = defaultMain $ testGroup "ppad-bech32" [
    331     testGroup "base32" [
    332       Q.testProperty "decode . encode ~ id" $
    333         Q.withMaxSuccess 1000 base32_decode_inverts_encode
    334     , Q.testProperty "decode ~ reference" $
    335         Q.withMaxSuccess 1000 base32_decode_matches_reference
    336     , Q.testProperty "decode rejects invalid characters" $
    337         Q.withMaxSuccess 1000 base32_decode_rejects_invalid_char
    338     , base32_rejects
    339     ]
    340   , testGroup "bech32" [
    341       Q.testProperty "Bech32.encode ~ R.bech32Encode" $
    342         Q.withMaxSuccess 1000 matches_reference
    343     , Q.testProperty "decode . encode ~ id" $
    344         Q.withMaxSuccess 1000 bech32_decode_inverts_encode
    345     , Q.testProperty "decode . upper . encode ~ id" $
    346         Q.withMaxSuccess 1000 bech32_decode_inverts_encode_upper
    347     , Q.testProperty "invalid bech32 input fails to encode" $
    348         Q.withMaxSuccess 1000 bech32_invalid_input_fails_encode
    349     , testGroup "BIP173 valid vectors" $
    350         fmap (valid_vector Bech32.verify Bech32.decode Bech32.encode)
    351           bip173_valid
    352     , testGroup "BIP173 invalid vectors" $
    353         fmap (invalid_vector Bech32.decode) bip173_invalid
    354     , testGroup "BIP350 valid vectors (invalid as bech32)" $
    355         fmap (cross_vector Bech32.verify Bech32.decode) bip350_valid
    356     ]
    357   , testGroup "bech32m" [
    358       Q.testProperty "decode . encode ~ id" $
    359         Q.withMaxSuccess 1000 bech32m_decode_inverts_encode
    360     , Q.testProperty "decode . upper . encode ~ id" $
    361         Q.withMaxSuccess 1000 bech32m_decode_inverts_encode_upper
    362     , Q.testProperty "invalid bech32m input fails to encode" $
    363         Q.withMaxSuccess 1000 bech32m_invalid_input_fails_encode
    364     , testGroup "BIP350 valid vectors" $
    365         fmap (valid_vector Bech32m.verify Bech32m.decode Bech32m.encode)
    366           bip350_valid
    367     , testGroup "BIP350 invalid vectors" $
    368         fmap (invalid_vector Bech32m.decode) bip350_invalid
    369     , testGroup "BIP173 valid vectors (invalid as bech32m)" $
    370         fmap (cross_vector Bech32m.verify Bech32m.decode) bip173_valid
    371     ]
    372   , mixed_case
    373   ]