Typed.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NamedFieldPuns #-}

{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DefaultSignatures #-}

-- The Shelley ledger uses promoted data kinds which we have to use, but we do
-- not export any from this API. We also use them unticked as nature intended.
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

-- | This module provides a library interface for interacting with Cardano as
-- a user of the system.
--
-- It is intended to be used to write tools and
--
-- In the interest of simplicity it glosses over some details of the system.
-- Most simple tools should be able to work just using this interface,
-- however you can go deeper and expose the types from the underlying libraries
-- using "Cardano.Api.Byron" or "Cardano.Api.Shelley".
--
module Cardano.Api.Typed (
    -- * Eras
    Byron,
    Shelley,
    HasTypeProxy(..),
    AsType(..),

    -- * Cryptographic key interface
    -- $keys
    Key,
    VerificationKey(..),
    SigningKey(..),
    getVerificationKey,
    verificationKeyHash,
    castVerificationKey,
    castSigningKey,

    -- ** Generating keys
    generateSigningKey,
    deterministicSigningKey,
    deterministicSigningKeySeedSize,
    Crypto.Seed,
    Crypto.mkSeedFromBytes,
    Crypto.readSeedFromSystemEntropy,

    -- ** Hashes
    -- | In Cardano most keys are identified by their hash, and hashes are
    -- used in many other places.
    Hash(..),
    castHash,

    -- * Payment addresses
    -- | Constructing and inspecting normal payment addresses
    Address(..),
    NetworkId(..),
    -- * Byron addresses
    makeByronAddress,
    ByronKey,
    -- * Shelley addresses
    makeShelleyAddress,
    PaymentCredential(..),
    StakeAddressReference(..),
    PaymentKey,

    -- * Stake addresses
    -- | Constructing and inspecting stake addresses
    StakeAddress(..),
    StakeCredential(..),
    makeStakeAddress,
    StakeKey,

    -- * Building transactions
    -- | Constructing and inspecting transactions
    TxBody(..),
    TxId,
    getTxId,
    TxIn(..),
    TxOut(..),
    TxIx,
    Lovelace(..),
    makeByronTransaction,
    makeShelleyTransaction,
    SlotNo,
    TxExtraContent(..),
    txExtraContentEmpty,
    Certificate,

    -- * Signing transactions
    -- | Creating transaction witnesses one by one, or all in one go.
    Tx(..),
    getTxBody,
    getTxWitnesses,

    -- ** Signing in one go
    signByronTransaction,
    signShelleyTransaction,

    -- ** Incremental signing and separate witnesses
    makeSignedTransaction,
    Witness(..),
    makeByronKeyWitness,
    ShelleyWitnessSigningKey(..),
    makeShelleyKeyWitness,
    makeShelleyBootstrapWitness,
    makeShelleyScriptWitness,

    -- * Fee calculation
    transactionFee,
    estimateTransactionFee,

    -- * Transaction metadata
    -- | Embedding additional structured data within transactions.
    TxMetadata,
    TxMetadataValue(..),
    makeTransactionMetadata,

    -- * Registering stake address and delegating
    -- | Certificates that are embedded in transactions for registering and
    -- unregistering stake address, and for setting the stake pool delegation
    -- choice for a stake address.
    makeStakeAddressRegistrationCertificate,
    makeStakeAddressDeregistrationCertificate,
    makeStakeAddressDelegationCertificate,

    -- * Registering stake pools
    -- | Certificates that are embedded in transactions for registering and
    -- retiring stake pools. This incldes updating the stake pool parameters.
    makeStakePoolRegistrationCertificate,
    makeStakePoolRetirementCertificate,
    StakePoolParameters(..),
    StakePoolRelay(..),
    StakePoolMetadataReference(..),

    -- ** Stake pool off-chain metadata
    StakePoolMetadata(..),
    validateAndHashStakePoolMetadata,
    StakePoolMetadataValidationError(..),

    -- * Scripts
    -- | Both 'PaymentCredential's and 'StakeCredential's can use scripts.
    -- Shelley supports multi-signatures via scripts.

    -- ** Script addresses
    -- | Making addresses from scripts.

    -- ** Multi-sig scripts
    -- | Making multi-signature scripts.

    -- * Serialisation
    -- | Support for serialising data in JSON, CBOR and text files.

    -- ** CBOR
    SerialiseAsCBOR,
    ToCBOR,
    FromCBOR,
    serialiseToCBOR,
    deserialiseFromCBOR,

    -- ** JSON
    ToJSON,
    FromJSON,
    serialiseToJSON,
    deserialiseFromJSON,

    -- ** Bech32
    SerialiseAsBech32,
    Bech32EncodeError(..),
    Bech32DecodeError(..),
    serialiseToBech32,
    deserialiseFromBech32,
    renderBech32EncodeError,
    renderBech32DecodeError,

    -- ** Raw binary
    -- | Some types have a natural raw binary format.
    SerialiseAsRawBytes,
    serialiseToRawBytes,
    deserialiseFromRawBytes,
    serialiseToRawBytesHex,
    deserialiseFromRawBytesHex,

    -- ** Text envelope
    -- | Support for a envelope file format with text headers and a hex-encoded
    -- binary payload.
    HasTextEnvelope(..),
    TextEnvelope,
    TextEnvelopeType,
    TextEnvelopeDescr,
    TextEnvelopeError,
    serialiseToTextEnvelope,
    deserialiseFromTextEnvelope,
    readFileTextEnvelope,
    writeFileTextEnvelope,
    -- *** Reading one of several key types
    FromSomeType(..),
    deserialiseFromTextEnvelopeAnyOf,
    readFileTextEnvelopeAnyOf,

    -- * Errors
    Error(..),
    throwErrorAsException,
    FileError(..),

    -- * Node interaction
    -- | Operations that involve talking to a local Cardano node.

    -- ** Queries
    -- ** Submitting transactions

    -- ** Low level protocol interaction with a Cardano node
    connectToLocalNode,
    LocalNodeClientProtocols(..),
    nullLocalNodeClientProtocols,
--  connectToRemoteNode,

    -- *** Chain sync protocol
    ChainSyncClient(..),

    -- *** Local tx submission
    LocalTxSubmissionClient(..),

    -- *** Local state query
    LocalStateQueryClient(..),

    -- * Node operation
    -- | Support for the steps needed to operate a node, including the
    -- operator's offline keys, operational KES and VRF keys, and operational
    -- certificates.

    -- ** Stake pool operator's keys
    StakePoolKey,
    PoolId,

    -- ** KES keys
    KesKey,

    -- ** VRF keys
    VrfKey,

    -- ** Operational certificates
    OperationalCertificate(..),
    OperationalCertificateIssueCounter(..),
    Shelley.KESPeriod(..),
    OperationalCertIssueError(..),
    issueOperationalCertificate,

    -- * Genesis file
    -- | Types and functions needed to inspect or create a genesis file.
    GenesisKey,
    GenesisDelegateKey,
    GenesisUTxOKey,

    -- * Special transactions
    -- | There are various additional things that can be embedded in a
    -- transaction for special operations.
    makeMIRCertificate,
    makeGenesisKeyDelegationCertificate,

    -- ** Protocol parameter updates
    UpdateProposal,
    ProtocolParametersUpdate(..),
    makeShelleyUpdateProposal,
  ) where


import           Prelude

import           Data.Proxy (Proxy(..))
import           Data.Kind (Constraint)
import           Data.Void (Void)
import           Data.Word
import           Data.Maybe
import           Data.Bifunctor (first)
import           Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
--import           Data.Either
import           Data.String (IsString(fromString))
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Numeric.Natural

import           Data.IP (IPv4, IPv6)
import           Network.Socket (PortNumber)
import qualified Network.URI as URI


import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Base16 as Base16

import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import           Data.Map.Strict (Map)
import qualified Data.Sequence.Strict as Seq
import qualified Data.Vector as Vector

import qualified Codec.Binary.Bech32 as Bech32

import           Control.Monad
--import Control.Monad.IO.Class
--import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Except.Extra
import           Control.Exception (Exception(..), IOException, throwIO)
import           Control.Tracer (nullTracer)

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import           Data.Aeson (ToJSON(..), FromJSON(..), (.:))


--
-- Common types, consensus, network
--
import qualified Cardano.Binary as CBOR
import           Cardano.Binary
                   (ToCBOR(toCBOR), FromCBOR(fromCBOR),
                    Annotated(..), reAnnotate, recoverBytes)
import qualified Cardano.Prelude as CBOR (cborError)
import           Shelley.Spec.Ledger.Serialization (CBORGroup(..))

import           Cardano.Slotting.Slot (SlotNo, EpochNo)

-- TODO: it'd be nice if the network imports needed were a bit more coherent
import           Ouroboros.Network.Block (Tip)
import           Ouroboros.Network.Magic (NetworkMagic(..))
import           Ouroboros.Network.NodeToClient
                   (NodeToClientProtocols(..), NodeToClientVersionData(..),
                    NetworkConnectTracers(..), withIOManager, connectTo,
                    localSnocket, foldMapVersions,
                    versionedNodeToClientProtocols, chainSyncPeerNull,
                    localTxSubmissionPeerNull, localStateQueryPeerNull)
import           Ouroboros.Network.Mux
                   (MuxMode(InitiatorMode), MuxPeer(..),
                    RunMiniProtocol(InitiatorProtocolOnly))

-- TODO: it'd be nice if the consensus imports needed were a bit more coherent
import           Ouroboros.Consensus.Cardano (ProtocolClient, protocolClientInfo)
import           Ouroboros.Consensus.Block (BlockProtocol)
import           Ouroboros.Consensus.Ledger.Abstract (Query)
import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx)
import           Ouroboros.Consensus.Network.NodeToClient
                   (Codecs'(..), clientCodecs)
import           Ouroboros.Consensus.Node.ProtocolInfo (ProtocolClientInfo(..))
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
                  (BlockNodeToClientVersion, TranslateNetworkProtocolVersion,
                   nodeToClientProtocolVersion, supportedNodeToClientVersions)
import           Ouroboros.Consensus.Node.Run (SerialiseNodeToClientConstraints)

--
-- Crypto API used by consensus and Shelley (and should be used by Byron)
--
import qualified Cardano.Crypto.Seed        as Crypto
import qualified Cardano.Crypto.Hash.Class  as Crypto
import qualified Cardano.Crypto.DSIGN.Class as Crypto
import qualified Cardano.Crypto.KES.Class   as Crypto
import qualified Cardano.Crypto.VRF.Class   as Crypto

--
-- Byron imports
--
import qualified Cardano.Crypto.Hashing as Byron
import qualified Cardano.Crypto.Signing as Byron
import qualified Cardano.Crypto.ProtocolMagic as Byron
import qualified Cardano.Crypto.Wallet as Byron.Crypto.Wallet

import qualified Cardano.Chain.Common as Byron
import qualified Cardano.Chain.Genesis as Byron
import qualified Cardano.Chain.UTxO   as Byron

--
-- Shelley imports
--
import qualified Ouroboros.Consensus.Shelley.Protocol.Crypto as Shelley

import qualified Shelley.Spec.Ledger.Address                 as Shelley
import qualified Shelley.Spec.Ledger.Address.Bootstrap       as Shelley
import qualified Shelley.Spec.Ledger.BaseTypes               as Shelley
import           Shelley.Spec.Ledger.BaseTypes (maybeToStrictMaybe)
import qualified Shelley.Spec.Ledger.Coin                    as Shelley
import qualified Shelley.Spec.Ledger.Credential              as Shelley
import qualified Shelley.Spec.Ledger.LedgerState             as Shelley
import qualified Shelley.Spec.Ledger.Keys                    as Shelley
import qualified Shelley.Spec.Ledger.MetaData                as Shelley
import qualified Shelley.Spec.Ledger.OCert                   as Shelley
import qualified Shelley.Spec.Ledger.PParams                 as Shelley
import qualified Shelley.Spec.Ledger.Scripts                 as Shelley
import qualified Shelley.Spec.Ledger.TxData                  as Shelley
import qualified Shelley.Spec.Ledger.Tx                      as Shelley
import qualified Shelley.Spec.Ledger.UTxO                    as Shelley

-- Types we will re-export as-is
import           Shelley.Spec.Ledger.TxData
                   (MIRPot(..))

-- TODO: replace the above with
--import qualified Cardano.Api.Byron   as Byron
--import qualified Cardano.Api.Shelley as Shelley

--
-- Other config and common types
--
import qualified Cardano.Api.TextView as TextView

import           Ouroboros.Network.Protocol.ChainSync.Client
import           Ouroboros.Network.Protocol.LocalTxSubmission.Client
import           Ouroboros.Network.Protocol.LocalStateQuery.Client





-- ----------------------------------------------------------------------------
-- Cardano eras, sometimes we have to distinguish them
--

-- | A type used as a tag to distinguish the Byron era.
data Byron

-- | A type used as a tag to distinguish the Shelley era.
data Shelley


class HasTypeProxy t where
  -- | A family of singleton types used in this API to indicate which type to
  -- use where it would otherwise be ambiguous or merely unclear.
  --
  -- Values of this type are passed to
  --
  data AsType t

  proxyToAsType :: Proxy t -> AsType t


-- ----------------------------------------------------------------------------
-- Keys key keys!
--



-- $keys
-- Cardano has lots of cryptographic keys used for lots of different purposes.
-- Some keys have different representations, but most are just using keys in
-- different roles.
--
-- To allow for the different representations and to avoid mistakes we
-- distinguish the key /role/. These are type level distinctions, so each of
-- these roles is a type level tag.
--

-- | An interface for cryptographic keys used for signatures with a 'SigningKey'
-- and a 'VerificationKey' key.
--
-- This interface does not provide actual signing or verifying functions since
-- this API is concerned with the management of keys: generating and
-- serialising.
--
class (Eq (VerificationKey keyrole),
       Show (VerificationKey keyrole),
       Show (SigningKey keyrole),
       SerialiseAsRawBytes (Hash keyrole),
       HasTextEnvelope (VerificationKey keyrole),
       HasTextEnvelope (SigningKey keyrole))
    => Key keyrole where

    -- | The type of cryptographic verification key, for each key role.
    data VerificationKey keyrole :: *

    -- | The type of cryptographic signing key, for each key role.
    data SigningKey keyrole :: *

    -- | Get the corresponding verification key from a signing key.
    getVerificationKey :: SigningKey keyrole -> VerificationKey keyrole

    -- | Generate a 'SigningKey' deterministically, given a 'Crypto.Seed'. The
    -- required size of the seed is given by 'deterministicSigningKeySeedSize'.
    --
    deterministicSigningKey :: AsType keyrole -> Crypto.Seed -> SigningKey keyrole
    deterministicSigningKeySeedSize :: AsType keyrole -> Word

    verificationKeyHash :: VerificationKey keyrole -> Hash keyrole


-- | Generate a 'SigningKey' using a seed from operating system entropy.
--
generateSigningKey :: Key keyrole => AsType keyrole -> IO (SigningKey keyrole)
generateSigningKey keytype = do
    seed <- Crypto.readSeedFromSystemEntropy seedSize
    return $! deterministicSigningKey keytype seed
  where
    seedSize = deterministicSigningKeySeedSize keytype


-- | Some key roles share the same representation and it is sometimes
-- legitimate to change the role of a key.
--
class CastKeyRole keyroleA keyroleB where

    -- | Change the role of a 'VerificationKey', if the representation permits.
    castVerificationKey :: VerificationKey keyroleA -> VerificationKey keyroleB

    -- | Change the role of a 'SigningKey', if the representation permits.
    castSigningKey :: SigningKey keyroleA -> SigningKey keyroleB


data family Hash keyrole :: *

class CastHash keyroleA keyroleB where

    castHash :: Hash keyroleA -> Hash keyroleB


-- ----------------------------------------------------------------------------
-- Addresses
--

data Address era where

     -- | Byron addresses are valid in both the Byron and Shelley era.
     --
     ByronAddress
       :: Byron.Address
       -> Address era

     -- | Shelley addresses are only valid in the Shelley era.
     --
     ShelleyAddress
       :: Shelley.Network
       -> Shelley.PaymentCredential ShelleyCrypto
       -> Shelley.StakeReference    ShelleyCrypto
       -> Address Shelley

deriving instance Eq (Address Byron)
deriving instance Show (Address Byron)

deriving instance Eq (Address Shelley)
deriving instance Show (Address Shelley)

data StakeAddress where

     StakeAddress
       :: Shelley.Network
       -> Shelley.StakeCredential ShelleyCrypto
       -> StakeAddress
  deriving (Eq, Show)

data NetworkId
       = Mainnet
       | Testnet !NetworkMagic
  deriving (Eq, Show)

data PaymentCredential
       = PaymentCredentialByKey    (Hash PaymentKey)
       | PaymentCredentialByScript (Hash Script)
  deriving (Eq, Show)

data StakeCredential
       = StakeCredentialByKey    (Hash StakeKey)
       | StakeCredentialByScript (Hash Script)
  deriving (Eq, Show)

data StakeAddressReference
       = StakeAddressByValue   StakeCredential
       | StakeAddressByPointer StakeAddressPointer
       | NoStakeAddress
  deriving (Eq, Show)

type StakeAddressPointer = Shelley.Ptr


instance HasTypeProxy (Address Byron) where
    data AsType (Address Byron) = AsByronAddress
    proxyToAsType _ = AsByronAddress


instance HasTypeProxy (Address Shelley) where
    data AsType (Address Shelley) = AsShelleyAddress
    proxyToAsType _ = AsShelleyAddress


instance HasTypeProxy StakeAddress where
    data AsType StakeAddress = AsStakeAddress
    proxyToAsType _ = AsStakeAddress


instance SerialiseAsRawBytes (Address Byron) where
    serialiseToRawBytes (ByronAddress addr) = CBOR.serialize' addr

    deserialiseFromRawBytes AsByronAddress bs =
      case CBOR.decodeFull' bs of
        Left  _    -> Nothing
        Right addr -> Just (ByronAddress addr)


instance SerialiseAsRawBytes (Address Shelley) where
    serialiseToRawBytes (ByronAddress addr) =
        Shelley.serialiseAddr
      . Shelley.AddrBootstrap
      . Shelley.BootstrapAddress
      $ addr

    serialiseToRawBytes (ShelleyAddress nw pc scr) =
        Shelley.serialiseAddr (Shelley.Addr nw pc scr)

    deserialiseFromRawBytes AsShelleyAddress bs =
        case Shelley.deserialiseAddr bs of
          Nothing -> Nothing
          Just (Shelley.Addr nw pc scr) ->
            Just (ShelleyAddress nw pc scr)

          Just (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) ->
            Just (ByronAddress addr)


instance SerialiseAsRawBytes StakeAddress where
    serialiseToRawBytes (StakeAddress nw sc) =
        Shelley.serialiseRewardAcnt (Shelley.RewardAcnt nw sc)

    deserialiseFromRawBytes AsStakeAddress bs =
        case Shelley.deserialiseRewardAcnt bs of
          Nothing -> Nothing
          Just (Shelley.RewardAcnt nw sc) -> Just (StakeAddress nw sc)


instance SerialiseAsBech32 (Address Shelley) where
  humanReadablePrefix (ByronAddress _) =
    error "TODO @intricate: What do we do about this?"
  humanReadablePrefix (ShelleyAddress nw _ _) =
      case Bech32.humanReadablePartFromText prefix of
        Left err -> error $ "Impossible: " <> show err
        Right hrp -> hrp
    where
      prefix :: Text
      prefix =
        case nw of
          Shelley.Mainnet -> "addr_"
          Shelley.Testnet -> "addr_test_"


instance SerialiseAsBech32 StakeAddress where
  humanReadablePrefix (StakeAddress nw _ ) =
    case Bech32.humanReadablePartFromText prefix of
      Left err -> error $ "Impossible: " <> show err
      Right hrp -> hrp
    where
      prefix :: Text
      prefix =
        case nw of
          Shelley.Mainnet -> "stake_"
          Shelley.Testnet -> "stake_test_"


makeByronAddress :: VerificationKey ByronKey
                 -> NetworkId
                 -> Address era
makeByronAddress (ByronVerificationKey vk) nid =
    ByronAddress $
      Byron.makeVerKeyAddress
        (toByronNetworkMagic nid)
        vk


makeShelleyAddress :: NetworkId
                   -> PaymentCredential
                   -> StakeAddressReference
                   -> Address Shelley
makeShelleyAddress nw pc scr =
    ShelleyAddress
      (toShelleyNetwork nw)
      (toShelleyPaymentCredential pc)
      (toShelleyStakeReference scr)


makeStakeAddress :: NetworkId
                 -> StakeCredential
                 -> StakeAddress
makeStakeAddress nw sc =
    StakeAddress
      (toShelleyNetwork nw)
      (toShelleyStakeCredential sc)


toByronProtocolMagicId :: NetworkId -> Byron.ProtocolMagicId
toByronProtocolMagicId Mainnet = Byron.mainnetProtocolMagicId
toByronProtocolMagicId (Testnet (NetworkMagic pm)) = Byron.ProtocolMagicId pm

toByronNetworkMagic :: NetworkId -> Byron.NetworkMagic
toByronNetworkMagic Mainnet                     = Byron.NetworkMainOrStage
toByronNetworkMagic (Testnet (NetworkMagic nm)) = Byron.NetworkTestnet nm

toShelleyNetwork :: NetworkId -> Shelley.Network
toShelleyNetwork  Mainnet    = Shelley.Mainnet
toShelleyNetwork (Testnet _) = Shelley.Testnet

toNetworkMagic :: NetworkId -> NetworkMagic
toNetworkMagic  Mainnet     = NetworkMagic 764824073
toNetworkMagic (Testnet nm) = nm

toShelleyAddr :: Address era -> Shelley.Addr ShelleyCrypto
toShelleyAddr (ByronAddress addr)        = Shelley.AddrBootstrap
                                             (Shelley.BootstrapAddress addr)
toShelleyAddr (ShelleyAddress nw pc scr) = Shelley.Addr nw pc scr

toShelleyStakeAddr :: StakeAddress -> Shelley.RewardAcnt ShelleyCrypto
toShelleyStakeAddr (StakeAddress nw sc) =
    Shelley.RewardAcnt {
      Shelley.getRwdNetwork = nw,
      Shelley.getRwdCred    = sc
    }

toShelleyPaymentCredential :: PaymentCredential
                           -> Shelley.PaymentCredential ShelleyCrypto
toShelleyPaymentCredential (PaymentCredentialByKey (PaymentKeyHash kh)) =
    Shelley.KeyHashObj kh
toShelleyPaymentCredential (PaymentCredentialByScript (ScriptHash sh)) =
    Shelley.ScriptHashObj sh

toShelleyStakeCredential :: StakeCredential
                         -> Shelley.StakeCredential ShelleyCrypto
toShelleyStakeCredential (StakeCredentialByKey (StakeKeyHash kh)) =
    Shelley.KeyHashObj kh
toShelleyStakeCredential (StakeCredentialByScript (ScriptHash kh)) =
    Shelley.ScriptHashObj kh

toShelleyStakeReference :: StakeAddressReference
                        -> Shelley.StakeReference ShelleyCrypto
toShelleyStakeReference (StakeAddressByValue stakecred) =
    Shelley.StakeRefBase (toShelleyStakeCredential stakecred)
toShelleyStakeReference (StakeAddressByPointer ptr) =
    Shelley.StakeRefPtr ptr
toShelleyStakeReference  NoStakeAddress =
    Shelley.StakeRefNull


-- ----------------------------------------------------------------------------
-- Transaction Ids
--

newtype TxId = TxId (Shelley.Hash ShelleyCrypto ())
  deriving (Eq, Ord, Show)
               -- We use the Shelley representation and convert the Byron one

instance HasTypeProxy TxId where
    data AsType TxId = AsTxId
    proxyToAsType _ = AsTxId

instance SerialiseAsRawBytes TxId where
    serialiseToRawBytes (TxId h) = Crypto.getHash h
    deserialiseFromRawBytes AsTxId bs = TxId <$> Crypto.hashFromBytes bs

toByronTxId :: TxId -> Byron.TxId
toByronTxId (TxId (Crypto.UnsafeHash h)) =
    Byron.unsafeHashFromBytes h

toShelleyTxId :: TxId -> Shelley.TxId ShelleyCrypto
toShelleyTxId (TxId h) =
    Shelley.TxId (Crypto.castHash h)

-- | Calculate the transaction identifier for a 'TxBody'.
--
getTxId :: TxBody era -> TxId
getTxId (ByronTxBody tx) =
    TxId
  . Crypto.UnsafeHash
  . recoverBytes
  $ tx

getTxId (ShelleyTxBody tx) =
    TxId
  . Crypto.castHash
  . (\(Shelley.TxId txhash) -> txhash)
  . Shelley.txid
  $ tx


-- ----------------------------------------------------------------------------
-- Transaction constituent types
--

data TxIn = TxIn TxId TxIx

deriving instance Eq TxIn
deriving instance Show TxIn

newtype TxIx = TxIx Word
  deriving stock (Eq, Ord, Show)
  deriving newtype (Enum)

data TxOut era = TxOut (Address era) Lovelace

deriving instance Eq (TxOut Byron)
deriving instance Eq (TxOut Shelley)
deriving instance Show (TxOut Byron)
deriving instance Show (TxOut Shelley)

newtype Lovelace = Lovelace Integer
  deriving (Eq, Ord, Enum, Show)


toByronTxIn  :: TxIn -> Byron.TxIn
toByronTxIn (TxIn txid (TxIx txix)) =
    Byron.TxInUtxo (toByronTxId txid) (fromIntegral txix)

toByronTxOut :: TxOut Byron -> Maybe Byron.TxOut
toByronTxOut (TxOut (ByronAddress addr) value) =
    Byron.TxOut addr <$> toByronLovelace value

toByronLovelace :: Lovelace -> Maybe Byron.Lovelace
toByronLovelace (Lovelace x) =
    case Byron.integerToLovelace x of
      Left  _  -> Nothing
      Right x' -> Just x'

toShelleyTxIn  :: TxIn -> Shelley.TxIn ShelleyCrypto
toShelleyTxIn (TxIn txid (TxIx txix)) =
    Shelley.TxIn (toShelleyTxId txid) (fromIntegral txix)

toShelleyTxOut :: TxOut era -> Shelley.TxOut ShelleyCrypto
toShelleyTxOut (TxOut addr value) =
    Shelley.TxOut (toShelleyAddr addr) (toShelleyLovelace value)

toShelleyLovelace :: Lovelace -> Shelley.Coin
toShelleyLovelace (Lovelace l) = Shelley.Coin l
--TODO: validate bounds


-- ----------------------------------------------------------------------------
-- Unsigned transactions
--

data TxBody era where

     ByronTxBody
       :: Annotated Byron.Tx ByteString
       -> TxBody Byron

     ShelleyTxBody
       :: Shelley.TxBody ShelleyCrypto
       -> TxBody Shelley


instance HasTypeProxy (TxBody Byron) where
    data AsType (TxBody Byron) = AsByronTxBody
    proxyToAsType _ = AsByronTxBody

instance HasTypeProxy (TxBody Shelley) where
    data AsType (TxBody Shelley) = AsShelleyTxBody
    proxyToAsType _ = AsShelleyTxBody


instance SerialiseAsCBOR (TxBody Byron) where
    serialiseToCBOR (ByronTxBody txbody) =
      recoverBytes txbody

    deserialiseFromCBOR AsByronTxBody bs = do
      ByronTxBody <$>
        CBOR.decodeFullAnnotatedBytes
          "Byron TxBody"
          CBOR.fromCBORAnnotated
          (LBS.fromStrict bs)

instance SerialiseAsCBOR (TxBody Shelley) where
    serialiseToCBOR (ShelleyTxBody txbody) =
      CBOR.serialize' txbody

    deserialiseFromCBOR AsShelleyTxBody bs =
      ShelleyTxBody <$>
        CBOR.decodeAnnotator
          "Shelley TxBody"
          fromCBOR
          (LBS.fromStrict bs)


instance HasTextEnvelope (TxBody Byron) where
    textEnvelopeType _ = "TxUnsignedByron"

instance HasTextEnvelope (TxBody Shelley) where
    textEnvelopeType _ = "TxUnsignedShelley"


data ByronTxBodyConversionError =
       ByronTxBodyEmptyTxIns
     | ByronTxBodyEmptyTxOuts
     | ByronTxBodyLovelaceOverflow (TxOut Byron)

makeByronTransaction :: [TxIn]
                     -> [TxOut Byron]
                     -> Either ByronTxBodyConversionError
                               (TxBody Byron)
makeByronTransaction ins outs = do
    ins'  <- NonEmpty.nonEmpty ins        ?! ByronTxBodyEmptyTxIns
    let ins'' = NonEmpty.map toByronTxIn ins'

    outs'  <- NonEmpty.nonEmpty outs      ?! ByronTxBodyEmptyTxOuts
    outs'' <- traverse
                (\out -> toByronTxOut out ?! ByronTxBodyLovelaceOverflow out)
                outs'
    return $
      ByronTxBody $
        reAnnotate $
          Annotated
            (Byron.UnsafeTx ins'' outs'' (Byron.mkAttributes ()))
            ()


data TxExtraContent =
     TxExtraContent {
       txMetadata        :: Maybe TxMetadata,
       txWithdrawals     :: [(StakeAddress, Lovelace)],
       txCertificates    :: [Certificate],
       txUpdateProposal  :: Maybe UpdateProposal
     }

txExtraContentEmpty :: TxExtraContent
txExtraContentEmpty =
    TxExtraContent {
      txMetadata        = Nothing,
      txWithdrawals     = [],
      txCertificates    = [],
      txUpdateProposal  = Nothing
    }

type TxFee = Lovelace
type TTL   = SlotNo

makeShelleyTransaction :: TxExtraContent
                       -> TTL
                       -> TxFee
                       -> [TxIn]
                       -> [TxOut anyera]
                       -> TxBody Shelley
makeShelleyTransaction TxExtraContent {
                         txMetadata,
                         txWithdrawals,
                         txCertificates,
                         txUpdateProposal
                       } ttl fee ins outs =
    --TODO: validate the txins are not empty, and tx out coin values are in range
    ShelleyTxBody
      (Shelley.TxBody
        (Set.fromList (map toShelleyTxIn ins))
        (Seq.fromList (map toShelleyTxOut outs))
        (Seq.fromList [ cert | Certificate cert <- txCertificates ])
        (toShelleyWdrl txWithdrawals)
        (toShelleyLovelace fee)
        ttl
        (toShelleyUpdate <$> maybeToStrictMaybe txUpdateProposal)
        (toShelleyMetadataHash <$> maybeToStrictMaybe txMetadata))
  where
    toShelleyUpdate (UpdateProposal p) = p
    toShelleyMetadataHash (TxMetadata m) = Shelley.hashMetaData m

    toShelleyWdrl :: [(StakeAddress, Lovelace)] -> Shelley.Wdrl ShelleyCrypto
    toShelleyWdrl wdrls =
        Shelley.Wdrl $
          Map.fromList
            [ (toShelleyStakeAddr stakeAddr, toShelleyLovelace value)
            | (stakeAddr, value) <- wdrls ]


-- ----------------------------------------------------------------------------
-- Signed transactions
--

data Tx era where

     ByronTx
       :: Byron.ATxAux ByteString
       -> Tx Byron

     ShelleyTx
       :: Shelley.Tx ShelleyCrypto
       -> Tx Shelley


instance HasTypeProxy (Tx Byron) where
    data AsType (Tx Byron) = AsByronTx
    proxyToAsType _ = AsByronTx

instance HasTypeProxy (Tx Shelley) where
    data AsType (Tx Shelley) = AsShelleyTx
    proxyToAsType _ = AsShelleyTx


instance SerialiseAsCBOR (Tx Byron) where
    serialiseToCBOR (ByronTx tx) = CBOR.recoverBytes tx

    deserialiseFromCBOR AsByronTx bs =
      ByronTx <$>
        CBOR.decodeFullAnnotatedBytes "Byron Tx" fromCBOR (LBS.fromStrict bs)

instance SerialiseAsCBOR (Tx Shelley) where
    serialiseToCBOR (ShelleyTx tx) =
      CBOR.serialize' tx

    deserialiseFromCBOR AsShelleyTx bs =
      ShelleyTx <$>
        CBOR.decodeAnnotator "Shelley Tx" fromCBOR (LBS.fromStrict bs)


instance HasTextEnvelope (Tx Byron) where
    textEnvelopeType _ = "TxSignedByron"

instance HasTextEnvelope (Tx Shelley) where
    textEnvelopeType _ = "TxSignedShelley"


data Witness era where

     ByronKeyWitness
       :: Byron.TxInWitness
       -> Witness Byron

     ShelleyBootstrapWitness
       :: Shelley.BootstrapWitness ShelleyCrypto
       -> Witness Shelley

     ShelleyKeyWitness
       :: Shelley.WitVKey ShelleyCrypto Shelley.Witness
       -> Witness Shelley

     ShelleyScriptWitness
       :: Shelley.MultiSig ShelleyCrypto
       -> Witness Shelley


instance HasTypeProxy (Witness Byron) where
    data AsType (Witness Byron) = AsByronWitness
    proxyToAsType _ = AsByronWitness

instance HasTypeProxy (Witness Shelley) where
    data AsType (Witness Shelley) = AsShelleyWitness
    proxyToAsType _ = AsShelleyWitness

instance SerialiseAsCBOR (Witness Byron) where
    serialiseToCBOR (ByronKeyWitness wit) = CBOR.serialize' wit

    deserialiseFromCBOR AsByronWitness bs =
      ByronKeyWitness <$> CBOR.decodeFull' bs

instance SerialiseAsCBOR (Witness Shelley) where
    serialiseToCBOR = CBOR.serializeEncoding' . encodeShelleyWitness
      where
        encodeShelleyWitness :: Witness Shelley -> CBOR.Encoding
        encodeShelleyWitness (ShelleyKeyWitness    wit) =
            CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> toCBOR wit
        encodeShelleyWitness (ShelleyBootstrapWitness wit) =
            CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> toCBOR wit
        encodeShelleyWitness (ShelleyScriptWitness wit) =
            CBOR.encodeListLen 2 <> CBOR.encodeWord 2 <> toCBOR wit

    deserialiseFromCBOR AsShelleyWitness bs =
        CBOR.decodeAnnotator "Shelley Witness"
                             decodeShelleyWitness (LBS.fromStrict bs)
      where
        decodeShelleyWitness :: CBOR.Decoder s (CBOR.Annotator (Witness Shelley))
        decodeShelleyWitness =  do
          CBOR.decodeListLenOf 2
          t <- CBOR.decodeWord
          case t of
            0 -> fmap (fmap ShelleyKeyWitness) fromCBOR
            1 -> fmap (fmap ShelleyBootstrapWitness) fromCBOR
            2 -> fmap (pure . ShelleyScriptWitness) fromCBOR
            _ -> CBOR.cborError $ CBOR.DecoderErrorUnknownTag
                                    "Shelley Witness" (fromIntegral t)

instance HasTextEnvelope (Witness Byron) where
    textEnvelopeType _ = "TxWinessByron"

instance HasTextEnvelope (Witness Shelley) where
    textEnvelopeType _ = "TxWinessShelley"


getTxBody :: Tx era -> TxBody era
getTxBody (ByronTx Byron.ATxAux { Byron.aTaTx = txbody }) =
    ByronTxBody txbody

getTxBody (ShelleyTx Shelley.Tx { Shelley._body = txbody }) =
    ShelleyTxBody txbody


getTxWitnesses :: Tx era -> [Witness era]
getTxWitnesses (ByronTx Byron.ATxAux { Byron.aTaWitness = witnesses }) =
    map ByronKeyWitness
  . Vector.toList
  . unAnnotated
  $ witnesses

getTxWitnesses (ShelleyTx Shelley.Tx {
                       Shelley._witnessSet =
                         Shelley.WitnessSet {
                           Shelley.addrWits,
                           Shelley.bootWits,
                           Shelley.msigWits
                         }
                     }) =
    map ShelleyBootstrapWitness (Set.elems bootWits)
 ++ map ShelleyKeyWitness       (Set.elems addrWits)
 ++ map ShelleyScriptWitness    (Map.elems msigWits)


makeSignedTransaction :: [Witness era]
                      -> TxBody era
                      -> Tx era
makeSignedTransaction witnesses (ByronTxBody txbody) =
    ByronTx
  . Byron.annotateTxAux
  $ Byron.mkTxAux
      (unAnnotated txbody)
      (Vector.fromList (map selectByronWitness witnesses))
  where
    selectByronWitness :: Witness Byron -> Byron.TxInWitness
    selectByronWitness (ByronKeyWitness w) = w

makeSignedTransaction witnesses (ShelleyTxBody txbody) =
    ShelleyTx $
      Shelley.Tx
        txbody
        Shelley.WitnessSet {
          Shelley.bootWits = Set.fromList
                               [ w | ShelleyBootstrapWitness w <- witnesses ],
          Shelley.addrWits = Set.fromList
                               [ w | ShelleyKeyWitness w <- witnesses ],
          Shelley.msigWits = Map.fromList
                               [ (Shelley.hashScript sw, sw)
                               | ShelleyScriptWitness sw <- witnesses ]
        }
        Shelley.SNothing -- (maybeToStrictMaybe txmetadata)

makeByronKeyWitness :: NetworkId
                    -> TxBody Byron
                    -> SigningKey ByronKey
                    -> Witness Byron
makeByronKeyWitness nw (ByronTxBody txbody) =
    let txhash :: Byron.Hash Byron.Tx
        txhash = Byron.hashDecoded txbody

        pm :: Byron.ProtocolMagicId
        pm = toByronProtocolMagicId nw

        -- To allow sharing of the txhash computation across many signatures we
        -- define and share the txhash outside the lambda for the signing key:
     in \(ByronSigningKey sk) ->
        ByronKeyWitness $
          Byron.VKWitness
            (Byron.toVerification sk)
            (Byron.sign pm Byron.SignTx sk (Byron.TxSigData txhash))

makeShelleyBootstrapWitness :: NetworkId
                            -> TxBody Shelley
                            -> SigningKey ByronKey
                            -> Witness Shelley
makeShelleyBootstrapWitness nw (ShelleyTxBody txbody) (ByronSigningKey sk) =
    ShelleyBootstrapWitness $
      -- Byron era witnesses were weird. This reveals all that weirdness.
      Shelley.BootstrapWitness {
        Shelley.bwKey       = vk,
        Shelley.bwSig       = signature,
        Shelley.bwChainCode = chainCode,
        Shelley.bwPadding   = padding
      }
  where
    -- Starting with the easy bits: we /can/ convert the Byron verification key
    -- to a the pair of a Shelley verification key plus the chain code.
    --
    (vk, chainCode) = Shelley.unpackByronVKey (Byron.toVerification sk)

    -- Now the hairy bits.
    --
    -- We start with a Byron era /extended/ signing key. This /cannot/ be
    -- converted to a plain (non-extended) signing key. So we have to produce a
    -- signature using this extended signing key directly.
    --
    signature :: Shelley.SignedDSIGN ShelleyCrypto
                  (Shelley.Hash ShelleyCrypto (Shelley.TxBody ShelleyCrypto))
    signature = fromByronSignature $
                  Byron.Crypto.Wallet.sign
                    BS.empty  -- passphrase for (unused) in-mem encryption
                    (Byron.unSigningKey sk)
                    (Crypto.getHash txhash)

    txhash :: Shelley.Hash ShelleyCrypto (Shelley.TxBody ShelleyCrypto)
    txhash = Crypto.hash txbody

    -- The crypto lib types are different so we also have to convert the type
    -- of the resulting signature.
    --
    fromByronSignature :: Byron.Crypto.Wallet.XSignature
                       -> Shelley.SignedDSIGN ShelleyCrypto b
    fromByronSignature =
        Crypto.SignedDSIGN
      . fromMaybe impossible
      . Crypto.rawDeserialiseSigDSIGN
      . Byron.Crypto.Wallet.unXSignature

    impossible =
      error "fromByronSignature: byron and shelley signature sizes do not match"

    padding = Shelley.byronVerKeyAddressPadding $
                Byron.mkAttributes Byron.AddrAttributes {
                  Byron.aaVKDerivationPath = Nothing,
                  Byron.aaNetworkMagic     = toByronNetworkMagic nw
                }

data ShelleyWitnessSigningKey =
       WitnessPaymentKey         (SigningKey PaymentKey)
     | WitnessStakeKey           (SigningKey StakeKey)
     | WitnessStakePoolKey       (SigningKey StakePoolKey)
     | WitnessGenesisDelegateKey (SigningKey GenesisDelegateKey)
     | WitnessGenesisUTxOKey     (SigningKey GenesisUTxOKey)

makeShelleyKeyWitness :: TxBody Shelley
                      -> ShelleyWitnessSigningKey
                      -> Witness Shelley
makeShelleyKeyWitness (ShelleyTxBody txbody) wsk =
    ShelleyKeyWitness $
      Shelley.WitVKey vk signature
  where
    sk = toShelleySignKey wsk
    vk = Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)

    signature :: Shelley.SignedDSIGN ShelleyCrypto
                  (Shelley.Hash ShelleyCrypto (Shelley.TxBody ShelleyCrypto))
    signature = Crypto.signedDSIGN () txhash sk

    txhash :: Shelley.Hash ShelleyCrypto (Shelley.TxBody ShelleyCrypto)
    txhash = Crypto.hash txbody

toShelleySignKey :: ShelleyWitnessSigningKey
                 -> Shelley.SignKeyDSIGN ShelleyCrypto
toShelleySignKey (WitnessPaymentKey         (PaymentSigningKey         sk)) = sk
toShelleySignKey (WitnessStakeKey           (StakeSigningKey           sk)) = sk
toShelleySignKey (WitnessStakePoolKey       (StakePoolSigningKey       sk)) = sk
toShelleySignKey (WitnessGenesisDelegateKey (GenesisDelegateSigningKey sk)) = sk
toShelleySignKey (WitnessGenesisUTxOKey     (GenesisUTxOSigningKey     sk)) = sk


-- order of signing keys must match txins
signByronTransaction :: NetworkId
                     -> TxBody Byron
                     -> [SigningKey ByronKey]
                     -> Tx Byron
signByronTransaction nw txbody sks =
    makeSignedTransaction witnesses txbody
  where
    witnesses = map (makeByronKeyWitness nw txbody) sks

-- signing keys is a set
signShelleyTransaction :: TxBody Shelley
                       -> [ShelleyWitnessSigningKey]
                       -> Tx Shelley
signShelleyTransaction txbody sks =
    makeSignedTransaction witnesses txbody
  where
    witnesses = map (makeShelleyKeyWitness txbody) sks


-- ----------------------------------------------------------------------------
-- Transaction fees
--

-- | For a concrete fully-constructed transaction, determine the minimum fee
-- that it needs to pay.
--
-- This function is simple, but if you are doing input selection then you
-- probably want to consider estimateTransactionFee.
--
transactionFee :: Natural -- ^ The fixed tx fee
               -> Natural -- ^ The tx fee per byte
               -> Tx Shelley
               -> Lovelace
transactionFee txFeeFixed txFeePerByte (ShelleyTx tx) =
    Lovelace (a * x + b)
  where
    a = toInteger txFeePerByte
    x = Shelley.txsize tx
    b = toInteger txFeeFixed

--TODO: in the Byron case the per-byte is non-integral, would need different
-- parameters. e.g. a new data type for fee params, byron vs shelley

-- | This can estimate what the transaction fee will be, based on a starting
-- base transaction, plus the numbers of the additional components of the
-- transaction that may be added.
--
-- So for example with wallet coin selection, the base transaction should
-- contain all the things not subject to coin selection (such as script inputs,
-- metadata, withdrawals, certs etc)
--
estimateTransactionFee :: NetworkId
                       -> Natural -- ^ The fixed tx fee
                       -> Natural -- ^ The tx fee per byte
                       -> Tx Shelley
                       -> Int -- ^ The number of extra UTxO transaction inputs
                       -> Int -- ^ The number of extra transaction outputs
                       -> Int -- ^ The number of extra Shelley key witnesses
                       -> Int -- ^ The number of extra Byron key witnesses
                       -> Lovelace
estimateTransactionFee nw txFeeFixed txFeePerByte (ShelleyTx tx) =
    let Lovelace baseFee = transactionFee txFeeFixed txFeePerByte (ShelleyTx tx)
     in \nInputs nOutputs nShelleyKeyWitnesses nByronKeyWitnesses ->

        --TODO: this is fragile. Move something like this to the ledger and
        -- make it robust, based on the txsize calculation.
        let extraBytes :: Int
            extraBytes = nInputs               * sizeInput
                       + nOutputs              * sizeOutput
                       + nByronKeyWitnesses    * sizeByronKeyWitnesses
                       + nShelleyKeyWitnesses  * sizeShelleyKeyWitnesses

         in Lovelace (baseFee + toInteger txFeePerByte * toInteger extraBytes)
  where
    sizeInput               = smallArray + uint + hashObj
    sizeOutput              = smallArray + uint + address
    sizeByronKeyWitnesses   = smallArray + keyObj + sigObj + ccodeObj
                                         + paddingPref + paddingSuff
    sizeShelleyKeyWitnesses = smallArray + keyObj + sigObj

    smallArray  = 1
    uint        = 5

    hashObj     = 2 + hashLen
    hashLen     = 32

    keyObj      = 2 + keyLen
    keyLen      = 32

    sigObj      = 2 + sigLen
    sigLen      = 64

    ccodeObj    = 2 + ccodeLen
    ccodeLen    = 32

    address     = 2 + addrHeader + 2 * addrHashLen
    addrHeader  = 1
    addrHashLen = 28

    paddingPref = 2 + BS.length (Shelley.paddingPrefix padding)
    paddingSuff = 2 + BS.length (Shelley.paddingSuffix padding)
    padding     = Shelley.byronVerKeyAddressPadding $
                    Byron.mkAttributes Byron.AddrAttributes {
                      Byron.aaVKDerivationPath = Nothing,
                      Byron.aaNetworkMagic     = toByronNetworkMagic nw
                    }


-- ----------------------------------------------------------------------------
-- Scripts
--

data Script

newtype instance Hash Script = ScriptHash (Shelley.ScriptHash ShelleyCrypto)
  deriving (Eq, Ord, Show)


makeShelleyScriptWitness :: Script -> Witness Shelley
makeShelleyScriptWitness = undefined


-- ----------------------------------------------------------------------------
-- Certificates embedded in transactions
--

newtype Certificate = Certificate (Shelley.DCert ShelleyCrypto)
  deriving stock (Eq, Show)
  deriving newtype (ToCBOR, FromCBOR)
  deriving anyclass SerialiseAsCBOR

instance HasTypeProxy Certificate where
    data AsType Certificate = AsCertificate
    proxyToAsType _ = AsCertificate

instance HasTextEnvelope Certificate where
    textEnvelopeType _ = "Certificate"
    textEnvelopeDefaultDescr (Certificate cert) = case cert of
      Shelley.DCertDeleg (Shelley.RegKey {})    -> "Stake address registration"
      Shelley.DCertDeleg (Shelley.DeRegKey {})  -> "Stake address de-registration"
      Shelley.DCertDeleg (Shelley.Delegate {})  -> "Stake address delegation"
      Shelley.DCertPool (Shelley.RegPool {})    -> "Pool registration"
      Shelley.DCertPool (Shelley.RetirePool {}) -> "Pool retirement"
      Shelley.DCertGenesis{}                    -> "Genesis key delegation"
      Shelley.DCertMir{}                        -> "MIR"

makeStakeAddressRegistrationCertificate
  :: StakeCredential
  -> Certificate
makeStakeAddressRegistrationCertificate stakecred =
    Certificate
  . Shelley.DCertDeleg
  $ Shelley.RegKey
      (toShelleyStakeCredential stakecred)

makeStakeAddressDeregistrationCertificate
  :: StakeCredential
  -> Certificate
makeStakeAddressDeregistrationCertificate stakecred =
    Certificate
  . Shelley.DCertDeleg
  $ Shelley.DeRegKey
      (toShelleyStakeCredential stakecred)

makeStakeAddressDelegationCertificate
  :: StakeCredential
  -> PoolId
  -> Certificate
makeStakeAddressDelegationCertificate stakecred (StakePoolKeyHash poolid) =
    Certificate
  . Shelley.DCertDeleg
  . Shelley.Delegate
  $ Shelley.Delegation
      (toShelleyStakeCredential stakecred)
      poolid

makeGenesisKeyDelegationCertificate
  :: Hash GenesisKey
  -> Hash GenesisDelegateKey
  -> Hash VrfKey
  -> Certificate
makeGenesisKeyDelegationCertificate (GenesisKeyHash         genesiskh)
                                    (GenesisDelegateKeyHash delegatekh)
                                    (VrfKeyHash             vrfkh) =
    Certificate
  . Shelley.DCertGenesis
  $ Shelley.GenesisDelegCert
      genesiskh
      delegatekh
      vrfkh

makeMIRCertificate
  :: MIRPot
  -> [(StakeCredential, Lovelace)]
  -> Certificate
makeMIRCertificate mirpot amounts =
    Certificate
  . Shelley.DCertMir
  $ Shelley.MIRCert
      mirpot
      (Map.fromListWith (+)
         [ (toShelleyStakeCredential sc, toShelleyLovelace v)
         | (sc, v) <- amounts ])



-- ----------------------------------------------------------------------------
-- Stake pool certificates
--

makeStakePoolRegistrationCertificate
  :: StakePoolParameters
  -> Certificate
makeStakePoolRegistrationCertificate poolparams =
    Certificate
  . Shelley.DCertPool
  $ Shelley.RegPool
      (toShelleyPoolParams poolparams)

makeStakePoolRetirementCertificate
  :: PoolId
  -> EpochNo
  -> Certificate
makeStakePoolRetirementCertificate (StakePoolKeyHash poolid) epochno =
    Certificate
  . Shelley.DCertPool
  $ Shelley.RetirePool
      poolid
      epochno

type PoolId = Hash StakePoolKey

data StakePoolParameters =
     StakePoolParameters {
       stakePoolId            :: PoolId,
       stakePoolVRF           :: Hash VrfKey,
       stakePoolCost          :: Lovelace,
       stakePoolMargin        :: Rational,
       stakePoolRewardAccount :: StakeAddress,
       stakePoolPledge        :: Lovelace,
       stakePoolOwners        :: [Hash StakeKey],
       stakePoolRelays        :: [StakePoolRelay],
       stakePoolMetadata      :: Maybe StakePoolMetadataReference
     }
  deriving (Eq, Show)

data StakePoolRelay =

       -- | One or both of IPv4 & IPv6
       StakePoolRelayIp
          (Maybe IPv4) (Maybe IPv6) (Maybe PortNumber)

       -- | An DNS name pointing to a @A@ or @AAAA@ record.
     | StakePoolRelayDnsARecord
          ByteString (Maybe PortNumber)

       -- | A DNS name pointing to a @SRV@ record.
     | StakePoolRelayDnsSrvRecord
          ByteString

  deriving (Eq, Show)

data StakePoolMetadataReference =
     StakePoolMetadataReference {
       stakePoolMetadataURL  :: URI.URI,
       stakePoolMetadataHash :: Hash StakePoolMetadata
     }
  deriving (Eq, Show)

toShelleyPoolParams :: StakePoolParameters -> Shelley.PoolParams ShelleyCrypto
toShelleyPoolParams StakePoolParameters {
                      stakePoolId            = StakePoolKeyHash poolkh
                    , stakePoolVRF           = VrfKeyHash vrfkh
                    , stakePoolCost
                    , stakePoolMargin
                    , stakePoolRewardAccount
                    , stakePoolPledge
                    , stakePoolOwners
                    , stakePoolRelays
                    , stakePoolMetadata
                    } =
    --TODO: validate pool parameters
    Shelley.PoolParams {
      Shelley._poolPubKey = poolkh
    , Shelley._poolVrf    = vrfkh
    , Shelley._poolPledge = toShelleyLovelace stakePoolPledge
    , Shelley._poolCost   = toShelleyLovelace stakePoolCost
    , Shelley._poolMargin = Shelley.truncateUnitInterval
                              (fromRational stakePoolMargin)
    , Shelley._poolRAcnt  = toShelleyStakeAddr stakePoolRewardAccount
    , Shelley._poolOwners = Set.fromList
                              [ kh | StakeKeyHash kh <- stakePoolOwners ]
    , Shelley._poolRelays = Seq.fromList
                              (map toShelleyStakePoolRelay stakePoolRelays)
    , Shelley._poolMD     = toShelleyPoolMetaData <$>
                              maybeToStrictMaybe stakePoolMetadata
    }
  where
    toShelleyStakePoolRelay :: StakePoolRelay -> Shelley.StakePoolRelay
    toShelleyStakePoolRelay (StakePoolRelayIp mipv4 mipv6 mport) =
      Shelley.SingleHostAddr
        (fromIntegral <$> maybeToStrictMaybe mport)
        (maybeToStrictMaybe mipv4)
        (maybeToStrictMaybe mipv6)

    toShelleyStakePoolRelay (StakePoolRelayDnsARecord dnsname mport) =
      Shelley.SingleHostName
        (fromIntegral <$> maybeToStrictMaybe mport)
        (toShelleyDnsName dnsname)

    toShelleyStakePoolRelay (StakePoolRelayDnsSrvRecord dnsname) =
      Shelley.MultiHostName
        (toShelleyDnsName dnsname)

    toShelleyPoolMetaData :: StakePoolMetadataReference -> Shelley.PoolMetaData
    toShelleyPoolMetaData StakePoolMetadataReference {
                            stakePoolMetadataURL
                          , stakePoolMetadataHash = StakePoolMetadataHash mdh
                          } =
      Shelley.PoolMetaData {
        Shelley._poolMDUrl  = toShelleyUrl stakePoolMetadataURL
      , Shelley._poolMDHash = Crypto.getHash mdh
      }

    toShelleyDnsName :: ByteString -> Shelley.DnsName
    toShelleyDnsName = fromMaybe (error "toShelleyDnsName: invalid dns name. TODO: proper validation")
                     . Shelley.textToDns
                     . Text.decodeLatin1

    toShelleyUrl :: URI.URI -> Shelley.Url
    toShelleyUrl uri = fromMaybe (error "toShelleyUrl: invalid url. TODO: proper validation")
                     . Shelley.textToUrl
                     . Text.pack
                     $ URI.uriToString id uri ""


-- ----------------------------------------------------------------------------
-- Stake pool metadata
--

-- | A representation of the required fields for off-chain stake pool metadata.
--
data StakePoolMetadata =
     StakePoolMetadata {

        -- | A name of up to 50 characters.
        stakePoolName :: !Text

        -- | A description of up to 255 characters.
     , stakePoolDescription :: !Text

        -- | A ticker of 3-5 characters, for a compact display of stake pools in
        -- a wallet.
     , stakePoolTicker :: !Text

       -- | A URL to a homepage with additional information about the pool.
       -- n.b. the spec does not specify a character limit for this field.
     , stakePoolHomepage :: !Text
     }
  deriving (Eq, Show)

newtype instance Hash StakePoolMetadata =
                 StakePoolMetadataHash (Crypto.Hash (Shelley.HASH ShelleyCrypto)
                                                    ByteString)
    deriving (Eq, Show)

--TODO: instance ToJSON StakePoolMetadata where

instance FromJSON StakePoolMetadata where
    parseJSON =
        Aeson.withObject "StakePoolMetadata" $ \obj ->
          StakePoolMetadata
            <$> parseName obj
            <*> parseDescription obj
            <*> parseTicker obj
            <*> obj .: "homepage"

      where
        -- Parse and validate the stake pool metadata name from a JSON object.
        -- The name must be 50 characters or fewer.
        --
        parseName :: Aeson.Object -> Aeson.Parser Text
        parseName obj = do
          name <- obj .: "name"
          if Text.length name <= 50
            then pure name
            else fail $ "\"name\" must have at most 50 characters, but it has "
                     <> show (Text.length name)
                     <> " characters."

        -- Parse and validate the stake pool metadata description
        -- The description must be 255 characters or fewer.
        --
        parseDescription :: Aeson.Object -> Aeson.Parser Text
        parseDescription obj = do
          description <- obj .: "description"
          if Text.length description <= 255
            then pure description
            else fail $
                 "\"description\" must have at most 255 characters, but it has "
              <> show (Text.length description)
              <> " characters."

        -- | Parse and validate the stake pool ticker description
        -- The ticker must be 3 to 5 characters long.
        --
        parseTicker :: Aeson.Object -> Aeson.Parser Text
        parseTicker obj = do
          ticker <- obj .: "ticker"
          let tickerLen = Text.length ticker
          if tickerLen >= 3 && tickerLen <= 5
            then pure ticker
            else fail $
                 "\"ticker\" must have at least 3 and at most 5 "
              <> "characters, but it has "
              <> show (Text.length ticker)
              <> " characters."

-- | A stake pool metadata validation error.
data StakePoolMetadataValidationError
  = StakePoolMetadataJsonDecodeError !String
  | StakePoolMetadataInvalidLengthError
    -- ^ The length of the JSON-encoded stake pool metadata exceeds the
    -- maximum.
      !Int
      -- ^ Maximum byte length.
      !Int
      -- ^ Actual byte length.
  deriving Show

instance Error StakePoolMetadataValidationError where
    displayError (StakePoolMetadataJsonDecodeError errStr) = errStr
    displayError (StakePoolMetadataInvalidLengthError maxLen actualLen) =
         "Stake pool metadata must consist of at most "
      <> show maxLen
      <> " bytes, but it consists of "
      <> show actualLen
      <> " bytes."

-- | Decode and validate the provided JSON-encoded bytes as 'StakePoolMetadata'.
-- Return the decoded metadata and the hash of the original bytes.
--
validateAndHashStakePoolMetadata
  :: ByteString
  -> Either StakePoolMetadataValidationError
            (StakePoolMetadata, Hash StakePoolMetadata)
validateAndHashStakePoolMetadata bs
  | BS.length bs <= 512 = do
      md <- first StakePoolMetadataJsonDecodeError
                  (Aeson.eitherDecodeStrict' bs)
      let mdh = StakePoolMetadataHash (Crypto.hashRaw id bs)
      return (md, mdh)
  | otherwise = Left $ StakePoolMetadataInvalidLengthError 512 (BS.length bs)



-- ----------------------------------------------------------------------------
-- Metadata embedded in transactions
--

newtype TxMetadata = TxMetadata Shelley.MetaData
    deriving stock (Eq, Show)

data TxMetadataValue = TxMetaNumber Integer -- -2^64 .. 2^64-1
                     | TxMetaBytes  ByteString
                     | TxMetaText   Text
                     | TxMetaList   [TxMetadataValue]
                     | TxMetaMap    [(TxMetadataValue, TxMetadataValue)]
    deriving stock (Eq, Show)

instance HasTypeProxy TxMetadata where
    data AsType TxMetadata = AsTxMetadata
    proxyToAsType _ = AsTxMetadata

instance SerialiseAsCBOR TxMetadata where
    serialiseToCBOR (TxMetadata tx) =
      CBOR.serialize' tx

    deserialiseFromCBOR AsTxMetadata bs =
      TxMetadata <$>
        CBOR.decodeAnnotator "TxMetadata" fromCBOR (LBS.fromStrict bs)

makeTransactionMetadata :: Map Word64 TxMetadataValue -> TxMetadata
makeTransactionMetadata =
    TxMetadata
  . Shelley.MetaData
  . Map.map toShelleyMetaDatum
  where
    toShelleyMetaDatum :: TxMetadataValue -> Shelley.MetaDatum
    toShelleyMetaDatum (TxMetaNumber x) = Shelley.I x
    toShelleyMetaDatum (TxMetaBytes  x) = Shelley.B x
    toShelleyMetaDatum (TxMetaText   x) = Shelley.S x
    toShelleyMetaDatum (TxMetaList  xs) = Shelley.List
                                            [ toShelleyMetaDatum x | x <- xs ]
    toShelleyMetaDatum (TxMetaMap   xs) = Shelley.Map
                                            [ (toShelleyMetaDatum k,
                                               toShelleyMetaDatum v)
                                            | (k,v) <- xs ]


-- ----------------------------------------------------------------------------
-- Protocol updates embedded in transactions
--

newtype UpdateProposal = UpdateProposal (Shelley.Update ShelleyCrypto)
    deriving stock (Eq, Show)
    deriving newtype (ToCBOR, FromCBOR)
    deriving anyclass SerialiseAsCBOR

instance HasTypeProxy UpdateProposal where
    data AsType UpdateProposal = AsUpdateProposal
    proxyToAsType _ = AsUpdateProposal

instance HasTextEnvelope UpdateProposal where
    textEnvelopeType _ = "Shelley update proposal"

data ProtocolParametersUpdate =
     ProtocolParametersUpdate {

       -- | Protocol version, major and minor. Updating the major version is
       -- used to trigger hard forks.
       --
       protocolUpdateProtocolVersion :: Maybe (Natural, Natural),

       -- | The decentralization parameter. This is fraction of slots that
       -- belong to the BFT overlay schedule, rather than the Praos schedule.
       -- So 1 means fully centralised, while 0 means fully decentralised.
       --
       -- This is the \"d\" parameter from the design document.
       --
       protocolUpdateDecentralization :: Maybe Rational,

       -- | Extra entropy for the Praos per-epoch nonce.
       --
       -- This can be used to add extra entropy during the decentralisation
       -- process. If the extra entropy can be demonstrated to be generated
       -- randomly then this method can be used to show that the initial
       -- federated operators did not subtly bias the initial schedule so that
       -- they retain undue influence after decentralisation.
       --
       protocolUpdateExtraPraosEntropy :: Maybe (Maybe ByteString),

       -- | The maximum permitted size of a block header.
       --
       -- This must be at least as big as the largest legitimate block headers
       -- but should not be too much larger, to help prevent DoS attacks.
       --
       -- Caution: setting this to be smaller than legitimate block headers is
       -- a sure way to brick the system!
       --
       protocolUpdateMaxBlockHeaderSize :: Maybe Natural,

       -- | The maximum permitted size of the block body (that is, the block
       -- payload, without the block header).
       --
       -- This should be picked with the Praos network delta security parameter
       -- in mind. Making this too large can severely weaken the Praos
       -- consensus properties.
       --
       -- Caution: setting this to be smaller than a transaction that can
       -- change the protocol parameters is a sure way to brick the system!
       --
       protocolUpdateMaxBlockBodySize :: Maybe Natural,

       -- | The maximum permitted size of a transaction.
       --
       -- Typically this should not be too high a fraction of the block size,
       -- otherwise wastage from block fragmentation becomes a problem, and
       -- the current implementation does not use any sophisticated box packing
       -- algorithm.
       --
       protocolUpdateMaxTxSize :: Maybe Natural,

       -- | The constant factor for the minimum fee calculation.
       --
       protocolUpdateTxFeeFixed :: Maybe Natural,

       -- | The linear factor for the minimum fee calculation.
       --
       protocolUpdateTxFeePerByte :: Maybe Natural,

       -- | The minimum permitted value for new UTxO entries, ie for
       -- transaction outputs.
       --
       protocolUpdateMinUTxOValue :: Maybe Lovelace,

       -- | The deposit required to register a stake address.
       --
       protocolUpdateStakeAddressDeposit :: Maybe Lovelace,

       -- | The deposit required to register a stake pool.
       --
       protocolUpdateStakePoolDeposit :: Maybe Lovelace,

       -- | The minimum value that stake pools are permitted to declare for
       -- their cost parameter.
       --
       protocolUpdateMinPoolCost :: Maybe Lovelace,

       -- | The maximum number of epochs into the future that stake pools
       -- are permitted to schedule a retirement.
       --
       protocolUpdatePoolRetireMaxEpoch :: Maybe EpochNo,

       -- | The equilibrium target number of stake pools.
       --
       -- This is the \"k\" incentives parameter from the design document.
       --
       protocolUpdateStakePoolTargetNum :: Maybe Natural,

       -- | The influence of the pledge in stake pool rewards.
       --
       -- This is the \"a_0\" incentives parameter from the design document.
       --
       protocolUpdatePoolPledgeInfluence :: Maybe Rational,

       -- | The monetary expansion rate. This determines the fraction of the
       -- reserves that are added to the fee pot each epoch.
       --
       -- This is the \"rho\" incentives parameter from the design document.
       --
       protocolUpdateMonetaryExpansion :: Maybe Rational,

       -- | The fraction of the fee pot each epoch that goes to the treasury.
       --
       -- This is the \"tau\" incentives parameter from the design document.
       --
       protocolUpdateTreasuryCut :: Maybe Rational
    }
  deriving (Eq, Show)

instance Semigroup ProtocolParametersUpdate where
    ppu1 <> ppu2 =
      ProtocolParametersUpdate {
        protocolUpdateProtocolVersion     = merge protocolUpdateProtocolVersion
      , protocolUpdateDecentralization    = merge protocolUpdateDecentralization
      , protocolUpdateExtraPraosEntropy   = merge protocolUpdateExtraPraosEntropy
      , protocolUpdateMaxBlockHeaderSize  = merge protocolUpdateMaxBlockHeaderSize
      , protocolUpdateMaxBlockBodySize    = merge protocolUpdateMaxBlockBodySize
      , protocolUpdateMaxTxSize           = merge protocolUpdateMaxTxSize
      , protocolUpdateTxFeeFixed          = merge protocolUpdateTxFeeFixed
      , protocolUpdateTxFeePerByte        = merge protocolUpdateTxFeePerByte
      , protocolUpdateMinUTxOValue        = merge protocolUpdateMinUTxOValue
      , protocolUpdateStakeAddressDeposit = merge protocolUpdateStakeAddressDeposit
      , protocolUpdateStakePoolDeposit    = merge protocolUpdateStakePoolDeposit
      , protocolUpdateMinPoolCost         = merge protocolUpdateMinPoolCost
      , protocolUpdatePoolRetireMaxEpoch  = merge protocolUpdatePoolRetireMaxEpoch
      , protocolUpdateStakePoolTargetNum  = merge protocolUpdateStakePoolTargetNum
      , protocolUpdatePoolPledgeInfluence = merge protocolUpdatePoolPledgeInfluence
      , protocolUpdateMonetaryExpansion   = merge protocolUpdateMonetaryExpansion
      , protocolUpdateTreasuryCut         = merge protocolUpdateTreasuryCut
      }
      where
        -- prefer the right hand side:
        merge :: (ProtocolParametersUpdate -> Maybe a) -> Maybe a
        merge f = f ppu2 `mplus` f ppu1

instance Monoid ProtocolParametersUpdate where
    mempty =
      ProtocolParametersUpdate {
        protocolUpdateProtocolVersion     = Nothing
      , protocolUpdateDecentralization    = Nothing
      , protocolUpdateExtraPraosEntropy   = Nothing
      , protocolUpdateMaxBlockHeaderSize  = Nothing
      , protocolUpdateMaxBlockBodySize    = Nothing
      , protocolUpdateMaxTxSize           = Nothing
      , protocolUpdateTxFeeFixed          = Nothing
      , protocolUpdateTxFeePerByte        = Nothing
      , protocolUpdateMinUTxOValue        = Nothing
      , protocolUpdateStakeAddressDeposit = Nothing
      , protocolUpdateStakePoolDeposit    = Nothing
      , protocolUpdateMinPoolCost         = Nothing
      , protocolUpdatePoolRetireMaxEpoch  = Nothing
      , protocolUpdateStakePoolTargetNum  = Nothing
      , protocolUpdatePoolPledgeInfluence = Nothing
      , protocolUpdateMonetaryExpansion   = Nothing
      , protocolUpdateTreasuryCut         = Nothing
      }

makeShelleyUpdateProposal :: ProtocolParametersUpdate
                          -> [Hash GenesisKey]
                          -> EpochNo
                          -> UpdateProposal
makeShelleyUpdateProposal params genesisKeyHashes epochno =
    --TODO decide how to handle parameter validation
    let ppup = toShelleyPParamsUpdate params in
    UpdateProposal $
      Shelley.Update
        (Shelley.ProposedPPUpdates
           (Map.fromList
              [ (kh, ppup) | GenesisKeyHash kh <- genesisKeyHashes ]))
        epochno
  where
toShelleyPParamsUpdate :: ProtocolParametersUpdate
                       -> Shelley.PParamsUpdate
toShelleyPParamsUpdate
    ProtocolParametersUpdate {
      protocolUpdateProtocolVersion
    , protocolUpdateDecentralization
    , protocolUpdateExtraPraosEntropy
    , protocolUpdateMaxBlockHeaderSize
    , protocolUpdateMaxBlockBodySize
    , protocolUpdateMaxTxSize
    , protocolUpdateTxFeeFixed
    , protocolUpdateTxFeePerByte
    , protocolUpdateMinUTxOValue
    , protocolUpdateStakeAddressDeposit
    , protocolUpdateStakePoolDeposit
    , protocolUpdateMinPoolCost
    , protocolUpdatePoolRetireMaxEpoch
    , protocolUpdateStakePoolTargetNum
    , protocolUpdatePoolPledgeInfluence
    , protocolUpdateMonetaryExpansion
    , protocolUpdateTreasuryCut
    } =
    Shelley.PParams {
      Shelley._minfeeA     = maybeToStrictMaybe protocolUpdateTxFeePerByte
    , Shelley._minfeeB     = maybeToStrictMaybe protocolUpdateTxFeeFixed
    , Shelley._maxBBSize   = maybeToStrictMaybe protocolUpdateMaxBlockBodySize
    , Shelley._maxTxSize   = maybeToStrictMaybe protocolUpdateMaxTxSize
    , Shelley._maxBHSize   = maybeToStrictMaybe protocolUpdateMaxBlockHeaderSize
    , Shelley._keyDeposit  = toShelleyLovelace <$>
                               maybeToStrictMaybe protocolUpdateStakeAddressDeposit
    , Shelley._poolDeposit = toShelleyLovelace <$>
                               maybeToStrictMaybe protocolUpdateStakePoolDeposit
    , Shelley._eMax        = maybeToStrictMaybe protocolUpdatePoolRetireMaxEpoch
    , Shelley._nOpt        = maybeToStrictMaybe protocolUpdateStakePoolTargetNum
    , Shelley._a0          = maybeToStrictMaybe protocolUpdatePoolPledgeInfluence
    , Shelley._rho         = Shelley.truncateUnitInterval . fromRational <$>
                               maybeToStrictMaybe protocolUpdateMonetaryExpansion
    , Shelley._tau         = Shelley.truncateUnitInterval . fromRational <$>
                               maybeToStrictMaybe protocolUpdateTreasuryCut
    , Shelley._d           = Shelley.truncateUnitInterval . fromRational <$>
                               maybeToStrictMaybe protocolUpdateDecentralization
    , Shelley._extraEntropy    = mkNonce <$>
                                   maybeToStrictMaybe protocolUpdateExtraPraosEntropy
    , Shelley._protocolVersion = uncurry Shelley.ProtVer <$>
                                   maybeToStrictMaybe protocolUpdateProtocolVersion
    , Shelley._minUTxOValue    = toShelleyLovelace <$>
                                   maybeToStrictMaybe protocolUpdateMinUTxOValue
    , Shelley._minPoolCost     = toShelleyLovelace <$>
                                   maybeToStrictMaybe protocolUpdateMinPoolCost
    }
  where
    mkNonce Nothing   = Shelley.NeutralNonce
    mkNonce (Just bs) = Shelley.Nonce
                      . Crypto.castHash
                      . Crypto.hashRaw id
                      $ bs

-- ----------------------------------------------------------------------------
-- Operational certificates
--

data OperationalCertificate =
     OperationalCertificate
       !(Shelley.OCert ShelleyCrypto)
       !(VerificationKey StakePoolKey)
  deriving (Eq, Show)
  deriving anyclass SerialiseAsCBOR

data OperationalCertificateIssueCounter =
     OperationalCertificateIssueCounter
       !Natural
       !(VerificationKey StakePoolKey) -- For consistency checking
  deriving (Eq, Show)
  deriving anyclass SerialiseAsCBOR

instance ToCBOR OperationalCertificate where
    toCBOR (OperationalCertificate ocert vkey) =
      toCBOR (CBORGroup ocert, vkey)

instance FromCBOR OperationalCertificate where
    fromCBOR = do
      (CBORGroup ocert, vkey) <- fromCBOR
      return (OperationalCertificate ocert vkey)

instance ToCBOR OperationalCertificateIssueCounter where
    toCBOR (OperationalCertificateIssueCounter counter vkey) =
      toCBOR (counter, vkey)

instance FromCBOR OperationalCertificateIssueCounter where
    fromCBOR = do
      (counter, vkey) <- fromCBOR
      return (OperationalCertificateIssueCounter counter vkey)

instance HasTypeProxy OperationalCertificate where
    data AsType OperationalCertificate = AsOperationalCertificate
    proxyToAsType _ = AsOperationalCertificate

instance HasTypeProxy OperationalCertificateIssueCounter where
    data AsType OperationalCertificateIssueCounter = AsOperationalCertificateIssueCounter
    proxyToAsType _ = AsOperationalCertificateIssueCounter

instance HasTextEnvelope OperationalCertificate where
    textEnvelopeType _ = "Node operational certificate"

instance HasTextEnvelope OperationalCertificateIssueCounter where
    textEnvelopeType _ = "Node operational certificate issue counter"

data OperationalCertIssueError =
       -- | The stake pool verification key expected for the
       -- 'OperationalCertificateIssueCounter' does not match the signing key
       -- supplied for signing.
       --
       -- Order: pool vkey expected, pool skey supplied
       --
       OperationalCertKeyMismatch (VerificationKey StakePoolKey)
                                  (VerificationKey StakePoolKey)
  deriving Show

instance Error OperationalCertIssueError where
    displayError (OperationalCertKeyMismatch _counterKey _signingKey) =
      "Key mismatch: the signing key does not match the one that goes with the counter"
      --TODO: include key ids

issueOperationalCertificate :: VerificationKey KesKey
                            -> SigningKey StakePoolKey
                            -> Shelley.KESPeriod
                            -> OperationalCertificateIssueCounter
                            -> Either OperationalCertIssueError
                                      (OperationalCertificate,
                                      OperationalCertificateIssueCounter)
issueOperationalCertificate (KesVerificationKey kesVKey)
                            (StakePoolSigningKey poolSKey)
                            kesPeriod
                            (OperationalCertificateIssueCounter counter poolVKey)
    | poolVKey /= poolVKey'
    = Left (OperationalCertKeyMismatch poolVKey poolVKey')

    | otherwise
    = Right (OperationalCertificate ocert poolVKey,
            OperationalCertificateIssueCounter (succ counter) poolVKey)
  where
    poolVKey' = getVerificationKey (StakePoolSigningKey poolSKey)

    ocert     :: Shelley.OCert ShelleyCrypto
    ocert     = Shelley.OCert kesVKey counter kesPeriod signature

    signature :: Crypto.SignedDSIGN
                   (Shelley.DSIGN ShelleyCrypto)
                   (Shelley.VerKeyKES ShelleyCrypto,
                    Natural,
                    Shelley.KESPeriod)
    signature = Crypto.signedDSIGN ()
                  (kesVKey, counter, kesPeriod)
                  poolSKey


-- ----------------------------------------------------------------------------
-- Node IPC protocols
--

data LocalNodeClientProtocols blk =
     LocalNodeClientProtocols {
       localChainSyncClient
         :: Maybe (ChainSyncClient
                    blk
                    (Tip blk)
                    IO ())

     , localTxSubmissionClient
         :: Maybe (LocalTxSubmissionClient
                    (GenTx blk)
                    (ApplyTxErr blk)
                    IO ())

     , localStateQueryClient
         :: Maybe (LocalStateQueryClient
                    blk
                    (Query blk)
                    IO ())
     }

nullLocalNodeClientProtocols :: LocalNodeClientProtocols blk
nullLocalNodeClientProtocols =
    LocalNodeClientProtocols {
      localChainSyncClient    = Nothing,
      localTxSubmissionClient = Nothing,
      localStateQueryClient   = Nothing
    }

connectToLocalNode :: forall blk.
                      (SerialiseNodeToClientConstraints blk,
                       TranslateNetworkProtocolVersion blk)
                   => FilePath  -- ^ The local socket path.
                   -> NetworkId
                   -> ProtocolClient blk (BlockProtocol blk)
                   -> (BlockNodeToClientVersion blk -> LocalNodeClientProtocols blk)
                   -> IO ()
connectToLocalNode path nw ptcl clientptcls =
    withIOManager $ \iomgr ->
      connectTo
        (localSnocket iomgr path)
        NetworkConnectTracers {
          nctMuxTracer       = nullTracer,
          nctHandshakeTracer = nullTracer
        }
        (foldMapVersions
            (\v -> versionedNodeToClientProtocols
                     (nodeToClientProtocolVersion proxy v)
                     NodeToClientVersionData {
                       networkMagic = toNetworkMagic nw
                     }
                     (\_conn _runOrStop -> protocols v))
            (supportedNodeToClientVersions proxy))
        path
  where
    proxy :: Proxy blk
    proxy = Proxy

    protocols :: BlockNodeToClientVersion blk
              -> NodeToClientProtocols InitiatorMode LBS.ByteString IO () Void
    protocols clientVersion =
      let Codecs {
              cChainSyncCodec
            , cTxSubmissionCodec
            , cStateQueryCodec
            } = clientCodecs (pClientInfoCodecConfig (protocolClientInfo ptcl))
                             clientVersion

          LocalNodeClientProtocols {
            localChainSyncClient,
            localTxSubmissionClient,
            localStateQueryClient
          } = clientptcls clientVersion

       in NodeToClientProtocols {
            localChainSyncProtocol =
              InitiatorProtocolOnly $
                MuxPeer
                  nullTracer
                  cChainSyncCodec
                  (maybe chainSyncPeerNull
                         chainSyncClientPeer
                         localChainSyncClient)

          , localTxSubmissionProtocol =
              InitiatorProtocolOnly $
                MuxPeer
                  nullTracer
                  cTxSubmissionCodec
                  (maybe localTxSubmissionPeerNull
                         localTxSubmissionClientPeer
                         localTxSubmissionClient)

          , localStateQueryProtocol =
              InitiatorProtocolOnly $
                MuxPeer
                  nullTracer
                  cStateQueryCodec
                  (maybe localStateQueryPeerNull
                         localStateQueryClientPeer
                         localStateQueryClient)
          }


-- ----------------------------------------------------------------------------
-- CBOR and JSON Serialisation
--

class HasTypeProxy a => SerialiseAsCBOR a where
    serialiseToCBOR :: a -> ByteString
    deserialiseFromCBOR :: AsType a -> ByteString -> Either CBOR.DecoderError a

    default serialiseToCBOR :: ToCBOR a => a -> ByteString
    serialiseToCBOR = CBOR.serialize'

    default deserialiseFromCBOR :: FromCBOR a
                                => AsType a
                                -> ByteString
                                -> Either CBOR.DecoderError a
    deserialiseFromCBOR _proxy = CBOR.decodeFull'

newtype JsonDecodeError = JsonDecodeError String

serialiseToJSON :: ToJSON a => a -> ByteString
serialiseToJSON = LBS.toStrict . Aeson.encode

deserialiseFromJSON :: FromJSON a
                    => AsType a
                    -> ByteString
                    -> Either JsonDecodeError a
deserialiseFromJSON _proxy = either (Left . JsonDecodeError) Right
                           . Aeson.eitherDecodeStrict'

class HasTypeProxy a => SerialiseAsRawBytes a where

  serialiseToRawBytes :: a -> ByteString

  deserialiseFromRawBytes :: AsType a -> ByteString -> Maybe a

serialiseToRawBytesHex :: SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex = Base16.encode . serialiseToRawBytes

deserialiseFromRawBytesHex :: SerialiseAsRawBytes a
                           => AsType a -> ByteString -> Maybe a
deserialiseFromRawBytesHex proxy hex =
  case Base16.decode hex of
    (raw, trailing)
      | BS.null trailing -> deserialiseFromRawBytes proxy raw
      | otherwise        -> Nothing


-- ----------------------------------------------------------------------------
-- Bech32 Serialisation
--

class (HasTypeProxy a, SerialiseAsRawBytes a) => SerialiseAsBech32 a where
  humanReadablePrefix :: a -> Bech32.HumanReadablePart

  serialiseToBech32 :: a -> Either Bech32EncodeError Text
  serialiseToBech32 a =
    first Bech32EncodingError
      . Bech32.encode (humanReadablePrefix a)
      . Bech32.dataPartFromBytes
      . serialiseToRawBytes
      $ a

  deserialiseFromBech32 :: AsType a -> Text -> Either Bech32DecodeError a
  deserialiseFromBech32 asType bech32Str =
      case Bech32.decode bech32Str of
        Left decErr -> Left (Bech32DecodingError decErr)
        Right (humanReadablePart, dataPart) ->
          case deserialiseFromDataPartBytes dataPart tryDeserialise of
            Left err -> Left err
            Right res -> validatePrefix humanReadablePart res
    where
      deserialiseFromDataPartBytes
        :: Bech32.DataPart
        -> (ByteString -> Either Bech32DecodeError b)
        -> Either Bech32DecodeError b
      deserialiseFromDataPartBytes dp deserialise =
        maybe
          (Left $ Bech32DataPartToBytesError $ Bech32.dataPartToText dp)
          deserialise
          (Bech32.dataPartToBytes dp)

      tryDeserialise :: ByteString -> Either Bech32DecodeError a
      tryDeserialise bs =
        maybe
          (Left $ Bech32DeserialiseFromBytesError bs)
          Right
          (deserialiseFromRawBytes asType bs)

      validatePrefix
        :: Bech32.HumanReadablePart
        -> a
        -> Either Bech32DecodeError a
      validatePrefix actualHrp a = do
        let expected = Bech32.humanReadablePartToText (humanReadablePrefix a)
            actual = Bech32.humanReadablePartToText actualHrp
        if expected == actual
          then Right a
          else Left (Bech32IncorrectHumanReadablePrefixError expected actual)

-- | Bech32 encoding error.
data Bech32EncodeError
  = Bech32EncodingError !Bech32.EncodingError
    -- ^ There was an error encoding the string as Bech32.
  deriving Show

-- | Render a 'Bech32EncodeError' as a human-readable error message.
renderBech32EncodeError :: Bech32EncodeError -> Text
renderBech32EncodeError (Bech32EncodingError Bech32.EncodedStringTooLong) =
  "Failed to encode the Bech32 string as the resulting string would be too long."

-- | Bech32 decoding error.
data Bech32DecodeError
  = Bech32DecodingError !Bech32.DecodingError
    -- ^ There was an error decoding the string as Bech32.
  | Bech32IncorrectHumanReadablePrefixError
    -- ^ The human-readable prefix in the provided Bech32-encoded string
    -- differs from that which was expected.
      !Text
      -- ^ Expected human-readable prefix.
      !Text
      -- ^ Actual human-readable prefix.
  | Bech32DataPartToBytesError
    -- ^ There was an error in extracting a 'ByteString' from the data part of
    -- the Bech32-encoded string.
      !Text
      -- ^ The data part from which a 'ByteString' could not be extracted.
  | Bech32DeserialiseFromBytesError
    -- ^ There was an error in deserialising the bytes into a value of the
    -- expected type.
      !ByteString
      -- ^ The bytes that could not be deserialised.
  deriving Show

-- | Render a 'Bech32DecodeError' as a human-readable error message.
renderBech32DecodeError :: Bech32DecodeError -> Text
renderBech32DecodeError err =
  case err of
    Bech32DecodingError decErr -> Text.pack (show decErr) -- TODO
    Bech32IncorrectHumanReadablePrefixError expected actual ->
      "Expected a human-readable prefix of \""
        <> expected
        <> "\", but the actual prefix is \""
        <> actual
        <> "\"."
    Bech32DataPartToBytesError _dataPart ->
      "There was an error in extracting the bytes from the data part of the \
      \Bech32-encoded string."
    Bech32DeserialiseFromBytesError _bytes ->
      "There was an error in deserialising the data part of the \
      \Bech32-encoded string into a value of the expected type."

-- ----------------------------------------------------------------------------
-- TextEnvelope Serialisation
--

type TextEnvelope = TextView.TextView
type TextEnvelopeType = TextView.TextViewType
type TextEnvelopeDescr = TextView.TextViewTitle

class SerialiseAsCBOR a => HasTextEnvelope a where
    textEnvelopeType :: AsType a -> TextEnvelopeType

    textEnvelopeDefaultDescr :: a -> TextEnvelopeDescr
    textEnvelopeDefaultDescr _ = ""

type TextEnvelopeError = TextView.TextViewError

data FileError e = FileError   FilePath e
                 | FileIOError FilePath IOException
  deriving Show

instance Error e => Error (FileError e) where
  displayError (FileIOError path ioe) =
    path ++ ": " ++ displayException ioe
  displayError (FileError path e) =
    path ++ ": " ++ displayError e

instance Error TextView.TextViewError where
  displayError = Text.unpack . TextView.renderTextViewError

serialiseToTextEnvelope :: forall a. HasTextEnvelope a
                        => Maybe TextEnvelopeDescr -> a -> TextEnvelope
serialiseToTextEnvelope mbDescr a =
    TextView.TextView {
      TextView.tvType    = textEnvelopeType ttoken
    , TextView.tvTitle   = fromMaybe (textEnvelopeDefaultDescr a) mbDescr
    , TextView.tvRawCBOR = serialiseToCBOR a
    }
  where
    ttoken :: AsType a
    ttoken = proxyToAsType Proxy


deserialiseFromTextEnvelope :: HasTextEnvelope a
                            => AsType a
                            -> TextEnvelope
                            -> Either TextEnvelopeError a
deserialiseFromTextEnvelope ttoken te = do
    TextView.expectTextViewOfType (textEnvelopeType ttoken) te
    first TextView.TextViewDecodeError $
      deserialiseFromCBOR ttoken (TextView.tvRawCBOR te)

data FromSomeType (c :: * -> Constraint) b where
     FromSomeType :: c a => AsType a -> (a -> b) -> FromSomeType c b


deserialiseFromTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b]
                                 -> TextEnvelope
                                 -> Either TextEnvelopeError b
deserialiseFromTextEnvelopeAnyOf types te =
    case List.find matching types of
      Nothing ->
        Left (TextView.TextViewTypeError expectedTypes actualType)

      Just (FromSomeType ttoken f) ->
        first TextView.TextViewDecodeError $
          f <$> deserialiseFromCBOR ttoken (TextView.tvRawCBOR te)
  where
    actualType    = TextView.tvType te
    expectedTypes = [ textEnvelopeType ttoken
                    | FromSomeType ttoken _f <- types ]

    matching (FromSomeType ttoken _f) = actualType == textEnvelopeType ttoken


writeFileTextEnvelope :: HasTextEnvelope a
                      => FilePath
                      -> Maybe TextEnvelopeDescr
                      -> a
                      -> IO (Either (FileError ()) ())
writeFileTextEnvelope path mbDescr a =
    runExceptT $ do
      handleIOExceptT (FileIOError path) $ BS.writeFile path content
  where
    content = TextView.renderTextView (serialiseToTextEnvelope mbDescr a)


readFileTextEnvelope :: HasTextEnvelope a
                     => AsType a
                     -> FilePath
                     -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope ttoken path =
    runExceptT $ do
      content <- handleIOExceptT (FileIOError path) $ BS.readFile path
      firstExceptT (FileError path) $ hoistEither $ do
        te <- TextView.parseTextView content
        deserialiseFromTextEnvelope ttoken te


readFileTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b]
                          -> FilePath
                          -> IO (Either (FileError TextEnvelopeError) b)
readFileTextEnvelopeAnyOf types path =
    runExceptT $ do
      content <- handleIOExceptT (FileIOError path) $ BS.readFile path
      firstExceptT (FileError path) $ hoistEither $ do
        te <- TextView.parseTextView content
        deserialiseFromTextEnvelopeAnyOf types te


-- ----------------------------------------------------------------------------
-- Error reporting
--

class Show e => Error e where

    displayError :: e -> String

instance Error () where
    displayError () = ""

-- | The preferred approach is to use 'Except' or 'ExceptT', but you can if
-- necessary use IO exceptions.
--
throwErrorAsException :: Error e => e -> IO a
throwErrorAsException e = throwIO (ErrorAsException e)

data ErrorAsException where
     ErrorAsException :: Error e => e -> ErrorAsException

instance Show ErrorAsException where
    show (ErrorAsException e) = show e

instance Exception ErrorAsException where
    displayException (ErrorAsException e) = displayError e


-- ----------------------------------------------------------------------------
-- Shelley type aliases
--

type ShelleyCrypto = Shelley.TPraosStandardCrypto


-- ----------------------------------------------------------------------------
-- Key instances
--

instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where
    data AsType (VerificationKey a) = AsVerificationKey (AsType a)
    proxyToAsType _ = AsVerificationKey (proxyToAsType (Proxy :: Proxy a))

instance HasTypeProxy a => HasTypeProxy (SigningKey a) where
    data AsType (SigningKey a) = AsSigningKey (AsType a)
    proxyToAsType _ = AsSigningKey (proxyToAsType (Proxy :: Proxy a))

instance HasTypeProxy a => HasTypeProxy (Hash a) where
    data AsType (Hash a) = AsHash (AsType a)
    proxyToAsType _ = AsHash (proxyToAsType (Proxy :: Proxy a))

-- | Map the various Shelley key role types into corresponding 'Shelley.KeyRole'
-- types.
--
type family ShelleyKeyRole (keyrole :: *) :: Shelley.KeyRole

type instance ShelleyKeyRole PaymentKey         = Shelley.Payment
type instance ShelleyKeyRole GenesisKey         = Shelley.Genesis
type instance ShelleyKeyRole GenesisUTxOKey     = Shelley.Payment
type instance ShelleyKeyRole GenesisDelegateKey = Shelley.GenesisDelegate
type instance ShelleyKeyRole StakeKey           = Shelley.Staking
type instance ShelleyKeyRole StakePoolKey       = Shelley.StakePool


--
-- Byron keys
--

-- | Byron-era payment keys. Used for Byron addresses and witnessing
-- transactions that spend from these addresses.
--
-- These use Ed25519 but with a 32byte \"chaincode\" used in HD derivation.
-- The inclusion of the chaincode is a design mistake but one that cannot
-- be corrected for the Byron era. The Shelley era 'PaymentKey's do not include
-- a chaincode. It is safe to use a zero or random chaincode for new Byron keys.
--
-- This is a type level tag, used with other interfaces like 'Key'.
--
data ByronKey

instance HasTypeProxy ByronKey where
    data AsType ByronKey = AsByronKey
    proxyToAsType _ = AsByronKey

instance Key ByronKey where

    newtype VerificationKey ByronKey =
           ByronVerificationKey Byron.VerificationKey
      deriving stock (Eq, Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    newtype SigningKey ByronKey =
           ByronSigningKey Byron.SigningKey
      deriving stock (Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    deterministicSigningKey :: AsType ByronKey -> Crypto.Seed -> SigningKey ByronKey
    deterministicSigningKey AsByronKey seed =
       ByronSigningKey (snd (Crypto.runMonadRandomWithSeed seed Byron.keyGen))

    deterministicSigningKeySeedSize :: AsType ByronKey -> Word
    deterministicSigningKeySeedSize AsByronKey = 32

    getVerificationKey :: SigningKey ByronKey -> VerificationKey ByronKey
    getVerificationKey (ByronSigningKey sk) =
      ByronVerificationKey (Byron.toVerification sk)

    verificationKeyHash :: VerificationKey ByronKey -> Hash ByronKey
    verificationKeyHash (ByronVerificationKey vkey) =
      ByronKeyHash (Byron.hashKey vkey)

newtype instance Hash ByronKey = ByronKeyHash Byron.KeyHash
  deriving (Eq, Ord, Show)

instance SerialiseAsRawBytes (Hash ByronKey) where
    serialiseToRawBytes (ByronKeyHash (Byron.KeyHash vkh)) =
      Byron.abstractHashToBytes vkh

    deserialiseFromRawBytes (AsHash AsByronKey) bs =
      ByronKeyHash . Byron.KeyHash <$> Byron.abstractHashFromBytes bs

instance HasTextEnvelope (VerificationKey ByronKey) where
    textEnvelopeType _ = "PaymentVerificationKeyByron"

instance HasTextEnvelope (SigningKey ByronKey) where
    textEnvelopeType _ = "SigningKeyByron"
    -- TODO: fix these inconsistent names for the public testnet re-spin


--
-- Shelley payment keys
--

-- | Shelley-era payment keys. Used for Shelley payment addresses and witnessing
-- transactions that spend from these addresses.
--
-- This is a type level tag, used with other interfaces like 'Key'.
--
data PaymentKey

instance HasTypeProxy PaymentKey where
    data AsType PaymentKey = AsPaymentKey
    proxyToAsType _ = AsPaymentKey

instance Key PaymentKey where

    newtype VerificationKey PaymentKey =
        PaymentVerificationKey (Shelley.VKey Shelley.Payment ShelleyCrypto)
      deriving stock (Eq, Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    newtype SigningKey PaymentKey =
        PaymentSigningKey (Shelley.SignKeyDSIGN ShelleyCrypto)
      deriving stock (Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    deterministicSigningKey :: AsType PaymentKey -> Crypto.Seed -> SigningKey PaymentKey
    deterministicSigningKey AsPaymentKey seed =
        PaymentSigningKey (Crypto.genKeyDSIGN seed)

    deterministicSigningKeySeedSize :: AsType PaymentKey -> Word
    deterministicSigningKeySeedSize AsPaymentKey =
        Crypto.seedSizeDSIGN proxy
      where
        proxy :: Proxy (Shelley.DSIGN ShelleyCrypto)
        proxy = Proxy

    getVerificationKey :: SigningKey PaymentKey -> VerificationKey PaymentKey
    getVerificationKey (PaymentSigningKey sk) =
        PaymentVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk))

    verificationKeyHash :: VerificationKey PaymentKey -> Hash PaymentKey
    verificationKeyHash (PaymentVerificationKey vkey) =
        PaymentKeyHash (Shelley.hashKey vkey)

newtype instance Hash PaymentKey =
    PaymentKeyHash (Shelley.KeyHash Shelley.Payment ShelleyCrypto)
  deriving (Eq, Ord, Show)

instance SerialiseAsRawBytes (Hash PaymentKey) where
    serialiseToRawBytes (PaymentKeyHash (Shelley.KeyHash vkh)) =
      Crypto.getHash vkh

    deserialiseFromRawBytes (AsHash AsPaymentKey) bs =
      PaymentKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs

instance HasTextEnvelope (VerificationKey PaymentKey) where
    textEnvelopeType _ = "PaymentVerificationKeyShelley"
    -- TODO: include the actual crypto algorithm name, to catch changes:
{-
                      <> fromString (Crypto.algorithmNameDSIGN proxy)
      where
        proxy :: Proxy (Shelley.DSIGN ShelleyCrypto)
        proxy = Proxy
-}

instance HasTextEnvelope (SigningKey PaymentKey) where
    textEnvelopeType _ = "SigningKeyShelley"
    -- TODO: include the actual crypto algorithm name, to catch changes
    -- TODO: fix these inconsistent names for the public testnet re-spin


--
-- Stake keys
--

data StakeKey

instance HasTypeProxy StakeKey where
    data AsType StakeKey = AsStakeKey
    proxyToAsType _ = AsStakeKey

instance Key StakeKey where

    newtype VerificationKey StakeKey =
        StakeVerificationKey (Shelley.VKey Shelley.Staking ShelleyCrypto)
      deriving stock (Eq, Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    newtype SigningKey StakeKey =
        StakeSigningKey (Shelley.SignKeyDSIGN ShelleyCrypto)
      deriving stock (Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    deterministicSigningKey :: AsType StakeKey -> Crypto.Seed -> SigningKey StakeKey
    deterministicSigningKey AsStakeKey seed =
        StakeSigningKey (Crypto.genKeyDSIGN seed)

    deterministicSigningKeySeedSize :: AsType StakeKey -> Word
    deterministicSigningKeySeedSize AsStakeKey =
        Crypto.seedSizeDSIGN proxy
      where
        proxy :: Proxy (Shelley.DSIGN ShelleyCrypto)
        proxy = Proxy

    getVerificationKey :: SigningKey StakeKey -> VerificationKey StakeKey
    getVerificationKey (StakeSigningKey sk) =
        StakeVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk))

    verificationKeyHash :: VerificationKey StakeKey -> Hash StakeKey
    verificationKeyHash (StakeVerificationKey vkey) =
        StakeKeyHash (Shelley.hashKey vkey)

newtype instance Hash StakeKey =
    StakeKeyHash (Shelley.KeyHash Shelley.Staking ShelleyCrypto)
  deriving (Eq, Ord, Show)

instance SerialiseAsRawBytes (Hash StakeKey) where
    serialiseToRawBytes (StakeKeyHash (Shelley.KeyHash vkh)) =
      Crypto.getHash vkh

    deserialiseFromRawBytes (AsHash AsStakeKey) bs =
      StakeKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs

instance HasTextEnvelope (VerificationKey StakeKey) where
    textEnvelopeType _ = "StakingVerificationKeyShelley"
    -- TODO: include the actual crypto algorithm name, to catch changes

instance HasTextEnvelope (SigningKey StakeKey) where
    textEnvelopeType _ = "SigningKeyShelley"
    -- TODO: include the actual crypto algorithm name, to catch changes
    -- TODO: fix these inconsistent names for the public testnet re-spin


--
-- Genesis keys
--

data GenesisKey

instance HasTypeProxy GenesisKey where
    data AsType GenesisKey = AsGenesisKey
    proxyToAsType _ = AsGenesisKey

instance Key GenesisKey where

    newtype VerificationKey GenesisKey =
        GenesisVerificationKey (Shelley.VKey Shelley.Genesis ShelleyCrypto)
      deriving stock (Eq, Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    newtype SigningKey GenesisKey =
        GenesisSigningKey (Shelley.SignKeyDSIGN ShelleyCrypto)
      deriving stock (Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    deterministicSigningKey :: AsType GenesisKey -> Crypto.Seed -> SigningKey GenesisKey
    deterministicSigningKey AsGenesisKey seed =
        GenesisSigningKey (Crypto.genKeyDSIGN seed)

    deterministicSigningKeySeedSize :: AsType GenesisKey -> Word
    deterministicSigningKeySeedSize AsGenesisKey =
        Crypto.seedSizeDSIGN proxy
      where
        proxy :: Proxy (Shelley.DSIGN ShelleyCrypto)
        proxy = Proxy

    getVerificationKey :: SigningKey GenesisKey -> VerificationKey GenesisKey
    getVerificationKey (GenesisSigningKey sk) =
        GenesisVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk))

    verificationKeyHash :: VerificationKey GenesisKey -> Hash GenesisKey
    verificationKeyHash (GenesisVerificationKey vkey) =
        GenesisKeyHash (Shelley.hashKey vkey)

newtype instance Hash GenesisKey =
    GenesisKeyHash (Shelley.KeyHash Shelley.Genesis ShelleyCrypto)
  deriving (Eq, Ord, Show)

instance SerialiseAsRawBytes (Hash GenesisKey) where
    serialiseToRawBytes (GenesisKeyHash (Shelley.KeyHash vkh)) =
      Crypto.getHash vkh

    deserialiseFromRawBytes (AsHash AsGenesisKey) bs =
      GenesisKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs

instance HasTextEnvelope (VerificationKey GenesisKey) where
    textEnvelopeType _ = "Genesis verification key"
    -- TODO: include the actual crypto algorithm name, to catch changes

instance HasTextEnvelope (SigningKey GenesisKey) where
    textEnvelopeType _ = "Genesis signing key"
    -- TODO: include the actual crypto algorithm name, to catch changes


--
-- Genesis delegate keys
--

data GenesisDelegateKey

instance HasTypeProxy GenesisDelegateKey where
    data AsType GenesisDelegateKey = AsGenesisDelegateKey
    proxyToAsType _ = AsGenesisDelegateKey


instance Key GenesisDelegateKey where

    newtype VerificationKey GenesisDelegateKey =
        GenesisDelegateVerificationKey (Shelley.VKey Shelley.GenesisDelegate ShelleyCrypto)
      deriving stock (Eq, Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    newtype SigningKey GenesisDelegateKey =
        GenesisDelegateSigningKey (Shelley.SignKeyDSIGN ShelleyCrypto)
      deriving stock (Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    deterministicSigningKey :: AsType GenesisDelegateKey -> Crypto.Seed -> SigningKey GenesisDelegateKey
    deterministicSigningKey AsGenesisDelegateKey seed =
        GenesisDelegateSigningKey (Crypto.genKeyDSIGN seed)

    deterministicSigningKeySeedSize :: AsType GenesisDelegateKey -> Word
    deterministicSigningKeySeedSize AsGenesisDelegateKey =
        Crypto.seedSizeDSIGN proxy
      where
        proxy :: Proxy (Shelley.DSIGN ShelleyCrypto)
        proxy = Proxy

    getVerificationKey :: SigningKey GenesisDelegateKey -> VerificationKey GenesisDelegateKey
    getVerificationKey (GenesisDelegateSigningKey sk) =
        GenesisDelegateVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk))

    verificationKeyHash :: VerificationKey GenesisDelegateKey -> Hash GenesisDelegateKey
    verificationKeyHash (GenesisDelegateVerificationKey vkey) =
        GenesisDelegateKeyHash (Shelley.hashKey vkey)

newtype instance Hash GenesisDelegateKey =
    GenesisDelegateKeyHash (Shelley.KeyHash Shelley.GenesisDelegate ShelleyCrypto)
  deriving (Eq, Ord, Show)

instance SerialiseAsRawBytes (Hash GenesisDelegateKey) where
    serialiseToRawBytes (GenesisDelegateKeyHash (Shelley.KeyHash vkh)) =
      Crypto.getHash vkh

    deserialiseFromRawBytes (AsHash AsGenesisDelegateKey) bs =
      GenesisDelegateKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs

instance HasTextEnvelope (VerificationKey GenesisDelegateKey) where
    textEnvelopeType _ = "Node operator verification key"
    -- TODO: include the actual crypto algorithm name, to catch changes

instance HasTextEnvelope (SigningKey GenesisDelegateKey) where
    textEnvelopeType _ = "Node operator signing key"
    -- TODO: include the actual crypto algorithm name, to catch changes
    -- TODO: use a different type from the stake pool key, since some operations
    -- need a genesis key specifically

instance CastKeyRole GenesisDelegateKey StakePoolKey where
    castVerificationKey (GenesisDelegateVerificationKey (Shelley.VKey vkey)) =
      StakePoolVerificationKey (Shelley.VKey vkey)

    castSigningKey (GenesisDelegateSigningKey skey) =
      StakePoolSigningKey skey


--
-- Genesis UTxO keys
--

data GenesisUTxOKey

instance HasTypeProxy GenesisUTxOKey where
    data AsType GenesisUTxOKey = AsGenesisUTxOKey
    proxyToAsType _ = AsGenesisUTxOKey


instance Key GenesisUTxOKey where

    newtype VerificationKey GenesisUTxOKey =
        GenesisUTxOVerificationKey (Shelley.VKey Shelley.Payment ShelleyCrypto)
      deriving stock (Eq, Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    newtype SigningKey GenesisUTxOKey =
        GenesisUTxOSigningKey (Shelley.SignKeyDSIGN ShelleyCrypto)
      deriving stock (Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    deterministicSigningKey :: AsType GenesisUTxOKey -> Crypto.Seed -> SigningKey GenesisUTxOKey
    deterministicSigningKey AsGenesisUTxOKey seed =
        GenesisUTxOSigningKey (Crypto.genKeyDSIGN seed)

    deterministicSigningKeySeedSize :: AsType GenesisUTxOKey -> Word
    deterministicSigningKeySeedSize AsGenesisUTxOKey =
        Crypto.seedSizeDSIGN proxy
      where
        proxy :: Proxy (Shelley.DSIGN ShelleyCrypto)
        proxy = Proxy

    getVerificationKey :: SigningKey GenesisUTxOKey -> VerificationKey GenesisUTxOKey
    getVerificationKey (GenesisUTxOSigningKey sk) =
        GenesisUTxOVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk))

    verificationKeyHash :: VerificationKey GenesisUTxOKey -> Hash GenesisUTxOKey
    verificationKeyHash (GenesisUTxOVerificationKey vkey) =
        GenesisUTxOKeyHash (Shelley.hashKey vkey)

newtype instance Hash GenesisUTxOKey =
    GenesisUTxOKeyHash (Shelley.KeyHash Shelley.Payment ShelleyCrypto)
  deriving (Eq, Ord, Show)

instance SerialiseAsRawBytes (Hash GenesisUTxOKey) where
    serialiseToRawBytes (GenesisUTxOKeyHash (Shelley.KeyHash vkh)) =
      Crypto.getHash vkh

    deserialiseFromRawBytes (AsHash AsGenesisUTxOKey) bs =
      GenesisUTxOKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs

instance HasTextEnvelope (VerificationKey GenesisUTxOKey) where
    textEnvelopeType _ = "Genesis UTxO verification key"
    -- TODO: include the actual crypto algorithm name, to catch changes

instance HasTextEnvelope (SigningKey GenesisUTxOKey) where
    textEnvelopeType _ = "Genesis UTxO signing key"
    -- TODO: include the actual crypto algorithm name, to catch changes
    -- TODO: use a different type from the stake pool key, since some operations
    -- need a genesis key specifically


--
-- stake pool keys
--

data StakePoolKey

instance HasTypeProxy StakePoolKey where
    data AsType StakePoolKey = AsStakePoolKey
    proxyToAsType _ = AsStakePoolKey

instance Key StakePoolKey where

    newtype VerificationKey StakePoolKey =
        StakePoolVerificationKey (Shelley.VKey Shelley.StakePool ShelleyCrypto)
      deriving stock (Eq, Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    newtype SigningKey StakePoolKey =
        StakePoolSigningKey (Shelley.SignKeyDSIGN ShelleyCrypto)
      deriving stock (Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    deterministicSigningKey :: AsType StakePoolKey -> Crypto.Seed -> SigningKey StakePoolKey
    deterministicSigningKey AsStakePoolKey seed =
        StakePoolSigningKey (Crypto.genKeyDSIGN seed)

    deterministicSigningKeySeedSize :: AsType StakePoolKey -> Word
    deterministicSigningKeySeedSize AsStakePoolKey =
        Crypto.seedSizeDSIGN proxy
      where
        proxy :: Proxy (Shelley.DSIGN ShelleyCrypto)
        proxy = Proxy

    getVerificationKey :: SigningKey StakePoolKey -> VerificationKey StakePoolKey
    getVerificationKey (StakePoolSigningKey sk) =
        StakePoolVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk))

    verificationKeyHash :: VerificationKey StakePoolKey -> Hash StakePoolKey
    verificationKeyHash (StakePoolVerificationKey vkey) =
        StakePoolKeyHash (Shelley.hashKey vkey)

newtype instance Hash StakePoolKey =
    StakePoolKeyHash (Shelley.KeyHash Shelley.StakePool ShelleyCrypto)
  deriving (Eq, Ord, Show)

instance SerialiseAsRawBytes (Hash StakePoolKey) where
    serialiseToRawBytes (StakePoolKeyHash (Shelley.KeyHash vkh)) =
      Crypto.getHash vkh

    deserialiseFromRawBytes (AsHash AsStakePoolKey) bs =
      StakePoolKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs

instance HasTextEnvelope (VerificationKey StakePoolKey) where
    textEnvelopeType _ = "Node operator verification key"
    -- TODO: include the actual crypto algorithm name, to catch changes

instance HasTextEnvelope (SigningKey StakePoolKey) where
    textEnvelopeType _ = "Node operator signing key"
    -- TODO: include the actual crypto algorithm name, to catch changes


--
-- KES keys
--

data KesKey

instance HasTypeProxy KesKey where
    data AsType KesKey = AsKesKey
    proxyToAsType _ = AsKesKey

instance Key KesKey where

    newtype VerificationKey KesKey =
        KesVerificationKey (Shelley.VerKeyKES ShelleyCrypto)
      deriving stock (Eq, Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    newtype SigningKey KesKey =
        KesSigningKey (Shelley.SignKeyKES ShelleyCrypto)
      deriving stock (Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    deterministicSigningKey :: AsType KesKey -> Crypto.Seed -> SigningKey KesKey
    deterministicSigningKey AsKesKey seed =
        KesSigningKey (Crypto.genKeyKES seed)

    deterministicSigningKeySeedSize :: AsType KesKey -> Word
    deterministicSigningKeySeedSize AsKesKey =
        Crypto.seedSizeKES proxy
      where
        proxy :: Proxy (Shelley.KES ShelleyCrypto)
        proxy = Proxy

    getVerificationKey :: SigningKey KesKey -> VerificationKey KesKey
    getVerificationKey (KesSigningKey sk) =
        KesVerificationKey (Crypto.deriveVerKeyKES sk)

    verificationKeyHash :: VerificationKey KesKey -> Hash KesKey
    verificationKeyHash (KesVerificationKey vkey) =
        KesKeyHash (Crypto.hashVerKeyKES vkey)

newtype instance Hash KesKey =
    KesKeyHash (Crypto.Hash (Shelley.HASH ShelleyCrypto)
                            (Shelley.VerKeyKES ShelleyCrypto))
  deriving (Eq, Ord, Show)

instance SerialiseAsRawBytes (Hash KesKey) where
    serialiseToRawBytes (KesKeyHash vkh) =
      Crypto.getHash vkh

    deserialiseFromRawBytes (AsHash AsKesKey) bs =
      KesKeyHash <$> Crypto.hashFromBytes bs

instance HasTextEnvelope (VerificationKey KesKey) where
    textEnvelopeType _ = "VKeyES TPraosStandardCrypto"
    -- TODO: include the actual crypto algorithm name, to catch changes

instance HasTextEnvelope (SigningKey KesKey) where
    textEnvelopeType _ = "SKeyES TPraosStandardCrypto"
    -- TODO: include the actual crypto algorithm name, to catch changes


--
-- VRF keys
--

data VrfKey

instance HasTypeProxy VrfKey where
    data AsType VrfKey = AsVrfKey
    proxyToAsType _ = AsVrfKey

instance Key VrfKey where

    newtype VerificationKey VrfKey =
        VrfVerificationKey (Shelley.VerKeyVRF ShelleyCrypto)
      deriving stock (Eq, Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    newtype SigningKey VrfKey =
        VrfSigningKey (Shelley.SignKeyVRF ShelleyCrypto)
      deriving stock (Show)
      deriving newtype (ToCBOR, FromCBOR)
      deriving anyclass SerialiseAsCBOR

    deterministicSigningKey :: AsType VrfKey -> Crypto.Seed -> SigningKey VrfKey
    deterministicSigningKey AsVrfKey seed =
        VrfSigningKey (Crypto.genKeyVRF seed)

    deterministicSigningKeySeedSize :: AsType VrfKey -> Word
    deterministicSigningKeySeedSize AsVrfKey =
        Crypto.seedSizeVRF proxy
      where
        proxy :: Proxy (Shelley.VRF ShelleyCrypto)
        proxy = Proxy

    getVerificationKey :: SigningKey VrfKey -> VerificationKey VrfKey
    getVerificationKey (VrfSigningKey sk) =
        VrfVerificationKey (Crypto.deriveVerKeyVRF sk)

    verificationKeyHash :: VerificationKey VrfKey -> Hash VrfKey
    verificationKeyHash (VrfVerificationKey vkey) =
        VrfKeyHash (Crypto.hashVerKeyVRF vkey)

newtype instance Hash VrfKey =
    VrfKeyHash (Crypto.Hash (Shelley.HASH ShelleyCrypto)
                            (Shelley.VerKeyVRF ShelleyCrypto))
  deriving (Eq, Ord, Show)

instance SerialiseAsRawBytes (Hash VrfKey) where
    serialiseToRawBytes (VrfKeyHash vkh) =
      Crypto.getHash vkh

    deserialiseFromRawBytes (AsHash AsVrfKey) bs =
      VrfKeyHash <$> Crypto.hashFromBytes bs

instance HasTextEnvelope (VerificationKey VrfKey) where
    textEnvelopeType _ = "VerKeyVRF " <> fromString (backCompatAlgorithmNameVrf proxy)
      where
        proxy :: Proxy (Shelley.VRF ShelleyCrypto)
        proxy = Proxy

instance HasTextEnvelope (SigningKey VrfKey) where
    textEnvelopeType _ = "SignKeyVRF " <> fromString (backCompatAlgorithmNameVrf proxy)
      where
        proxy :: Proxy (Shelley.VRF ShelleyCrypto)
        proxy = Proxy

-- | Temporary solution for maintaining backward compatibility with the output
-- of 'Cardano.Api.Shelley.VRF.encodeVRFVerificationKey'.
backCompatAlgorithmNameVrf :: Proxy (Shelley.VRF ShelleyCrypto) -> String
backCompatAlgorithmNameVrf p =
  let algoName = Crypto.algorithmNameVRF p
  in if algoName == "simple" then "SimpleVRF" else algoName

--
-- Utils
--

(?!) :: Maybe a -> e -> Either e a
Nothing ?! e = Left e
Just x  ?! _ = Right x