Base32.hs (8119B)
1 {-# OPTIONS_HADDOCK hide, prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE BinaryLiterals #-} 4 {-# LANGUAGE OverloadedStrings #-} 5 {-# LANGUAGE ViewPatterns #-} 6 7 module Data.ByteString.Base32 ( 8 encode 9 , as_word5 10 , as_base32 11 12 -- not actually base32-related, but convenient to put here 13 , Encoding(..) 14 , create_checksum 15 , verify 16 , valid_hrp 17 ) where 18 19 import Data.Bits ((.|.), (.&.)) 20 import qualified Data.Bits as B 21 import qualified Data.ByteString as BS 22 import qualified Data.ByteString.Builder as BSB 23 import qualified Data.ByteString.Builder.Extra as BE 24 import qualified Data.ByteString.Unsafe as BU 25 import qualified Data.Primitive.PrimArray as PA 26 import Data.Word (Word32) 27 28 _BECH32M_CONST :: Word32 29 _BECH32M_CONST = 0x2bc830a3 30 31 fi :: (Integral a, Num b) => a -> b 32 fi = fromIntegral 33 {-# INLINE fi #-} 34 35 word32be :: BS.ByteString -> Word32 36 word32be s = 37 (fi (s `BU.unsafeIndex` 0) `B.shiftL` 24) .|. 38 (fi (s `BU.unsafeIndex` 1) `B.shiftL` 16) .|. 39 (fi (s `BU.unsafeIndex` 2) `B.shiftL` 8) .|. 40 (fi (s `BU.unsafeIndex` 3)) 41 {-# INLINE word32be #-} 42 43 -- realization for small builders 44 toStrict :: BSB.Builder -> BS.ByteString 45 toStrict = BS.toStrict 46 . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty 47 {-# INLINE toStrict #-} 48 49 bech32_charset :: BS.ByteString 50 bech32_charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l" 51 52 -- adapted from emilypi's 'base32' library 53 encode :: BS.ByteString -> BS.ByteString 54 encode dat = toStrict (go dat) where 55 bech32_char = fi . BS.index bech32_charset . fi 56 57 go bs = case BS.splitAt 5 bs of 58 (chunk, etc) -> case BS.length etc of 59 -- https://datatracker.ietf.org/doc/html/rfc4648#section-6 60 0 | BS.length chunk == 5 -> case BS.unsnoc chunk of 61 Nothing -> error "impossible, chunk length is 5" 62 Just (word32be -> w32, fi -> w8) -> arrange w32 w8 63 64 | BS.length chunk == 1 -> 65 let a = BU.unsafeIndex chunk 0 66 t = bech32_char ((a .&. 0b11111000) `B.shiftR` 3) 67 u = bech32_char ((a .&. 0b00000111) `B.shiftL` 2) 68 69 !w16 = fi t 70 .|. fi u `B.shiftL` 8 71 72 in BSB.word16LE w16 73 74 | BS.length chunk == 2 -> 75 let a = BU.unsafeIndex chunk 0 76 b = BU.unsafeIndex chunk 1 77 t = bech32_char ((a .&. 0b11111000) `B.shiftR` 3) 78 u = bech32_char $ 79 ((a .&. 0b00000111) `B.shiftL` 2) 80 .|. ((b .&. 0b11000000) `B.shiftR` 6) 81 v = bech32_char ((b .&. 0b00111110) `B.shiftR` 1) 82 w = bech32_char ((b .&. 0b00000001) `B.shiftL` 4) 83 84 !w32 = fi t 85 .|. fi u `B.shiftL` 8 86 .|. fi v `B.shiftL` 16 87 .|. fi w `B.shiftL` 24 88 89 in BSB.word32LE w32 90 91 | BS.length chunk == 3 -> 92 let a = BU.unsafeIndex chunk 0 93 b = BU.unsafeIndex chunk 1 94 c = BU.unsafeIndex chunk 2 95 t = bech32_char ((a .&. 0b11111000) `B.shiftR` 3) 96 u = bech32_char $ 97 ((a .&. 0b00000111) `B.shiftL` 2) 98 .|. ((b .&. 0b11000000) `B.shiftR` 6) 99 v = bech32_char ((b .&. 0b00111110) `B.shiftR` 1) 100 w = bech32_char $ 101 ((b .&. 0b00000001) `B.shiftL` 4) 102 .|. ((c .&. 0b11110000) `B.shiftR` 4) 103 x = bech32_char ((c .&. 0b00001111) `B.shiftL` 1) 104 105 !w32 = fi t 106 .|. fi u `B.shiftL` 8 107 .|. fi v `B.shiftL` 16 108 .|. fi w `B.shiftL` 24 109 110 in BSB.word32LE w32 <> BSB.word8 x 111 112 | BS.length chunk == 4 -> 113 let a = BU.unsafeIndex chunk 0 114 b = BU.unsafeIndex chunk 1 115 c = BU.unsafeIndex chunk 2 116 d = BU.unsafeIndex chunk 3 117 t = bech32_char ((a .&. 0b11111000) `B.shiftR` 3) 118 u = bech32_char $ 119 ((a .&. 0b00000111) `B.shiftL` 2) 120 .|. ((b .&. 0b11000000) `B.shiftR` 6) 121 v = bech32_char ((b .&. 0b00111110) `B.shiftR` 1) 122 w = bech32_char $ 123 ((b .&. 0b00000001) `B.shiftL` 4) 124 .|. ((c .&. 0b11110000) `B.shiftR` 4) 125 x = bech32_char $ 126 ((c .&. 0b00001111) `B.shiftL` 1) 127 .|. ((d .&. 0b10000000) `B.shiftR` 7) 128 y = bech32_char ((d .&. 0b01111100) `B.shiftR` 2) 129 z = bech32_char ((d .&. 0b00000011) `B.shiftL` 3) 130 131 !w32 = fi t 132 .|. fi u `B.shiftL` 8 133 .|. fi v `B.shiftL` 16 134 .|. fi w `B.shiftL` 24 135 136 !w16 = fi x 137 .|. fi y `B.shiftL` 8 138 139 in BSB.word32LE w32 <> BSB.word16LE w16 <> BSB.word8 z 140 141 | otherwise -> mempty 142 143 _ -> case BS.unsnoc chunk of 144 Nothing -> error "impossible, chunk length is 5" 145 Just (word32be -> w32, fi -> w8) -> arrange w32 w8 <> go etc 146 147 -- adapted from emilypi's 'base32' library 148 arrange :: Word32 -> Word32 -> BSB.Builder 149 arrange w32 w8 = 150 let mask = 0b00011111 151 bech32_char = fi . BS.index bech32_charset . fi 152 153 w8_0 = bech32_char (mask .&. (w32 `B.shiftR` 27)) 154 w8_1 = bech32_char (mask .&. (w32 `B.shiftR` 22)) 155 w8_2 = bech32_char (mask .&. (w32 `B.shiftR` 17)) 156 w8_3 = bech32_char (mask .&. (w32 `B.shiftR` 12)) 157 w8_4 = bech32_char (mask .&. (w32 `B.shiftR` 07)) 158 w8_5 = bech32_char (mask .&. (w32 `B.shiftR` 02)) 159 w8_6 = bech32_char (mask .&. (w32 `B.shiftL` 03 .|. w8 `B.shiftR` 05)) 160 w8_7 = bech32_char (mask .&. w8) 161 162 !w64 = w8_0 163 .|. w8_1 `B.shiftL` 8 164 .|. w8_2 `B.shiftL` 16 165 .|. w8_3 `B.shiftL` 24 166 .|. w8_4 `B.shiftL` 32 167 .|. w8_5 `B.shiftL` 40 168 .|. w8_6 `B.shiftL` 48 169 .|. w8_7 `B.shiftL` 56 170 171 in BSB.word64LE w64 172 {-# INLINE arrange #-} 173 174 -- naive base32 -> word5 175 as_word5 :: BS.ByteString -> BS.ByteString 176 as_word5 = BS.map f where 177 f b = case BS.elemIndex (fi b) bech32_charset of 178 Nothing -> error "ppad-bech32 (as_word5): input not bech32-encoded" 179 Just w -> fi w 180 181 -- naive word5 -> base32 182 as_base32 :: BS.ByteString -> BS.ByteString 183 as_base32 = BS.map (BS.index bech32_charset . fi) 184 185 polymod :: BS.ByteString -> Word32 186 polymod = BS.foldl' alg 1 where 187 generator = PA.primArrayFromListN 5 188 [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3] 189 190 alg !chk v = 191 let !b = chk `B.shiftR` 25 192 c = (chk .&. 0x1ffffff) `B.shiftL` 5 `B.xor` fi v 193 in loop_gen 0 b c 194 195 loop_gen i b !chk 196 | i > 4 = chk 197 | otherwise = 198 let sor | B.testBit (b `B.shiftR` i) 0 = 199 PA.indexPrimArray generator i 200 | otherwise = 0 201 in loop_gen (succ i) b (chk `B.xor` sor) 202 203 valid_hrp :: BS.ByteString -> Bool 204 valid_hrp hrp 205 | l == 0 || l > 83 = False 206 | otherwise = BS.all (\b -> (b > 32) && (b < 127)) hrp 207 where 208 l = BS.length hrp 209 210 hrp_expand :: BS.ByteString -> BS.ByteString 211 hrp_expand bs = toStrict 212 $ BSB.byteString (BS.map (`B.shiftR` 5) bs) 213 <> BSB.word8 0 214 <> BSB.byteString (BS.map (.&. 0b11111) bs) 215 216 data Encoding = 217 Bech32 218 | Bech32m 219 220 create_checksum :: Encoding -> BS.ByteString -> BS.ByteString -> BS.ByteString 221 create_checksum enc hrp dat = 222 let pre = hrp_expand hrp <> dat 223 pay = toStrict $ 224 BSB.byteString pre 225 <> BSB.byteString "\NUL\NUL\NUL\NUL\NUL\NUL" 226 pm = polymod pay `B.xor` case enc of 227 Bech32 -> 1 228 Bech32m -> _BECH32M_CONST 229 230 code i = (fi (pm `B.shiftR` fi i) .&. 0b11111) 231 232 in BS.map code "\EM\DC4\SI\n\ENQ\NUL" -- BS.pack [25, 20, 15, 10, 5, 0] 233 234 verify :: Encoding -> BS.ByteString -> Bool 235 verify enc b32 = case BS.elemIndexEnd 0x31 b32 of 236 Nothing -> False 237 Just idx -> 238 let (hrp, BU.unsafeDrop 1 -> dat) = BS.splitAt idx b32 239 bs = hrp_expand hrp <> as_word5 dat 240 in polymod bs == case enc of 241 Bech32 -> 1 242 Bech32m -> _BECH32M_CONST 243