{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Data.Solidity.Prim.Address
-- Copyright   :  Aleksandr Krupenkin 2016-2024
-- License     :  Apache-2.0
--
-- Maintainer  :  mail@akru.me
-- Stability   :  experimental
-- Portability :  noportable
--
-- Ethreum account address.
--

module Data.Solidity.Prim.Address
    (
    -- * The @Address@ type
      Address

    -- * Hex string encoding
    , toHexString
    , fromHexString

    -- * Derive address from public key
    , fromPubKey

    -- * EIP55 Mix-case checksum address encoding
    , toChecksum
    , verifyChecksum
    ) where

import           Control.Monad            ((<=<))
import           Crypto.Ethereum          (PublicKey)
import           Data.Aeson               (FromJSON (..), ToJSON (..))
import           Data.Bits                ((.&.))
import           Data.Bool                (bool)
import           Data.ByteArray           (zero)
import qualified Data.ByteArray           as BA (drop)
import           Data.ByteString          (ByteString)
import qualified Data.ByteString          as BS (take, unpack)
import qualified Data.ByteString.Char8    as C8 (drop, length, pack, unpack)
import qualified Data.Char                as C (toLower, toUpper)
import           Data.Default             (Default (..))
import           Data.String              (IsString (..))
import           Data.Text.Encoding       as T (encodeUtf8)
import           Generics.SOP             (Generic)
import qualified GHC.Generics             as GHC (Generic)

import           Crypto.Ecdsa.Utils       (exportPubKey)
import           Crypto.Ethereum.Utils    (keccak256)
import           Data.ByteArray.HexString (HexString, fromBytes, toBytes,
                                           toText)
import           Data.Solidity.Abi        (AbiGet (..), AbiPut (..),
                                           AbiType (..))
import           Data.Solidity.Abi.Codec  (decode, encode)
import           Data.Solidity.Prim.Int   (UIntN)

-- | Ethereum account address
newtype Address = Address { Address -> UIntN 160
unAddress :: UIntN 160 }
  deriving (Address -> Address -> Bool
(Address -> Address -> Bool)
-> (Address -> Address -> Bool) -> Eq Address
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Address -> Address -> Bool
== :: Address -> Address -> Bool
$c/= :: Address -> Address -> Bool
/= :: Address -> Address -> Bool
Eq, Eq Address
Eq Address =>
(Address -> Address -> Ordering)
-> (Address -> Address -> Bool)
-> (Address -> Address -> Bool)
-> (Address -> Address -> Bool)
-> (Address -> Address -> Bool)
-> (Address -> Address -> Address)
-> (Address -> Address -> Address)
-> Ord Address
Address -> Address -> Bool
Address -> Address -> Ordering
Address -> Address -> Address
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Address -> Address -> Ordering
compare :: Address -> Address -> Ordering
$c< :: Address -> Address -> Bool
< :: Address -> Address -> Bool
$c<= :: Address -> Address -> Bool
<= :: Address -> Address -> Bool
$c> :: Address -> Address -> Bool
> :: Address -> Address -> Bool
$c>= :: Address -> Address -> Bool
>= :: Address -> Address -> Bool
$cmax :: Address -> Address -> Address
max :: Address -> Address -> Address
$cmin :: Address -> Address -> Address
min :: Address -> Address -> Address
Ord, (forall x. Address -> Rep Address x)
-> (forall x. Rep Address x -> Address) -> Generic Address
forall x. Rep Address x -> Address
forall x. Address -> Rep Address x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Address -> Rep Address x
from :: forall x. Address -> Rep Address x
$cto :: forall x. Rep Address x -> Address
to :: forall x. Rep Address x -> Address
GHC.Generic)

instance Generic Address

instance Default Address where
    def :: Address
def = UIntN 160 -> Address
Address UIntN 160
0

instance Show Address where
    show :: Address -> [Char]
show = ByteString -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> [Char])
-> (Address -> ByteString) -> Address -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toChecksum (ByteString -> ByteString)
-> (Address -> ByteString) -> Address -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (Address -> Text) -> Address -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HexString -> Text
toText (HexString -> Text) -> (Address -> HexString) -> Address -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> HexString
toHexString

instance IsString Address where
    fromString :: [Char] -> Address
fromString = ([Char] -> Address)
-> (Address -> Address) -> Either [Char] Address -> Address
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Address
forall a. HasCallStack => [Char] -> a
error Address -> Address
forall a. a -> a
id (Either [Char] Address -> Address)
-> ([Char] -> Either [Char] Address) -> [Char] -> Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HexString -> Either [Char] Address
fromHexString (HexString -> Either [Char] Address)
-> ([Char] -> HexString) -> [Char] -> Either [Char] Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> HexString
forall a. IsString a => [Char] -> a
fromString

instance AbiType Address where
    isDynamic :: Proxy Address -> Bool
isDynamic Proxy Address
_ = Bool
False

instance AbiGet Address where
    abiGet :: Get Address
abiGet = UIntN 160 -> Address
Address (UIntN 160 -> Address) -> Get (UIntN 160) -> Get Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (UIntN 160)
forall a. AbiGet a => Get a
abiGet

instance AbiPut Address where
    abiPut :: Putter Address
abiPut = Putter (UIntN 160)
forall a. AbiPut a => Putter a
abiPut Putter (UIntN 160) -> (Address -> UIntN 160) -> Putter Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> UIntN 160
unAddress

instance FromJSON Address where
    parseJSON :: Value -> Parser Address
parseJSON = (([Char] -> Parser Address)
-> (Address -> Parser Address)
-> Either [Char] Address
-> Parser Address
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Parser Address
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail Address -> Parser Address
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] Address -> Parser Address)
-> (HexString -> Either [Char] Address)
-> HexString
-> Parser Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HexString -> Either [Char] Address
fromHexString) (HexString -> Parser Address)
-> (Value -> Parser HexString) -> Value -> Parser Address
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> Parser HexString
forall a. FromJSON a => Value -> Parser a
parseJSON

instance ToJSON Address where
    toJSON :: Address -> Value
toJSON = HexString -> Value
forall a. ToJSON a => a -> Value
toJSON (HexString -> Value) -> (Address -> HexString) -> Address -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> HexString
toHexString

-- | Derive address from secp256k1 public key
fromPubKey :: PublicKey -> Address
fromPubKey :: PublicKey -> Address
fromPubKey PublicKey
key =
    case HexString -> Either [Char] Address
forall ba a.
(ByteArrayAccess ba, AbiGet a) =>
ba -> Either [Char] a
decode (HexString -> Either [Char] Address)
-> HexString -> Either [Char] Address
forall a b. (a -> b) -> a -> b
$ Int -> HexString
forall ba. ByteArray ba => Int -> ba
zero Int
12 HexString -> HexString -> HexString
forall a. Semigroup a => a -> a -> a
<> HexString -> HexString
toAddress (PublicKey -> HexString
forall publicKey. ByteArray publicKey => PublicKey -> publicKey
exportPubKey PublicKey
key) of
        Right Address
a -> Address
a
        Left [Char]
e  -> [Char] -> Address
forall a. HasCallStack => [Char] -> a
error ([Char] -> Address) -> [Char] -> Address
forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible error: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
e
  where
    toAddress :: HexString -> HexString
    toAddress :: HexString -> HexString
toAddress = Int -> HexString -> HexString
forall bs. ByteArray bs => Int -> bs -> bs
BA.drop Int
12 (HexString -> HexString)
-> (HexString -> HexString) -> HexString -> HexString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HexString -> HexString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
keccak256

-- | Decode address from hex string
fromHexString :: HexString -> Either String Address
fromHexString :: HexString -> Either [Char] Address
fromHexString HexString
bs
  | Int
bslen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
20 = ByteString -> Either [Char] Address
forall ba a.
(ByteArrayAccess ba, AbiGet a) =>
ba -> Either [Char] a
decode (Int -> ByteString
forall ba. ByteArray ba => Int -> ba
zero Int
12 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> HexString -> ByteString
forall ba. ByteArray ba => HexString -> ba
toBytes HexString
bs :: ByteString)
  | Bool
otherwise = [Char] -> Either [Char] Address
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Address)
-> [Char] -> Either [Char] Address
forall a b. (a -> b) -> a -> b
$ [Char]
"Incorrect address length: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
bslen
  where bslen :: Int
bslen = ByteString -> Int
C8.length (HexString -> ByteString
forall ba. ByteArray ba => HexString -> ba
toBytes HexString
bs)

-- | Encode address to hex string
toHexString :: Address -> HexString
toHexString :: Address -> HexString
toHexString = ByteString -> HexString
forall ba. ByteArrayAccess ba => ba -> HexString
fromBytes (ByteString -> HexString)
-> (Address -> ByteString) -> Address -> HexString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
C8.drop Int
12 (ByteString -> ByteString)
-> (Address -> ByteString) -> Address -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> ByteString
forall a ba. (AbiPut a, ByteArray ba) => a -> ba
encode

-- | Encode address with mixed-case checksum
-- https://github.com/ethereum/EIPs/blob/master/EIPS/eip-55.md
toChecksum :: ByteString -> ByteString
toChecksum :: ByteString -> ByteString
toChecksum ByteString
addr = (ByteString
"0x" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString)
-> ([Char] -> ByteString) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
C8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ ((Char -> Char) -> Char -> Char) -> [Char -> Char] -> ShowS
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
($) [Char -> Char]
upcaseVector [Char]
lower
  where
    upcaseVector :: [Char -> Char]
upcaseVector = ([Word8] -> (Word8 -> [Char -> Char]) -> [Char -> Char]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> [Char -> Char]
forall {a}. (Bits a, Num a) => a -> [Char -> Char]
fourthBits) ([Word8] -> [Char -> Char])
-> (ByteString -> [Word8]) -> ByteString -> [Char -> Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack (ByteString -> [Word8])
-> (ByteString -> ByteString) -> ByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.take Int
20 (ByteString -> [Char -> Char]) -> ByteString -> [Char -> Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
keccak256 ([Char] -> ByteString
C8.pack [Char]
lower)
    fourthBits :: a -> [Char -> Char]
fourthBits a
n = (Char -> Char) -> (Char -> Char) -> Bool -> Char -> Char
forall a. a -> a -> Bool -> a
bool Char -> Char
forall a. a -> a
id Char -> Char
C.toUpper (Bool -> Char -> Char) -> [Bool] -> [Char -> Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a
n a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x80 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0, a
n a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x08 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0]
    lower :: [Char]
lower = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
2 ShowS -> (ByteString -> [Char]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
C.toLower ShowS -> (ByteString -> [Char]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
C8.unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString
addr

-- | Verify mixed-case address checksum
-- https://github.com/ethereum/EIPs/blob/master/EIPS/eip-55.md
verifyChecksum :: ByteString -> Bool
verifyChecksum :: ByteString -> Bool
verifyChecksum = ByteString -> ByteString
toChecksum (ByteString -> ByteString)
-> (ByteString -> ByteString -> Bool) -> ByteString -> Bool
forall a b.
(ByteString -> a) -> (a -> ByteString -> b) -> ByteString -> b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==)