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 (3218B)

      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 (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 -- naive base32 -> word5
     43 as_word5 :: BS.ByteString -> BS.ByteString
     44 as_word5 = BS.map f where
     45   f b = case BS.elemIndex (fi b) bech32_charset of
     46     Nothing -> error "ppad-bech32 (as_word5): input not bech32-encoded"
     47     Just w -> fi w
     48 
     49 -- naive word5 -> base32
     50 as_base32 :: BS.ByteString -> BS.ByteString
     51 as_base32 = BS.map (BU.unsafeIndex bech32_charset . fi)
     52 
     53 polymod :: BS.ByteString -> Word32
     54 polymod = BS.foldl' alg 1 where
     55   generator :: Int -> Word32
     56   generator = \case
     57     0 -> 0x3b6a57b2
     58     1 -> 0x26508e6d
     59     2 -> 0x1ea119fa
     60     3 -> 0x3d4233dd
     61     4 -> 0x2a1462b3
     62     _ -> error "ppad-bech32: internal error (please report this as a bug!)"
     63 
     64   alg !chk v =
     65     let !b = chk `B.shiftR` 25
     66         c = (chk .&. 0x1ffffff) `B.shiftL` 5 `B.xor` fi v
     67     in  loop_gen 0 b c
     68 
     69   loop_gen i b !chk
     70     | i > 4 = chk
     71     | otherwise =
     72         let sor | B.testBit (b `B.shiftR` i) 0 = generator i
     73                 | otherwise = 0
     74         in  loop_gen (succ i) b (chk `B.xor` sor)
     75 
     76 valid_hrp :: BS.ByteString -> Bool
     77 valid_hrp hrp@(BI.PS _ _ l)
     78   | l == 0 || l > 83 = False
     79   | otherwise = BS.all (\b -> (b > 32) && (b < 127)) hrp
     80 
     81 hrp_expand :: BS.ByteString -> BS.ByteString
     82 hrp_expand bs = toStrict
     83   $  BSB.byteString (BS.map (`B.shiftR` 5) bs)
     84   <> BSB.word8 0
     85   <> BSB.byteString (BS.map (.&. 0b11111) bs)
     86 
     87 data Encoding =
     88     Bech32
     89   | Bech32m
     90 
     91 create_checksum :: Encoding -> BS.ByteString -> BS.ByteString -> BS.ByteString
     92 create_checksum enc hrp dat =
     93   let pre = hrp_expand hrp <> dat
     94       pay = toStrict $
     95            BSB.byteString pre
     96         <> BSB.byteString "\NUL\NUL\NUL\NUL\NUL\NUL"
     97       pm = polymod pay `B.xor` case enc of
     98         Bech32  -> 1
     99         Bech32m -> _BECH32M_CONST
    100 
    101       code i = (fi (pm `B.shiftR` fi i) .&. 0b11111)
    102 
    103   in  BS.map code "\EM\DC4\SI\n\ENQ\NUL" -- BS.pack [25, 20, 15, 10, 5, 0]
    104 
    105 verify :: Encoding -> BS.ByteString -> Bool
    106 verify enc b32 = case BS.elemIndexEnd 0x31 b32 of
    107   Nothing  -> False
    108   Just idx ->
    109     let (hrp, BU.unsafeDrop 1 -> dat) = BS.splitAt idx b32
    110         bs = hrp_expand hrp <> as_word5 dat
    111     in  polymod bs == case enc of
    112           Bech32 -> 1
    113           Bech32m -> _BECH32M_CONST
    114