diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,6 @@ +# Changelog + +- 0.1.0 (2024-12-14) + * Initial release, supporting encoding and checksum verification for + bech32 and bech32m. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 Jared Tobin + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Main where + +import Criterion.Main +import qualified Data.ByteString as BS +import qualified Data.ByteString.Bech32 as Bech32 +import GHC.Generics +import qualified Reference.Bech32 as R +import Control.DeepSeq + +deriving instance Generic R.Word5 +instance NFData R.Word5 + +main :: IO () +main = defaultMain [ + suite + ] + +suite :: Benchmark +suite = env setup $ \ ~(a, b, c) -> bgroup "benchmarks" [ + bgroup "ppad-bech32" [ + bgroup "bech32" [ + bench "120b" $ whnf (Bech32.encode "bc") + "jtobin was here" + , bench "128b (non 40-bit multiple length)" $ whnf (Bech32.encode "bc") + "jtobin was here!" + , bench "240b" $ whnf (Bech32.encode "bc") + "jtobin was herejtobin was here" + ] + ] + , bgroup "reference" [ + bgroup "bech32" [ + bench "120b" $ whnf (R.bech32Encode "bc") a + , bench "128b (non 40-bit multiple length)" $ + whnf (R.bech32Encode "bc") b + , bench "240b" $ whnf (R.bech32Encode "bc") c + ] + ] + ] + where + setup = do + let a = R.toBase32 (BS.unpack "jtobin was here") + b = R.toBase32 (BS.unpack "jtobin was here!") + c = R.toBase32 (BS.unpack "jtobin was herejtobin was here") + pure (a, b, c) diff --git a/bench/Reference/Bech32.hs b/bench/Reference/Bech32.hs new file mode 100644 --- /dev/null +++ b/bench/Reference/Bech32.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +-- 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 diff --git a/lib/Data/ByteString/Base32.hs b/lib/Data/ByteString/Base32.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Base32.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Data.ByteString.Base32 ( + encode + , as_word5 + , as_base32 + + -- not actually base32-related, but convenient to put here + , Encoding(..) + , create_checksum + , verify + , valid_hrp + ) where + +import Data.Bits ((.|.), (.&.)) +import qualified Data.Bits as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Builder.Extra as BE +import qualified Data.ByteString.Unsafe as BU +import qualified Data.Primitive.PrimArray as PA +import Data.Word (Word32) + +_BECH32M_CONST :: Word32 +_BECH32M_CONST = 0x2bc830a3 + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral +{-# INLINE fi #-} + +word32be :: BS.ByteString -> Word32 +word32be s = + (fi (s `BU.unsafeIndex` 0) `B.shiftL` 24) .|. + (fi (s `BU.unsafeIndex` 1) `B.shiftL` 16) .|. + (fi (s `BU.unsafeIndex` 2) `B.shiftL` 8) .|. + (fi (s `BU.unsafeIndex` 3)) +{-# INLINE word32be #-} + +-- realization for small builders +toStrict :: BSB.Builder -> BS.ByteString +toStrict = BS.toStrict + . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty + +bech32_charset :: BS.ByteString +bech32_charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l" + +-- adapted from emilypi's 'base32' library +encode :: BS.ByteString -> BS.ByteString +encode dat = toStrict (go dat) where + bech32_char = fi . BS.index bech32_charset . fi + go bs = case BS.splitAt 5 bs of + (chunk, etc) -> case BS.length etc of + -- https://datatracker.ietf.org/doc/html/rfc4648#section-6 + 0 | BS.length chunk == 5 -> case BS.unsnoc chunk of + Nothing -> error "impossible, chunk length is 5" + Just (word32be -> w32, fi -> w8) -> arrange w32 w8 + + | BS.length chunk == 1 -> + let a = BU.unsafeIndex chunk 0 + t = bech32_char ((a .&. 0b11111000) `B.shiftR` 3) + u = bech32_char ((a .&. 0b00000111) `B.shiftL` 2) + in BSB.word8 t <> BSB.word8 u + + | BS.length chunk == 2 -> + let a = BU.unsafeIndex chunk 0 + b = BU.unsafeIndex chunk 1 + t = bech32_char ((a .&. 0b11111000) `B.shiftR` 3) + u = bech32_char $ + ((a .&. 0b00000111) `B.shiftL` 2) + .|. ((b .&. 0b11000000) `B.shiftR` 6) + v = bech32_char ((b .&. 0b00111110) `B.shiftR` 1) + w = bech32_char ((b .&. 0b00000001) `B.shiftL` 4) + in BSB.word8 t <> BSB.word8 u <> BSB.word8 v <> BSB.word8 w + + | BS.length chunk == 3 -> + let a = BU.unsafeIndex chunk 0 + b = BU.unsafeIndex chunk 1 + c = BU.unsafeIndex chunk 2 + t = bech32_char ((a .&. 0b11111000) `B.shiftR` 3) + u = bech32_char $ + ((a .&. 0b00000111) `B.shiftL` 2) + .|. ((b .&. 0b11000000) `B.shiftR` 6) + v = bech32_char ((b .&. 0b00111110) `B.shiftR` 1) + w = bech32_char $ + ((b .&. 0b00000001) `B.shiftL` 4) + .|. ((c .&. 0b11110000) `B.shiftR` 4) + x = bech32_char ((c .&. 0b00001111) `B.shiftL` 1) + in BSB.word8 t <> BSB.word8 u <> BSB.word8 v <> BSB.word8 w + <> BSB.word8 x + + | BS.length chunk == 4 -> + let a = BU.unsafeIndex chunk 0 + b = BU.unsafeIndex chunk 1 + c = BU.unsafeIndex chunk 2 + d = BU.unsafeIndex chunk 3 + t = bech32_char ((a .&. 0b11111000) `B.shiftR` 3) + u = bech32_char $ + ((a .&. 0b00000111) `B.shiftL` 2) + .|. ((b .&. 0b11000000) `B.shiftR` 6) + v = bech32_char ((b .&. 0b00111110) `B.shiftR` 1) + w = bech32_char $ + ((b .&. 0b00000001) `B.shiftL` 4) + .|. ((c .&. 0b11110000) `B.shiftR` 4) + x = bech32_char $ + ((c .&. 0b00001111) `B.shiftL` 1) + .|. ((d .&. 0b10000000) `B.shiftR` 7) + y = bech32_char ((d .&. 0b01111100) `B.shiftR` 2) + z = bech32_char ((d .&. 0b00000011) `B.shiftL` 3) + in BSB.word8 t <> BSB.word8 u <> BSB.word8 v <> BSB.word8 w + <> BSB.word8 x <> BSB.word8 y <> BSB.word8 z + + | otherwise -> mempty + + _ -> case BS.unsnoc chunk of + Nothing -> error "impossible, chunk length is 5" + Just (word32be -> w32, fi -> w8) -> arrange w32 w8 <> go etc + +-- adapted from emilypi's 'base32' library +arrange :: Word32 -> Word32 -> BSB.Builder +arrange w32 w8 = + let mask = 0b00011111 + bech32_char = fi . BS.index bech32_charset . fi + + w8_0 = bech32_char (mask .&. (w32 `B.shiftR` 27)) + w8_1 = bech32_char (mask .&. (w32 `B.shiftR` 22)) + w8_2 = bech32_char (mask .&. (w32 `B.shiftR` 17)) + w8_3 = bech32_char (mask .&. (w32 `B.shiftR` 12)) + w8_4 = bech32_char (mask .&. (w32 `B.shiftR` 07)) + w8_5 = bech32_char (mask .&. (w32 `B.shiftR` 02)) + w8_6 = bech32_char (mask .&. (w32 `B.shiftL` 03 .|. w8 `B.shiftR` 05)) + w8_7 = bech32_char (mask .&. w8) + + w64 = w8_0 + .|. w8_1 `B.shiftL` 8 + .|. w8_2 `B.shiftL` 16 + .|. w8_3 `B.shiftL` 24 + .|. w8_4 `B.shiftL` 32 + .|. w8_5 `B.shiftL` 40 + .|. w8_6 `B.shiftL` 48 + .|. w8_7 `B.shiftL` 56 + + in BSB.word64LE w64 + +-- naive base32 -> word5 +as_word5 :: BS.ByteString -> BS.ByteString +as_word5 = BS.map f where + f b = case BS.elemIndex (fi b) bech32_charset of + Nothing -> error "ppad-bech32 (as_word5): input not bech32-encoded" + Just w -> fi w + +-- naive word5 -> base32 +as_base32 :: BS.ByteString -> BS.ByteString +as_base32 = BS.map (BS.index bech32_charset . fi) + +polymod :: BS.ByteString -> Word32 +polymod = BS.foldl' alg 1 where + generator = PA.primArrayFromListN 5 + [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3] + + alg !chk v = + let !b = chk `B.shiftR` 25 + c = (chk .&. 0x1ffffff) `B.shiftL` 5 `B.xor` fi v + in loop_gen 0 b c + + loop_gen i b !chk + | i > 4 = chk + | otherwise = + let sor | B.testBit (b `B.shiftR` i) 0 = + PA.indexPrimArray generator i + | otherwise = 0 + in loop_gen (succ i) b (chk `B.xor` sor) + +valid_hrp :: BS.ByteString -> Bool +valid_hrp hrp + | l == 0 || l > 83 = False + | otherwise = BS.all (\b -> (b > 32) && (b < 127)) hrp + where + l = BS.length hrp + +hrp_expand :: BS.ByteString -> BS.ByteString +hrp_expand bs = toStrict + $ BSB.byteString (BS.map (`B.shiftR` 5) bs) + <> BSB.word8 0 + <> BSB.byteString (BS.map (.&. 0b11111) bs) + +data Encoding = + Bech32 + | Bech32m + +create_checksum :: Encoding -> BS.ByteString -> BS.ByteString -> BS.ByteString +create_checksum enc hrp dat = + let pre = hrp_expand hrp <> dat + pay = toStrict $ + BSB.byteString pre + <> BSB.byteString "\NUL\NUL\NUL\NUL\NUL\NUL" + pm = polymod pay `B.xor` case enc of + Bech32 -> 1 + Bech32m -> _BECH32M_CONST + + code i = (fi (pm `B.shiftR` fi i) .&. 0b11111) + + in BS.map code "\EM\DC4\SI\n\ENQ\NUL" -- BS.pack [25, 20, 15, 10, 5, 0] + +verify :: Encoding -> BS.ByteString -> Bool +verify enc b32 = case BS.elemIndexEnd 0x31 b32 of + Nothing -> False + Just idx -> + let (hrp, BS.drop 1 -> dat) = BS.splitAt idx b32 + bs = hrp_expand hrp <> as_word5 dat + in polymod bs == case enc of + Bech32 -> 1 + Bech32m -> _BECH32M_CONST + diff --git a/lib/Data/ByteString/Bech32.hs b/lib/Data/ByteString/Bech32.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Bech32.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module: Data.ByteString.Bech32 +-- Copyright: (c) 2024 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- The +-- [BIP0173](https://github.com/bitcoin/bips/blob/master/bip-0173.mediawiki) +-- bech32 checksummed base32 encoding, with checksum verification. + +module Data.ByteString.Bech32 ( + -- * encoding + encode + + -- * checksum verification + , verify + ) where + +import Control.Monad (guard) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Base32 as B32 +import Data.ByteString.Base32 (Encoding(..)) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Builder.Extra as BE +import qualified Data.Char as C (toLower) + +-- realization for small builders +toStrict :: BSB.Builder -> BS.ByteString +toStrict = BS.toStrict + . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty + +create_checksum :: BS.ByteString -> BS.ByteString -> BS.ByteString +create_checksum = B32.create_checksum Bech32 + +-- | Encode a base255 human-readable part and input as bech32. +-- +-- >>> let Just bech32 = encode "bc" "my string" +-- >>> bech32 +-- "bc1d4ujqum5wf5kuecmu02w2" +encode + :: BS.ByteString -- ^ base255-encoded human-readable part + -> BS.ByteString -- ^ base255-encoded data part + -> Maybe BS.ByteString -- ^ bech32-encoded bytestring +encode hrp (B32.encode -> dat) = do + guard (B32.valid_hrp hrp) + let check = create_checksum hrp (B32.as_word5 dat) + res = toStrict $ + BSB.byteString (B8.map C.toLower hrp) + <> BSB.word8 49 -- 1 + <> BSB.byteString dat + <> BSB.byteString (B32.as_base32 check) + guard (BS.length res < 91) + pure res + +-- | Verify that a bech32 string has a valid checksum. +-- +-- >>> verify "bc1d4ujqum5wf5kuecmu02w2" +-- True +-- >>> verify "bc1d4ujquw5wf5kuecmu02w2" -- s/m/w +-- False +verify + :: BS.ByteString -- ^ bech32-encoded bytestring + -> Bool +verify = B32.verify Bech32 + diff --git a/lib/Data/ByteString/Bech32m.hs b/lib/Data/ByteString/Bech32m.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Bech32m.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module: Data.ByteString.Bech32m +-- Copyright: (c) 2024 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- The +-- [BIP350](https://github.com/bitcoin/bips/blob/master/bip-0350.mediawiki) +-- bech32m checksummed base32 encoding, with checksum verification. + +module Data.ByteString.Bech32m ( + -- * encoding + encode + + -- * checksum verification + , verify + ) where + +import Control.Monad (guard) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Base32 as B32 +import Data.ByteString.Base32 (Encoding(..)) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Builder.Extra as BE +import qualified Data.Char as C (toLower) + +-- realization for small builders +toStrict :: BSB.Builder -> BS.ByteString +toStrict = BS.toStrict + . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty + +create_checksum :: BS.ByteString -> BS.ByteString -> BS.ByteString +create_checksum = B32.create_checksum Bech32m + +-- | Encode a base255 human-readable part and input as bech32m. +-- +-- >>> let Just bech32m = encode "bc" "my string" +-- >>> bech32m +-- "bc1d4ujqum5wf5kuecwqlxtg" +encode + :: BS.ByteString -- ^ base255-encoded human-readable part + -> BS.ByteString -- ^ base255-encoded data part + -> Maybe BS.ByteString -- ^ bech32-encoded bytestring +encode hrp (B32.encode -> dat) = do + guard (B32.valid_hrp hrp) + let check = create_checksum hrp (B32.as_word5 dat) + res = toStrict $ + BSB.byteString (B8.map C.toLower hrp) + <> BSB.word8 49 -- 1 + <> BSB.byteString dat + <> BSB.byteString (B32.as_base32 check) + guard (BS.length res < 91) + pure res + +-- | Verify that a bech32m string has a valid checksum. +-- +-- >>> verify "bc1d4ujqum5wf5kuecwqlxtg" +-- True +-- >>> verify "bc1d4ujquw5wf5kuecwqlxtg" -- s/m/w +-- False +verify + :: BS.ByteString -- ^ bech32m-encoded bytestring + -> Bool +verify = B32.verify Bech32m + diff --git a/ppad-bech32.cabal b/ppad-bech32.cabal new file mode 100644 --- /dev/null +++ b/ppad-bech32.cabal @@ -0,0 +1,72 @@ +cabal-version: 3.0 +name: ppad-bech32 +version: 0.1.0 +synopsis: The bech32 and bech32m encodings, per BIPs 173 & 350. +license: MIT +license-file: LICENSE +author: Jared Tobin +maintainer: jared@ppad.tech +category: Cryptography +build-type: Simple +tested-with: GHC == 9.8.1 +extra-doc-files: CHANGELOG +description: + The bech32 and bech32m encodings on strict bytestrings, per BIPs 173 & + 350. + +source-repository head + type: git + location: git.ppad.tech/bech32.git + +library + default-language: Haskell2010 + hs-source-dirs: lib + ghc-options: + -Wall + exposed-modules: + Data.ByteString.Base32 + , Data.ByteString.Bech32 + , Data.ByteString.Bech32m + build-depends: + base >= 4.9 && < 5 + , bytestring >= 0.9 && < 0.13 + , primitive >= 0.8 && < 0.10 + +test-suite bech32-tests + type: exitcode-stdio-1.0 + 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 + +benchmark bech32-bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + other-modules: + Reference.Bech32 + + ghc-options: + -rtsopts -O2 -Wall + + build-depends: + base + , array + , bytestring + , criterion + , deepseq + , ppad-bech32 + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,38 @@ +module Main where + +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 new file mode 100644 --- /dev/null +++ b/test/Reference/Bech32.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +-- 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