{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Haskoin.Address.Base58
Copyright   : No rights reserved
License     : MIT
Maintainer  : jprupp@protonmail.ch
Stability   : experimental
Portability : POSIX

Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit
(BTC) and CashAddr for Bitcoin Cash (BCH).
-}
module Haskoin.Address.Base58 (
    -- * Base58
    Base58,
    encodeBase58,
    decodeBase58,
    encodeBase58Check,
    decodeBase58Check,
) where

import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import Data.Array
import Data.Char
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
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)

-- | 'Base58' classic Bitcoin address format.
type Base58 = Text

-- | Symbols for Base58 encoding.
b58Data :: ByteString
b58Data :: ByteString
b58Data = ByteString
"123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"

b58Array :: Array Int Word8
b58Array :: Array Int Word8
b58Array = (Int, Int) -> [Word8] -> Array Int Word8
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 = (Word8, Word8) -> [Maybe Int] -> Array Word8 (Maybe Int)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Word8
forall a. Bounded a => a
minBound, Word8
forall a. Bounded a => a
maxBound) (Maybe Int -> [Maybe Int]
forall a. a -> [a]
repeat Maybe Int
forall a. Maybe a
Nothing) Array Word8 (Maybe Int)
-> [(Word8, Maybe Int)] -> Array Word8 (Maybe Int)
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// ((Int, Word8) -> (Word8, Maybe Int))
-> [(Int, Word8)] -> [(Word8, Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Word8) -> (Word8, Maybe Int)
forall a a. (a, a) -> (a, Maybe a)
swap (Array Int Word8 -> [(Int, Word8)]
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, a -> Maybe a
forall a. a -> Maybe a
Just a
i)

{- | Convert a number less than or equal to provided integer into a 'Base58'
 character.
-}
b58 :: Int -> Word8
b58 :: Int -> Word8
b58 = (Array Int Word8
b58Array Array Int Word8 -> Int -> Word8
forall i e. Ix i => Array i e -> i -> e
!)

-- | Convert a 'Base58' character into the number it represents.
b58' :: Word8 -> Maybe Int
b58' :: Word8 -> Maybe Int
b58' = (Array Word8 (Maybe Int)
b58InvArray Array Word8 (Maybe Int) -> Word8 -> Maybe Int
forall i e. Ix i => Array i e -> i -> e
!)

{- | Encode an arbitrary-length 'Integer' into a 'Base58' string. Leading zeroes
 will not be part of the resulting string.
-}
encodeBase58I :: Integer -> Base58
encodeBase58I :: Integer -> Base58
encodeBase58I Integer
i = String -> Base58
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Base58) -> String -> Base58
forall a b. (a -> b) -> a -> b
$ Integer -> (Int -> Char) -> Integer -> ShowS
forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Integer
58 (Int -> Char
chr (Int -> Char) -> (Int -> Int) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> (Int -> Word8) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
b58) Integer
i String
""

-- | Decode a 'Base58' string into an arbitrary-length 'Integer'.
decodeBase58I :: Base58 -> Maybe Integer
decodeBase58I :: Base58 -> Maybe Integer
decodeBase58I Base58
s =
    case Maybe (Integer, String)
go of
        Just (Integer
r, []) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
r
        Maybe (Integer, String)
_ -> Maybe Integer
forall a. Maybe a
Nothing
  where
    p :: Char -> Bool
p = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> (Char -> Maybe Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Maybe Int
b58' (Word8 -> Maybe Int) -> (Char -> Word8) -> Char -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
    f :: Char -> Int
f = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
forall a. a
e (Maybe Int -> Int) -> (Char -> Maybe Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Maybe Int
b58' (Word8 -> Maybe Int) -> (Char -> Word8) -> Char -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
    go :: Maybe (Integer, String)
go = [(Integer, String)] -> Maybe (Integer, String)
forall a. [a] -> Maybe a
listToMaybe ([(Integer, String)] -> Maybe (Integer, String))
-> [(Integer, String)] -> Maybe (Integer, String)
forall a b. (a -> b) -> a -> b
$ Integer -> (Char -> Bool) -> (Char -> Int) -> ReadS Integer
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt Integer
58 Char -> Bool
p Char -> Int
f (Base58 -> String
forall a b. ConvertibleStrings a b => a -> b
cs Base58
s)
    e :: a
e = String -> a
forall a. HasCallStack => String -> a
error String
"Could not decode base58"

{- | Encode an arbitrary 'ByteString' into a its 'Base58' representation,
 preserving leading zeroes.
-}
encodeBase58 :: ByteString -> Base58
encodeBase58 :: ByteString -> Base58
encodeBase58 ByteString
bs =
    Base58
l Base58 -> Base58 -> Base58
forall a. Semigroup a => a -> a -> a
<> Base58
r
  where
    (ByteString
z, ByteString
b) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
bs
    l :: Base58
l = ByteString -> Base58
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Base58) -> ByteString -> Base58
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate (ByteString -> Int
BS.length ByteString
z) (Int -> Word8
b58 Int
0) -- preserve leading 0's
    r :: Base58
r
        | ByteString -> Bool
BS.null ByteString
b = Base58
T.empty
        | Bool
otherwise = Integer -> Base58
encodeBase58I (Integer -> Base58) -> Integer -> Base58
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
bsToInteger ByteString
b

-- | Decode a 'Base58'-encoded 'Text' to a 'ByteString'.
decodeBase58 :: Base58 -> Maybe ByteString
decodeBase58 :: Base58 -> Maybe ByteString
decodeBase58 Base58
t =
    ByteString -> ByteString -> ByteString
BS.append ByteString
prefix (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
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 (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Word8
b58 Int
0) (Base58 -> ByteString
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 -- preserve leading 1's
    r :: Maybe ByteString
r
        | ByteString -> Bool
BS.null ByteString
b = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
BS.empty
        | Bool
otherwise = Integer -> ByteString
integerToBS (Integer -> ByteString) -> Maybe Integer -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Base58 -> Maybe Integer
decodeBase58I (ByteString -> Base58
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
b)

{- | Computes a checksum for the input 'ByteString' and encodes the input and
 the checksum as 'Base58'.
-}
encodeBase58Check :: ByteString -> Base58
encodeBase58Check :: ByteString -> Base58
encodeBase58Check ByteString
bs =
    ByteString -> Base58
encodeBase58 (ByteString -> Base58) -> ByteString -> Base58
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
BS.append ByteString
bs (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPutS (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ CheckSum32 -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (CheckSum32 -> Put) -> CheckSum32 -> Put
forall a b. (a -> b) -> a -> b
$ ByteString -> CheckSum32
forall b. ByteArrayAccess b => b -> CheckSum32
checkSum32 ByteString
bs

{- | Decode a 'Base58'-encoded string that contains a checksum. This function
 returns 'Nothing' if the input string contains invalid 'Base58' characters or
 if the checksum fails.
-}
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) ByteString
rs
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString
chk ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Put -> ByteString
runPutS (CheckSum32 -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (ByteString -> CheckSum32
forall b. ByteArrayAccess b => b -> CheckSum32
checkSum32 ByteString
res))
    ByteString -> Maybe ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
res