diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,11 @@ # Changelog +- 0.2.0 (2025-01-04) + * Adds bech32/bech32m/base32 decoding. + * Fixes a bug in which mixed-case HRP's would result in encodings with + invalid checksums (IIRC this also affects the Haskell reference + implementation). + - 0.1.2 (2024-12-15) * Minor performance improvements. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -21,40 +21,45 @@ suite ] -base32 :: Benchmark -base32 = bgroup "base32 encode" [ +base32_encode :: Benchmark +base32_encode = bgroup "base32 encode" [ bench "120b" $ nf Base32.encode "jtobin was here" , bench "128b (non 40-bit multiple length)" $ nf Base32.encode "jtobin was here!" , bench "240b" $ nf Base32.encode "jtobin was herejtobin was here" ] -bech32 :: Benchmark -bech32 = bgroup "bech32 encode" [ - bench "120b" $ nf (Bech32.encode "bc") "jtobin was here" +base32_decode :: Benchmark +base32_decode = bgroup "base32 decode" [ + bench "120b" $ nf Base32.decode "df6x7cnfdcs8wctnyp5x2un9" , bench "128b (non 40-bit multiple length)" $ - nf (Bech32.encode "bc") "jtobin was here!" - , bench "240b" $ nf (Bech32.encode "bc") "jtobin was herejtobin was here" + nf Base32.decode "df6x7cnfdcs8wctnyp5x2un9yy" ] +bech32_encode :: Benchmark +bech32_encode = bgroup "bech32 encode" [ + bench "120b" $ nf (Bech32.encode "bc") "jtobin was here" + ] + +bech32_decode :: Benchmark +bech32_decode = bgroup "bech32 decode" [ + bench "120b" $ nf Bech32.decode "bc1df6x7cnfdcs8wctnyp5x2un9f0pw8y" + ] + suite :: Benchmark -suite = env setup $ \ ~(a, b, c) -> bgroup "benchmarks" [ +suite = bgroup "benchmarks" [ bgroup "ppad-bech32" [ - base32 - , bech32 + base32_encode + , base32_decode + , bech32_encode + , bech32_decode ] , bgroup "reference" [ - bgroup "bech32" [ - bench "120b" $ nf (R.bech32Encode "bc") a - , bench "128b (non 40-bit multiple length)" $ - nf (R.bech32Encode "bc") b - , bench "240b" $ nf (R.bech32Encode "bc") c + bgroup "bech32 encode" [ + bench "120b" $ nf (refEncode "bc") "jtobin was here" ] ] ] 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) + refEncode h a = R.bech32Encode h (R.toBase32 (BS.unpack a)) + diff --git a/lib/Data/ByteString/Base32.hs b/lib/Data/ByteString/Base32.hs --- a/lib/Data/ByteString/Base32.hs +++ b/lib/Data/ByteString/Base32.hs @@ -1,32 +1,36 @@ -{-# OPTIONS_HADDOCK hide, prune #-} +{-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +-- | +-- Module: Data.ByteString.Base32 +-- Copyright: (c) 2024 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Unpadded base32 encoding & decoding using the bech32 character set. + +-- this module is an adaptation of emilypi's 'base32' library + module Data.ByteString.Base32 ( + -- * base32 encoding and decoding encode - , as_word5 - , as_base32 - - -- not actually base32-related, but convenient to put here - , Encoding(..) - , create_checksum - , verify - , valid_hrp + , decode ) where +import Control.Monad (guard) 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.Internal as BI import qualified Data.ByteString.Unsafe as BU -import qualified Data.Primitive.PrimArray as PA -import Data.Word (Word32) - -_BECH32M_CONST :: Word32 -_BECH32M_CONST = 0x2bc830a3 +import Data.Word (Word8, Word32, Word64) fi :: (Integral a, Num b) => a -> b fi = fromIntegral @@ -49,195 +53,245 @@ 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 +word5 :: Word8 -> Maybe Word8 +word5 w8 = fmap fi (BS.elemIndex w8 bech32_charset) - 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 +arrange :: Word32 -> Word8 -> BSB.Builder +arrange w32 w8 = + let mask = 0b00011111 -- low 5-bit mask + bech32_char = fi . BS.index bech32_charset . fi -- word5 -> bech32 - | 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) + -- split 40 bits into 8 w5's + w5_0 = mask .&. (w32 `B.shiftR` 27) -- highest 5 bits + w5_1 = mask .&. (w32 `B.shiftR` 22) + w5_2 = mask .&. (w32 `B.shiftR` 17) + w5_3 = mask .&. (w32 `B.shiftR` 12) + w5_4 = mask .&. (w32 `B.shiftR` 07) + w5_5 = mask .&. (w32 `B.shiftR` 02) + -- combine lowest 2 bits of w32 with highest 3 bits of w8 + w5_6 = mask .&. (w32 `B.shiftL` 03 .|. fi w8 `B.shiftR` 05) + -- lowest 5 bits of w8 + w5_7 = mask .&. fi w8 - !w16 = fi t - .|. fi u `B.shiftL` 8 + -- get (w8) bech32 char for each w5, pack all into little-endian w64 + !w64 = bech32_char w5_0 + .|. bech32_char w5_1 `B.shiftL` 8 + .|. bech32_char w5_2 `B.shiftL` 16 + .|. bech32_char w5_3 `B.shiftL` 24 + .|. bech32_char w5_4 `B.shiftL` 32 + .|. bech32_char w5_5 `B.shiftL` 40 + .|. bech32_char w5_6 `B.shiftL` 48 + .|. bech32_char w5_7 `B.shiftL` 56 - in BSB.word16LE w16 + in BSB.word64LE w64 +{-# INLINE arrange #-} - | 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) +-- | Encode a base256-encoded 'ByteString' as a base32-encoded +-- 'ByteString', using the bech32 character set. +-- +-- >>> encode "jtobin was here!" +-- "df6x7cnfdcs8wctnyp5x2un9yy" +encode + :: BS.ByteString -- ^ base256-encoded bytestring + -> BS.ByteString -- ^ base32-encoded bytestring +encode dat = toStrict (go dat) where + bech32_char = fi . BS.index bech32_charset . fi - !w32 = fi t - .|. fi u `B.shiftL` 8 - .|. fi v `B.shiftL` 16 - .|. fi w `B.shiftL` 24 + go bs@(BI.PS _ _ l) + | l >= 5 = case BS.splitAt 5 bs of + (chunk, etc) -> case BS.unsnoc chunk of + Nothing -> error "impossible, chunk length is 5" + Just (word32be -> w32, w8) -> arrange w32 w8 <> go etc + | l == 0 = mempty + | l == 1 = + let a = BU.unsafeIndex bs 0 + t = bech32_char ((a .&. 0b11111000) `B.shiftR` 3) + u = bech32_char ((a .&. 0b00000111) `B.shiftL` 2) - in BSB.word32LE w32 + !w16 = fi t + .|. fi u `B.shiftL` 8 - | 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.word16LE w16 + | l == 2 = + let a = BU.unsafeIndex bs 0 + b = BU.unsafeIndex bs 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) - !w32 = fi t - .|. fi u `B.shiftL` 8 - .|. fi v `B.shiftL` 16 - .|. fi w `B.shiftL` 24 + !w32 = fi t + .|. fi u `B.shiftL` 8 + .|. fi v `B.shiftL` 16 + .|. fi w `B.shiftL` 24 - in BSB.word32LE w32 <> BSB.word8 x + in BSB.word32LE w32 + | l == 3 = + let a = BU.unsafeIndex bs 0 + b = BU.unsafeIndex bs 1 + c = BU.unsafeIndex bs 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) - | 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) + !w32 = fi t + .|. fi u `B.shiftL` 8 + .|. fi v `B.shiftL` 16 + .|. fi w `B.shiftL` 24 - !w32 = fi t - .|. fi u `B.shiftL` 8 - .|. fi v `B.shiftL` 16 - .|. fi w `B.shiftL` 24 + in BSB.word32LE w32 <> BSB.word8 x + | l == 4 = + let a = BU.unsafeIndex bs 0 + b = BU.unsafeIndex bs 1 + c = BU.unsafeIndex bs 2 + d = BU.unsafeIndex bs 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) - !w16 = fi x - .|. fi y `B.shiftL` 8 + !w32 = fi t + .|. fi u `B.shiftL` 8 + .|. fi v `B.shiftL` 16 + .|. fi w `B.shiftL` 24 - in BSB.word32LE w32 <> BSB.word16LE w16 <> BSB.word8 z + !w16 = fi x + .|. fi y `B.shiftL` 8 - | otherwise -> mempty + in BSB.word32LE w32 <> BSB.word16LE w16 <> BSB.word8 z - _ -> case BS.unsnoc chunk of - Nothing -> error "impossible, chunk length is 5" - Just (word32be -> w32, fi -> w8) -> arrange w32 w8 <> go etc + | otherwise = + error "impossible" --- 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 +-- | Decode a 'ByteString', encoded as base32 using the bech32 character +-- set, to a base256-encoded 'ByteString'. +-- +-- >>> decode "df6x7cnfdcs8wctnyp5x2un9yy" +-- Just "jtobin was here!" +-- >>> decode "dfOx7cnfdcs8wctnyp5x2un9yy" -- s/6/O (non-bech32 character) +-- Nothing +decode + :: BS.ByteString -- ^ base32-encoded bytestring + -> Maybe BS.ByteString -- ^ base256-encoded bytestring +decode = fmap toStrict . go mempty where + go acc bs@(BI.PS _ _ l) + | l < 8 = do + fin <- finalize bs + pure (acc <> fin) + | otherwise = case BS.splitAt 8 bs of + (chunk, etc) -> do + res <- decode_chunk chunk + go (acc <> res) etc - 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) +finalize :: BS.ByteString -> Maybe BSB.Builder +finalize bs@(BI.PS _ _ l) + | l == 0 = Just mempty + | otherwise = do + guard (l >= 2) + w5_0 <- word5 (BU.unsafeIndex bs 0) + w5_1 <- word5 (BU.unsafeIndex bs 1) + let w8_0 = w5_0 `B.shiftL` 3 + .|. w5_1 `B.shiftR` 2 - !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 + -- https://datatracker.ietf.org/doc/html/rfc4648#section-6 + if | l == 2 -> do -- 2 w5's, need 1 w8; 2 bits remain + guard (w5_1 `B.shiftL` 6 == 0) + pure (BSB.word8 w8_0) - in BSB.word64LE w64 -{-# INLINE arrange #-} + | l == 4 -> do -- 4 w5's, need 2 w8's; 4 bits remain + w5_2 <- word5 (BU.unsafeIndex bs 2) + w5_3 <- word5 (BU.unsafeIndex bs 3) + let w8_1 = w5_1 `B.shiftL` 6 + .|. w5_2 `B.shiftL` 1 + .|. w5_3 `B.shiftR` 4 --- 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 + !w16 = fi w8_1 + .|. fi w8_0 `B.shiftL` 8 --- naive word5 -> base32 -as_base32 :: BS.ByteString -> BS.ByteString -as_base32 = BS.map (BS.index bech32_charset . fi) + guard (w5_3 `B.shiftL` 4 == 0) + pure (BSB.word16BE w16) -polymod :: BS.ByteString -> Word32 -polymod = BS.foldl' alg 1 where - generator = PA.primArrayFromListN 5 - [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3] + | l == 5 -> do -- 5 w5's, need 3 w8's; 1 bit remains + w5_2 <- word5 (BU.unsafeIndex bs 2) + w5_3 <- word5 (BU.unsafeIndex bs 3) + w5_4 <- word5 (BU.unsafeIndex bs 4) + let w8_1 = w5_1 `B.shiftL` 6 + .|. w5_2 `B.shiftL` 1 + .|. w5_3 `B.shiftR` 4 + w8_2 = w5_3 `B.shiftL` 4 + .|. w5_4 `B.shiftR` 1 - 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 + w16 = fi w8_1 + .|. fi w8_0 `B.shiftL` 8 - 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) + guard (w5_4 `B.shiftL` 7 == 0) + pure (BSB.word16BE w16 <> BSB.word8 w8_2) -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 + | l == 7 -> do -- 7 w5's, need 4 w8's; 3 bits remain + w5_2 <- word5 (BU.unsafeIndex bs 2) + w5_3 <- word5 (BU.unsafeIndex bs 3) + w5_4 <- word5 (BU.unsafeIndex bs 4) + w5_5 <- word5 (BU.unsafeIndex bs 5) + w5_6 <- word5 (BU.unsafeIndex bs 6) + let w8_1 = w5_1 `B.shiftL` 6 + .|. w5_2 `B.shiftL` 1 + .|. w5_3 `B.shiftR` 4 + w8_2 = w5_3 `B.shiftL` 4 + .|. w5_4 `B.shiftR` 1 + w8_3 = w5_4 `B.shiftL` 7 + .|. w5_5 `B.shiftL` 2 + .|. w5_6 `B.shiftR` 3 -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) + w32 = fi w8_3 + .|. fi w8_2 `B.shiftL` 8 + .|. fi w8_1 `B.shiftL` 16 + .|. fi w8_0 `B.shiftL` 24 -data Encoding = - Bech32 - | Bech32m + guard (w5_6 `B.shiftL` 5 == 0) + pure (BSB.word32BE w32) -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 + | otherwise -> Nothing - code i = (fi (pm `B.shiftR` fi i) .&. 0b11111) +-- assumes length 8 input +decode_chunk :: BS.ByteString -> Maybe BSB.Builder +decode_chunk bs = do + w5_0 <- word5 (BU.unsafeIndex bs 0) + w5_1 <- word5 (BU.unsafeIndex bs 1) + w5_2 <- word5 (BU.unsafeIndex bs 2) + w5_3 <- word5 (BU.unsafeIndex bs 3) + w5_4 <- word5 (BU.unsafeIndex bs 4) + w5_5 <- word5 (BU.unsafeIndex bs 5) + w5_6 <- word5 (BU.unsafeIndex bs 6) + w5_7 <- word5 (BU.unsafeIndex bs 7) - in BS.map code "\EM\DC4\SI\n\ENQ\NUL" -- BS.pack [25, 20, 15, 10, 5, 0] + let w40 :: Word64 + !w40 = fi w5_0 `B.shiftL` 35 + .|. fi w5_1 `B.shiftL` 30 + .|. fi w5_2 `B.shiftL` 25 + .|. fi w5_3 `B.shiftL` 20 + .|. fi w5_4 `B.shiftL` 15 + .|. fi w5_5 `B.shiftL` 10 + .|. fi w5_6 `B.shiftL` 05 + .|. fi w5_7 + !w32 = fi (w40 `B.shiftR` 8) :: Word32 + !w8 = fi (0b11111111 .&. w40) :: Word8 -verify :: Encoding -> BS.ByteString -> Bool -verify enc b32 = case BS.elemIndexEnd 0x31 b32 of - Nothing -> False - Just idx -> - let (hrp, BU.unsafeDrop 1 -> dat) = BS.splitAt idx b32 - bs = hrp_expand hrp <> as_word5 dat - in polymod bs == case enc of - Bech32 -> 1 - Bech32m -> _BECH32M_CONST + pure $ BSB.word32BE w32 <> BSB.word8 w8 diff --git a/lib/Data/ByteString/Bech32.hs b/lib/Data/ByteString/Bech32.hs --- a/lib/Data/ByteString/Bech32.hs +++ b/lib/Data/ByteString/Bech32.hs @@ -9,11 +9,12 @@ -- -- The -- [BIP0173](https://github.com/bitcoin/bips/blob/master/bip-0173.mediawiki) --- bech32 checksummed base32 encoding, with checksum verification. +-- bech32 checksummed base32 encoding, with decoding and checksum verification. module Data.ByteString.Bech32 ( - -- * Encoding + -- * Encoding and Decoding encode + , decode -- * Checksum , verify @@ -23,10 +24,11 @@ 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.Bech32.Internal as BI import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Builder.Extra as BE -import qualified Data.Char as C (toLower) +import qualified Data.ByteString.Internal as BSI +import qualified Data.Char as C (toLower, isLower, isAlpha) -- realization for small builders toStrict :: BSB.Builder -> BS.ByteString @@ -35,28 +37,51 @@ {-# INLINE toStrict #-} create_checksum :: BS.ByteString -> BS.ByteString -> BS.ByteString -create_checksum = B32.create_checksum Bech32 +create_checksum = BI.create_checksum BI.Bech32 --- | Encode a base255 human-readable part and input as bech32. +-- | Encode a base256 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 + :: BS.ByteString -- ^ base256-encoded human-readable part + -> BS.ByteString -- ^ base256-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) +encode (B8.map C.toLower -> hrp) (B32.encode -> dat) = do + guard (BI.valid_hrp hrp) + let check = create_checksum hrp (BI.as_word5 dat) res = toStrict $ - BSB.byteString (B8.map C.toLower hrp) + BSB.byteString hrp <> BSB.word8 49 -- 1 <> BSB.byteString dat - <> BSB.byteString (B32.as_base32 check) + <> BSB.byteString (BI.as_base32 check) guard (BS.length res < 91) pure res +-- | Decode a bech32-encoded 'ByteString' into its human-readable and data +-- parts. +-- +-- >>> decode "hi1df6x7cnfdcs8wctnyp5x2un9wed5st" +-- Just ("hi","jtobin was here") +-- >>> decode "hey1df6x7cnfdcs8wctnyp5x2un9wed5st" -- s/hi/hey +-- Nothing +decode + :: BS.ByteString -- ^ bech23-encoded bytestring + -> Maybe (BS.ByteString, BS.ByteString) -- ^ (hrp, data less checksum) +decode bs@(BSI.PS _ _ l) = do + guard (l <= 90) + guard (B8.all (\a -> if C.isAlpha a then C.isLower a else True) bs) + guard (verify bs) + sep <- BS.elemIndexEnd 0x31 bs + case BS.splitAt sep bs of + (hrp, raw) -> do + guard (BI.valid_hrp hrp) + guard (BS.length raw >= 6) + (_, BS.dropEnd 6 -> bech32dat) <- BS.uncons raw + dat <- B32.decode bech32dat + pure (hrp, dat) + -- | Verify that a bech32 string has a valid checksum. -- -- >>> verify "bc1d4ujqum5wf5kuecmu02w2" @@ -66,5 +91,5 @@ verify :: BS.ByteString -- ^ bech32-encoded bytestring -> Bool -verify = B32.verify Bech32 +verify = BI.verify BI.Bech32 diff --git a/lib/Data/ByteString/Bech32/Internal.hs b/lib/Data/ByteString/Bech32/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Bech32/Internal.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_HADDOCK hide, prune #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Data.ByteString.Bech32.Internal ( + as_word5 + , as_base32 + , 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.Internal as BI +import qualified Data.ByteString.Unsafe as BU +import qualified Data.Primitive.PrimArray as PA +import Data.Word (Word32) + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral +{-# INLINE fi #-} + +-- realization for small builders +toStrict :: BSB.Builder -> BS.ByteString +toStrict = BS.toStrict + . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty +{-# INLINE toStrict #-} + +_BECH32M_CONST :: Word32 +_BECH32M_CONST = 0x2bc830a3 + +bech32_charset :: BS.ByteString +bech32_charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l" + +-- 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@(BI.PS _ _ l) + | l == 0 || l > 83 = False + | otherwise = BS.all (\b -> (b > 32) && (b < 127)) 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, BU.unsafeDrop 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/Bech32m.hs b/lib/Data/ByteString/Bech32m.hs --- a/lib/Data/ByteString/Bech32m.hs +++ b/lib/Data/ByteString/Bech32m.hs @@ -9,11 +9,13 @@ -- -- The -- [BIP350](https://github.com/bitcoin/bips/blob/master/bip-0350.mediawiki) --- bech32m checksummed base32 encoding, with checksum verification. +-- bech32m checksummed base32 encoding, with decoding and checksum +-- verification. module Data.ByteString.Bech32m ( - -- * Encoding + -- * Encoding and Decoding encode + , decode -- * Checksum , verify @@ -23,9 +25,10 @@ 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.Bech32.Internal as BI import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Builder.Extra as BE +import qualified Data.ByteString.Internal as BSI import qualified Data.Char as C (toLower) -- realization for small builders @@ -35,28 +38,50 @@ {-# INLINE toStrict #-} create_checksum :: BS.ByteString -> BS.ByteString -> BS.ByteString -create_checksum = B32.create_checksum Bech32m +create_checksum = BI.create_checksum BI.Bech32m --- | Encode a base255 human-readable part and input as bech32m. +-- | Encode a base256 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 + :: BS.ByteString -- ^ base256-encoded human-readable part + -> BS.ByteString -- ^ base256-encoded data part -> Maybe BS.ByteString -- ^ bech32m-encoded bytestring -encode hrp (B32.encode -> dat) = do - guard (B32.valid_hrp hrp) - let check = create_checksum hrp (B32.as_word5 dat) +encode (B8.map C.toLower -> hrp) (B32.encode -> dat) = do + guard (BI.valid_hrp hrp) + let check = create_checksum hrp (BI.as_word5 dat) res = toStrict $ - BSB.byteString (B8.map C.toLower hrp) + BSB.byteString hrp <> BSB.word8 49 -- 1 <> BSB.byteString dat - <> BSB.byteString (B32.as_base32 check) + <> BSB.byteString (BI.as_base32 check) guard (BS.length res < 91) pure res +-- | Decode a bech32m-encoded 'ByteString' into its human-readable and data +-- parts. +-- +-- >>> decode "hi1df6x7cnfdcs8wctnyp5x2un9m9ac4f" +-- Just ("hi","jtobin was here") +-- >>> decode "hey1df6x7cnfdcs8wctnyp5x2un9m9ac4f" -- s/hi/hey +-- Nothing +decode + :: BS.ByteString -- ^ bech23-encoded bytestring + -> Maybe (BS.ByteString, BS.ByteString) -- ^ (hrp, data less checksum) +decode bs@(BSI.PS _ _ l) = do + guard (l <= 90) + guard (verify bs) + sep <- BS.elemIndexEnd 0x31 bs + case BS.splitAt sep bs of + (hrp, raw) -> do + guard (BI.valid_hrp hrp) + guard (BS.length raw >= 6) + (_, BS.dropEnd 6 -> bech32dat) <- BS.uncons raw + dat <- B32.decode bech32dat + pure (hrp, dat) + -- | Verify that a bech32m string has a valid checksum. -- -- >>> verify "bc1d4ujqum5wf5kuecwqlxtg" @@ -66,5 +91,5 @@ verify :: BS.ByteString -- ^ bech32m-encoded bytestring -> Bool -verify = B32.verify Bech32m +verify = BI.verify BI.Bech32m diff --git a/ppad-bech32.cabal b/ppad-bech32.cabal --- a/ppad-bech32.cabal +++ b/ppad-bech32.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: ppad-bech32 -version: 0.1.2 -synopsis: The bech32 and bech32m encodings, per BIPs 173 & 350. +version: 0.2.0 +synopsis: bech32 and bech32m encoding/decoding, per BIPs 173 & 350. license: MIT license-file: LICENSE author: Jared Tobin @@ -11,8 +11,8 @@ tested-with: GHC == 9.8.1 extra-doc-files: CHANGELOG description: - The bech32 and bech32m encodings on strict bytestrings, per BIPs 173 & - 350. + bech32 and bech32m encoding/decoding on strict bytestrings, per BIPs + 173 & 350. source-repository head type: git @@ -25,6 +25,7 @@ -Wall exposed-modules: Data.ByteString.Base32 + , Data.ByteString.Bech32.Internal , Data.ByteString.Bech32 , Data.ByteString.Bech32m build-depends: diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,25 +1,39 @@ module Main where +import qualified Data.Char as C import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Bech32 as Bech32 +import qualified Data.ByteString.Bech32m as Bech32m +import qualified Data.ByteString.Base32 as B32 import Test.Tasty import qualified Test.Tasty.QuickCheck as Q import qualified Reference.Bech32 as R -data Input = Input BS.ByteString BS.ByteString +newtype BS = BS BS.ByteString deriving (Eq, Show) -instance Q.Arbitrary Input where +data ValidInput = ValidInput BS.ByteString BS.ByteString + deriving (Eq, Show) + +instance Q.Arbitrary ValidInput where arbitrary = do h <- hrp - b <- bytes (83 - BS.length h) - pure (Input h b) + let l = 83 - BS.length h + a = l * 5 `quot` 8 + b <- bytes a + pure (ValidInput h b) +instance Q.Arbitrary BS where + arbitrary = do + b <- bytes 1024 + pure (BS 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) + pure (B8.map C.toLower (BS.pack v)) bytes :: Int -> Q.Gen BS.ByteString bytes k = do @@ -27,12 +41,46 @@ v <- Q.vectorOf l Q.arbitrary pure (BS.pack v) -matches :: Input -> Bool -matches (Input h b) = +matches_reference :: ValidInput -> Bool +matches_reference (ValidInput h b) = let ref = R.bech32Encode h (R.toBase32 (BS.unpack b)) our = Bech32.encode h b in ref == our +bech32_decode_inverts_encode :: ValidInput -> Bool +bech32_decode_inverts_encode (ValidInput h b) = case Bech32.encode h b of + Nothing -> error "generated faulty input" + Just enc -> case Bech32.decode enc of + Nothing -> False + Just (h', dat) -> h == h' && b == dat + +bech32m_decode_inverts_encode :: ValidInput -> Bool +bech32m_decode_inverts_encode (ValidInput h b) = case Bech32m.encode h b of + Nothing -> error "generated faulty input" + Just enc -> case Bech32m.decode enc of + Nothing -> False + Just (h', dat) -> h == h' && b == dat + +base32_decode_inverts_encode :: BS -> Bool +base32_decode_inverts_encode (BS bs) = case B32.decode (B32.encode bs) of + Nothing -> False + Just b -> b == bs + main :: IO () -main = defaultMain $ - Q.testProperty "encoding matches reference" matches +main = defaultMain $ testGroup "ppad-bech32" [ + testGroup "base32" [ + Q.testProperty "decode . encode ~ id" $ + Q.withMaxSuccess 1000 base32_decode_inverts_encode + ] + , testGroup "bech32" [ + Q.testProperty "Bech32.encode ~ R.bech32Encode" $ + Q.withMaxSuccess 1000 matches_reference + , Q.testProperty "decode . encode ~ id" $ + Q.withMaxSuccess 1000 bech32_decode_inverts_encode + ] + , testGroup "bech32m" [ + Q.testProperty "decode . encode ~ id" $ + Q.withMaxSuccess 1000 bech32m_decode_inverts_encode + ] + ] +