{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE ViewPatterns      #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
module Plutus.Contracts.Swap(
    Swap(..),
    -- * Script
    swapValidator
    ) where

import Ledger (POSIXTime, PaymentPubKey, PaymentPubKeyHash (unPaymentPubKeyHash), PubKeyHash)
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.Contract.Oracle (Observation (..), SignedMessage)
import Plutus.Contract.Oracle qualified as Oracle
import Plutus.Script.Utils.Ada (Ada)
import Plutus.Script.Utils.Ada qualified as Ada
import Plutus.Script.Utils.Value (Value)
import Plutus.V1.Ledger.Address (toPubKeyHash)
import Plutus.V2.Ledger.Api qualified as V2
import Plutus.V2.Ledger.Contexts qualified as V2
import PlutusTx qualified
import PlutusTx.Prelude

-- | A swap is an agreement to exchange cashflows at future dates. To keep
--  things simple, this is an interest rate swap (meaning that the cashflows are
--  interest payments on the same principal amount but with two different
--  interest rates, of which one is fixed and one is floating (varying with
--  time)) with only a single payment date.
--
--  At the beginning of the contract, the fixed rate is set to the expected
--  future value of the floating rate (so if the floating rate behaves as
--  expected, the two payments will be exactly equal).
--
data Swap = Swap
    { Swap -> Ada
swapNotionalAmt     :: !Ada
    , Swap -> POSIXTime
swapObservationTime :: !POSIXTime
    , Swap -> Rational
swapFixedRate       :: !Rational
    -- ^ Interest rate fixed at the beginning of the contract
    , Swap -> Rational
swapFloatingRate    :: !Rational
    -- ^ Interest rate whose value will be observed (by an oracle) on the day
    -- of the payment
    , Swap -> Ada
swapMargin          :: !Ada
    -- ^ Margin deposited at the beginning of the contract to protect against
    -- default (one party failing to pay)
    , Swap -> PaymentPubKey
swapOracle          :: PaymentPubKey
    -- ^ Public key of the oracle (see note [Oracles] in [[Plutus.Contracts]]).
    -- Unsure why, but this field needs to be non-strict, otherwise GHC will try
    -- to unbox the datatype, which will result in a compilation error such as
    -- "GHC Core to PLC plugin: E042:Error: Unsupported feature: Type constructor: GHC.Prim.Addr#"
    }

PlutusTx.makeLift ''Swap

-- | Identities of the parties involved in the swap. This will be the data
--   script which allows us to change the identities during the lifetime of
--   the contract (ie. if one of the parties sells their part of the contract)
--
--   In the future we could also put the `swapMargin` value in here to implement
--   a variable margin.
data SwapOwners = SwapOwners {
    SwapOwners -> PaymentPubKeyHash
swapOwnersFixedLeg :: PaymentPubKeyHash,
    SwapOwners -> PaymentPubKeyHash
swapOwnersFloating :: PaymentPubKeyHash
    }

PlutusTx.unstableMakeIsData ''SwapOwners
PlutusTx.makeLift ''SwapOwners

type SwapOracleMessage = SignedMessage (Observation Rational)

{-# INLINABLE mkValidator #-}
mkValidator :: Swap -> SwapOwners -> SwapOracleMessage -> V2.ScriptContext -> Bool
mkValidator :: Swap -> SwapOwners -> SwapOracleMessage -> ScriptContext -> Bool
mkValidator Swap{PaymentPubKey
POSIXTime
Ada
Rational
swapOracle :: PaymentPubKey
swapMargin :: Ada
swapFloatingRate :: Rational
swapFixedRate :: Rational
swapObservationTime :: POSIXTime
swapNotionalAmt :: Ada
swapOracle :: Swap -> PaymentPubKey
swapMargin :: Swap -> Ada
swapFloatingRate :: Swap -> Rational
swapFixedRate :: Swap -> Rational
swapObservationTime :: Swap -> POSIXTime
swapNotionalAmt :: Swap -> Ada
..} SwapOwners{PaymentPubKeyHash
swapOwnersFloating :: PaymentPubKeyHash
swapOwnersFixedLeg :: PaymentPubKeyHash
swapOwnersFloating :: SwapOwners -> PaymentPubKeyHash
swapOwnersFixedLeg :: SwapOwners -> PaymentPubKeyHash
..} SwapOracleMessage
redeemer p :: ScriptContext
p@V2.ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
V2.scriptContextTxInfo=TxInfo
txInfo} =
    let
        extractVerifyAt :: SignedMessage (Observation Rational) -> PaymentPubKey -> POSIXTime -> Rational
        extractVerifyAt :: SwapOracleMessage -> PaymentPubKey -> POSIXTime -> Rational
extractVerifyAt SwapOracleMessage
sm PaymentPubKey
pk POSIXTime
time =
            case ScriptContext
-> PaymentPubKey
-> SwapOracleMessage
-> Either SignedMessageCheckError (Observation Rational)
forall a.
FromData a =>
ScriptContext
-> PaymentPubKey
-> SignedMessage a
-> Either SignedMessageCheckError a
Oracle.verifySignedMessageOnChain ScriptContext
p PaymentPubKey
pk SwapOracleMessage
sm of
                Left SignedMessageCheckError
_ -> BuiltinString -> Rational
forall a. BuiltinString -> a
traceError BuiltinString
"checkSignatureAndDecode failed"
                Right Observation{Rational
obsValue :: forall a. Observation a -> a
obsValue :: Rational
obsValue, POSIXTime
obsTime :: forall a. Observation a -> POSIXTime
obsTime :: POSIXTime
obsTime} ->
                    if POSIXTime
obsTime POSIXTime -> POSIXTime -> Bool
forall a. Eq a => a -> a -> Bool
== POSIXTime
time
                        then Rational
obsValue
                        else BuiltinString -> Rational
forall a. BuiltinString -> a
traceError BuiltinString
"wrong time"

        -- | Convert an [[Integer]] to a [[Rational]]
        fromInt :: Integer -> Rational
        fromInt :: Integer -> Rational
fromInt = () -> Integer -> Rational
forall a. () -> a
error ()

        adaValueIn :: Value -> Integer
        adaValueIn :: Value -> Integer
adaValueIn Value
v = Ada -> Integer
Ada.getLovelace (Value -> Ada
Ada.fromValue Value
v)

        isPaymentPubKeyOutput :: V2.TxOut -> PaymentPubKeyHash -> Bool
        isPaymentPubKeyOutput :: TxOut -> PaymentPubKeyHash -> Bool
isPaymentPubKeyOutput TxOut
o PaymentPubKeyHash
k = Bool -> (PubKeyHash -> Bool) -> Maybe PubKeyHash -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (PubKeyHash -> PubKeyHash -> Bool
forall a. Eq a => a -> a -> Bool
(==) (PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
k)) (TxOut -> Maybe PubKeyHash
pubKeyOutput TxOut
o)

        -- | Get the public key hash that locks the transaction output, if any.
        pubKeyOutput :: V2.TxOut -> Maybe PubKeyHash
        pubKeyOutput :: TxOut -> Maybe PubKeyHash
pubKeyOutput V2.TxOut{Address
txOutAddress :: TxOut -> Address
txOutAddress :: Address
txOutAddress} = Address -> Maybe PubKeyHash
toPubKeyHash Address
txOutAddress

        -- Verify the authenticity of the oracle value and compute
        -- the payments.
        rt :: Rational
rt = SwapOracleMessage -> PaymentPubKey -> POSIXTime -> Rational
extractVerifyAt SwapOracleMessage
redeemer PaymentPubKey
swapOracle POSIXTime
swapObservationTime

        rtDiff :: Rational
        rtDiff :: Rational
rtDiff = Rational
rt Rational -> Rational -> Rational
forall a. AdditiveGroup a => a -> a -> a
- Rational
swapFixedRate

        amt :: Integer
amt    = Ada -> Integer
Ada.getLovelace Ada
swapNotionalAmt
        margin :: Integer
margin = Ada -> Integer
Ada.getLovelace Ada
swapMargin

        amt' :: Rational
        amt' :: Rational
amt' = Integer -> Rational
fromInt Integer
amt

        delta :: Rational
        delta :: Rational
delta = Rational
amt' Rational -> Rational -> Rational
forall a. MultiplicativeSemigroup a => a -> a -> a
* Rational
rtDiff

        fixedPayment :: Integer
        fixedPayment :: Integer
fixedPayment = Rational -> Integer
round (Rational
amt' Rational -> Rational -> Rational
forall a. AdditiveSemigroup a => a -> a -> a
+ Rational
delta)

        floatPayment :: Integer
        floatPayment :: Integer
floatPayment = Rational -> Integer
round (Rational
amt' Rational -> Rational -> Rational
forall a. AdditiveSemigroup a => a -> a -> a
+ Rational
delta)

        -- Compute the payouts (initial margin +/- the sum of the two
        -- payments), ensuring that it is at least 0 and does not exceed
        -- the total amount of money at stake (2 * margin)
        clamp :: Integer -> Integer
        clamp :: Integer -> Integer
clamp Integer
x = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
0 (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (Integer
2 Integer -> Integer -> Integer
forall a. MultiplicativeSemigroup a => a -> a -> a
* Integer
margin) Integer
x)
        fixedRemainder :: Integer
fixedRemainder = Integer -> Integer
clamp ((Integer
margin Integer -> Integer -> Integer
forall a. AdditiveGroup a => a -> a -> a
- Integer
fixedPayment) Integer -> Integer -> Integer
forall a. AdditiveSemigroup a => a -> a -> a
+ Integer
floatPayment)
        floatRemainder :: Integer
floatRemainder = Integer -> Integer
clamp ((Integer
margin Integer -> Integer -> Integer
forall a. AdditiveGroup a => a -> a -> a
- Integer
floatPayment) Integer -> Integer -> Integer
forall a. AdditiveSemigroup a => a -> a -> a
+ Integer
fixedPayment)

        -- The transaction must have one input from each of the
        -- participants.
        -- NOTE: Partial match is OK because if it fails then the PLC script
        --       terminates with `error` and the validation fails (which is
        --       what we want when the number of inputs and outputs is /= 2)
        [TxInInfo
t1, TxInInfo
t2] = TxInfo -> [TxInInfo]
V2.txInfoInputs TxInfo
txInfo
        [TxOut
o1, TxOut
o2] = TxInfo -> [TxOut]
V2.txInfoOutputs TxInfo
txInfo

        -- Each participant must deposit the margin. But we don't know
        -- which of the two participant's deposit we are currently
        -- evaluating (this script runs on both). So we use the two
        -- predicates iP1 and iP2 to cover both cases

        -- True if the transaction input is the margin payment of the
        -- fixed leg
        iP1 :: V2.TxInInfo -> Bool
        iP1 :: TxInInfo -> Bool
iP1 V2.TxInInfo{txInInfoResolved :: TxInInfo -> TxOut
V2.txInInfoResolved=V2.TxOut{Value
txOutValue :: TxOut -> Value
txOutValue :: Value
txOutValue}} =
            TxInfo -> PubKeyHash -> Bool
V2.txSignedBy TxInfo
txInfo (PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
swapOwnersFixedLeg) Bool -> Bool -> Bool
&& Value -> Integer
adaValueIn Value
txOutValue Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
margin

        -- True if the transaction input is the margin payment of the
        -- floating leg
        iP2 :: V2.TxInInfo -> Bool
        iP2 :: TxInInfo -> Bool
iP2 V2.TxInInfo{txInInfoResolved :: TxInInfo -> TxOut
V2.txInInfoResolved=V2.TxOut{Value
txOutValue :: Value
txOutValue :: TxOut -> Value
txOutValue}} =
            TxInfo -> PubKeyHash -> Bool
V2.txSignedBy TxInfo
txInfo (PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
swapOwnersFloating) Bool -> Bool -> Bool
&& Value -> Integer
adaValueIn Value
txOutValue Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
margin

        inConditions :: Bool
inConditions = (TxInInfo -> Bool
iP1 TxInInfo
t1 Bool -> Bool -> Bool
&& TxInInfo -> Bool
iP2 TxInInfo
t2) Bool -> Bool -> Bool
|| (TxInInfo -> Bool
iP1 TxInInfo
t2 Bool -> Bool -> Bool
&& TxInInfo -> Bool
iP2 TxInInfo
t1)

        -- The transaction must have two outputs, one for each of the
        -- participants, which equal the margin adjusted by the difference
        -- between fixed and floating payment

        -- True if the output is the payment of the fixed leg.
        ol1 :: V2.TxOut -> Bool
        ol1 :: TxOut -> Bool
ol1 o :: TxOut
o@V2.TxOut{Value
txOutValue :: Value
txOutValue :: TxOut -> Value
V2.txOutValue} =
            TxOut -> PaymentPubKeyHash -> Bool
isPaymentPubKeyOutput TxOut
o PaymentPubKeyHash
swapOwnersFixedLeg Bool -> Bool -> Bool
&& Value -> Integer
adaValueIn Value
txOutValue Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
fixedRemainder

        -- True if the output is the payment of the floating leg.
        ol2 :: V2.TxOut -> Bool
        ol2 :: TxOut -> Bool
ol2 o :: TxOut
o@V2.TxOut{Value
txOutValue :: Value
txOutValue :: TxOut -> Value
V2.txOutValue} =
            TxOut -> PaymentPubKeyHash -> Bool
isPaymentPubKeyOutput TxOut
o PaymentPubKeyHash
swapOwnersFloating Bool -> Bool -> Bool
&& Value -> Integer
adaValueIn Value
txOutValue Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
floatRemainder

        -- NOTE: I didn't include a check that the time is greater
        -- than the observation time. This is because the time is
        -- already part of the oracle value and we trust the oracle.

        outConditions :: Bool
outConditions = (TxOut -> Bool
ol1 TxOut
o1 Bool -> Bool -> Bool
&& TxOut -> Bool
ol2 TxOut
o2) Bool -> Bool -> Bool
|| (TxOut -> Bool
ol1 TxOut
o2 Bool -> Bool -> Bool
&& TxOut -> Bool
ol2 TxOut
o1)

    in Bool
inConditions Bool -> Bool -> Bool
&& Bool
outConditions

-- | Validator script for the two transactions that initialise the swap.
--   See note [Swap Transactions]
--   See note [Contracts and Validator Scripts] in
--       Language.Plutus.Coordination.Contracts
swapValidator :: Swap -> V2.Validator
swapValidator :: Swap -> Validator
swapValidator Swap
swp = CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ())
-> Validator
V2.mkValidatorScript (CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ())
 -> Validator)
-> CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ())
-> Validator
forall a b. (a -> b) -> a -> b
$
    $$(PlutusTx.compile [|| validatorParam ||])
        CompiledCode
  (Swap -> BuiltinData -> BuiltinData -> BuiltinData -> ())
-> CompiledCodeIn DefaultUni DefaultFun Swap
-> CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ())
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun,
 Everywhere uni PrettyConst, GShow uni, Pretty fun) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
`PlutusTx.applyCode`
            Swap -> CompiledCodeIn DefaultUni DefaultFun Swap
forall (uni :: * -> *) a fun.
(Lift uni a, Throwable uni fun, Typecheckable uni fun) =>
a -> CompiledCodeIn uni fun a
PlutusTx.liftCode Swap
swp
    where validatorParam :: Swap -> BuiltinData -> BuiltinData -> BuiltinData -> ()
validatorParam Swap
s = (SwapOwners -> SwapOracleMessage -> ScriptContext -> Bool)
-> BuiltinData -> BuiltinData -> BuiltinData -> ()
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool)
-> BuiltinData -> BuiltinData -> BuiltinData -> ()
Scripts.mkUntypedValidator (Swap -> SwapOwners -> SwapOracleMessage -> ScriptContext -> Bool
mkValidator Swap
s)

{- Note [Swap Transactions]

The swap involves three transactions at two different times.

1. At t=0. Each participant deposits the margin. The outputs are locked with
   the same validator script, `swapValidator`
2. At t=n. The value of the floating rate, and consequently the values of the
   two payments are determined. Each participant gets their margin plus or
   minus the actual payment.

There is a risk of losing out if the interest rate moves outside the range of
fixedRate +/- (margin / notional amount). In a real financial contract this
would be dealt with by agreeing a "Variation Margin". This means that the
margin is adjusted at predefined dates before the actual payment is due. If one
of the parties fails to make the variation margin payment, the contract ends
prematurely and the other party gets to keep both margins.

Plutus should be able to handle variation margins in a series of validation
scripts. But it seems to me that they could get quite messy so I don't want to
write them by hand :) We can probably use TH to generate them at compile time.

-}