{-# LANGUAGE OverloadedStrings #-}
module Haskoin.Address.Base58 (
Base58,
encodeBase58,
decodeBase58,
encodeBase58Check,
decodeBase58Check,
) where
import Control.Monad
import Data.Array
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Char
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word
import Haskoin.Crypto.Hash
import Haskoin.Util
import Numeric (readInt, showIntAtBase)
type Base58 = Text
b58Data :: ByteString
b58Data :: ByteString
b58Data = ByteString
"123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
b58Array :: Array Int Word8
b58Array :: Array Int Word8
b58Array = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
57) (ByteString -> [Word8]
BS.unpack ByteString
b58Data)
b58InvArray :: Array Word8 (Maybe Int)
b58InvArray :: Array Word8 (Maybe Int)
b58InvArray = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound) (forall a. a -> [a]
repeat forall a. Maybe a
Nothing) forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (a, a) -> (a, Maybe a)
swap (forall i e. Ix i => Array i e -> [(i, e)]
assocs Array Int Word8
b58Array)
where
swap :: (a, a) -> (a, Maybe a)
swap (a
i, a
c) = (a
c, forall a. a -> Maybe a
Just a
i)
b58 :: Int -> Word8
b58 :: Int -> Word8
b58 = (Array Int Word8
b58Array forall i e. Ix i => Array i e -> i -> e
!)
b58' :: Word8 -> Maybe Int
b58' :: Word8 -> Maybe Int
b58' = (Array Word8 (Maybe Int)
b58InvArray forall i e. Ix i => Array i e -> i -> e
!)
encodeBase58I :: Integer -> Base58
encodeBase58I :: Integer -> Base58
encodeBase58I Integer
i = forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Integer
58 (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
b58) Integer
i String
""
decodeBase58I :: Base58 -> Maybe Integer
decodeBase58I :: Base58 -> Maybe Integer
decodeBase58I Base58
s =
case Maybe (Integer, String)
go of
Just (Integer
r, []) -> forall a. a -> Maybe a
Just Integer
r
Maybe (Integer, String)
_ -> forall a. Maybe a
Nothing
where
p :: Char -> Bool
p = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Maybe Int
b58' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
f :: Char -> Int
f = forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Maybe Int
b58' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
go :: Maybe (Integer, String)
go = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt Integer
58 Char -> Bool
p Char -> Int
f (forall a b. ConvertibleStrings a b => a -> b
cs Base58
s)
e :: a
e = forall a. HasCallStack => String -> a
error String
"Could not decode base58"
encodeBase58 :: ByteString -> Base58
encodeBase58 :: ByteString -> Base58
encodeBase58 ByteString
bs =
Base58
l forall a. Semigroup a => a -> a -> a
<> Base58
r
where
(ByteString
z, ByteString
b) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span (forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
bs
l :: Base58
l = forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate (ByteString -> Int
BS.length ByteString
z) (Int -> Word8
b58 Int
0)
r :: Base58
r
| ByteString -> Bool
BS.null ByteString
b = Base58
T.empty
| Bool
otherwise = Integer -> Base58
encodeBase58I forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
bsToInteger ByteString
b
decodeBase58 :: Base58 -> Maybe ByteString
decodeBase58 :: Base58 -> Maybe ByteString
decodeBase58 Base58
t =
ByteString -> ByteString -> ByteString
BS.append ByteString
prefix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
r
where
(ByteString
z, ByteString
b) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span (forall a. Eq a => a -> a -> Bool
== Int -> Word8
b58 Int
0) (forall a b. ConvertibleStrings a b => a -> b
cs Base58
t)
prefix :: ByteString
prefix = Int -> Word8 -> ByteString
BS.replicate (ByteString -> Int
BS.length ByteString
z) Word8
0
r :: Maybe ByteString
r
| ByteString -> Bool
BS.null ByteString
b = forall a. a -> Maybe a
Just ByteString
BS.empty
| Bool
otherwise = Integer -> ByteString
integerToBS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Base58 -> Maybe Integer
decodeBase58I (forall a b. ConvertibleStrings a b => a -> b
cs ByteString
b)
encodeBase58Check :: ByteString -> Base58
encodeBase58Check :: ByteString -> Base58
encodeBase58Check ByteString
bs =
ByteString -> Base58
encodeBase58 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
BS.append ByteString
bs forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize forall a b. (a -> b) -> a -> b
$ forall b. ByteArrayAccess b => b -> CheckSum32
checkSum32 ByteString
bs
decodeBase58Check :: Base58 -> Maybe ByteString
decodeBase58Check :: Base58 -> Maybe ByteString
decodeBase58Check Base58
bs = do
ByteString
rs <- Base58 -> Maybe ByteString
decodeBase58 Base58
bs
let (ByteString
res, ByteString
chk) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (ByteString -> Int
BS.length ByteString
rs forall a. Num a => a -> a -> a
- Int
4) ByteString
rs
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ ByteString
chk forall a. Eq a => a -> a -> Bool
== Put -> ByteString
runPutS (forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (forall b. ByteArrayAccess b => b -> CheckSum32
checkSum32 ByteString
res))
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
res