ppad-bech32 (empty) → 0.1.0
raw patch · 10 files changed
+863/−0 lines, 10 filesdep +arraydep +basedep +bytestring
Dependencies added: array, base, bytestring, criterion, deepseq, ppad-bech32, primitive, tasty, tasty-quickcheck
Files
- CHANGELOG +6/−0
- LICENSE +20/−0
- bench/Main.hs +49/−0
- bench/Reference/Bech32.hs +163/−0
- lib/Data/ByteString/Base32.hs +216/−0
- lib/Data/ByteString/Bech32.hs +68/−0
- lib/Data/ByteString/Bech32m.hs +68/−0
- ppad-bech32.cabal +72/−0
- test/Main.hs +38/−0
- test/Reference/Bech32.hs +163/−0
+ CHANGELOG view
@@ -0,0 +1,6 @@+# Changelog++- 0.1.0 (2024-12-14)+ * Initial release, supporting encoding and checksum verification for+ bech32 and bech32m.+
+ LICENSE view
@@ -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.
+ bench/Main.hs view
@@ -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)
+ bench/Reference/Bech32.hs view
@@ -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
+ lib/Data/ByteString/Base32.hs view
@@ -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+
+ lib/Data/ByteString/Bech32.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module: Data.ByteString.Bech32+-- Copyright: (c) 2024 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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+
+ lib/Data/ByteString/Bech32m.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module: Data.ByteString.Bech32m+-- Copyright: (c) 2024 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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+
+ ppad-bech32.cabal view
@@ -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+
+ test/Main.hs view
@@ -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
+ test/Reference/Bech32.hs view
@@ -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