diff --git a/ref/haskell/src/Codec/Binary/Bech32.hs b/ref/haskell/src/Codec/Binary/Bech32.hs index 23e58a5..87fd746 100644 --- a/ref/haskell/src/Codec/Binary/Bech32.hs +++ b/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 diff --git a/ref/haskell/test/Spec.hs b/ref/haskell/test/Spec.hs index 964571d..1896bc3 100644 --- a/ref/haskell/test/Spec.hs +++ b/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