Base58.hs (3315B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 {-# LANGUAGE ViewPatterns #-} 4 5 -- | 6 -- Module: Data.ByteString.Base58 7 -- Copyright: (c) 2024 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- base58 encoding and decoding of strict bytestrings. 12 13 module Data.ByteString.Base58 ( 14 encode 15 , decode 16 ) where 17 18 import Control.Monad (guard) 19 import qualified Data.Bits as B 20 import Data.Bits ((.|.)) 21 import qualified Data.ByteString as BS 22 import qualified Data.ByteString.Unsafe as BU 23 import Data.Word (Word8) 24 25 fi :: (Integral a, Num b) => a -> b 26 fi = fromIntegral 27 {-# INLINE fi #-} 28 29 -- word8 base58 character to word6 (ish) 30 word6 :: Word8 -> Maybe Word8 31 word6 c 32 | c >= 49 && c <= 57 = pure $! c - 49 -- 1–9 33 | c >= 65 && c <= 72 = pure $! c - 56 -- A–H 34 | c >= 74 && c <= 78 = pure $! c - 57 -- J–N 35 | c >= 80 && c <= 90 = pure $! c - 58 -- P–Z 36 | c >= 97 && c <= 107 = pure $! c - 64 -- a–k 37 | c >= 109 && c <= 122 = pure $! c - 65 -- m–z 38 | otherwise = Nothing 39 {-# INLINE word6 #-} 40 41 -- | Encode a base256 'ByteString' as base58. 42 -- 43 -- >>> encode "hello world" 44 -- "StV1DL6CwTryKyV" 45 encode :: BS.ByteString -> BS.ByteString 46 encode bs = ls <> unroll_base58 (roll_base256 bs) where 47 ls = leading_ones bs 48 49 -- | Decode a base58 'ByteString' to base256. 50 -- 51 -- Invalid inputs will produce 'Nothing'. 52 -- 53 -- >>> decode "StV1DL6CwTryKyV" 54 -- Just "hello world" 55 -- >>> decode "StV1DL0CwTryKyV" -- s/6/0 56 -- Nothing 57 decode :: BS.ByteString -> Maybe BS.ByteString 58 decode bs = do 59 guard (verify_base58 bs) 60 let ls = leading_zeros bs 61 pure $ ls <> unroll_base256 (roll_base58 bs) 62 63 verify_base58 :: BS.ByteString -> Bool 64 verify_base58 bs = case BS.uncons bs of 65 Nothing -> True 66 Just (h, t) 67 | BS.elem h base58_charset -> verify_base58 t 68 | otherwise -> False 69 70 base58_charset :: BS.ByteString 71 base58_charset = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" 72 73 -- produce leading ones from leading zeros 74 leading_ones :: BS.ByteString -> BS.ByteString 75 leading_ones = go mempty where 76 go acc bs = case BS.uncons bs of 77 Nothing -> acc 78 Just (h, t) 79 | h == 0 -> go (BS.cons 0x31 acc) t 80 | otherwise -> acc 81 82 -- produce leading zeros from leading ones 83 leading_zeros :: BS.ByteString -> BS.ByteString 84 leading_zeros = go mempty where 85 go acc bs = case BS.uncons bs of 86 Nothing -> acc 87 Just (h, t) 88 | h == 0x31 -> go (BS.cons 0x00 acc) t 89 | otherwise -> acc 90 91 -- to base256 92 unroll_base256 :: Integer -> BS.ByteString 93 unroll_base256 = BS.reverse . BS.unfoldr coalg where 94 coalg a 95 | a == 0 = Nothing 96 | otherwise = Just $ 97 let (b, c) = quotRem a 256 98 in (fi c, b) 99 100 -- from base256 101 roll_base256 :: BS.ByteString -> Integer 102 roll_base256 = BS.foldl' alg 0 where 103 alg !a !b = a `B.shiftL` 8 .|. fi b 104 105 -- to base58 106 unroll_base58 :: Integer -> BS.ByteString 107 unroll_base58 = BS.reverse . BS.unfoldr coalg where 108 coalg a 109 | a == 0 = Nothing 110 | otherwise = Just $ 111 let (b, c) = quotRem a 58 112 in (BU.unsafeIndex base58_charset (fi c), b) 113 114 -- from base58 115 roll_base58 :: BS.ByteString -> Integer 116 roll_base58 bs = BS.foldl' alg 0 bs where 117 alg !b !a = case word6 a of 118 Just w -> b * 58 + fi w 119 Nothing -> 120 error "ppad-base58 (roll_base58): internal error" 121