Bech32.hs (5854B)
1 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} 2 3 -- official BIP173 reference 4 -- https://github.com/sipa/bech32/tree/master/ref/haskell 5 module Reference.Bech32 6 ( bech32Encode 7 , bech32Decode 8 , toBase32 9 , toBase256 10 , segwitEncode 11 , segwitDecode 12 , Word5(..) 13 , word5 14 , fromWord5 15 ) where 16 17 import Control.Monad (guard) 18 import qualified Data.Array as Arr 19 import Data.Bits (Bits, unsafeShiftL, unsafeShiftR, (.&.), (.|.), xor, testBit) 20 import qualified Data.ByteString as BS 21 import qualified Data.ByteString.Char8 as BSC 22 import Data.Char (toLower, toUpper) 23 import Data.Functor.Identity (Identity, runIdentity) 24 import Data.Ix (Ix(..)) 25 import Data.Word (Word8) 26 27 type HRP = BS.ByteString 28 type Data = [Word8] 29 30 (.>>.), (.<<.) :: Bits a => a -> Int -> a 31 (.>>.) = unsafeShiftR 32 (.<<.) = unsafeShiftL 33 34 newtype Word5 = UnsafeWord5 Word8 35 deriving (Eq, Ord) 36 37 instance Ix Word5 where 38 range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n) 39 index (UnsafeWord5 m, UnsafeWord5 n) (UnsafeWord5 i) = index (m, n) i 40 inRange (m,n) i = m <= i && i <= n 41 42 word5 :: Integral a => a -> Word5 43 word5 x = UnsafeWord5 ((fromIntegral x) .&. 31) 44 {-# INLINE word5 #-} 45 {-# SPECIALIZE INLINE word5 :: Word8 -> Word5 #-} 46 47 fromWord5 :: Num a => Word5 -> a 48 fromWord5 (UnsafeWord5 x) = fromIntegral x 49 {-# INLINE fromWord5 #-} 50 {-# SPECIALIZE INLINE fromWord5 :: Word5 -> Word8 #-} 51 52 charset :: Arr.Array Word5 Char 53 charset = Arr.listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l" 54 55 charsetMap :: Char -> Maybe Word5 56 charsetMap c | inRange (Arr.bounds inv) upperC = inv Arr.! upperC 57 | otherwise = Nothing 58 where 59 upperC = toUpper c 60 inv = Arr.listArray ('0', 'Z') (repeat Nothing) Arr.// (map swap (Arr.assocs charset)) 61 swap (a, b) = (toUpper b, Just a) 62 63 bech32Polymod :: [Word5] -> Word 64 bech32Polymod values = foldl' go 1 values .&. 0x3fffffff 65 where 66 go chk value = foldl' xor chk' [g | (g, i) <- zip generator [25..], testBit chk i] 67 where 68 generator = [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3] 69 chk' = chk .<<. 5 `xor` (fromWord5 value) 70 71 bech32HRPExpand :: HRP -> [Word5] 72 bech32HRPExpand hrp = map (UnsafeWord5 . (.>>. 5)) (BS.unpack hrp) ++ [UnsafeWord5 0] ++ map word5 (BS.unpack hrp) 73 74 bech32CreateChecksum :: HRP -> [Word5] -> [Word5] 75 bech32CreateChecksum hrp dat = [word5 (polymod .>>. i) | i <- [25,20..0]] 76 where 77 values = bech32HRPExpand hrp ++ dat 78 polymod = bech32Polymod (values ++ map UnsafeWord5 [0, 0, 0, 0, 0, 0]) `xor` 1 79 80 bech32VerifyChecksum :: HRP -> [Word5] -> Bool 81 bech32VerifyChecksum hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat) == 1 82 83 bech32Encode :: HRP -> [Word5] -> Maybe BS.ByteString 84 bech32Encode hrp dat = do 85 guard $ checkHRP hrp 86 let dat' = dat ++ bech32CreateChecksum hrp dat 87 rest = map (charset Arr.!) dat' 88 result = BSC.concat [BSC.map toLower hrp, BSC.pack "1", BSC.pack rest] 89 guard $ BS.length result <= 90 90 return result 91 92 checkHRP :: BS.ByteString -> Bool 93 checkHRP hrp = not (BS.null hrp) && BS.all (\char -> char >= 33 && char <= 126) hrp 94 95 bech32Decode :: BS.ByteString -> Maybe (HRP, [Word5]) 96 bech32Decode bech32 = do 97 guard $ BS.length bech32 <= 90 98 guard $ BSC.map toUpper bech32 == bech32 || BSC.map toLower bech32 == bech32 99 let (hrp, dat) = BSC.breakEnd (== '1') $ BSC.map toLower bech32 100 guard $ BS.length dat >= 6 101 hrp' <- BSC.stripSuffix (BSC.pack "1") hrp 102 guard $ checkHRP hrp' 103 dat' <- mapM charsetMap $ BSC.unpack dat 104 guard $ bech32VerifyChecksum hrp' dat' 105 return (hrp', take (BS.length dat - 6) dat') 106 107 type Pad f = Int -> Int -> Word -> [[Word]] -> f [[Word]] 108 109 yesPadding :: Pad Identity 110 yesPadding _ 0 _ result = return result 111 yesPadding _ _ padValue result = return $ [padValue] : result 112 {-# INLINE yesPadding #-} 113 114 noPadding :: Pad Maybe 115 noPadding frombits bits padValue result = do 116 guard $ bits < frombits && padValue == 0 117 return result 118 {-# INLINE noPadding #-} 119 120 -- Big endian conversion of a bytestring from base 2^frombits to base 2^tobits. 121 -- frombits and twobits must be positive and 2^frombits and 2^tobits must be smaller than the size of Word. 122 -- Every value in dat must be strictly smaller than 2^frombits. 123 convertBits :: Functor f => [Word] -> Int -> Int -> Pad f -> f [Word] 124 convertBits dat frombits tobits pad = fmap (concat . reverse) $ go dat 0 0 [] 125 where 126 go [] acc bits result = 127 let padValue = (acc .<<. (tobits - bits)) .&. maxv 128 in pad frombits bits padValue result 129 go (value:dat') acc bits result = go dat' acc' (bits' `rem` tobits) (result':result) 130 where 131 acc' = (acc .<<. frombits) .|. fromIntegral value 132 bits' = bits + frombits 133 result' = [(acc' .>>. b) .&. maxv | b <- [bits'-tobits,bits'-2*tobits..0]] 134 maxv = (1 .<<. tobits) - 1 135 {-# INLINE convertBits #-} 136 137 toBase32 :: [Word8] -> [Word5] 138 toBase32 dat = map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5 yesPadding 139 140 toBase256 :: [Word5] -> Maybe [Word8] 141 toBase256 dat = fmap (map fromIntegral) $ convertBits (map fromWord5 dat) 5 8 noPadding 142 143 segwitCheck :: Word8 -> Data -> Bool 144 segwitCheck witver witprog = 145 witver <= 16 && 146 if witver == 0 147 then length witprog == 20 || length witprog == 32 148 else length witprog >= 2 && length witprog <= 40 149 150 segwitDecode :: HRP -> BS.ByteString -> Maybe (Word8, Data) 151 segwitDecode hrp addr = do 152 (hrp', dat) <- bech32Decode addr 153 guard $ (hrp == hrp') && not (null dat) 154 let (UnsafeWord5 witver : datBase32) = dat 155 decoded <- toBase256 datBase32 156 guard $ segwitCheck witver decoded 157 return (witver, decoded) 158 159 segwitEncode :: HRP -> Word8 -> Data -> Maybe BS.ByteString 160 segwitEncode hrp witver witprog = do 161 guard $ segwitCheck witver witprog 162 bech32Encode hrp $ UnsafeWord5 witver : toBase32 witprog