Address.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Address in Tezos.

{-# LANGUAGE DeriveLift #-}

module Morley.Tezos.Address
  ( ContractHash
  , Address (..)
  , TxRollupL2Address (..)
  , mkKeyAddress
  , detGenKeyAddress
  , isKeyAddress

  , GlobalCounter(..)
  , mkContractHashHack

  -- * Formatting
  , ParseAddressError (..)
  , ParseAddressRawError (..)
  , formatAddress
  , mformatAddress
  , parseAddressRaw
  , parseAddress
  , ta
  ) where

import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey)
import Data.Aeson qualified as Aeson
import Data.Aeson.Encoding qualified as Aeson
import Data.Aeson.Types qualified as AesonTypes
import Data.ByteString qualified as BS
import Data.Text (strip)
import Fmt (Buildable(build), hexF, pretty)
import Instances.TH.Lift ()
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax (Lift)
import Language.Haskell.TH.Syntax qualified as TH
import Text.PrettyPrint.Leijen.Text (backslash, dquotes, int, (<+>))

import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)
import Morley.Michelson.Text
import Morley.Tezos.Crypto
import Morley.Util.CLI
import Morley.Util.TypeLits

-- | Data type corresponding to address structure in Tezos.
data Address
  = KeyAddress KeyHash
  -- ^ @tz1@, @tz2@ or @tz3@ address which is a hash of a public key.
  | ContractAddress ContractHash
  -- ^ @KT@ address which corresponds to a callable contract.
  | TransactionRollupAddress TxRollupHash
  -- ^ @txr1@ address which corresponds to a transaction rollup.
  deriving stock (Show, Eq, Ord, Generic, Lift)

instance NFData Address

-- | @tz4@ level-2 public key hash address, used with transaction rollups, corresponds
-- to @tx_rollup_l2_address@ Michelson type.
newtype TxRollupL2Address = TxRollupL2Address KeyHashL2
  deriving stock (Show, Eq, Ord, Generic, Lift)
  deriving newtype NFData

-- | Returns @True@ if given address is implicit.
isKeyAddress :: Address -> Bool
isKeyAddress = \case
  KeyAddress _      -> True
  ContractAddress _ -> False
  TransactionRollupAddress _ -> False

-- | Smart constructor for 'KeyAddress'.
mkKeyAddress :: PublicKey -> Address
mkKeyAddress = KeyAddress . hashKey

-- | Deterministically generate a random 'KeyAddress' and discard its
-- secret key.
detGenKeyAddress :: ByteString -> Address
detGenKeyAddress = mkKeyAddress . toPublic . detSecretKey

-- | Represents the network's global counter.
--
-- We store the current value of this counter in the operation at the time of its creation
-- for the following reasons:
-- * to guarantee the uniqueness of contract addresses upon origination
--   (see 'Morley.Michelson.Typed.Operation.mkContractAddress)
-- * to prevent replay attacks by checking that an operation with the same counter value
--   con't be performed twice.
--
-- The counter is incremented after every operation execution and interpretation of instructions
-- @CREATE_CONTRACT@ and @TRANSFER_TOKENS@, and thus ensures that these addresses are unique
-- (i.e. origination of identical contracts with identical metadata will result in
-- different addresses.)
--
-- Our counter is represented as 'Word64', while in Tezos it is unbounded. We believe that
-- for our interpreter it should not matter.
newtype GlobalCounter = GlobalCounter { unGlobalCounter :: Word64 }
  deriving stock (Show, Eq, Generic)
  deriving anyclass (NFData)
  deriving newtype (ToJSON, FromJSON, Num, Buildable, Hashable)

-- | Create a dummy 'ContractHash' value by hashing given 'ByteString'.
--
-- Use in tests **only**.
mkContractHashHack :: ByteString -> ContractHash
mkContractHashHack = Hash HashContract . blake2b160

----------------------------------------------------------------------------
-- Formatting/parsing
----------------------------------------------------------------------------

formatAddress :: Address -> Text
formatAddress =
  \case
    KeyAddress h -> formatHash h
    ContractAddress h -> formatHash h
    TransactionRollupAddress h -> formatHash h

mformatAddress :: Address -> MText
mformatAddress = unsafe . mkMText . formatAddress

instance Buildable Address where
  build = build . formatAddress

instance Buildable TxRollupL2Address where
  build (TxRollupL2Address kh) = build $ formatHash kh

-- | Errors that can happen during address parsing.
data ParseAddressError
  = ParseAddressWrongBase58Check
  -- ^ Address is not in Base58Check format.
  | ParseAddressAllFailed (NonEmpty CryptoParseError)
  -- ^ All address parsers failed with some error.
  deriving stock (Show, Eq, Generic)

instance Semigroup ParseAddressError where
  ParseAddressWrongBase58Check <> _ =  ParseAddressWrongBase58Check
  _ <> ParseAddressWrongBase58Check =  ParseAddressWrongBase58Check
  ParseAddressAllFailed xs <> ParseAddressAllFailed ys = ParseAddressAllFailed $ xs <> ys

instance NFData ParseAddressError

instance Buildable ParseAddressError where
  build = buildRenderDoc

instance RenderDoc ParseAddressError where
  renderDoc context =
    \case
      ParseAddressWrongBase58Check -> "Wrong base58check format"
      ParseAddressAllFailed pkErr ->
        mconcat $ "Address failed to parse: " : intersperse ", "
          (toList $ renderDoc context <$> pkErr)

-- | Parse an address from its human-readable textual representation
-- used by Tezos (e. g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"). Or
-- fail if it's invalid.
parseAddress :: Text -> Either ParseAddressError Address
parseAddress addressText =
  let implicit = tryParse KeyAddress parseHash handleCrypto
      contract = tryParse ContractAddress parseHash handleCrypto
      txr = tryParse TransactionRollupAddress parseHash handleCrypto
  in implicit `merge` contract `merge` txr
  where
    handleCrypto = \case
      CryptoParseWrongBase58Check -> ParseAddressWrongBase58Check
      x -> ParseAddressAllFailed $ pure x
    merge :: Semigroup a => Either a b -> Either a b -> Either a b
    merge (Left xs) (Left ys) = Left $ xs <> ys
    merge r@Right{} _ = r
    merge _ r@Right{} = r
    tryParse :: (t -> b) -> (Text -> Either t1 t) -> (t1 -> a) -> Either a b
    tryParse ctor parser handler =
      case parser addressText of
        Left err -> Left $ handler err
        Right res -> Right $ ctor res

data ParseAddressRawError
  = ParseAddressRawWrongSize ByteString
  -- ^ Raw bytes representation of an address has invalid length.
  | ParseAddressRawInvalidPrefix ByteString
  -- ^ Raw bytes representation of an address has incorrect prefix.
  | ParseAddressRawMalformedSeparator ByteString
  -- ^ Raw bytes representation of an address does not end with "\00".
  deriving stock (Eq, Show, Generic)

instance NFData ParseAddressRawError

instance RenderDoc ParseAddressRawError where
  renderDoc _ =
    \case
      ParseAddressRawInvalidPrefix prefix ->
        "Invalid prefix for raw address" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided"
      ParseAddressRawWrongSize addr -> "Given raw address+" <+>
        (renderAnyBuildable $ hexF addr) <+> "has invalid length" <+> int (length addr)
      ParseAddressRawMalformedSeparator addr -> "Given raw address+" <+> (renderAnyBuildable $ hexF addr) <+>
        "does not end with" <+> dquotes (backslash <> "00")

instance Buildable ParseAddressRawError where
  build = buildRenderDoc

-- | Parse the given address in its raw byte form used by Tezos
-- (e.g "01521139f84791537d54575df0c74a8084cc68861c00")) . Or fail otherwise
-- if it's invalid.
parseAddressRaw :: ByteString -> Either ParseAddressRawError Address
parseAddressRaw bytes =
  case BS.splitAt 1 bytes of
    -- key hash address
    ("\00", rest) -> checkHashLength (BS.drop 1 rest) >> case BS.splitAt 1 rest of
      ("\00", addr) -> pure $ KeyAddress $ Hash HashEd25519 addr
      ("\01", addr) -> pure $ KeyAddress $ Hash HashSecp256k1 addr
      ("\02", addr) -> pure $ KeyAddress $ Hash HashP256 addr
      (x, _) -> Left $ ParseAddressRawInvalidPrefix x
    (pfx, rest) -> do
      (address, sep) <- maybe (Left $ ParseAddressRawWrongSize rest) pure $ BS.unsnoc rest
      checkHashLength address
      unless (sep == 0x00) $
        Left $ ParseAddressRawMalformedSeparator rest
      case pfx of
        -- contract address
        "\01" -> pure $ ContractAddress $ Hash HashContract address
        -- transaction rollup address
        "\02" -> pure $ TransactionRollupAddress $ Hash HashTXR address
        x -> Left $ ParseAddressRawInvalidPrefix x
  where
    checkHashLength addr
      | length addr /= hashLengthBytes
      = Left $ ParseAddressRawWrongSize addr
      | otherwise = pass

-- | QuasyQuoter for constructing Tezos addresses.
--
-- Validity of result will be checked at compile time.
ta :: TH.QuasiQuoter
ta = TH.QuasiQuoter
  { TH.quoteExp = \s ->
      case parseAddress . strip $ toText s of
        Left   err -> fail $ pretty err
        Right addr -> TH.lift addr
  , TH.quotePat = \_ ->
      fail "Cannot use this QuasyQuotation at pattern position"
  , TH.quoteType = \_ ->
      fail "Cannot use this QuasyQuotation at type position"
  , TH.quoteDec = \_ ->
      fail "Cannot use this QuasyQuotation at declaration position"
  }


instance
    TypeError ('Text "There is no instance defined for (IsString Address)" ':$$:
               'Text "Consider using QuasiQuotes: `[ta|some text...|]`"
              ) =>
    IsString Address where
  fromString = error "impossible"


----------------------------------------------------------------------------
-- Unsafe
----------------------------------------------------------------------------

instance HasCLReader Address where
  getReader = eitherReader parseAddrDo
    where
      parseAddrDo addr =
        either (Left . mappend "Failed to parse address: " . pretty) Right $
        parseAddress $ toText addr
  getMetavar = "ADDRESS"

----------------------------------------------------------------------------
-- Aeson instances
----------------------------------------------------------------------------

instance ToJSON Address where
  toJSON = Aeson.String . formatAddress
  toEncoding = Aeson.text . formatAddress

instance ToJSONKey Address where
  toJSONKey = AesonTypes.toJSONKeyText formatAddress

instance FromJSON Address where
  parseJSON =
    Aeson.withText "Address" $
    either (fail . pretty) pure . parseAddress

instance FromJSONKey Address where
  fromJSONKey =
    AesonTypes.FromJSONKeyTextParser
      (either (fail . pretty) pure . parseAddress)