commit 2283baaea266b6e65c1899df09c62d28d4042d27
parent 4905cadaf299c87175578895d82b5a3882ee0923
Author: Jared Tobin <jared@jtobin.io>
Date: Thu, 12 Dec 2024 17:07:28 -0330
lib: base32 encoding
Diffstat:
1 file changed, 107 insertions(+), 45 deletions(-)
diff --git a/lib/Data/ByteString/Bech32.hs b/lib/Data/ByteString/Bech32.hs
@@ -29,56 +29,118 @@ toStrict :: BSB.Builder -> BS.ByteString
toStrict = BS.toStrict
. BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty
--- (maybe) pad to a multiple of 40 bits
-maybe_pad :: BS.ByteString -> BS.ByteString
-maybe_pad bs
- | l `rem` 5 == 0 = bs
- | otherwise = bs <> BS.replicate k 0x00
- where
- l = BS.length bs
- k = let r = fi l `rem` 5
- in if r == 0 then 0 else r + 5
-
bech32_charset :: BS.ByteString
bech32_charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
+bech32_char_w64 :: Word32 -> Word64
+bech32_char_w64 = fi . BS.index bech32_charset . fi
+
+bech32_char :: Word8 -> Word8
+bech32_char = fi . BS.index bech32_charset . fi
+
+-- adapted from emilypi's 'base32' library
+w40_to_w64 :: Word32 -> Word32 -> BSB.Builder
+w40_to_w64 w32 w8 =
+ let mask = 0b00011111
+
+ w8_0 = bech32_char_w64 (mask .&. (w32 `B.shiftR` 27))
+ w8_1 = bech32_char_w64 (mask .&. (w32 `B.shiftR` 22))
+ w8_2 = bech32_char_w64 (mask .&. (w32 `B.shiftR` 17))
+ w8_3 = bech32_char_w64 (mask .&. (w32 `B.shiftR` 12))
+ w8_4 = bech32_char_w64 (mask .&. (w32 `B.shiftR` 07))
+ w8_5 = bech32_char_w64 (mask .&. (w32 `B.shiftR` 02))
+ w8_6 = bech32_char_w64 (mask .&. (w32 `B.shiftL` 03 .|. w8 `B.shiftR` 05))
+ w8_7 = bech32_char_w64 (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
+
-- adapted from emilypi's 'base32' library
base32 :: BS.ByteString -> BS.ByteString
base32 dat = toStrict (go dat) where
- mask = 0b11111
-
go bs = case BS.splitAt 5 bs of
- (chunk, etc)
- | BS.length chunk /= 5 -> mempty
- | otherwise -> case BS.unsnoc chunk of
- Nothing -> error "impossible, chunk length is 5"
- Just (word32be -> w32, fi -> w8) ->
- let i0 = fi (mask .&. (w32 `B.shiftR` 27))
- i1 = fi (mask .&. (w32 `B.shiftR` 22))
- i2 = fi (mask .&. (w32 `B.shiftR` 17))
- i3 = fi (mask .&. (w32 `B.shiftR` 12))
- i4 = fi (mask .&. (w32 `B.shiftR` 07))
- i5 = fi (mask .&. (w32 `B.shiftR` 02))
- i6 = fi (mask .&. (w32 `B.shiftL` 03 .|. w8 `B.shiftR` 05))
- i7 = fi (mask .&. w8)
-
- w8_0 = fi (BS.index bech32_charset i0)
- w8_1 = fi (BS.index bech32_charset i1)
- w8_2 = fi (BS.index bech32_charset i2)
- w8_3 = fi (BS.index bech32_charset i3)
- w8_4 = fi (BS.index bech32_charset i4)
- w8_5 = fi (BS.index bech32_charset i5)
- w8_6 = fi (BS.index bech32_charset i6)
- w8_7 = fi (BS.index bech32_charset i7)
-
- 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 <> go etc
+ (chunk, etc) -> case BS.length etc of
+ 0 | BS.length chunk == 5 -> case BS.unsnoc chunk of
+ Nothing -> error "impossible, chunk length is 5"
+ Just (word32be -> w32, fi -> w8) -> w40_to_w64 w32 w8
+
+ | BS.length chunk == 1 ->
+ let a = BS.index 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 = BS.index chunk 0
+ b = BS.index 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 = BS.index chunk 0
+ b = BS.index chunk 1
+ c = BS.index 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 = BS.index chunk 0
+ b = BS.index chunk 1
+ c = BS.index chunk 2
+ d = BS.index 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) -> w40_to_w64 w32 w8 <> go etc
+
+-- naive base32 -> word5
+as_w5s :: BS.ByteString -> BS.ByteString
+as_w5s bs = BS.map f bs where
+ f b = case BS.elemIndex (fi b) bech32_charset of
+ Nothing -> error "ppad-bech32 (as_w5s): input not bech32-encoded"
+ Just w -> fi w
+
+-- naive word5 -> bech32
+as_bech32 :: BS.ByteString -> BS.ByteString
+as_bech32 bs = BS.map f bs where
+ f b = BS.index bech32_charset (fi b)
