{-# LANGUAGE DataKinds #-}

{- |
Module      : Singular.Registry.Signing
Description : Payment-key witnesses and signed transaction capability
License     : Apache-2.0

Signing changes only the witness set. The body and its transaction identity
are preserved. The constructor stays private: submission capabilities accept
only a transaction passed through this payment-key signing boundary.
-}
module Singular.Registry.Signing
    ( SignedTx
    , signTx
    , signedTx
    ) where

import Cardano.Crypto.DSIGN
    ( Ed25519DSIGN
    , SignKeyDSIGN
    , deriveVerKeyDSIGN
    )
import Cardano.Ledger.Api.Tx (addrTxWitsL, txIdTx, witsTxL)
import Cardano.Ledger.Core (extractHash)
import Cardano.Ledger.Keys
    ( VKey (..)
    , WitVKey (..)
    , asWitness
    , signedDSIGN
    )
import Cardano.Ledger.TxIn (TxId (..))
import Cardano.Tx.Ledger (ConwayTx)
import Data.Set qualified as Set
import Lens.Micro ((%~), (&))

-- | A transaction carrying a witness from the key that signed its body.
newtype SignedTx = SignedTx ConwayTx

-- | Add a payment-key witness, preserving the body and other witnesses.
signTx :: SignKeyDSIGN Ed25519DSIGN -> ConwayTx -> SignedTx
signTx :: SignKeyDSIGN Ed25519DSIGN -> ConwayTx -> SignedTx
signTx SignKeyDSIGN Ed25519DSIGN
key ConwayTx
tx =
    let TxId SafeHash EraIndependentTxBody
bodyHash = ConwayTx -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx ConwayTx
tx
        witness :: WitVKey Witness
witness =
            VKey Witness
-> SignedDSIGN Ed25519DSIGN (Hash HASH EraIndependentTxBody)
-> WitVKey Witness
forall (kr :: KeyRole).
VKey kr
-> SignedDSIGN Ed25519DSIGN (Hash HASH EraIndependentTxBody)
-> WitVKey kr
WitVKey
                (VKey (ZonkAny 0) -> VKey Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a Witness
asWitness (VerKeyDSIGN Ed25519DSIGN -> VKey (ZonkAny 0)
forall (kd :: KeyRole). VerKeyDSIGN Ed25519DSIGN -> VKey kd
VKey (SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN Ed25519DSIGN
key)))
                (SignKeyDSIGN Ed25519DSIGN
-> Hash HASH EraIndependentTxBody
-> SignedDSIGN Ed25519DSIGN (Hash HASH EraIndependentTxBody)
forall a.
Signable Ed25519DSIGN a =>
SignKeyDSIGN Ed25519DSIGN -> a -> SignedDSIGN Ed25519DSIGN a
signedDSIGN SignKeyDSIGN Ed25519DSIGN
key (SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody
forall i. SafeHash i -> Hash HASH i
extractHash SafeHash EraIndependentTxBody
bodyHash))
    in  ConwayTx -> SignedTx
SignedTx (ConwayTx
tx ConwayTx -> (ConwayTx -> ConwayTx) -> ConwayTx
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> ConwayTx -> Identity ConwayTx
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> ConwayTx -> Identity ConwayTx
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> ConwayTx -> Identity ConwayTx)
-> ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey Witness))
Lens' (TxWits ConwayEra) (Set (WitVKey Witness))
addrTxWitsL ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
 -> ConwayTx -> Identity ConwayTx)
-> (Set (WitVKey Witness) -> Set (WitVKey Witness))
-> ConwayTx
-> ConwayTx
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ WitVKey Witness -> Set (WitVKey Witness) -> Set (WitVKey Witness)
forall a. Ord a => a -> Set a -> Set a
Set.insert WitVKey Witness
witness)

-- | The signed ledger transaction, for identity and durable journalling.
signedTx :: SignedTx -> ConwayTx
signedTx :: SignedTx -> ConwayTx
signedTx (SignedTx ConwayTx
tx) = ConwayTx
tx