275 lines
7.5 KiB
Plaintext
275 lines
7.5 KiB
Plaintext
module Exercise3.Swaps where
|
|
|
|
import DA.Assert
|
|
import DA.Action
|
|
import DA.Foldable (forA_)
|
|
|
|
import Daml.Script
|
|
|
|
data VAsset = VAsset with
|
|
issuer : Party
|
|
owner : Party
|
|
assetType : Text
|
|
quantity : Decimal
|
|
obs : [Party]
|
|
deriving (Eq, Show)
|
|
|
|
data VAssetTransferProposal = VAssetTransferProposal with
|
|
vasset : VAsset
|
|
newOwner : Party
|
|
deriving (Eq, Show)
|
|
|
|
interface IAssetTransferProposal where
|
|
viewtype VAssetTransferProposal
|
|
asset : IAsset
|
|
|
|
choice Accept_TransferProposal : ContractId IAsset
|
|
controller (view this).newOwner
|
|
do
|
|
create $ set_owner (asset this) (view this).newOwner
|
|
|
|
choice Reject_TransferProposal : ContractId IAsset
|
|
controller (view this).newOwner
|
|
do
|
|
create $ asset this
|
|
|
|
interface IAsset where
|
|
viewtype VAsset
|
|
set_owner : Party -> IAsset
|
|
set_obs : [Party] -> IAsset
|
|
set_quantity : Decimal -> IAsset
|
|
transfer_for : Party -> IAssetTransferProposal
|
|
|
|
|
|
choice Transfer : ContractId IAsset
|
|
with
|
|
newOwner : Party
|
|
controller [(view this).owner, newOwner]
|
|
do
|
|
create $ set_owner (set_obs this []) newOwner
|
|
|
|
choice Split : (ContractId IAsset, [ContractId IAsset])
|
|
with
|
|
splitQuantities : [Decimal]
|
|
controller (view this).owner
|
|
do
|
|
remCid <- create $ set_quantity this ((view this).quantity - sum splitQuantities)
|
|
splitCids <- forA splitQuantities (\splitQuantity -> create$ set_quantity this splitQuantity)
|
|
return (remCid, splitCids)
|
|
|
|
choice Merge : ContractId IAsset
|
|
with
|
|
otherCids : [ContractId IAsset]
|
|
controller (view this).owner
|
|
do
|
|
quantities <- forA otherCids (\otherCid -> do
|
|
other <- fetch otherCid
|
|
let vo = view other
|
|
vo === (view this) with
|
|
quantity = vo.quantity
|
|
obs = vo.obs
|
|
exercise otherCid Archive_Asset
|
|
return vo.quantity)
|
|
create $ set_quantity this ((view this).quantity + sum quantities)
|
|
|
|
choice Propose_Transfer : ContractId IAssetTransferProposal
|
|
with
|
|
newOwner : Party
|
|
controller (view this).owner
|
|
do
|
|
create (transfer_for this newOwner)
|
|
|
|
choice Set_Observers : ContractId IAsset
|
|
with
|
|
newObs : [Party]
|
|
controller (view this).owner
|
|
do
|
|
create $ set_obs this newObs
|
|
|
|
choice Archive_Asset : ()
|
|
controller (signatory this)
|
|
do return ()
|
|
|
|
template Cash
|
|
with
|
|
_issuer : Party
|
|
_owner : Party
|
|
_quantity : Decimal
|
|
_obs : [Party]
|
|
where
|
|
signatory [_issuer, _owner]
|
|
observer _obs
|
|
|
|
interface instance IAsset for Cash where
|
|
view = VAsset with
|
|
issuer = _issuer
|
|
owner = _owner
|
|
obs = _obs
|
|
quantity = _quantity
|
|
assetType = "Cash"
|
|
set_obs newObs = toInterface (this with _obs = newObs)
|
|
set_owner newOwner = toInterface (this with _owner = newOwner)
|
|
set_quantity newQuantity = toInterface (this with _quantity = newQuantity)
|
|
transfer_for newOwner = toInterface $ CashTransferProposal with cash = this; ..
|
|
|
|
-- Workaround for https://github.com/digital-asset/daml/issues/15459
|
|
myView = view
|
|
|
|
template CashTransferProposal
|
|
with
|
|
newOwner : Party
|
|
cash : Cash
|
|
where
|
|
signatory (signatory cash)
|
|
observer newOwner
|
|
|
|
interface instance IAssetTransferProposal for CashTransferProposal where
|
|
view = VAssetTransferProposal with
|
|
newOwner = newOwner
|
|
vasset = myView (toInterface @IAsset cash)
|
|
asset = toInterface @IAsset cash
|
|
|
|
template AssetSwapProposal
|
|
with
|
|
requester : Party
|
|
receiver : Party
|
|
-- Triples of issuer, assetType, quantity
|
|
offerSpec : (Party, Text, Decimal)
|
|
offerCid : ContractId IAsset
|
|
requestedSpec : (Party, Text, Decimal)
|
|
where
|
|
signatory requester
|
|
observer receiver
|
|
|
|
choice Settle : ()
|
|
with
|
|
requestedCid : ContractId IAsset
|
|
controller receiver
|
|
do
|
|
actualOffer <- fetch offerCid
|
|
actualRequested <- fetch requestedCid
|
|
let
|
|
vo = view actualOffer
|
|
vr = view actualRequested
|
|
|
|
-- Check signatories. Needed for safety!
|
|
assertMsg "Offer Asset not signed by issuer!" (vo.issuer `elem` signatory actualOffer)
|
|
assertMsg "Requested Asset not signed by issuer!" (vr.issuer `elem` signatory actualRequested)
|
|
|
|
-- Check against spec
|
|
(vo.issuer, vo.assetType, vo.quantity) === offerSpec
|
|
(vr.issuer, vr.assetType, vr.quantity) === requestedSpec
|
|
|
|
-- Transfer
|
|
exercise offerCid Transfer with newOwner = receiver
|
|
exercise requestedCid Transfer with newOwner = requester
|
|
|
|
return ()
|
|
|
|
|
|
-- Scripts
|
|
data TestParties = TestParties with
|
|
pBank : Party
|
|
pAlice : Party
|
|
pBob : Party
|
|
|
|
data TestUsers = TestUsers with
|
|
uBank : UserId
|
|
uAlice : UserId
|
|
uBob : UserId
|
|
|
|
init_parties : Script TestParties
|
|
init_parties = do
|
|
let allocate t = allocatePartyWithHint t (PartyIdHint t)
|
|
pBank <- allocate "Bank"
|
|
pAlice <- allocate "Alice"
|
|
pBob <- allocate "Bob"
|
|
|
|
return (TestParties with ..)
|
|
|
|
init_users : TestParties -> Script TestUsers
|
|
init_users TestParties{..} = do
|
|
let
|
|
makeUser t p rs = do
|
|
uid <- validateUserId t
|
|
let
|
|
u = User with
|
|
userId = uid
|
|
primaryParty = Some p
|
|
createUser u (CanActAs p :: rs)
|
|
return uid
|
|
uBank <- makeUser "bank" pBank []
|
|
uAlice <- makeUser "alice" pAlice []
|
|
uBob <- makeUser "bob" pBob []
|
|
|
|
return (TestUsers with ..)
|
|
|
|
init_cash : Script (TestParties, TestUsers)
|
|
init_cash = do
|
|
ps@TestParties{..} <- init_parties
|
|
us@TestUsers{..} <- init_users ps
|
|
|
|
-- Issue some cash in the form of transfer proposals.
|
|
let cash = Cash with
|
|
_issuer = pBank
|
|
_owner = pBank
|
|
_obs = []
|
|
_quantity = 1.0
|
|
|
|
-- 2 positions of $1 for Alice
|
|
replicateA_ 1 $ submitUser uBank do
|
|
replicateA_ 2 $ createCmd CashTransferProposal with
|
|
cash
|
|
newOwner = pAlice
|
|
|
|
-- 1 positions for Bob
|
|
replicateA_ 1 $ submitUser uBank do
|
|
replicateA_ 1 $ createCmd CashTransferProposal with
|
|
cash
|
|
newOwner = pBob
|
|
|
|
-- Accept all transfer proposals
|
|
let
|
|
accept_all p = do
|
|
proposals <- queryFilter @CashTransferProposal p (\tp -> tp.newOwner == p)
|
|
submit p do
|
|
forA_ proposals (\(cid, _) -> exerciseCmd (toInterfaceContractId @IAssetTransferProposal cid) Accept_TransferProposal)
|
|
forA_ [pAlice, pBob] accept_all
|
|
|
|
|
|
-- Alice transfers 1 of her positions to Bob
|
|
alicePositions <- query @Cash pAlice
|
|
forA_ (take 1 alicePositions) (\(cid, _) -> do
|
|
submitUser uAlice do
|
|
exerciseCmd (toInterfaceContractId @IAsset cid) Propose_Transfer with
|
|
newOwner = pBob
|
|
)
|
|
|
|
return (ps, us)
|
|
|
|
test_swap : Script ()
|
|
test_swap = script do
|
|
(tps@TestParties{..}, tus@TestUsers{..}) <- init_cash
|
|
|
|
-- Alice proposes a swap
|
|
(cid, posa)::_ <- query @Cash pAlice
|
|
cid <- submitUser uAlice do
|
|
exerciseCmd (toInterfaceContractId @IAsset cid) Set_Observers with newObs = [pBob]
|
|
|
|
-- Cash for cash is all we can do...
|
|
let assetSpec = (pBank, "Cash", posa._quantity)
|
|
swapCid <- submitUser uAlice do
|
|
createCmd AssetSwapProposal with
|
|
requester = pAlice
|
|
receiver = pBob
|
|
offerSpec = assetSpec
|
|
requestedSpec = assetSpec
|
|
offerCid = toInterfaceContractId @IAsset cid
|
|
|
|
-- Bob accepts
|
|
(cid, _)::_ <- queryFilter @Cash pBob (\posb -> posb._owner == pBob && posb._quantity == posa._quantity)
|
|
submitUser uBob do
|
|
exerciseCmd swapCid Settle with requestedCid = toInterfaceContractId @IAsset cid
|
|
|
|
(cid, asset)::_ <- queryFilter @Cash pBob (\posb -> posb._owner == pBob && posb._quantity == posa._quantity)
|
|
return () |