Internal.hs (5328B)
1 {-# OPTIONS_HADDOCK hide, prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE LambdaCase #-} 4 {-# LANGUAGE ViewPatterns #-} 5 6 module Data.ByteString.Bech32.Internal ( 7 as_word5 8 , as_base32 9 , Encoding(..) 10 , create_checksum 11 , verify 12 , valid_hrp 13 ) where 14 15 import Data.Bits ((.&.), (.|.)) 16 import qualified Data.Bits as B 17 import qualified Data.ByteString as BS 18 import Data.ByteString.Base32.Internal (enc_tab, dec_tab) 19 import qualified Data.ByteString.Internal as BI 20 import qualified Data.ByteString.Unsafe as BU 21 import Data.Word (Word8, Word32) 22 import Foreign.ForeignPtr (withForeignPtr) 23 import Foreign.Ptr (Ptr, plusPtr) 24 import Foreign.Storable (peekElemOff, pokeElemOff) 25 import System.IO.Unsafe (unsafeDupablePerformIO) 26 27 fi :: (Integral a, Num b) => a -> b 28 fi = fromIntegral 29 {-# INLINE fi #-} 30 31 _BECH32M_CONST :: Word32 32 _BECH32M_CONST = 0x2bc830a3 33 34 -- | Translate base32 bytestring to its 5-bit-value bytestring. Each 35 -- input byte is looked up in 'dec_tab'; if any byte is not a valid 36 -- bech32 char, returns 'Nothing'. 37 as_word5 :: BS.ByteString -> Maybe BS.ByteString 38 as_word5 (BI.PS sfp soff l) = case dec_tab of 39 BI.PS tfp toff _ -> unsafeDupablePerformIO $ do 40 fp <- BI.mallocByteString l 41 ok <- withForeignPtr fp $ \dst -> 42 withForeignPtr sfp $ \sp0 -> 43 withForeignPtr tfp $ \tp0 -> do 44 let !sp = sp0 `plusPtr` soff :: Ptr Word8 45 !tp = tp0 `plusPtr` toff :: Ptr Word8 46 loop !i !acc 47 | i == l = pure $! acc .&. 0x40 == 0 48 | otherwise = do 49 c <- peekElemOff sp i 50 n <- peekElemOff tp (fi c) 51 pokeElemOff dst i (n .&. 0x1f) 52 loop (i + 1) (acc .|. n) 53 loop 0 0 54 pure $! if ok then Just (BI.PS fp 0 l) else Nothing 55 56 -- | Translate a 5-bit-value bytestring to its bech32 base32 57 -- bytestring. 58 as_base32 :: BS.ByteString -> BS.ByteString 59 as_base32 (BI.PS sfp soff l) = case enc_tab of 60 BI.PS tfp toff _ -> 61 BI.unsafeCreate l $ \dst -> 62 withForeignPtr sfp $ \sp0 -> 63 withForeignPtr tfp $ \tp0 -> do 64 let !sp = sp0 `plusPtr` soff :: Ptr Word8 65 !tp = tp0 `plusPtr` toff :: Ptr Word8 66 loop !i 67 | i == l = pure () 68 | otherwise = do 69 v <- peekElemOff sp i 70 c <- peekElemOff tp (fi v) 71 pokeElemOff dst i c 72 loop (i + 1) 73 loop 0 74 75 polymod :: BS.ByteString -> Word32 76 polymod = BS.foldl' alg 1 where 77 generator :: Int -> Word32 78 generator = \case 79 0 -> 0x3b6a57b2 80 1 -> 0x26508e6d 81 2 -> 0x1ea119fa 82 3 -> 0x3d4233dd 83 4 -> 0x2a1462b3 84 _ -> error "ppad-bech32: internal error (please report this as a bug!)" 85 86 alg !chk v = 87 let !b = chk `B.shiftR` 25 88 c = (chk .&. 0x1ffffff) `B.shiftL` 5 `B.xor` fi v 89 in loop_gen 0 b c 90 91 loop_gen i b !chk 92 | i > 4 = chk 93 | otherwise = 94 let sor | B.testBit (b `B.shiftR` i) 0 = generator i 95 | otherwise = 0 96 in loop_gen (succ i) b (chk `B.xor` sor) 97 98 valid_hrp :: BS.ByteString -> Bool 99 valid_hrp hrp@(BI.PS _ _ l) 100 | l == 0 || l > 83 = False 101 | otherwise = BS.all (\b -> (b > 32) && (b < 127)) hrp 102 103 -- | Build the bech32 HRP expansion: high-5-bits of each HRP byte, 104 -- then a single 0, then low-5-bits of each HRP byte. 105 hrp_expand :: BS.ByteString -> BS.ByteString 106 hrp_expand (BI.PS sfp soff l) = 107 BI.unsafeCreate (2 * l + 1) $ \dst -> 108 withForeignPtr sfp $ \sp0 -> do 109 let !sp = sp0 `plusPtr` soff :: Ptr Word8 110 loop_hi !i 111 | i == l = pure () 112 | otherwise = do 113 c <- peekElemOff sp i 114 pokeElemOff dst i (c `B.shiftR` 5) 115 loop_hi (i + 1) 116 loop_lo !i 117 | i == l = pure () 118 | otherwise = do 119 c <- peekElemOff sp i 120 pokeElemOff dst (l + 1 + i) (c .&. 0x1f) 121 loop_lo (i + 1) 122 loop_hi 0 123 pokeElemOff dst l (0 :: Word8) 124 loop_lo 0 125 126 data Encoding = 127 Bech32 128 | Bech32m 129 130 zero6 :: BS.ByteString 131 zero6 = BS.replicate 6 0 132 {-# NOINLINE zero6 #-} 133 134 create_checksum 135 :: Encoding -> BS.ByteString -> BS.ByteString -> BS.ByteString 136 create_checksum enc hrp dat = 137 let !pay = BS.concat [hrp_expand hrp, dat, zero6] 138 !pm = polymod pay `B.xor` case enc of 139 Bech32 -> 1 140 Bech32m -> _BECH32M_CONST 141 in BI.unsafeCreate 6 $ \dst -> do 142 pokeElemOff dst 0 (fi (pm `B.shiftR` 25) .&. 0x1f :: Word8) 143 pokeElemOff dst 1 (fi (pm `B.shiftR` 20) .&. 0x1f :: Word8) 144 pokeElemOff dst 2 (fi (pm `B.shiftR` 15) .&. 0x1f :: Word8) 145 pokeElemOff dst 3 (fi (pm `B.shiftR` 10) .&. 0x1f :: Word8) 146 pokeElemOff dst 4 (fi (pm `B.shiftR` 5) .&. 0x1f :: Word8) 147 pokeElemOff dst 5 (fi pm .&. 0x1f :: Word8) 148 149 verify :: Encoding -> BS.ByteString -> Bool 150 verify enc b32 = case BS.elemIndexEnd 0x31 b32 of 151 Nothing -> False 152 Just idx -> 153 let (hrp, BU.unsafeDrop 1 -> dat) = BS.splitAt idx b32 154 w5s = as_word5 dat 155 in case w5s of 156 Nothing -> False 157 Just ws -> 158 let bs = hrp_expand hrp <> ws 159 in polymod bs == case enc of 160 Bech32 -> 1 161 Bech32m -> _BECH32M_CONST