{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_HADDOCK prune #-}

-- |
-- Copyright: 2020 Input Output (Hong Kong) Ltd., 2021-2022 Input Output Global Inc. (IOG), 2023-2025 Intersect
-- License: Apache-2.0

module Cardano.Address
    ( -- * Address
      Address
    , PaymentAddress (..)
    , StakeAddress (..)
    , DelegationAddress (..)
    , PointerAddress (..)
    , ChainPointer (..)
    , unsafeMkAddress
    , unAddress

      -- * Conversion From / To Text
    , base58
    , fromBase58
    , bech32
    , bech32With
    , fromBech32

      -- Internal / Network Discrimination
    , HasNetworkDiscriminant (..)
    , AddressDiscrimination (..)
    , NetworkTag (..)
    , invariantSize
    , invariantNetworkTag
    ) where

import Prelude

import Cardano.Address.Derivation
    ( Depth (..), XPub )
import Cardano.Codec.Cbor
    ( decodeAddress, deserialiseCbor )
import Codec.Binary.Bech32
    ( HumanReadablePart )
import Codec.Binary.Encoding
    ( AbstractEncoding (..), encode )
import Control.DeepSeq
    ( NFData )
import Control.Monad
    ( (<=<) )
import Data.Aeson
    ( ToJSON (..), Value (..), object, (.=) )
import Data.Bits
    ( Bits (testBit) )
import Data.ByteString
    ( ByteString )
import Data.Either.Extra
    ( eitherToMaybe )
import Data.Kind
    ( Type )
import Data.Text
    ( Text )
import Data.Word
    ( Word32, Word8 )
import GHC.Generics
    ( Generic )
import GHC.Stack
    ( HasCallStack )
import Numeric.Natural
    ( Natural )

import qualified Cardano.Codec.Bech32.Prefixes as CIP5
import qualified Codec.Binary.Encoding as E
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as T

-- | An 'Address' type representing 'Cardano' addresses. Internals are
-- irrevelant to the user.
--
-- @since 1.0.0
newtype Address = Address
    { unAddress :: ByteString
    } deriving stock (Generic, Show, Eq, Ord)
instance NFData Address

-- Unsafe constructor for easily lifting bytes inside an 'Address'.
--
-- /!\ Use at your own risks.
unsafeMkAddress :: ByteString -> Address
unsafeMkAddress = Address

-- | Encode an 'Address' to a base58 'Text'.
--
-- @since 1.0.0
base58 :: Address -> Text
base58 = T.decodeUtf8 . encode EBase58 . unAddress

-- | Decode a base58-encoded 'Text' into an 'Address'
--
-- @since 1.0.0
fromBase58 :: Text -> Maybe Address
fromBase58 =
    (eitherToMaybe . deserialiseCbor (unsafeMkAddress <$> decodeAddress)
    <=< (eitherToMaybe . E.fromBase58 . T.encodeUtf8))

-- | Encode a Shelley 'Address' to bech32 'Text', using @addr@ or @addr_test@ as
-- a human readable prefix (depending on the network tag in the address).
--
-- @since 1.0.0
bech32 :: Address -> Text
bech32 addr = bech32With (addressHrp addr) addr

-- | Encode an 'Address' to bech32 'Text', using the specified human readable
-- prefix.
--
-- @since 2.0.0
bech32With :: HumanReadablePart -> Address -> Text
bech32With hrp = T.decodeLatin1 . encode (EBech32 hrp) . unAddress

-- | Decode a bech32-encoded 'Text' into an 'Address'
--
-- @since 1.0.0
fromBech32 :: Text -> Maybe Address
fromBech32 = eitherToMaybe
    . fmap (unsafeMkAddress . snd)
    . E.fromBech32 (const id)
    . T.encodeUtf8

-- | Returns the HRP for a shelley address, using the network tag.
addressHrp :: Address -> HumanReadablePart
addressHrp (Address bs) = case BS.uncons bs of
    Just (w8, _) | testBit w8 0 -> CIP5.addr
    _ -> CIP5.addr_test

-- | Encoding of addresses for certain key types and backend targets.
--
-- @since 2.0.0
class HasNetworkDiscriminant key => StakeAddress key where
    -- | Convert a delegation key to a stake 'Address' (aka: reward account address)
    -- valid for the given network discrimination.
    --
    -- @since 2.0.0
    stakeAddress :: NetworkDiscriminant key -> key 'DelegationK XPub -> Address

-- | Encoding of addresses for certain key types and backend targets.
--
-- @since 1.0.0
class HasNetworkDiscriminant key => PaymentAddress key where
    -- | Convert a public key to a payment 'Address' valid for the given
    -- network discrimination.
    --
    -- @since 1.0.0
    paymentAddress :: NetworkDiscriminant key -> key 'PaymentK XPub -> Address

-- | Encoding of delegation addresses for certain key types and backend targets.
--
-- @since 2.0.0
class PaymentAddress key
    => DelegationAddress key where
    -- | Convert a public key and a delegation key to a delegation 'Address' valid
    -- for the given network discrimination. Funds sent to this address will be
    -- delegated according to the delegation settings attached to the delegation
    -- key.
    --
    -- @since 2.0.0
    delegationAddress
        :: NetworkDiscriminant key
        ->  key 'PaymentK XPub
            -- ^ Payment key
        ->  key 'DelegationK XPub
            -- ^ Delegation key
        -> Address

-- | A 'ChainPointer' type representing location of some object
-- in the blockchain (eg., delegation certificate). This can be achieved
-- unambiguously by specifying slot number, transaction index and the index
-- in the object list (eg., certification list).
-- For delegation certificates, alternatively, the delegation key can be used and
-- then 'DelegationAddress' can be used.
--
-- @since 2.0.0
data ChainPointer = ChainPointer
    { slotNum :: Natural
      -- ^ Pointer to the slot
    , transactionIndex :: Natural
      -- ^ transaction index
    , outputIndex :: Natural
      -- ^ output list index
    } deriving stock (Generic, Show, Eq, Ord)
instance NFData ChainPointer

instance ToJSON ChainPointer where
    toJSON ChainPointer{..} = object
        [ "slot_num" .= slotNum
        , "transaction_index" .= transactionIndex
        , "output_index" .= outputIndex
        ]

-- | Encoding of pointer addresses for payment key type, pointer to delegation
-- certificate in the blockchain and backend targets.
--
-- @since 2.0.0
class PaymentAddress key
    => PointerAddress key where
    -- | Convert a payment public key and a pointer to delegation key in the
    -- blockchain to a delegation 'Address' valid for the given network
    -- discrimination. Funds sent to this address will be delegated according to
    -- the delegation settings attached to the delegation key located by
    -- 'ChainPointer'.
    --
    -- @since 2.0.0
    pointerAddress
        :: NetworkDiscriminant key
        ->  key 'PaymentK XPub
            -- ^ Payment key
        ->  ChainPointer
            -- ^ Pointer to locate delegation key in blockchain
        -> Address

class HasNetworkDiscriminant (key :: Depth -> Type -> Type) where
    type NetworkDiscriminant key :: Type

    addressDiscrimination :: NetworkDiscriminant key -> AddressDiscrimination
    networkTag :: NetworkDiscriminant key -> NetworkTag

-- Magic constant associated with a given network. This is mainly used in two
-- places:
--
-- (1) In 'Address' payloads, to discriminate addresses between networks.
-- (2) At the network-level, when doing handshake with nodes.
newtype NetworkTag
    = NetworkTag { unNetworkTag :: Word32 }
    deriving (Generic, Show, Eq)
instance NFData NetworkTag

instance ToJSON NetworkTag where
    toJSON (NetworkTag net) = Number (fromIntegral net)

-- Describe requirements for address discrimination on the Byron era.
data AddressDiscrimination
    = RequiresNetworkTag
    | RequiresNoTag
    deriving (Generic, Show, Eq)
instance NFData AddressDiscrimination

invariantSize :: HasCallStack => Int -> ByteString -> ByteString
invariantSize expectedLength bytes
    | BS.length bytes == expectedLength = bytes
    | otherwise = error
      $ "length was "
      ++ show (BS.length bytes)
      ++ ", but expected to be "
      ++ (show expectedLength)

invariantNetworkTag :: HasCallStack => Word32 -> NetworkTag -> Word8
invariantNetworkTag limit (NetworkTag num)
    | num < limit = fromIntegral num
    | otherwise = error
      $ "network tag was "
      ++ show num
      ++ ", but expected to be less than "
      ++ show limit