Internal.hs (7694B)
1 {-# OPTIONS_HADDOCK hide, prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE ViewPatterns #-} 4 5 module Data.ByteString.Bech32.Internal ( 6 as_word5 7 , as_base32 8 , Encoding(..) 9 , create_checksum 10 , verify 11 , valid_hrp 12 , encode 13 , decode 14 ) where 15 16 import Control.Monad (guard) 17 import Data.Bits ((.&.), (.|.)) 18 import qualified Data.Bits as B 19 import qualified Data.ByteString as BS 20 import qualified Data.ByteString.Base32 as B32 21 import Data.ByteString.Base32.Internal 22 (enc_tab, dec_tab, w5_tab, encode_with) 23 import qualified Data.ByteString.Internal as BI 24 import qualified Data.ByteString.Unsafe as BU 25 import Data.Word (Word8, Word32) 26 import Foreign.ForeignPtr (withForeignPtr) 27 import Foreign.Ptr (Ptr, plusPtr) 28 import Foreign.Storable (peekElemOff, pokeElemOff) 29 import System.IO.Unsafe (unsafeDupablePerformIO) 30 31 fi :: (Integral a, Num b) => a -> b 32 fi = fromIntegral 33 {-# INLINE fi #-} 34 35 _BECH32M_CONST :: Word32 36 _BECH32M_CONST = 0x2bc830a3 37 38 -- | Translate base32 bytestring to its 5-bit-value bytestring. Each 39 -- input byte is looked up in 'dec_tab'; if any byte is not a valid 40 -- bech32 char, returns 'Nothing'. 41 as_word5 :: BS.ByteString -> Maybe BS.ByteString 42 as_word5 (BI.PS sfp soff l) = case dec_tab of 43 BI.PS tfp toff _ -> unsafeDupablePerformIO $ do 44 fp <- BI.mallocByteString l 45 ok <- withForeignPtr fp $ \dst -> 46 withForeignPtr sfp $ \sp0 -> 47 withForeignPtr tfp $ \tp0 -> do 48 let !sp = sp0 `plusPtr` soff :: Ptr Word8 49 !tp = tp0 `plusPtr` toff :: Ptr Word8 50 loop !i !acc 51 | i == l = pure $! acc .&. 0x40 == 0 52 | otherwise = do 53 c <- peekElemOff sp i 54 n <- peekElemOff tp (fi c) 55 pokeElemOff dst i (n .&. 0x1f) 56 loop (i + 1) (acc .|. n) 57 loop 0 0 58 pure $! if ok then Just (BI.PS fp 0 l) else Nothing 59 60 -- | Translate a 5-bit-value bytestring to its bech32 base32 61 -- bytestring. Only the low 5 bits of each input byte are used. 62 as_base32 :: BS.ByteString -> BS.ByteString 63 as_base32 (BI.PS sfp soff l) = case enc_tab of 64 BI.PS tfp toff _ -> 65 BI.unsafeCreate l $ \dst -> 66 withForeignPtr sfp $ \sp0 -> 67 withForeignPtr tfp $ \tp0 -> do 68 let !sp = sp0 `plusPtr` soff :: Ptr Word8 69 !tp = tp0 `plusPtr` toff :: Ptr Word8 70 loop !i 71 | i == l = pure () 72 | otherwise = do 73 v <- peekElemOff sp i 74 c <- peekElemOff tp (fi (v .&. 0x1f)) 75 pokeElemOff dst i c 76 loop (i + 1) 77 loop 0 78 79 polymod :: BS.ByteString -> Word32 80 polymod = BS.foldl' alg 1 where 81 alg !chk v = 82 let !b = chk `B.shiftR` 25 83 !c = (chk .&. 0x1ffffff) `B.shiftL` 5 `B.xor` fi v 84 in c `B.xor` gen b 0 0x3b6a57b2 85 `B.xor` gen b 1 0x26508e6d 86 `B.xor` gen b 2 0x1ea119fa 87 `B.xor` gen b 3 0x3d4233dd 88 `B.xor` gen b 4 0x2a1462b3 89 90 -- the generator 'g' if bit 'i' of 'b' is set, else zero 91 gen :: Word32 -> Int -> Word32 -> Word32 92 gen b i g 93 | B.testBit b i = g 94 | otherwise = 0 95 {-# INLINE gen #-} 96 97 valid_hrp :: BS.ByteString -> Bool 98 valid_hrp hrp@(BI.PS _ _ l) 99 | l == 0 || l > 83 = False 100 | otherwise = BS.all (\b -> (b > 32) && (b < 127)) hrp 101 102 -- | Build the bech32 HRP expansion: high-5-bits of each HRP byte, 103 -- then a single 0, then low-5-bits of each HRP byte. 104 hrp_expand :: BS.ByteString -> BS.ByteString 105 hrp_expand (BI.PS sfp soff l) = 106 BI.unsafeCreate (2 * l + 1) $ \dst -> 107 withForeignPtr sfp $ \sp0 -> do 108 let !sp = sp0 `plusPtr` soff :: Ptr Word8 109 loop_hi !i 110 | i == l = pure () 111 | otherwise = do 112 c <- peekElemOff sp i 113 pokeElemOff dst i (c `B.shiftR` 5) 114 loop_hi (i + 1) 115 loop_lo !i 116 | i == l = pure () 117 | otherwise = do 118 c <- peekElemOff sp i 119 pokeElemOff dst (l + 1 + i) (c .&. 0x1f) 120 loop_lo (i + 1) 121 loop_hi 0 122 pokeElemOff dst l (0 :: Word8) 123 loop_lo 0 124 125 data Encoding = 126 Bech32 127 | Bech32m 128 129 zero6 :: BS.ByteString 130 zero6 = BS.replicate 6 0 131 {-# NOINLINE zero6 #-} 132 133 create_checksum 134 :: Encoding -> BS.ByteString -> BS.ByteString -> BS.ByteString 135 create_checksum enc hrp dat = 136 let !pay = BS.concat [hrp_expand hrp, dat, zero6] 137 !pm = polymod pay `B.xor` case enc of 138 Bech32 -> 1 139 Bech32m -> _BECH32M_CONST 140 in BI.unsafeCreate 6 $ \dst -> do 141 pokeElemOff dst 0 (fi (pm `B.shiftR` 25) .&. 0x1f :: Word8) 142 pokeElemOff dst 1 (fi (pm `B.shiftR` 20) .&. 0x1f :: Word8) 143 pokeElemOff dst 2 (fi (pm `B.shiftR` 15) .&. 0x1f :: Word8) 144 pokeElemOff dst 3 (fi (pm `B.shiftR` 10) .&. 0x1f :: Word8) 145 pokeElemOff dst 4 (fi (pm `B.shiftR` 5) .&. 0x1f :: Word8) 146 pokeElemOff dst 5 (fi pm .&. 0x1f :: Word8) 147 148 -- | Lowercase an all-uppercase string. Mixed-case strings (some 149 -- ASCII uppercase and some ASCII lowercase characters) are rejected, 150 -- per BIP173. 151 normalize_case :: BS.ByteString -> Maybe BS.ByteString 152 normalize_case bs 153 | has_upper && BS.any is_lower bs = Nothing 154 | has_upper = Just $! BS.map to_lower bs 155 | otherwise = Just bs 156 where 157 has_upper = BS.any is_upper bs 158 159 is_upper :: Word8 -> Bool 160 is_upper c = c >= 0x41 && c <= 0x5A 161 {-# INLINE is_upper #-} 162 163 is_lower :: Word8 -> Bool 164 is_lower c = c >= 0x61 && c <= 0x7A 165 {-# INLINE is_lower #-} 166 167 to_lower :: Word8 -> Word8 168 to_lower c 169 | is_upper c = c + 0x20 170 | otherwise = c 171 {-# INLINE to_lower #-} 172 173 -- | Does a lowercase hrp and data part (5-bit values plus a 6-value 174 -- checksum, as bech32 characters) carry a valid checksum? 175 valid_checksum :: Encoding -> BS.ByteString -> BS.ByteString -> Bool 176 valid_checksum enc hrp dat 177 | BS.length dat < 6 = False 178 | otherwise = case as_word5 dat of 179 Nothing -> False 180 Just ws -> polymod (hrp_expand hrp <> ws) == case enc of 181 Bech32 -> 1 182 Bech32m -> _BECH32M_CONST 183 184 -- | Verify that a bech32 or bech32m string has a valid checksum. 185 -- All-uppercase input is accepted; mixed-case input is not. 186 verify :: Encoding -> BS.ByteString -> Bool 187 verify enc b32 = case normalize_case b32 of 188 Nothing -> False 189 Just bs -> case BS.elemIndexEnd 0x31 bs of 190 Nothing -> False 191 Just idx -> 192 let (hrp, BU.unsafeDrop 1 -> dat) = BS.splitAt idx bs 193 in valid_checksum enc hrp dat 194 195 -- | Encode a human-readable part and base256 data as bech32 or 196 -- bech32m. The human-readable part is lowercased. 197 encode 198 :: Encoding 199 -> BS.ByteString -- ^ base256-encoded human-readable part 200 -> BS.ByteString -- ^ base256-encoded data part 201 -> Maybe BS.ByteString -- ^ bech32-encoded bytestring 202 encode enc (BS.map to_lower -> hrp) dat = do 203 guard (valid_hrp hrp) 204 let !ws = encode_with w5_tab dat 205 guard (BS.length hrp + BS.length ws + 7 <= 90) 206 let !chk = create_checksum enc hrp ws 207 pure $! BS.concat [hrp, BS.singleton 0x31, as_base32 ws, as_base32 chk] 208 209 -- | Decode a bech32 or bech32m string into its (lowercase) 210 -- human-readable part and base256 data part. All-uppercase input 211 -- is accepted; mixed-case input is not. 212 decode 213 :: Encoding 214 -> BS.ByteString -- ^ bech32-encoded bytestring 215 -> Maybe (BS.ByteString, BS.ByteString) -- ^ (hrp, data less checksum) 216 decode enc b32 = do 217 guard (BS.length b32 <= 90) 218 bs <- normalize_case b32 219 sep <- BS.elemIndexEnd 0x31 bs 220 let (hrp, BU.unsafeDrop 1 -> raw) = BS.splitAt sep bs 221 guard (valid_hrp hrp) 222 guard (valid_checksum enc hrp raw) 223 dat <- B32.decode (BS.dropEnd 6 raw) 224 pure (hrp, dat)