bech32

Pure Haskell bech32, bech32m encoding/decoding (docs.ppad.tech/bech32).
git clone git://git.ppad.tech/bech32.git
Log | Files | Refs | README | LICENSE

Internal.hs (4292B)

      1 {-# OPTIONS_HADDOCK hide, prune #-}
      2 {-# LANGUAGE BangPatterns #-}
      3 {-# LANGUAGE BinaryLiterals #-}
      4 {-# LANGUAGE LambdaCase #-}
      5 {-# LANGUAGE OverloadedStrings #-}
      6 {-# LANGUAGE ViewPatterns #-}
      7 
      8 module Data.ByteString.Bech32.Internal (
      9     as_word5
     10   , as_base32
     11   , Encoding(..)
     12   , create_checksum
     13   , verify
     14   , valid_hrp
     15   ) where
     16 
     17 import Data.Bits ((.&.))
     18 import qualified Data.Bits as B
     19 import qualified Data.ByteString as BS
     20 import qualified Data.ByteString.Builder as BSB
     21 import qualified Data.ByteString.Builder.Extra as BE
     22 import qualified Data.ByteString.Internal as BI
     23 import qualified Data.ByteString.Unsafe as BU
     24 import Data.Word (Word8, Word32)
     25 
     26 fi :: (Integral a, Num b) => a -> b
     27 fi = fromIntegral
     28 {-# INLINE fi #-}
     29 
     30 -- realization for small builders
     31 toStrict :: BSB.Builder -> BS.ByteString
     32 toStrict = BS.toStrict
     33   . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty
     34 {-# INLINE toStrict #-}
     35 
     36 _BECH32M_CONST :: Word32
     37 _BECH32M_CONST = 0x2bc830a3
     38 
     39 bech32_charset :: BS.ByteString
     40 bech32_charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
     41 
     42 word5 :: Word8 -> Maybe Word8
     43 word5 = \case
     44   113 -> pure $! 00 -- 'q'
     45   112 -> pure $! 01 -- 'p'
     46   122 -> pure $! 02 -- 'z'
     47   114 -> pure $! 03 -- 'r'
     48   121 -> pure $! 04 -- 'y'
     49   57  -> pure $! 05 -- '9'
     50   120 -> pure $! 06 -- 'x'
     51   56  -> pure $! 07 -- '8'
     52   103 -> pure $! 08 -- 'g'
     53   102 -> pure $! 09 -- 'f'
     54   50  -> pure $! 10 -- '2'
     55   116 -> pure $! 11 -- 't'
     56   118 -> pure $! 12 -- 'v'
     57   100 -> pure $! 13 -- 'd'
     58   119 -> pure $! 14 -- 'w'
     59   48  -> pure $! 15 -- '0'
     60   115 -> pure $! 16 -- 's'
     61   51  -> pure $! 17 -- '3'
     62   106 -> pure $! 18 -- 'j'
     63   110 -> pure $! 19 -- 'n'
     64   53  -> pure $! 20 -- '5'
     65   52  -> pure $! 21 -- '4'
     66   107 -> pure $! 22 -- 'k'
     67   104 -> pure $! 23 -- 'h'
     68   99  -> pure $! 24 -- 'c'
     69   101 -> pure $! 25 -- 'e'
     70   54  -> pure $! 26 -- '6'
     71   109 -> pure $! 27 -- 'm'
     72   117 -> pure $! 28 -- 'u'
     73   97  -> pure $! 29 -- 'a'
     74   55  -> pure $! 30 -- '7'
     75   108 -> pure $! 31 -- 'l'
     76   _   -> Nothing
     77 {-# INLINE word5 #-}
     78 
     79 -- base32 -> word5
     80 as_word5 :: BS.ByteString -> Maybe BS.ByteString
     81 as_word5 = go mempty where
     82   go acc bs = case BS.uncons bs of
     83     Nothing -> pure (toStrict acc)
     84     Just (h, t) -> do
     85       w5 <- word5 (fi h)
     86       go (acc <> BSB.word8 w5) t
     87 
     88 -- word5 -> base32
     89 as_base32 :: BS.ByteString -> BS.ByteString
     90 as_base32 = BS.map (BU.unsafeIndex bech32_charset . fi)
     91 
     92 polymod :: BS.ByteString -> Word32
     93 polymod = BS.foldl' alg 1 where
     94   generator :: Int -> Word32
     95   generator = \case
     96     0 -> 0x3b6a57b2
     97     1 -> 0x26508e6d
     98     2 -> 0x1ea119fa
     99     3 -> 0x3d4233dd
    100     4 -> 0x2a1462b3
    101     _ -> error "ppad-bech32: internal error (please report this as a bug!)"
    102 
    103   alg !chk v =
    104     let !b = chk `B.shiftR` 25
    105         c = (chk .&. 0x1ffffff) `B.shiftL` 5 `B.xor` fi v
    106     in  loop_gen 0 b c
    107 
    108   loop_gen i b !chk
    109     | i > 4 = chk
    110     | otherwise =
    111         let sor | B.testBit (b `B.shiftR` i) 0 = generator i
    112                 | otherwise = 0
    113         in  loop_gen (succ i) b (chk `B.xor` sor)
    114 
    115 valid_hrp :: BS.ByteString -> Bool
    116 valid_hrp hrp@(BI.PS _ _ l)
    117   | l == 0 || l > 83 = False
    118   | otherwise = BS.all (\b -> (b > 32) && (b < 127)) hrp
    119 
    120 hrp_expand :: BS.ByteString -> BS.ByteString
    121 hrp_expand bs = toStrict
    122   $  BSB.byteString (BS.map (`B.shiftR` 5) bs)
    123   <> BSB.word8 0
    124   <> BSB.byteString (BS.map (.&. 0b11111) bs)
    125 
    126 data Encoding =
    127     Bech32
    128   | Bech32m
    129 
    130 create_checksum :: Encoding -> BS.ByteString -> BS.ByteString -> BS.ByteString
    131 create_checksum enc hrp dat =
    132   let pre = hrp_expand hrp <> dat
    133       pay = toStrict $
    134            BSB.byteString pre
    135         <> BSB.byteString "\NUL\NUL\NUL\NUL\NUL\NUL"
    136       pm = polymod pay `B.xor` case enc of
    137         Bech32  -> 1
    138         Bech32m -> _BECH32M_CONST
    139 
    140       code i = (fi (pm `B.shiftR` fi i) .&. 0b11111)
    141 
    142   in  BS.map code "\EM\DC4\SI\n\ENQ\NUL" -- BS.pack [25, 20, 15, 10, 5, 0]
    143 
    144 verify :: Encoding -> BS.ByteString -> Bool
    145 verify enc b32 = case BS.elemIndexEnd 0x31 b32 of
    146   Nothing  -> False
    147   Just idx ->
    148     let (hrp, BU.unsafeDrop 1 -> dat) = BS.splitAt idx b32
    149         w5s = as_word5 dat
    150     in  case w5s of
    151           Nothing -> False
    152           Just ws ->
    153             let bs = hrp_expand hrp <> ws
    154             in  polymod bs == case enc of
    155                   Bech32 -> 1
    156                   Bech32m -> _BECH32M_CONST
    157