ppad-bech32 0.2.4 → 0.2.5
raw patch · 7 files changed
+408/−386 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG +3/−0
- lib/Data/ByteString/Base32.hs +262/−284
- lib/Data/ByteString/Base32/Internal.hs +59/−0
- lib/Data/ByteString/Bech32.hs +1/−13
- lib/Data/ByteString/Bech32/Internal.hs +79/−75
- lib/Data/ByteString/Bech32m.hs +1/−13
- ppad-bech32.cabal +3/−1
CHANGELOG view
@@ -1,5 +1,8 @@ # Changelog +- 0.2.5 (2026-05-16)+ * Improves bech32 encode/decode performance by about 2x.+ - 0.2.4 (2025-12-28) * Adds an 'llvm' build flag and tests with GHC 9.10.3.
lib/Data/ByteString/Base32.hs view
@@ -1,10 +1,5 @@ {-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-} -- | -- Module: Data.ByteString.Base32@@ -14,112 +9,27 @@ -- -- 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 , decode ) where -import Control.Monad (guard)-import Data.Bits ((.|.), (.&.)) import qualified Data.Bits as B+import Data.Bits ((.&.), (.|.)) import qualified Data.ByteString as BS-import qualified Data.ByteString.Builder as BSB-import qualified Data.ByteString.Builder.Extra as BE+import Data.ByteString.Base32.Internal (enc_tab, dec_tab) import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Unsafe as BU-import Data.Word (Word8, Word32, Word64)+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peekElemOff, pokeElemOff)+import System.IO.Unsafe (unsafeDupablePerformIO) -fi :: (Integral a, Num b) => a -> b+fi :: (Num a, Integral b) => b -> a 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-{-# INLINE toStrict #-}--bech32_charset :: BS.ByteString-bech32_charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"--word5 :: Word8 -> Maybe Word8-word5 = \case- 113 -> pure $! 0- 112 -> pure $! 1- 122 -> pure $! 2- 114 -> pure $! 3- 121 -> pure $! 4- 57 -> pure $! 5- 120 -> pure $! 6- 56 -> pure $! 7- 103 -> pure $! 8- 102 -> pure $! 9- 50 -> pure $! 10- 116 -> pure $! 11- 118 -> pure $! 12- 100 -> pure $! 13- 119 -> pure $! 14- 48 -> pure $! 15- 115 -> pure $! 16- 51 -> pure $! 17- 106 -> pure $! 18- 110 -> pure $! 19- 53 -> pure $! 20- 52 -> pure $! 21- 107 -> pure $! 22- 104 -> pure $! 23- 99 -> pure $! 24- 101 -> pure $! 25- 54 -> pure $! 26- 109 -> pure $! 27- 117 -> pure $! 28- 97 -> pure $! 29- 55 -> pure $! 30- 108 -> pure $! 31- _ -> Nothing-{-# INLINE word5 #-}--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-- -- 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-- -- 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.word64LE w64-{-# INLINE arrange #-}- -- | Encode a base256-encoded 'ByteString' as a base32-encoded -- 'ByteString', using the bech32 character set. --@@ -128,91 +38,101 @@ 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-- 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)-- !w16 = fi t- .|. fi u `B.shiftL` 8-- 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-- 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)-- !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)-- !w32 = fi t- .|. fi u `B.shiftL` 8- .|. fi v `B.shiftL` 16- .|. fi w `B.shiftL` 24-- !w16 = fi x- .|. fi y `B.shiftL` 8+encode (BI.PS sfp soff l) = case enc_tab of+ BI.PS tfp toff _ ->+ let !outlen = (l * 8 + 4) `quot` 5+ in BI.unsafeCreate outlen $ \dst ->+ withForeignPtr sfp $ \sp0 ->+ withForeignPtr tfp $ \tp0 -> do+ let !sp = sp0 `plusPtr` soff :: Ptr Word8+ !tp = tp0 `plusPtr` toff :: Ptr Word8+ encode_loop sp tp dst l 0 0 - in BSB.word32LE w32 <> BSB.word16LE w16 <> BSB.word8 z+encode_loop+ :: Ptr Word8 -> Ptr Word8 -> Ptr Word8+ -> Int -> Int -> Int -> IO ()+encode_loop !sp !tp !dst !len !i !j+ | i + 5 <= len = do+ a <- peekElemOff sp i+ b <- peekElemOff sp (i + 1)+ c <- peekElemOff sp (i + 2)+ d <- peekElemOff sp (i + 3)+ e <- peekElemOff sp (i + 4)+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f+ !w2 = (b `B.shiftR` 1) .&. 0x1f+ !w3 = (b `B.shiftL` 4 .|. c `B.shiftR` 4) .&. 0x1f+ !w4 = (c `B.shiftL` 1 .|. d `B.shiftR` 7) .&. 0x1f+ !w5 = (d `B.shiftR` 2) .&. 0x1f+ !w6 = (d `B.shiftL` 3 .|. e `B.shiftR` 5) .&. 0x1f+ !w7 = e .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)+ peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)+ peekElemOff tp (fi w4) >>= pokeElemOff dst (j + 4)+ peekElemOff tp (fi w5) >>= pokeElemOff dst (j + 5)+ peekElemOff tp (fi w6) >>= pokeElemOff dst (j + 6)+ peekElemOff tp (fi w7) >>= pokeElemOff dst (j + 7)+ encode_loop sp tp dst len (i + 5) (j + 8)+ | otherwise = encode_tail sp tp dst len i j - | otherwise =- error "impossible"+encode_tail+ :: Ptr Word8 -> Ptr Word8 -> Ptr Word8+ -> Int -> Int -> Int -> IO ()+encode_tail !sp !tp !dst !len !i !j = case len - i of+ 0 -> pure ()+ 1 -> do+ a <- peekElemOff sp i+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2) .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ 2 -> do+ a <- peekElemOff sp i+ b <- peekElemOff sp (i + 1)+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f+ !w2 = (b `B.shiftR` 1) .&. 0x1f+ !w3 = (b `B.shiftL` 4) .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)+ peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)+ 3 -> do+ a <- peekElemOff sp i+ b <- peekElemOff sp (i + 1)+ c <- peekElemOff sp (i + 2)+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f+ !w2 = (b `B.shiftR` 1) .&. 0x1f+ !w3 = (b `B.shiftL` 4 .|. c `B.shiftR` 4) .&. 0x1f+ !w4 = (c `B.shiftL` 1) .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)+ peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)+ peekElemOff tp (fi w4) >>= pokeElemOff dst (j + 4)+ 4 -> do+ a <- peekElemOff sp i+ b <- peekElemOff sp (i + 1)+ c <- peekElemOff sp (i + 2)+ d <- peekElemOff sp (i + 3)+ let !w0 = (a `B.shiftR` 3) .&. 0x1f+ !w1 = (a `B.shiftL` 2 .|. b `B.shiftR` 6) .&. 0x1f+ !w2 = (b `B.shiftR` 1) .&. 0x1f+ !w3 = (b `B.shiftL` 4 .|. c `B.shiftR` 4) .&. 0x1f+ !w4 = (c `B.shiftL` 1 .|. d `B.shiftR` 7) .&. 0x1f+ !w5 = (d `B.shiftR` 2) .&. 0x1f+ !w6 = (d `B.shiftL` 3) .&. 0x1f+ peekElemOff tp (fi w0) >>= pokeElemOff dst j+ peekElemOff tp (fi w1) >>= pokeElemOff dst (j + 1)+ peekElemOff tp (fi w2) >>= pokeElemOff dst (j + 2)+ peekElemOff tp (fi w3) >>= pokeElemOff dst (j + 3)+ peekElemOff tp (fi w4) >>= pokeElemOff dst (j + 4)+ peekElemOff tp (fi w5) >>= pokeElemOff dst (j + 5)+ peekElemOff tp (fi w6) >>= pokeElemOff dst (j + 6)+ _ -> pure () -- impossible: 0 <= len - i < 5 -- | Decode a 'ByteString', encoded as base32 using the bech32 character -- set, to a base256-encoded 'ByteString'.@@ -224,108 +144,166 @@ 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--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-- -- 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)-- | 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-- !w16 = fi w8_1- .|. fi w8_0 `B.shiftL` 8-- guard (w5_3 `B.shiftL` 4 == 0)- pure (BSB.word16BE w16)-- | 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-- w16 = fi w8_1- .|. fi w8_0 `B.shiftL` 8-- guard (w5_4 `B.shiftL` 7 == 0)- pure (BSB.word16BE w16 <> BSB.word8 w8_2)-- | 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-- w32 = fi w8_3- .|. fi w8_2 `B.shiftL` 8- .|. fi w8_1 `B.shiftL` 16- .|. fi w8_0 `B.shiftL` 24-- guard (w5_6 `B.shiftL` 5 == 0)- pure (BSB.word32BE w32)-- | otherwise -> Nothing---- 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)-- 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+decode (BI.PS sfp soff l) = case l `rem` 8 of+ 1 -> Nothing+ 3 -> Nothing+ 6 -> Nothing+ _ -> case dec_tab of+ BI.PS tfp toff _ -> unsafeDupablePerformIO $ do+ let !n = (l * 5) `B.shiftR` 3+ fp <- BI.mallocByteString n+ ok <- withForeignPtr fp $ \dst ->+ withForeignPtr sfp $ \sp0 ->+ withForeignPtr tfp $ \tp0 -> do+ let !sp = sp0 `plusPtr` soff :: Ptr Word8+ !tp = tp0 `plusPtr` toff :: Ptr Word8+ decode_loop sp tp dst l 0 0 0+ pure $! if ok then Just (BI.PS fp 0 n) else Nothing - pure $ BSB.word32BE w32 <> BSB.word8 w8+decode_loop+ :: Ptr Word8 -> Ptr Word8 -> Ptr Word8+ -> Int -> Int -> Int -> Word8 -> IO Bool+decode_loop !sp !tp !dst !len !i !j !acc+ | i + 8 <= len = do+ c0 <- peekElemOff sp i+ c1 <- peekElemOff sp (i + 1)+ c2 <- peekElemOff sp (i + 2)+ c3 <- peekElemOff sp (i + 3)+ c4 <- peekElemOff sp (i + 4)+ c5 <- peekElemOff sp (i + 5)+ c6 <- peekElemOff sp (i + 6)+ c7 <- peekElemOff sp (i + 7)+ n0 <- peekElemOff tp (fi c0)+ n1 <- peekElemOff tp (fi c1)+ n2 <- peekElemOff tp (fi c2)+ n3 <- peekElemOff tp (fi c3)+ n4 <- peekElemOff tp (fi c4)+ n5 <- peekElemOff tp (fi c5)+ n6 <- peekElemOff tp (fi c6)+ n7 <- peekElemOff tp (fi c7)+ let !v0 = n0 .&. 0x1f+ !v1 = n1 .&. 0x1f+ !v2 = n2 .&. 0x1f+ !v3 = n3 .&. 0x1f+ !v4 = n4 .&. 0x1f+ !v5 = n5 .&. 0x1f+ !v6 = n6 .&. 0x1f+ !v7 = n7 .&. 0x1f+ !b0 = (v0 `B.shiftL` 3) .|. (v1 `B.shiftR` 2)+ !b1 = (v1 `B.shiftL` 6) .|. (v2 `B.shiftL` 1) .|.+ (v3 `B.shiftR` 4)+ !b2 = (v3 `B.shiftL` 4) .|. (v4 `B.shiftR` 1)+ !b3 = (v4 `B.shiftL` 7) .|. (v5 `B.shiftL` 2) .|.+ (v6 `B.shiftR` 3)+ !b4 = (v6 `B.shiftL` 5) .|. v7+ pokeElemOff dst j b0+ pokeElemOff dst (j + 1) b1+ pokeElemOff dst (j + 2) b2+ pokeElemOff dst (j + 3) b3+ pokeElemOff dst (j + 4) b4+ decode_loop sp tp dst len (i + 8) (j + 5)+ (acc .|. n0 .|. n1 .|. n2 .|. n3 .|. n4 .|. n5 .|. n6 .|. n7)+ | otherwise = decode_tail sp tp dst len i j acc +decode_tail+ :: Ptr Word8 -> Ptr Word8 -> Ptr Word8+ -> Int -> Int -> Int -> Word8 -> IO Bool+decode_tail !sp !tp !dst !len !i !j !acc = case len - i of+ 0 -> pure $! acc .&. 0x40 == 0+ 2 -> do+ c0 <- peekElemOff sp i+ c1 <- peekElemOff sp (i + 1)+ n0 <- peekElemOff tp (fi c0)+ n1 <- peekElemOff tp (fi c1)+ let !v0 = n0 .&. 0x1f+ !v1 = n1 .&. 0x1f+ !b0 = (v0 `B.shiftL` 3) .|. (v1 `B.shiftR` 2)+ -- canonical-form check: bits dropped from v1 must be zero+ !slack = v1 `B.shiftL` 6+ pokeElemOff dst j b0+ pure $! (acc .|. n0 .|. n1) .&. 0x40 == 0 && slack == 0+ 4 -> do+ c0 <- peekElemOff sp i+ c1 <- peekElemOff sp (i + 1)+ c2 <- peekElemOff sp (i + 2)+ c3 <- peekElemOff sp (i + 3)+ n0 <- peekElemOff tp (fi c0)+ n1 <- peekElemOff tp (fi c1)+ n2 <- peekElemOff tp (fi c2)+ n3 <- peekElemOff tp (fi c3)+ let !v0 = n0 .&. 0x1f+ !v1 = n1 .&. 0x1f+ !v2 = n2 .&. 0x1f+ !v3 = n3 .&. 0x1f+ !b0 = (v0 `B.shiftL` 3) .|. (v1 `B.shiftR` 2)+ !b1 = (v1 `B.shiftL` 6) .|. (v2 `B.shiftL` 1) .|.+ (v3 `B.shiftR` 4)+ !slack = v3 `B.shiftL` 4+ pokeElemOff dst j b0+ pokeElemOff dst (j + 1) b1+ pure $! (acc .|. n0 .|. n1 .|. n2 .|. n3) .&. 0x40 == 0+ && slack == 0+ 5 -> do+ c0 <- peekElemOff sp i+ c1 <- peekElemOff sp (i + 1)+ c2 <- peekElemOff sp (i + 2)+ c3 <- peekElemOff sp (i + 3)+ c4 <- peekElemOff sp (i + 4)+ n0 <- peekElemOff tp (fi c0)+ n1 <- peekElemOff tp (fi c1)+ n2 <- peekElemOff tp (fi c2)+ n3 <- peekElemOff tp (fi c3)+ n4 <- peekElemOff tp (fi c4)+ let !v0 = n0 .&. 0x1f+ !v1 = n1 .&. 0x1f+ !v2 = n2 .&. 0x1f+ !v3 = n3 .&. 0x1f+ !v4 = n4 .&. 0x1f+ !b0 = (v0 `B.shiftL` 3) .|. (v1 `B.shiftR` 2)+ !b1 = (v1 `B.shiftL` 6) .|. (v2 `B.shiftL` 1) .|.+ (v3 `B.shiftR` 4)+ !b2 = (v3 `B.shiftL` 4) .|. (v4 `B.shiftR` 1)+ !slack = v4 `B.shiftL` 7+ pokeElemOff dst j b0+ pokeElemOff dst (j + 1) b1+ pokeElemOff dst (j + 2) b2+ pure $! (acc .|. n0 .|. n1 .|. n2 .|. n3 .|. n4) .&. 0x40 == 0+ && slack == 0+ 7 -> do+ c0 <- peekElemOff sp i+ c1 <- peekElemOff sp (i + 1)+ c2 <- peekElemOff sp (i + 2)+ c3 <- peekElemOff sp (i + 3)+ c4 <- peekElemOff sp (i + 4)+ c5 <- peekElemOff sp (i + 5)+ c6 <- peekElemOff sp (i + 6)+ n0 <- peekElemOff tp (fi c0)+ n1 <- peekElemOff tp (fi c1)+ n2 <- peekElemOff tp (fi c2)+ n3 <- peekElemOff tp (fi c3)+ n4 <- peekElemOff tp (fi c4)+ n5 <- peekElemOff tp (fi c5)+ n6 <- peekElemOff tp (fi c6)+ let !v0 = n0 .&. 0x1f+ !v1 = n1 .&. 0x1f+ !v2 = n2 .&. 0x1f+ !v3 = n3 .&. 0x1f+ !v4 = n4 .&. 0x1f+ !v5 = n5 .&. 0x1f+ !v6 = n6 .&. 0x1f+ !b0 = (v0 `B.shiftL` 3) .|. (v1 `B.shiftR` 2)+ !b1 = (v1 `B.shiftL` 6) .|. (v2 `B.shiftL` 1) .|.+ (v3 `B.shiftR` 4)+ !b2 = (v3 `B.shiftL` 4) .|. (v4 `B.shiftR` 1)+ !b3 = (v4 `B.shiftL` 7) .|. (v5 `B.shiftL` 2) .|.+ (v6 `B.shiftR` 3)+ !slack = v6 `B.shiftL` 5+ pokeElemOff dst j b0+ pokeElemOff dst (j + 1) b1+ pokeElemOff dst (j + 2) b2+ pokeElemOff dst (j + 3) b3+ pure $!+ (acc .|. n0 .|. n1 .|. n2 .|. n3 .|. n4 .|. n5 .|. n6)+ .&. 0x40 == 0+ && slack == 0+ _ -> pure False -- impossible: tail-length guard already rejected
+ lib/Data/ByteString/Base32/Internal.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_HADDOCK hide, prune #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Data.ByteString.Base32.Internal+-- Copyright: (c) 2024 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Static rodata tables for the bech32 base32 charset, shared by+-- 'Data.ByteString.Base32' and 'Data.ByteString.Bech32.Internal'.++module Data.ByteString.Base32.Internal (+ enc_tab+ , dec_tab+ ) where++import qualified Data.ByteString as BS++-- 32-byte encoding table: the bech32 character set. Maps a 5-bit+-- value (0..31) to its bech32 character. ASCII-only with no embedded+-- NUL, so the bytestring 'IsString' rule rewrites the literal to+-- 'unsafePackAddress' and the bytes live in static rodata.+enc_tab :: BS.ByteString+enc_tab = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"+{-# NOINLINE enc_tab #-}++-- 256-byte reverse table. Index by an ASCII byte to obtain its+-- 5-bit value (biased into bit 5); valid bech32 chars map to+-- 0x20..0x3f, every other byte maps to 0x40.+--+-- The encoding is chosen so the literal is strictly ASCII and+-- contains no embedded NUL, which is what the bytestring 'IsString'+-- rule needs to rewrite it into 'unsafePackAddress' (cf. 'enc_tab')+-- - the bytes end up in static rodata, with no CAF allocation.+--+-- The 0x40 sentinel is distinguished by bit 6; no value 0x20..0x3f+-- carries that bit, so callers OR-fold every lookup into an+-- accumulator and test 'acc .&. 0x40 == 0' once at the end. The+-- 5-bit value is extracted as 'b .&. 0x1f'.+dec_tab :: BS.ByteString+dec_tab =+ "\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x2f\x40\x2a\x31\x35\x34\x3a\x3e\x27\x25\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x3d\x40\x38\x2d\x39\x29\x28\x37\x40\x32\x36\x3f\x3b\x33\x40\+ \\x21\x20\x23\x30\x2b\x3c\x2c\x2e\x26\x24\x22\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\+ \\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40\x40"+{-# NOINLINE dec_tab #-}
lib/Data/ByteString/Bech32.hs view
@@ -25,17 +25,9 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Base32 as B32 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, isLower, isAlpha) --- realization for small builders-toStrict :: BSB.Builder -> BS.ByteString-toStrict = BS.toStrict- . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty-{-# INLINE toStrict #-}- create_checksum :: BS.ByteString -> BS.ByteString -> BS.ByteString create_checksum = BI.create_checksum BI.Bech32 @@ -52,11 +44,7 @@ guard (BI.valid_hrp hrp) ws <- BI.as_word5 dat let check = create_checksum hrp ws- res = toStrict $- BSB.byteString hrp- <> BSB.word8 49 -- 1- <> BSB.byteString dat- <> BSB.byteString (BI.as_base32 check)+ res = BS.concat [hrp, BS.singleton 49, dat, BI.as_base32 check] guard (BS.length res < 91) pure res
lib/Data/ByteString/Bech32/Internal.hs view
@@ -1,8 +1,6 @@ {-# OPTIONS_HADDOCK hide, prune #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Data.ByteString.Bech32.Internal (@@ -14,80 +12,65 @@ , valid_hrp ) where -import Data.Bits ((.&.))+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 Data.ByteString.Base32.Internal (enc_tab, dec_tab) import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Unsafe as BU import Data.Word (Word8, Word32)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peekElemOff, pokeElemOff)+import System.IO.Unsafe (unsafeDupablePerformIO) 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"--word5 :: Word8 -> Maybe Word8-word5 = \case- 113 -> pure $! 00 -- 'q'- 112 -> pure $! 01 -- 'p'- 122 -> pure $! 02 -- 'z'- 114 -> pure $! 03 -- 'r'- 121 -> pure $! 04 -- 'y'- 57 -> pure $! 05 -- '9'- 120 -> pure $! 06 -- 'x'- 56 -> pure $! 07 -- '8'- 103 -> pure $! 08 -- 'g'- 102 -> pure $! 09 -- 'f'- 50 -> pure $! 10 -- '2'- 116 -> pure $! 11 -- 't'- 118 -> pure $! 12 -- 'v'- 100 -> pure $! 13 -- 'd'- 119 -> pure $! 14 -- 'w'- 48 -> pure $! 15 -- '0'- 115 -> pure $! 16 -- 's'- 51 -> pure $! 17 -- '3'- 106 -> pure $! 18 -- 'j'- 110 -> pure $! 19 -- 'n'- 53 -> pure $! 20 -- '5'- 52 -> pure $! 21 -- '4'- 107 -> pure $! 22 -- 'k'- 104 -> pure $! 23 -- 'h'- 99 -> pure $! 24 -- 'c'- 101 -> pure $! 25 -- 'e'- 54 -> pure $! 26 -- '6'- 109 -> pure $! 27 -- 'm'- 117 -> pure $! 28 -- 'u'- 97 -> pure $! 29 -- 'a'- 55 -> pure $! 30 -- '7'- 108 -> pure $! 31 -- 'l'- _ -> Nothing-{-# INLINE word5 #-}---- base32 -> word5+-- | Translate base32 bytestring to its 5-bit-value bytestring. Each+-- input byte is looked up in 'dec_tab'; if any byte is not a valid+-- bech32 char, returns 'Nothing'. as_word5 :: BS.ByteString -> Maybe BS.ByteString-as_word5 = go mempty where- go acc bs = case BS.uncons bs of- Nothing -> pure (toStrict acc)- Just (h, t) -> do- w5 <- word5 (fi h)- go (acc <> BSB.word8 w5) t+as_word5 (BI.PS sfp soff l) = case dec_tab of+ BI.PS tfp toff _ -> unsafeDupablePerformIO $ do+ fp <- BI.mallocByteString l+ ok <- withForeignPtr fp $ \dst ->+ withForeignPtr sfp $ \sp0 ->+ withForeignPtr tfp $ \tp0 -> do+ let !sp = sp0 `plusPtr` soff :: Ptr Word8+ !tp = tp0 `plusPtr` toff :: Ptr Word8+ loop !i !acc+ | i == l = pure $! acc .&. 0x40 == 0+ | otherwise = do+ c <- peekElemOff sp i+ n <- peekElemOff tp (fi c)+ pokeElemOff dst i (n .&. 0x1f)+ loop (i + 1) (acc .|. n)+ loop 0 0+ pure $! if ok then Just (BI.PS fp 0 l) else Nothing --- word5 -> base32+-- | Translate a 5-bit-value bytestring to its bech32 base32+-- bytestring. as_base32 :: BS.ByteString -> BS.ByteString-as_base32 = BS.map (BU.unsafeIndex bech32_charset . fi)+as_base32 (BI.PS sfp soff l) = case enc_tab of+ BI.PS tfp toff _ ->+ BI.unsafeCreate l $ \dst ->+ withForeignPtr sfp $ \sp0 ->+ withForeignPtr tfp $ \tp0 -> do+ let !sp = sp0 `plusPtr` soff :: Ptr Word8+ !tp = tp0 `plusPtr` toff :: Ptr Word8+ loop !i+ | i == l = pure ()+ | otherwise = do+ v <- peekElemOff sp i+ c <- peekElemOff tp (fi v)+ pokeElemOff dst i c+ loop (i + 1)+ loop 0 polymod :: BS.ByteString -> Word32 polymod = BS.foldl' alg 1 where@@ -117,29 +100,51 @@ | l == 0 || l > 83 = False | otherwise = BS.all (\b -> (b > 32) && (b < 127)) hrp +-- | Build the bech32 HRP expansion: high-5-bits of each HRP byte,+-- then a single 0, then low-5-bits of each HRP byte. 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)+hrp_expand (BI.PS sfp soff l) =+ BI.unsafeCreate (2 * l + 1) $ \dst ->+ withForeignPtr sfp $ \sp0 -> do+ let !sp = sp0 `plusPtr` soff :: Ptr Word8+ loop_hi !i+ | i == l = pure ()+ | otherwise = do+ c <- peekElemOff sp i+ pokeElemOff dst i (c `B.shiftR` 5)+ loop_hi (i + 1)+ loop_lo !i+ | i == l = pure ()+ | otherwise = do+ c <- peekElemOff sp i+ pokeElemOff dst (l + 1 + i) (c .&. 0x1f)+ loop_lo (i + 1)+ loop_hi 0+ pokeElemOff dst l (0 :: Word8)+ loop_lo 0 data Encoding = Bech32 | Bech32m -create_checksum :: Encoding -> BS.ByteString -> BS.ByteString -> BS.ByteString+zero6 :: BS.ByteString+zero6 = BS.replicate 6 0+{-# NOINLINE zero6 #-}++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+ let !pay = BS.concat [hrp_expand hrp, dat, zero6]+ !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]+ in BI.unsafeCreate 6 $ \dst -> do+ pokeElemOff dst 0 (fi (pm `B.shiftR` 25) .&. 0x1f :: Word8)+ pokeElemOff dst 1 (fi (pm `B.shiftR` 20) .&. 0x1f :: Word8)+ pokeElemOff dst 2 (fi (pm `B.shiftR` 15) .&. 0x1f :: Word8)+ pokeElemOff dst 3 (fi (pm `B.shiftR` 10) .&. 0x1f :: Word8)+ pokeElemOff dst 4 (fi (pm `B.shiftR` 5) .&. 0x1f :: Word8)+ pokeElemOff dst 5 (fi pm .&. 0x1f :: Word8) verify :: Encoding -> BS.ByteString -> Bool verify enc b32 = case BS.elemIndexEnd 0x31 b32 of@@ -154,4 +159,3 @@ in polymod bs == case enc of Bech32 -> 1 Bech32m -> _BECH32M_CONST-
lib/Data/ByteString/Bech32m.hs view
@@ -26,17 +26,9 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Base32 as B32 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-toStrict :: BSB.Builder -> BS.ByteString-toStrict = BS.toStrict- . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty-{-# INLINE toStrict #-}- create_checksum :: BS.ByteString -> BS.ByteString -> BS.ByteString create_checksum = BI.create_checksum BI.Bech32m @@ -53,11 +45,7 @@ guard (BI.valid_hrp hrp) ws <- BI.as_word5 dat let check = create_checksum hrp ws- res = toStrict $- BSB.byteString hrp- <> BSB.word8 49 -- 1- <> BSB.byteString dat- <> BSB.byteString (BI.as_base32 check)+ res = BS.concat [hrp, BS.singleton 49, dat, BI.as_base32 check] guard (BS.length res < 91) pure res
ppad-bech32.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-bech32-version: 0.2.4+version: 0.2.5 synopsis: bech32 and bech32m encoding/decoding, per BIPs 173 & 350. license: MIT license-file: LICENSE@@ -35,6 +35,8 @@ , Data.ByteString.Bech32.Internal , Data.ByteString.Bech32 , Data.ByteString.Bech32m+ other-modules:+ Data.ByteString.Base32.Internal build-depends: base >= 4.9 && < 5 , bytestring >= 0.9 && < 0.13