Haskell support for Bech32m

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

@@ -1,6 +1,12 @@
 module Codec.Binary.Bech32
-  ( bech32Encode
+  (
+    DecodeError(..)
+  , EncodeError(..)
+  , Bech32Type(..)
+
+  , bech32Encode
   , bech32Decode
+  , bech32Spec
   , toBase32
   , toBase256
   , segwitEncode
@@ -12,13 +18,13 @@ module Codec.Binary.Bech32
 
 import Control.Monad (guard)
 import qualified Data.Array as Arr
-import Data.Bits (Bits, unsafeShiftL, unsafeShiftR, (.&.), (.|.), xor, testBit)
+import Data.Bits (Bits, testBit, unsafeShiftL, unsafeShiftR, xor, (.&.), (.|.))
 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.Ix (Ix (..))
 import Data.Word (Word8)
 
 type HRP = BS.ByteString
@@ -29,7 +35,7 @@ type Data = [Word8]
 (.<<.) = unsafeShiftL
 
 newtype Word5 = UnsafeWord5 Word8
-              deriving (Eq, Ord)
+              deriving (Eq, Ord, Show)
 
 instance Ix Word5 where
   range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n)
@@ -68,43 +74,60 @@ bech32Polymod values = foldl' go 1 values .&. 0x3fffffff
 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]]
+bech32CreateChecksum :: Word -> HRP -> [Word5] -> [Word5]
+bech32CreateChecksum residue 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
+    polymod = bech32Polymod (values ++ map UnsafeWord5 [0, 0, 0, 0, 0, 0]) `xor` residue
+
+bech32Residue :: HRP -> [Word5] -> Word
+bech32Residue hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat)
 
-bech32VerifyChecksum :: HRP -> [Word5] -> Bool
-bech32VerifyChecksum hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat) == 1
+data EncodeError =
+      ResultStringLengthExceeded
+    | InvalidHumanReadablePart
+    deriving (Show, Eq)
 
-bech32Encode :: HRP -> [Word5] -> Maybe BS.ByteString
-bech32Encode hrp dat = do
-    guard $ checkHRP hrp
-    let dat' = dat ++ bech32CreateChecksum hrp dat
+bech32Encode :: Word -> HRP -> [Word5] -> Either EncodeError BS.ByteString
+bech32Encode residue hrp dat = do
+    verify InvalidHumanReadablePart $ validHRP hrp
+    let dat' = dat ++ bech32CreateChecksum residue 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
+    verify ResultStringLengthExceeded $ BS.length result <= 90
     return result
 
-checkHRP :: BS.ByteString -> Bool
-checkHRP hrp = not (BS.null hrp) && BS.all (\char -> char >= 33 && char <= 126) hrp
+validHRP :: BS.ByteString -> Bool
+validHRP hrp = not (BS.null hrp) && BS.all (\char -> char >= 33 && char <= 126) hrp
+
+data DecodeError =
+    Bech32StringLengthExceeded
+  | CaseInconsistency
+  | TooShortDataPart
+  | InvalidHRP
+  | ChecksumVerificationFail
+  | InvalidCharsetMap
+  deriving (Show, Eq)
 
-bech32Decode :: BS.ByteString -> Maybe (HRP, [Word5])
+bech32Decode :: BS.ByteString -> Either DecodeError (Word, HRP, [Word5])
 bech32Decode bech32 = do
-    guard $ BS.length bech32 <= 90
-    guard $ BSC.map toUpper bech32 == bech32 || BSC.map toLower bech32 == bech32
+    verify Bech32StringLengthExceeded $ BS.length bech32 <= 90
+    verify CaseInconsistency $ validCase 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')
+    verify TooShortDataPart $ BS.length dat >= 6
+    hrp' <- maybeToRight InvalidHRP $ BSC.stripSuffix (BSC.pack "1") hrp
+    verify InvalidHRP $ validHRP hrp'
+    dat' <- maybeToRight InvalidCharsetMap . mapM charsetMap $ BSC.unpack dat
+    let residue = bech32Residue hrp' dat'
+    return (residue, hrp', take (BS.length dat - 6) dat')
+      where
+        validCase :: BS.ByteString -> Bool
+        validCase b32 = BSC.map toUpper b32 == b32 || BSC.map toLower b32 == b32
 
 type Pad f = Int -> Int -> Word -> [[Word]] -> f [[Word]]
 
 yesPadding :: Pad Identity
-yesPadding _ 0 _ result = return result
+yesPadding _ 0 _ result        = return result
 yesPadding _ _ padValue result = return $ [padValue] : result
 {-# INLINE yesPadding #-}
 
@@ -137,23 +160,41 @@ toBase32 dat = map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5
 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 &&
+data Bech32Type = Bech32
+                | Bech32m
+
+bech32Spec :: Bech32Type -> Word
+bech32Spec Bech32 = 1
+bech32Spec Bech32m = 0x2bc830a3
+
+segwitCheck :: Word8 -> Data -> Maybe Bech32Type
+segwitCheck witver witprog = do
+    guard $ witver <= 16
     if witver == 0
-    then length witprog == 20 || length witprog == 32
-    else length witprog >= 2 && length witprog <= 40
+    then guard (length witprog == 20 || length witprog == 32) >> return Bech32
+    else guard (length witprog >= 2 && length witprog <= 40) >> return Bech32m
 
 segwitDecode :: HRP -> BS.ByteString -> Maybe (Word8, Data)
 segwitDecode hrp addr = do
-    (hrp', dat) <- bech32Decode addr
+    (residue, hrp', dat) <- rightToMaybe $ bech32Decode addr
     guard $ (hrp == hrp') && not (null dat)
     let (UnsafeWord5 witver : datBase32) = dat
     decoded <- toBase256 datBase32
-    guard $ segwitCheck witver decoded
+    b32type <- segwitCheck witver decoded
+    guard $ bech32Spec b32type == residue
     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
+    b32type <- segwitCheck witver witprog
+    rightToMaybe $ bech32Encode (bech32Spec b32type) hrp $ UnsafeWord5 witver : toBase32 witprog
+
+rightToMaybe :: Either l r -> Maybe r
+rightToMaybe = either (const Nothing) Just
+
+maybeToRight :: l -> Maybe r -> Either l r
+maybeToRight l = maybe (Left l) Right
+
+verify :: a -> Bool -> Either a ()
+verify _ True  = Right ()
+verify v False = Left v

ref/haskell/test/Spec.hs

@@ -1,50 +1,82 @@
+import Codec.Binary.Bech32 (DecodeError (..), EncodeError (..), Bech32Type(..),
+                            bech32Decode, bech32Encode, bech32Spec,
+                            segwitDecode, segwitEncode, word5)
 import Control.Monad (forM_)
 import Data.Bits (xor)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Char8 as BSC
 import Data.Char (toLower)
-import Data.Maybe (isNothing, isJust)
+import Data.Maybe (isJust, isNothing)
 import Data.Word (Word8)
-import Codec.Binary.Bech32 (bech32Encode, bech32Decode, segwitEncode, segwitDecode, word5)
 import Test.Tasty
 import Test.Tasty.HUnit
 
 main :: IO ()
 main = defaultMain tests
 
-validChecksums :: [BS.ByteString]
-validChecksums = map BSC.pack
-    [ "A12UEL5L"
-    , "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs"
-    , "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw"
-    , "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j"
-    , "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w"
-    ]
+validChecksums :: [(Bech32Type, BS.ByteString)]
+validChecksums = [(b32type, BSC.pack string)
+  | (b32type, string) <-
+    [ (Bech32, "A12UEL5L")
+    , (Bech32, "a12uel5l")
+    , (Bech32, "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs")
+    , (Bech32, "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw")
+    , (Bech32, "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j")
+    , (Bech32, "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w")
+    , (Bech32m, "A1LQFN3A")
+    , (Bech32m, "a1lqfn3a")
+    , (Bech32m, "an83characterlonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11sg7hg6")
+    , (Bech32m, "abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx")
+    , (Bech32m, "11llllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllludsr8")
+    , (Bech32m, "split1checkupstagehandshakeupstreamerranterredcaperredlc445v")
+ ] ]
 
-invalidChecksums :: [BS.ByteString]
-invalidChecksums = map BSC.pack
-    [ " 1nwldj5"
-    , "\DEL1axkwrx"
-    , "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx"
-    , "pzry9x0s0muk"
-    , "1pzry9x0s0muk"
-    , "x1b4n0q5v"
-    , "li1dgmt3"
-    , "de1lg7wt\xFF"
-    ]
+invalidChecksums :: [(Bech32Type, BS.ByteString)]
+invalidChecksums = [(b32type, BSC.pack string)
+  | (b32type, string) <-
+    [ (Bech32, " 1nwldj5")
+    , (Bech32, "\DEL1axkwrx")
+    , (Bech32, "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx")
+    , (Bech32, "pzry9x0s0muk")
+    , (Bech32, "1pzry9x0s0muk")
+    , (Bech32, "x1b4n0q5v")
+    , (Bech32, "li1dgmt3")
+    , (Bech32, "de1lg7wt\xFF")
+    , (Bech32, "A1G7SGD8")
+    , (Bech32, "10a06t8")
+    , (Bech32, "1qzzfhee")
+    , (Bech32m, " 1xj0phk")
+    , (Bech32m, "\x79" ++ "1g6xzxy")
+    , (Bech32m, "\x80" ++ "1vctc34")
+    , (Bech32m, "an84characterslonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11d6pts4")
+    , (Bech32m, "qyrz8wqd2c9m")
+    , (Bech32m, "1qyrz8wqd2c9m")
+    , (Bech32m, "y1b0jsk6g")
+    , (Bech32m, "lt1igcx5c0")
+    , (Bech32m, "in1muywd")
+    , (Bech32m, "mm1crxm3i")
+    , (Bech32m, "au1s5cgom")
+    , (Bech32m, "M1VUXWEZ")
+    , (Bech32m, "16plkw9")
+    , (Bech32m, "1p2gdwpf")
+  ] ]
 
 validAddresses :: [(BS.ByteString, BS.ByteString)]
 validAddresses = map mapTuple
     [ ("BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4", "0014751e76e8199196d454941c45d1b3a323f1433bd6")
     , ("tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7"
       ,"00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262")
-    , ("bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7k7grplx"
+    , ("bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kt5nd6y"
       ,"5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6")
-    , ("BC1SW50QA3JX3S", "6002751e")
-    , ("bc1zw508d6qejxtdg4y5r3zarvaryvg6kdaj", "5210751e76e8199196d454941c45d1b3a323")
+    , ("BC1SW50QGDZ25J", "6002751e")
+    , ("bc1zw508d6qejxtdg4y5r3zarvaryvaxxpcs", "5210751e76e8199196d454941c45d1b3a323")
     , ("tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy"
       ,"0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433")
+    , ("tb1pqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesf3hn0c"
+      ,"5120000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433")
+    , ("bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqzk5jj0"
+      ,"512079be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798")
     ]
   where
     mapTuple (a, b) = (BSC.pack a, BSC.pack b)
@@ -60,6 +92,20 @@ invalidAddresses = map BSC.pack
     , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7"
     , "bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du"
     , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv"
+    , "tc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq5zuyut"
+    , "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqh2y7hd"
+    , "tb1z0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqglt7rf"
+    , "BC1S0XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ54WELL"
+    , "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kemeawh"
+    , "tb1q0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq24jc47"
+    , "bc1p38j9r5y49hruaue7wxjce0updqjuyyx0kh56v8s25huc6995vvpql3jow4"
+    , "BC130XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ7ZWS8R"
+    , "bc1pw5dgrnzv"
+    , "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v8n0nx0muaewav253zgeav"
+    , "BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P"
+    , "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq47Zagq"
+    , "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v07qwwzcrf"
+    , "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vpggkg4j"
     , "bc1gmk9yu"
     ]
 
@@ -72,21 +118,23 @@ segwitScriptPubkey witver witprog = BS.pack $ witver' : (fromIntegral $ length w
 
 tests :: TestTree
 tests = testGroup "Tests"
-    [ testCase "Checksums" $ forM_ validChecksums $ \checksum -> do
+    [ testCase "Checksums" $ forM_ validChecksums $ \(b32type, checksum) -> do
+          let spec = bech32Spec b32type
           case bech32Decode checksum of
-            Nothing -> assertFailure (show checksum)
-            Just (resultHRP, resultData) -> do
+            Left err -> assertFailure (show checksum ++ ", " ++ show err)
+            Right (residue, resultHRP, resultData) -> do
+                assertEqual (show checksum ++ " spec") spec residue
                 -- test that a corrupted checksum fails decoding.
                 let (hrp, rest) = BSC.breakEnd (== '1') checksum
                     Just (first, rest') = BS.uncons rest
                     checksumCorrupted = (hrp `BS.snoc` (first `xor` 1)) `BS.append` rest'
-                assertBool (show checksum ++ " corrupted") $ isNothing (bech32Decode checksumCorrupted)
+                assertBool (show checksum ++ " corrupted") $ isCorrupted spec (bech32Decode checksumCorrupted)
                 -- test that re-encoding the decoded checksum results in the same checksum.
-                let checksumEncoded = bech32Encode resultHRP resultData
-                    expectedChecksum = Just $ BSC.map toLower checksum
+                let checksumEncoded = bech32Encode spec resultHRP resultData
+                    expectedChecksum = Right $ BSC.map toLower checksum
                 assertEqual (show checksum ++ " re-encode") expectedChecksum checksumEncoded
     , testCase "Invalid checksums" $ forM_ invalidChecksums $
-          \checksum -> assertBool (show checksum) (isNothing $ bech32Decode checksum)
+          \(b32type, checksum) -> assertBool (show checksum) $ isCorrupted (bech32Spec b32type) (bech32Decode checksum)
     , testCase "Addresses" $ forM_ validAddresses $ \(address, hexscript) -> do
           let address' = BSC.map toLower address
               hrp = BSC.take 2 address'
@@ -99,8 +147,8 @@ tests = testGroup "Tests"
           assertBool (show address) (isNothing $ segwitDecode (BSC.pack "bc") address)
           assertBool (show address) (isNothing $ segwitDecode (BSC.pack "tb") address)
     , testCase "More Encoding/Decoding Cases" $ do
-          assertBool "length > 90" $ isNothing $
-              bech32Encode (BSC.pack "bc") (replicate 82 (word5 (1::Word8)))
+          assertBool "length > 90" $ isError ResultStringLengthExceeded $
+              bech32Encode 1 (BSC.pack "bc") (replicate 82 (word5 (1::Word8)))
           assertBool "segwit version bounds" $ isNothing $
               segwitEncode (BSC.pack "bc") 17 []
           assertBool "segwit prog len version 0" $ isNothing $
@@ -109,9 +157,17 @@ tests = testGroup "Tests"
               segwitEncode (BSC.pack "bc") 1 (replicate 30 1)
           assertBool "segwit prog len version != 0" $ isNothing $
               segwitEncode (BSC.pack "bc") 1 (replicate 41 1)
-          assertBool "empty HRP encode" $ isNothing $ bech32Encode (BSC.pack "") []
-          assertBool "empty HRP decode" $ isNothing $ bech32Decode (BSC.pack "10a06t8")
+          assertBool "empty HRP encode" $ isError InvalidHumanReadablePart $ bech32Encode 1 (BSC.pack "") []
+          assertBool "empty HRP decode" $ isError InvalidHRP $ bech32Decode (BSC.pack "10a06t8")
           assertEqual "hrp lowercased"
-              (Just $ BSC.pack "hrp1g9xj8m")
-              (bech32Encode (BSC.pack "HRP") [])
+              (Right $ BSC.pack "hrp1g9xj8m")
+              (bech32Encode 1 (BSC.pack "HRP") [])
     ]
+
+isError :: Eq a => a -> Either a b -> Bool
+isError e' (Left e) = e == e'
+isError _ _         = False
+
+isCorrupted :: Word -> Either x (Word, y, z) -> Bool
+isCorrupted _ (Left _) = True
+isCorrupted spec (Right (resultSpec, _, _)) = spec /= resultSpec