Initial commit
This commit is contained in:
commit
ab9a40dc27
3
.gitignore
vendored
Normal file
3
.gitignore
vendored
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
**/*.log
|
||||||
|
.daml
|
||||||
|
log
|
2
README.md
Normal file
2
README.md
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
# upgrading-daml-training
|
||||||
|
Code snippets for the upgrading daml training workshop
|
11
daml.yaml
Normal file
11
daml.yaml
Normal file
@ -0,0 +1,11 @@
|
|||||||
|
sdk-version: 2.4.0
|
||||||
|
name: upgrading-daml-training
|
||||||
|
version: 1.0.0
|
||||||
|
source: daml
|
||||||
|
start-navigator: false
|
||||||
|
dependencies:
|
||||||
|
- daml-prim
|
||||||
|
- daml-stdlib
|
||||||
|
- daml-script
|
||||||
|
build-options:
|
||||||
|
- --target=1.15
|
185
daml/Exercise1/Currency.daml
Normal file
185
daml/Exercise1/Currency.daml
Normal file
@ -0,0 +1,185 @@
|
|||||||
|
{-# LANGUAGE ApplicativeDo #-}
|
||||||
|
|
||||||
|
module Exercise1.Currency where
|
||||||
|
|
||||||
|
import Initial.Cash qualified as Old
|
||||||
|
import Initial.Scripts
|
||||||
|
|
||||||
|
import DA.Action
|
||||||
|
import DA.Assert
|
||||||
|
import DA.Foldable (forA_)
|
||||||
|
import Daml.Script
|
||||||
|
|
||||||
|
template Position
|
||||||
|
with
|
||||||
|
issuer : Party
|
||||||
|
owner : Party
|
||||||
|
quantity : Decimal
|
||||||
|
currency : Text
|
||||||
|
obs : [Party]
|
||||||
|
where
|
||||||
|
signatory [issuer, owner]
|
||||||
|
observer obs
|
||||||
|
|
||||||
|
choice Transfer : ContractId Position
|
||||||
|
with
|
||||||
|
newOwner : Party
|
||||||
|
controller [owner, newOwner]
|
||||||
|
do
|
||||||
|
create this with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
choice Propose_Transfer : ContractId TransferProposal
|
||||||
|
with
|
||||||
|
newOwner : Party
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
create TransferProposal with
|
||||||
|
position = this
|
||||||
|
newOwner
|
||||||
|
|
||||||
|
choice Split : (ContractId Position, [ContractId Position])
|
||||||
|
with
|
||||||
|
splitQuantities : [Decimal]
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
remCid <- create this with quantity = this.quantity - sum splitQuantities
|
||||||
|
splitCids <- forA splitQuantities (\splitQuantity -> create this with
|
||||||
|
quantity = splitQuantity
|
||||||
|
)
|
||||||
|
return (remCid, splitCids)
|
||||||
|
|
||||||
|
choice Merge : ContractId Position
|
||||||
|
with
|
||||||
|
otherCids : [ContractId Position]
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
quantities <- forA otherCids (\otherCid -> do
|
||||||
|
other <- fetch otherCid
|
||||||
|
other === this with
|
||||||
|
quantity = other.quantity
|
||||||
|
obs = other.obs
|
||||||
|
archive otherCid
|
||||||
|
return other.quantity)
|
||||||
|
create this with
|
||||||
|
quantity = quantity + sum quantities
|
||||||
|
|
||||||
|
template TransferProposal
|
||||||
|
with
|
||||||
|
position : Position
|
||||||
|
newOwner : Party
|
||||||
|
where
|
||||||
|
signatory (signatory position)
|
||||||
|
observer newOwner::(observer position)
|
||||||
|
|
||||||
|
choice Accept : ContractId Position
|
||||||
|
controller newOwner
|
||||||
|
do
|
||||||
|
create position with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
choice Cancel : ContractId Position
|
||||||
|
controller position.owner
|
||||||
|
do
|
||||||
|
create position
|
||||||
|
|
||||||
|
-- In a separate package:
|
||||||
|
|
||||||
|
template UpgradeProposal
|
||||||
|
with
|
||||||
|
bank : Party
|
||||||
|
counterparty : Party
|
||||||
|
where
|
||||||
|
signatory bank
|
||||||
|
observer counterparty
|
||||||
|
|
||||||
|
choice Accept_Upgrade : ContractId Upgrader
|
||||||
|
controller counterparty
|
||||||
|
do
|
||||||
|
create Upgrader with ..
|
||||||
|
|
||||||
|
-- As part of the upgrade we have to decide what to do with the
|
||||||
|
-- extra decimal places.
|
||||||
|
-- In this example, we collect them up and issue a new position,
|
||||||
|
-- rounded to two decimals.
|
||||||
|
-- Any additional left-over is left non-upgraded.
|
||||||
|
template Upgrader
|
||||||
|
with
|
||||||
|
bank : Party
|
||||||
|
counterparty : Party
|
||||||
|
where
|
||||||
|
signatory bank, counterparty
|
||||||
|
|
||||||
|
nonconsuming choice Run_Upgrade : ()
|
||||||
|
with
|
||||||
|
positionCids : [ContractId Old.Position]
|
||||||
|
tpCids : [ContractId Old.TransferProposal]
|
||||||
|
controller bank
|
||||||
|
do
|
||||||
|
forA_ positionCids (\positionCid -> do
|
||||||
|
Old.Position{..} <- fetch positionCid
|
||||||
|
owner === counterparty
|
||||||
|
issuer === bank
|
||||||
|
archive positionCid
|
||||||
|
create Position with currency = "USD"; ..
|
||||||
|
)
|
||||||
|
|
||||||
|
forA_ tpCids (\tpCid -> do
|
||||||
|
Old.TransferProposal{position = Old.Position{..}; ..} <- fetch tpCid
|
||||||
|
owner === counterparty
|
||||||
|
issuer === bank
|
||||||
|
archive tpCid
|
||||||
|
create TransferProposal with
|
||||||
|
position = Position with currency = "USD"; ..
|
||||||
|
..
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
while : (Action m) => m Bool -> m ()
|
||||||
|
while run = do
|
||||||
|
continue <- run
|
||||||
|
when continue (while run)
|
||||||
|
|
||||||
|
test_upgrade : Script ()
|
||||||
|
test_upgrade = do
|
||||||
|
(tps@TestParties{..}, tus@TestUsers{..}) <- init_cash
|
||||||
|
|
||||||
|
-- Bank proposes the upgrade
|
||||||
|
submitUser uBank do
|
||||||
|
createCmd UpgradeProposal with
|
||||||
|
bank = pBank
|
||||||
|
counterparty = pAlice
|
||||||
|
createCmd UpgradeProposal with
|
||||||
|
bank = pBank
|
||||||
|
counterparty = pBob
|
||||||
|
return ()
|
||||||
|
|
||||||
|
-- Alice and Bob accept
|
||||||
|
[(pa, _)] <- query @UpgradeProposal pAlice
|
||||||
|
submitUser uAlice do exerciseCmd pa Accept_Upgrade
|
||||||
|
[(pb, _)] <- query @UpgradeProposal pBob
|
||||||
|
submitUser uBob do exerciseCmd pb Accept_Upgrade
|
||||||
|
|
||||||
|
-- Run upgrade in batches of some reasonable size.
|
||||||
|
let batchSize = 10
|
||||||
|
upgraders <- query @Upgrader pBank
|
||||||
|
forA_ upgraders (\(upgraderCid, upgrader) -> do
|
||||||
|
while do
|
||||||
|
poss <- take batchSize <$> queryFilter @Old.Position pBank
|
||||||
|
(\pos -> pos.issuer == pBank && pos.owner == upgrader.counterparty)
|
||||||
|
tps <- take (batchSize - length poss) <$> queryFilter @Old.TransferProposal pBank
|
||||||
|
(\tp -> tp.position.issuer == pBank && tp.position.owner == upgrader.counterparty)
|
||||||
|
|
||||||
|
if (length poss + length tps > 0)
|
||||||
|
then do
|
||||||
|
submitUser uBank do
|
||||||
|
exerciseCmd upgraderCid Run_Upgrade with
|
||||||
|
positionCids = map fst poss
|
||||||
|
tpCids = map fst tps
|
||||||
|
return True
|
||||||
|
else return False
|
||||||
|
return ()
|
||||||
|
)
|
220
daml/Exercise1/Decimals.daml
Normal file
220
daml/Exercise1/Decimals.daml
Normal file
@ -0,0 +1,220 @@
|
|||||||
|
{-# LANGUAGE ApplicativeDo #-}
|
||||||
|
|
||||||
|
module Exercise1.Decimals where
|
||||||
|
|
||||||
|
import Initial.Cash qualified as Old
|
||||||
|
import Initial.Scripts
|
||||||
|
|
||||||
|
import DA.Action
|
||||||
|
import DA.Assert
|
||||||
|
import DA.Foldable (forA_)
|
||||||
|
import Daml.Script
|
||||||
|
|
||||||
|
roundDown : Decimal -> Decimal
|
||||||
|
roundDown (d : Decimal) = (intToDecimal (truncate (d * 100.0))) / 100.0
|
||||||
|
|
||||||
|
template Position
|
||||||
|
with
|
||||||
|
issuer : Party
|
||||||
|
owner : Party
|
||||||
|
quantity : Decimal
|
||||||
|
obs : [Party]
|
||||||
|
where
|
||||||
|
signatory [issuer, owner]
|
||||||
|
observer obs
|
||||||
|
ensure quantity > 0.0 && (roundDown quantity == quantity)
|
||||||
|
|
||||||
|
choice Transfer : ContractId Position
|
||||||
|
with
|
||||||
|
newOwner : Party
|
||||||
|
controller [owner, newOwner]
|
||||||
|
do
|
||||||
|
create this with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
choice Propose_Transfer : ContractId TransferProposal
|
||||||
|
with
|
||||||
|
newOwner : Party
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
create TransferProposal with
|
||||||
|
position = this
|
||||||
|
newOwner
|
||||||
|
|
||||||
|
choice Split : (ContractId Position, [ContractId Position])
|
||||||
|
with
|
||||||
|
splitQuantities : [Decimal]
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
remCid <- create this with quantity = this.quantity - sum splitQuantities
|
||||||
|
splitCids <- forA splitQuantities (\splitQuantity -> create this with
|
||||||
|
quantity = splitQuantity
|
||||||
|
)
|
||||||
|
return (remCid, splitCids)
|
||||||
|
|
||||||
|
choice Merge : ContractId Position
|
||||||
|
with
|
||||||
|
otherCids : [ContractId Position]
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
quantities <- forA otherCids (\otherCid -> do
|
||||||
|
other <- fetch otherCid
|
||||||
|
other === this with
|
||||||
|
quantity = other.quantity
|
||||||
|
obs = other.obs
|
||||||
|
archive otherCid
|
||||||
|
return other.quantity)
|
||||||
|
create this with
|
||||||
|
quantity = quantity + sum quantities
|
||||||
|
|
||||||
|
template TransferProposal
|
||||||
|
with
|
||||||
|
position : Position
|
||||||
|
newOwner : Party
|
||||||
|
where
|
||||||
|
signatory (signatory position)
|
||||||
|
observer newOwner::(observer position)
|
||||||
|
|
||||||
|
choice Accept : ContractId Position
|
||||||
|
controller newOwner
|
||||||
|
do
|
||||||
|
create position with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
choice Cancel : ContractId Position
|
||||||
|
controller position.owner
|
||||||
|
do
|
||||||
|
create position
|
||||||
|
|
||||||
|
-- In a separate package:
|
||||||
|
|
||||||
|
template UpgradeProposal
|
||||||
|
with
|
||||||
|
bank : Party
|
||||||
|
counterparty : Party
|
||||||
|
where
|
||||||
|
signatory bank
|
||||||
|
observer counterparty
|
||||||
|
|
||||||
|
choice Accept_Upgrade : ContractId Upgrader
|
||||||
|
controller counterparty
|
||||||
|
do
|
||||||
|
create Upgrader with ..
|
||||||
|
|
||||||
|
-- As part of the upgrade we have to decide what to do with the
|
||||||
|
-- extra decimal places.
|
||||||
|
-- In this example, we collect them up and issue a new position,
|
||||||
|
-- rounded to two decimals.
|
||||||
|
-- Any additional left-over is left non-upgraded.
|
||||||
|
template Upgrader
|
||||||
|
with
|
||||||
|
bank : Party
|
||||||
|
counterparty : Party
|
||||||
|
where
|
||||||
|
signatory bank, counterparty
|
||||||
|
|
||||||
|
nonconsuming choice Run_Upgrade : ()
|
||||||
|
with
|
||||||
|
positionCids : [ContractId Old.Position]
|
||||||
|
tpCids : [ContractId Old.TransferProposal]
|
||||||
|
controller bank
|
||||||
|
do
|
||||||
|
let
|
||||||
|
splitPosition Old.Position{..} =
|
||||||
|
let newQuantity = roundDown quantity
|
||||||
|
newPosition = Position with quantity = newQuantity; ..
|
||||||
|
rem = quantity - newQuantity
|
||||||
|
in (newPosition, rem)
|
||||||
|
cyclePosition p = do
|
||||||
|
let (newPosition, rem) = splitPosition p
|
||||||
|
create newPosition
|
||||||
|
return rem
|
||||||
|
cycleTp Old.TransferProposal{..} = do
|
||||||
|
let (newPosition, rem) = splitPosition position
|
||||||
|
create TransferProposal with position = newPosition; ..
|
||||||
|
return rem
|
||||||
|
|
||||||
|
posRems <- forA positionCids (\positionCid -> do
|
||||||
|
position <- fetch positionCid
|
||||||
|
position.owner === counterparty
|
||||||
|
position.issuer === bank
|
||||||
|
archive positionCid
|
||||||
|
cyclePosition position
|
||||||
|
)
|
||||||
|
|
||||||
|
tpRems <- forA tpCids (\tpCid -> do
|
||||||
|
tp <- fetch tpCid
|
||||||
|
tp.position.owner === counterparty
|
||||||
|
tp.position.issuer === bank
|
||||||
|
archive tpCid
|
||||||
|
cycleTp tp
|
||||||
|
)
|
||||||
|
|
||||||
|
let
|
||||||
|
totalRem = sum posRems + sum tpRems
|
||||||
|
roundedRems = roundDown totalRem
|
||||||
|
remRem = totalRem - roundedRems
|
||||||
|
|
||||||
|
|
||||||
|
when (roundedRems > 0.0) do
|
||||||
|
void $ create Position with
|
||||||
|
issuer = bank
|
||||||
|
owner = counterparty
|
||||||
|
quantity = roundedRems
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
when (remRem > 0.0) do
|
||||||
|
void $ create Old.Position with
|
||||||
|
issuer = bank
|
||||||
|
owner = counterparty
|
||||||
|
quantity = remRem
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
|
||||||
|
while : (Action m) => m Bool -> m ()
|
||||||
|
while run = do
|
||||||
|
continue <- run
|
||||||
|
when continue (while run)
|
||||||
|
|
||||||
|
test_upgrade : Script ()
|
||||||
|
test_upgrade = do
|
||||||
|
(tps@TestParties{..}, tus@TestUsers{..}) <- init_cash
|
||||||
|
|
||||||
|
-- Bank proposes the upgrade
|
||||||
|
submitUser uBank do
|
||||||
|
createCmd UpgradeProposal with
|
||||||
|
bank = pBank
|
||||||
|
counterparty = pAlice
|
||||||
|
createCmd UpgradeProposal with
|
||||||
|
bank = pBank
|
||||||
|
counterparty = pBob
|
||||||
|
return ()
|
||||||
|
|
||||||
|
-- Alice and Bob accept
|
||||||
|
[(pa, _)] <- query @UpgradeProposal pAlice
|
||||||
|
submitUser uAlice do exerciseCmd pa Accept_Upgrade
|
||||||
|
[(pb, _)] <- query @UpgradeProposal pBob
|
||||||
|
submitUser uBob do exerciseCmd pb Accept_Upgrade
|
||||||
|
|
||||||
|
-- Run upgrade in batches of some reasonable size.
|
||||||
|
let batchSize = 10
|
||||||
|
upgraders <- query @Upgrader pBank
|
||||||
|
forA_ upgraders (\(upgraderCid, upgrader) -> do
|
||||||
|
while do
|
||||||
|
poss <- take batchSize <$> queryFilter @Old.Position pBank
|
||||||
|
(\pos -> pos.issuer == pBank && pos.owner == upgrader.counterparty)
|
||||||
|
tps <- take (batchSize - length poss) <$> queryFilter @Old.TransferProposal pBank
|
||||||
|
(\tp -> tp.position.issuer == pBank && tp.position.owner == upgrader.counterparty)
|
||||||
|
|
||||||
|
if (length poss + length tps > 0)
|
||||||
|
then do
|
||||||
|
submitUser uBank do
|
||||||
|
exerciseCmd upgraderCid Run_Upgrade with
|
||||||
|
positionCids = map fst poss
|
||||||
|
tpCids = map fst tps
|
||||||
|
return True
|
||||||
|
else return False
|
||||||
|
return ()
|
||||||
|
)
|
27
daml/Exercise1/KYC.daml
Normal file
27
daml/Exercise1/KYC.daml
Normal file
@ -0,0 +1,27 @@
|
|||||||
|
module Exercise1.KYC where
|
||||||
|
|
||||||
|
import Initial.Scripts
|
||||||
|
|
||||||
|
import Daml.Script
|
||||||
|
|
||||||
|
template KYC
|
||||||
|
with
|
||||||
|
bank : Party
|
||||||
|
counterparty : Party
|
||||||
|
address : Text
|
||||||
|
where
|
||||||
|
signatory bank
|
||||||
|
observer counterparty
|
||||||
|
|
||||||
|
test_set_obs : Script ()
|
||||||
|
test_set_obs = script do
|
||||||
|
(tps@TestParties{..}, tus@TestUsers{..}) <- init_cash
|
||||||
|
|
||||||
|
-- Bank captures KYC data
|
||||||
|
rules <- submitUser uBank do
|
||||||
|
createCmd KYC with
|
||||||
|
bank = pBank
|
||||||
|
counterparty = pAlice
|
||||||
|
address = "Earth"
|
||||||
|
|
||||||
|
return ()
|
55
daml/Exercise1/Observers.daml
Normal file
55
daml/Exercise1/Observers.daml
Normal file
@ -0,0 +1,55 @@
|
|||||||
|
module Exercise1.Observers where
|
||||||
|
|
||||||
|
import Initial.Cash
|
||||||
|
import Initial.Scripts
|
||||||
|
|
||||||
|
import DA.Assert
|
||||||
|
import DA.Foldable (forA_)
|
||||||
|
import Daml.Script
|
||||||
|
|
||||||
|
template AdditionalRules
|
||||||
|
with
|
||||||
|
bank : Party
|
||||||
|
bankReader : Party
|
||||||
|
where
|
||||||
|
signatory bank
|
||||||
|
observer bankReader
|
||||||
|
|
||||||
|
nonconsuming choice Set_Observers : ContractId Position
|
||||||
|
with
|
||||||
|
owner : Party
|
||||||
|
positionCid : ContractId Position
|
||||||
|
new_obs : [Party]
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
position <- fetch positionCid
|
||||||
|
owner === position.owner
|
||||||
|
bank === position.issuer
|
||||||
|
|
||||||
|
archive positionCid
|
||||||
|
create position with obs = new_obs
|
||||||
|
|
||||||
|
test_set_obs : Script ()
|
||||||
|
test_set_obs = script do
|
||||||
|
(tps@TestParties{..}, tus@TestUsers{..}) <- init_cash
|
||||||
|
|
||||||
|
-- Create a reader party and give access to Alice and Bob
|
||||||
|
pBankReader <- allocateParty "BankReader"
|
||||||
|
grantUserRights uAlice [CanReadAs pBankReader]
|
||||||
|
grantUserRights uBob [CanReadAs pBankReader]
|
||||||
|
|
||||||
|
-- Bank Issues the new rule
|
||||||
|
rules <- submitUser uBank do
|
||||||
|
createCmd AdditionalRules with
|
||||||
|
bank = pBank
|
||||||
|
bankReader = pBankReader
|
||||||
|
|
||||||
|
-- Alice can make Bob observer on all her positions
|
||||||
|
alicePositions <- query @Position pAlice
|
||||||
|
forA_ (alicePositions) (\(cid, _) -> do
|
||||||
|
submitUser uAlice do
|
||||||
|
exerciseCmd rules Set_Observers with
|
||||||
|
owner = pAlice
|
||||||
|
positionCid = cid
|
||||||
|
new_obs = [pBob]
|
||||||
|
)
|
108
daml/Exercise2/Cash.daml
Normal file
108
daml/Exercise2/Cash.daml
Normal file
@ -0,0 +1,108 @@
|
|||||||
|
module Exercise2.Cash where
|
||||||
|
|
||||||
|
import DA.Assert
|
||||||
|
|
||||||
|
template Position
|
||||||
|
with
|
||||||
|
issuer : Party
|
||||||
|
owner : Party
|
||||||
|
quantity : Decimal
|
||||||
|
obs : [Party]
|
||||||
|
where
|
||||||
|
signatory [issuer, owner]
|
||||||
|
observer obs
|
||||||
|
ensure quantity > 0.0
|
||||||
|
|
||||||
|
template TransferProposal
|
||||||
|
with
|
||||||
|
position : Position
|
||||||
|
newOwner : Party
|
||||||
|
where
|
||||||
|
signatory (signatory position)
|
||||||
|
observer newOwner::(observer position)
|
||||||
|
|
||||||
|
template CashRules
|
||||||
|
with
|
||||||
|
bank : Party
|
||||||
|
bankReader : Party
|
||||||
|
where
|
||||||
|
signatory bank
|
||||||
|
observer bankReader
|
||||||
|
|
||||||
|
nonconsuming choice Transfer : ContractId Position
|
||||||
|
with
|
||||||
|
owner : Party
|
||||||
|
newOwner : Party
|
||||||
|
cid : ContractId Position
|
||||||
|
controller [owner, newOwner]
|
||||||
|
do
|
||||||
|
pos <- fetch cid
|
||||||
|
pos.issuer === bank
|
||||||
|
pos.owner === owner
|
||||||
|
create pos with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
nonconsuming choice Propose_Transfer : ContractId TransferProposal
|
||||||
|
with
|
||||||
|
owner : Party
|
||||||
|
newOwner : Party
|
||||||
|
cid : ContractId Position
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
pos <- fetch cid
|
||||||
|
pos.issuer === bank
|
||||||
|
pos.owner === owner
|
||||||
|
create TransferProposal with
|
||||||
|
position = pos
|
||||||
|
newOwner
|
||||||
|
|
||||||
|
nonconsuming choice Redistribute : (ContractId Position, [ContractId Position])
|
||||||
|
with
|
||||||
|
owner : Party
|
||||||
|
cids : [ContractId Position]
|
||||||
|
splitQuantities : [Decimal]
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
qs <- forA cids (\cid -> do
|
||||||
|
pos <- fetch cid
|
||||||
|
pos.issuer === bank
|
||||||
|
pos.owner === owner
|
||||||
|
archive cid
|
||||||
|
return pos.quantity
|
||||||
|
)
|
||||||
|
let
|
||||||
|
total = sum qs
|
||||||
|
issuer = bank
|
||||||
|
obs = []
|
||||||
|
remCid <- create Position with quantity = total - sum splitQuantities; ..
|
||||||
|
splitCids <- forA splitQuantities (\splitQuantity -> create Position with
|
||||||
|
quantity = splitQuantity
|
||||||
|
..
|
||||||
|
)
|
||||||
|
return (remCid, splitCids)
|
||||||
|
|
||||||
|
nonconsuming choice Accept_TransferProposal : ContractId Position
|
||||||
|
with
|
||||||
|
newOwner : Party
|
||||||
|
tpCid : ContractId TransferProposal
|
||||||
|
controller newOwner
|
||||||
|
do
|
||||||
|
tp <- fetch tpCid
|
||||||
|
tp.position.issuer === bank
|
||||||
|
tp.newOwner === newOwner
|
||||||
|
create tp.position with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
nonconsuming choice Cancel : ContractId Position
|
||||||
|
with
|
||||||
|
owner : Party
|
||||||
|
tpCid : ContractId TransferProposal
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
tp <- fetch tpCid
|
||||||
|
tp.position.issuer === bank
|
||||||
|
tp.position.owner === owner
|
||||||
|
create tp.position
|
||||||
|
|
102
daml/Exercise2/Scripts.daml
Normal file
102
daml/Exercise2/Scripts.daml
Normal file
@ -0,0 +1,102 @@
|
|||||||
|
module Exercise2.Scripts where
|
||||||
|
|
||||||
|
import Exercise2.Cash
|
||||||
|
|
||||||
|
import Daml.Script
|
||||||
|
import DA.Action
|
||||||
|
import DA.Foldable (forA_)
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
-- Create a reader party and give access to Alice and Bob
|
||||||
|
pBankReader <- allocateParty "BankReader"
|
||||||
|
grantUserRights uAlice [CanReadAs pBankReader]
|
||||||
|
grantUserRights uBob [CanReadAs pBankReader]
|
||||||
|
|
||||||
|
-- Bank Issues the new rule
|
||||||
|
rules <- submitUser uBank do
|
||||||
|
createCmd CashRules with
|
||||||
|
bank = pBank
|
||||||
|
bankReader = pBankReader
|
||||||
|
|
||||||
|
-- Issue some cash in the form of transfer proposals.
|
||||||
|
let position = Position with
|
||||||
|
issuer = pBank
|
||||||
|
owner = pBank
|
||||||
|
obs = []
|
||||||
|
quantity = 1.0
|
||||||
|
|
||||||
|
-- 200 positions of $1 for Alice
|
||||||
|
replicateA_ 20 $ submitUser uBank do
|
||||||
|
replicateA_ 10 $ createCmd TransferProposal with
|
||||||
|
position
|
||||||
|
newOwner = pAlice
|
||||||
|
|
||||||
|
-- 100 positions for Bob
|
||||||
|
replicateA_ 10 $ submitUser uBank do
|
||||||
|
replicateA_ 10 $ createCmd TransferProposal with
|
||||||
|
position
|
||||||
|
newOwner = pBob
|
||||||
|
|
||||||
|
-- Accept all transfer proposals
|
||||||
|
let
|
||||||
|
accept_all (u, p) = do
|
||||||
|
proposals <- queryFilter @TransferProposal p (\tp -> tp.newOwner == p)
|
||||||
|
submitUser u do
|
||||||
|
forA_ proposals (\(cid, _) ->
|
||||||
|
exerciseCmd rules Accept_TransferProposal with
|
||||||
|
tpCid = cid
|
||||||
|
newOwner = p
|
||||||
|
)
|
||||||
|
forA_ [(uAlice, pAlice), (uBob, pBob)] accept_all
|
||||||
|
|
||||||
|
-- Alice transfers 50 of her positions to Bob
|
||||||
|
alicePositions <- query @Position pAlice
|
||||||
|
forA_ (take 50 alicePositions) (\(cid, _) -> do
|
||||||
|
submitUser uAlice do
|
||||||
|
exerciseCmd rules Propose_Transfer with
|
||||||
|
owner = pAlice
|
||||||
|
newOwner = pBob
|
||||||
|
cid
|
||||||
|
)
|
||||||
|
|
||||||
|
return (ps, us)
|
122
daml/Exercise2/Upgrade.daml
Normal file
122
daml/Exercise2/Upgrade.daml
Normal file
@ -0,0 +1,122 @@
|
|||||||
|
module Exercise2.Upgrade where
|
||||||
|
|
||||||
|
|
||||||
|
import Exercise2.Cash qualified as Old (CashRules(..))
|
||||||
|
import Exercise2.Cash (Position(..), TransferProposal(..))
|
||||||
|
import Exercise2.Scripts
|
||||||
|
|
||||||
|
import DA.Assert
|
||||||
|
import Daml.Script
|
||||||
|
|
||||||
|
roundDown : Decimal -> Decimal
|
||||||
|
roundDown (d : Decimal) = (intToDecimal (truncate (d * 100.0))) / 100.0
|
||||||
|
|
||||||
|
template CashRules
|
||||||
|
with
|
||||||
|
bank : Party
|
||||||
|
bankReader : Party
|
||||||
|
where
|
||||||
|
signatory bank
|
||||||
|
observer bankReader
|
||||||
|
|
||||||
|
nonconsuming choice Transfer : ContractId Position
|
||||||
|
with
|
||||||
|
owner : Party
|
||||||
|
newOwner : Party
|
||||||
|
cid : ContractId Position
|
||||||
|
controller [owner, newOwner]
|
||||||
|
do
|
||||||
|
pos <- fetch cid
|
||||||
|
pos.issuer === bank
|
||||||
|
pos.owner === owner
|
||||||
|
create pos with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
nonconsuming choice Propose_Transfer : ContractId TransferProposal
|
||||||
|
with
|
||||||
|
owner : Party
|
||||||
|
newOwner : Party
|
||||||
|
cid : ContractId Position
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
pos <- fetch cid
|
||||||
|
pos.issuer === bank
|
||||||
|
pos.owner === owner
|
||||||
|
create TransferProposal with
|
||||||
|
position = pos
|
||||||
|
newOwner
|
||||||
|
|
||||||
|
nonconsuming choice Redistribute : (ContractId Position, [ContractId Position])
|
||||||
|
with
|
||||||
|
owner : Party
|
||||||
|
cids : [ContractId Position]
|
||||||
|
splitQuantities : [Decimal]
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
qs <- forA cids (\cid -> do
|
||||||
|
pos <- fetch cid
|
||||||
|
pos.issuer === bank
|
||||||
|
pos.owner === owner
|
||||||
|
archive cid
|
||||||
|
return pos.quantity
|
||||||
|
)
|
||||||
|
let
|
||||||
|
total = sum qs
|
||||||
|
issuer = bank
|
||||||
|
obs = []
|
||||||
|
remCid <- create Position with quantity = total - sum splitQuantities; ..
|
||||||
|
splitCids <- forA splitQuantities (\splitQuantity -> do
|
||||||
|
splitQuantity === roundDown splitQuantity
|
||||||
|
create Position with
|
||||||
|
quantity = splitQuantity
|
||||||
|
..
|
||||||
|
)
|
||||||
|
return (remCid, splitCids)
|
||||||
|
|
||||||
|
nonconsuming choice Accept_TransferProposal : ContractId Position
|
||||||
|
with
|
||||||
|
newOwner : Party
|
||||||
|
tpCid : ContractId TransferProposal
|
||||||
|
controller newOwner
|
||||||
|
do
|
||||||
|
tp <- fetch tpCid
|
||||||
|
tp.position.issuer === bank
|
||||||
|
tp.newOwner === newOwner
|
||||||
|
create tp.position with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
nonconsuming choice Cancel : ContractId Position
|
||||||
|
with
|
||||||
|
owner : Party
|
||||||
|
tpCid : ContractId TransferProposal
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
tp <- fetch tpCid
|
||||||
|
tp.position.issuer === bank
|
||||||
|
tp.position.owner === owner
|
||||||
|
create tp.position
|
||||||
|
|
||||||
|
test_upgrade : Script ()
|
||||||
|
test_upgrade = script do
|
||||||
|
(tps@TestParties{..}, tus@TestUsers{..}) <- init_cash
|
||||||
|
|
||||||
|
-- Create a reader party and give access to Alice and Bob
|
||||||
|
pBankReader <- allocateParty "BankReader"
|
||||||
|
grantUserRights uAlice [CanReadAs pBankReader]
|
||||||
|
grantUserRights uBob [CanReadAs pBankReader]
|
||||||
|
|
||||||
|
-- Bank Issues the new rule
|
||||||
|
rules <- submitUser uBank do
|
||||||
|
createCmd CashRules with
|
||||||
|
bank = pBank
|
||||||
|
bankReader = pBankReader
|
||||||
|
|
||||||
|
-- Bank removes the old rules
|
||||||
|
[(cid, _)] <- query @Old.CashRules pBank
|
||||||
|
submitUser uBank do
|
||||||
|
archiveCmd cid
|
||||||
|
|
||||||
|
-- No further upgrade needed as there are no existing assets with
|
||||||
|
-- More than two decimals.
|
116
daml/Exercise3/Solutions/Bonds.daml
Normal file
116
daml/Exercise3/Solutions/Bonds.daml
Normal file
@ -0,0 +1,116 @@
|
|||||||
|
module Exercise3.Solutions.Bonds where
|
||||||
|
|
||||||
|
import Exercise3.Solutions.Modularized.Interfaces
|
||||||
|
import Exercise3.Solutions.Modularized.Swap
|
||||||
|
import Exercise3.Solutions.Modularized.Cash
|
||||||
|
import Exercise3.Solutions.Modularized.Scripts
|
||||||
|
|
||||||
|
import Daml.Script
|
||||||
|
|
||||||
|
import DA.Action
|
||||||
|
import DA.Foldable (forA_)
|
||||||
|
|
||||||
|
template Bond
|
||||||
|
with
|
||||||
|
issuer : Party
|
||||||
|
owner : Party
|
||||||
|
quantity : Decimal
|
||||||
|
obs : [Party]
|
||||||
|
where
|
||||||
|
signatory [issuer, owner]
|
||||||
|
observer obs
|
||||||
|
|
||||||
|
interface instance IAsset for Bond where
|
||||||
|
view = VAsset with
|
||||||
|
assetType = "Bond"
|
||||||
|
..
|
||||||
|
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 $ BondTransferProposal with bond = this; ..
|
||||||
|
|
||||||
|
-- Workaround for https://github.com/digital-asset/daml/issues/15459
|
||||||
|
myView2 = view
|
||||||
|
|
||||||
|
template BondTransferProposal
|
||||||
|
with
|
||||||
|
newOwner : Party
|
||||||
|
bond : Bond
|
||||||
|
where
|
||||||
|
signatory (signatory bond)
|
||||||
|
observer newOwner
|
||||||
|
|
||||||
|
interface instance IAssetTransferProposal for BondTransferProposal where
|
||||||
|
view = VAssetTransferProposal with
|
||||||
|
newOwner = newOwner
|
||||||
|
vasset = myView2 (toInterface @IAsset bond)
|
||||||
|
asset = toInterface @IAsset bond
|
||||||
|
|
||||||
|
|
||||||
|
init_bonds : TestParties -> TestUsers -> Script ()
|
||||||
|
init_bonds TestParties{..} TestUsers{..} = do
|
||||||
|
-- Issue some bonds in the form of transfer proposals.
|
||||||
|
let bond = Bond with
|
||||||
|
issuer = pBank
|
||||||
|
owner = pBank
|
||||||
|
obs = []
|
||||||
|
quantity = 1.0
|
||||||
|
|
||||||
|
-- 2 positions for Alice
|
||||||
|
replicateA_ 1 $ submitUser uBank do
|
||||||
|
replicateA_ 2 $ createCmd BondTransferProposal with
|
||||||
|
bond
|
||||||
|
newOwner = pAlice
|
||||||
|
|
||||||
|
-- 1 positionsfor Bob
|
||||||
|
replicateA_ 1 $ submitUser uBank do
|
||||||
|
replicateA_ 1 $ createCmd BondTransferProposal with
|
||||||
|
bond
|
||||||
|
newOwner = pBob
|
||||||
|
|
||||||
|
-- Accept all transfer proposals
|
||||||
|
let
|
||||||
|
accept_all p = do
|
||||||
|
proposals <- queryFilter @BondTransferProposal 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 @Bond pAlice
|
||||||
|
forA_ (take 1 alicePositions) (\(cid, _) -> do
|
||||||
|
submitUser uAlice do
|
||||||
|
exerciseCmd (toInterfaceContractId @IAsset cid) Propose_Transfer with
|
||||||
|
newOwner = pBob
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
test_bond : Script ()
|
||||||
|
test_bond = script do
|
||||||
|
(tps@TestParties{..}, tus@TestUsers{..}) <- test_swap
|
||||||
|
|
||||||
|
init_bonds tps tus
|
||||||
|
|
||||||
|
-- Swap cash for bond
|
||||||
|
-- Alice proposes a new swap, Cash for Bond
|
||||||
|
(cid, posa)::_ <- query @Cash pAlice
|
||||||
|
cid <- submitUser uAlice do
|
||||||
|
exerciseCmd (toInterfaceContractId @IAsset cid) Set_Observers with newObs = [pBob]
|
||||||
|
|
||||||
|
let offerSpec = (pBank, "Cash", posa.quantity)
|
||||||
|
requestedSpec = (pBank, "Bond", posa.quantity)
|
||||||
|
swapCid <- submitUser uAlice do
|
||||||
|
createCmd AssetSwapProposal with
|
||||||
|
requester = pAlice
|
||||||
|
receiver = pBob
|
||||||
|
offerSpec
|
||||||
|
requestedSpec
|
||||||
|
offerCid = toInterfaceContractId @IAsset cid
|
||||||
|
|
||||||
|
-- Bob accepts using a Bond.
|
||||||
|
(cid, _)::_ <- queryFilter @Bond pBob (\posb -> posb.owner == pBob && posb.quantity == posa.quantity)
|
||||||
|
submitUser uBob do
|
||||||
|
exerciseCmd swapCid Settle with requestedCid = toInterfaceContractId @IAsset cid
|
||||||
|
|
||||||
|
|
||||||
|
return ()
|
133
daml/Exercise3/Solutions/Currency/Bonus/Interfaces.daml
Normal file
133
daml/Exercise3/Solutions/Currency/Bonus/Interfaces.daml
Normal file
@ -0,0 +1,133 @@
|
|||||||
|
-- This should be its own package!
|
||||||
|
|
||||||
|
module Exercise3.Solutions.Currency.Bonus.Interfaces where
|
||||||
|
|
||||||
|
-- This module is not really needed as part of the solution.
|
||||||
|
-- It demonstrates how to also upgrade in such a way that
|
||||||
|
-- "Cash" becomes "USD" and "Cash_V2 CHF" becomes merely "CHF".
|
||||||
|
|
||||||
|
import Exercise3.Solutions.Modularized.Cash qualified as V1
|
||||||
|
import Exercise3.Solutions.Currency.Cash qualified as V2
|
||||||
|
|
||||||
|
import DA.Assert
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
-- Workaround for https://github.com/digital-asset/daml/issues/15459
|
||||||
|
myView = view
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
-- Implement the new interface for old transfer proposals.
|
||||||
|
interface instance IAssetTransferProposal for V1.CashTransferProposal where
|
||||||
|
view = VAssetTransferProposal with
|
||||||
|
newOwner = newOwner
|
||||||
|
vasset = myView (toInterface @IAsset cash)
|
||||||
|
asset = toInterface @IAsset cash
|
||||||
|
|
||||||
|
-- Implement the new interface for new transfer proposals.
|
||||||
|
interface instance IAssetTransferProposal for V2.CashTransferProposal where
|
||||||
|
view = VAssetTransferProposal with
|
||||||
|
newOwner = newOwner
|
||||||
|
vasset = myView (toInterface @IAsset cash)
|
||||||
|
asset = toInterface @IAsset cash
|
||||||
|
|
||||||
|
|
||||||
|
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 ()
|
||||||
|
|
||||||
|
-- Implement the new interface for old cash, setting currency to USD.
|
||||||
|
interface instance IAsset for V1.Cash where
|
||||||
|
view = VAsset with
|
||||||
|
assetType = "USD"
|
||||||
|
..
|
||||||
|
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 $ V1.CashTransferProposal with cash = this; ..
|
||||||
|
|
||||||
|
-- Implement the new interface for new cash
|
||||||
|
interface instance IAsset for V2.Cash where
|
||||||
|
view = VAsset with
|
||||||
|
assetType = currency
|
||||||
|
..
|
||||||
|
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 $ V2.CashTransferProposal with cash = this; ..
|
67
daml/Exercise3/Solutions/Currency/Bonus/Scripts.daml
Normal file
67
daml/Exercise3/Solutions/Currency/Bonus/Scripts.daml
Normal file
@ -0,0 +1,67 @@
|
|||||||
|
module Exercise3.Solutions.Currency.Bonus.Scripts where
|
||||||
|
|
||||||
|
import Exercise3.Solutions.Currency.Cash qualified as V2.Cash
|
||||||
|
import Exercise3.Solutions.Modularized.Cash qualified as V1.Cash
|
||||||
|
import Exercise3.Solutions.Modularized.Scripts
|
||||||
|
import Exercise3.Solutions.Currency.Scripts
|
||||||
|
import Exercise3.Solutions.Currency.Bonus.Interfaces
|
||||||
|
import Exercise3.Solutions.Currency.Bonus.Swap
|
||||||
|
|
||||||
|
import Daml.Script
|
||||||
|
|
||||||
|
test_bonus : Script ()
|
||||||
|
test_bonus = script do
|
||||||
|
(tps@TestParties{..}, tus@TestUsers{..}) <- test_upgrade
|
||||||
|
|
||||||
|
-- Optional extra to change the ugly "V2_Cash CHF" and "Cash" to "CHF" and "USD"
|
||||||
|
|
||||||
|
-- NEW SWAP, OLD ASSETS
|
||||||
|
-- Alice proposes a new swap, USD for USD, but allocates using an old asset.
|
||||||
|
(cid, posa)::_ <- query @V1.Cash.Cash pAlice
|
||||||
|
cid <- submitUser uAlice do
|
||||||
|
exerciseCmd (toInterfaceContractId @IAsset cid) Set_Observers with newObs = [pBob]
|
||||||
|
|
||||||
|
let assetSpec = (pBank, "USD", posa.quantity)
|
||||||
|
swapCid <- submitUser uAlice do
|
||||||
|
createCmd AssetSwapProposal with
|
||||||
|
requester = pAlice
|
||||||
|
receiver = pBob
|
||||||
|
offerSpec = assetSpec
|
||||||
|
requestedSpec = assetSpec
|
||||||
|
offerCid = toInterfaceContractId @IAsset cid
|
||||||
|
|
||||||
|
-- Bob accepts using an old asset.
|
||||||
|
(cid, _)::_ <- queryFilter @V1.Cash.Cash pBob (\posb -> posb.owner == pBob && posb.quantity == posa.quantity)
|
||||||
|
submitUser uBob do
|
||||||
|
exerciseCmd swapCid Settle with requestedCid = toInterfaceContractId @IAsset cid
|
||||||
|
|
||||||
|
-- NEW SWAP, MIX OF ASSETS, MIX OF CURRENCIES
|
||||||
|
-- Alice proposes a new swap, USD for CHF, but allocates using an old asset.
|
||||||
|
(cid, posa)::_ <- queryFilter @V1.Cash.Cash pAlice (\pos -> pos.owner == pAlice)
|
||||||
|
cid <- submitUser uAlice do
|
||||||
|
exerciseCmd (toInterfaceContractId @IAsset cid) Set_Observers with newObs = [pBob]
|
||||||
|
|
||||||
|
let offerSpec = (pBank, "USD", posa.quantity)
|
||||||
|
requestedSpec = (pBank, "CHF", posa.quantity)
|
||||||
|
swapCid <- submitUser uAlice do
|
||||||
|
createCmd AssetSwapProposal with
|
||||||
|
requester = pAlice
|
||||||
|
receiver = pBob
|
||||||
|
offerSpec
|
||||||
|
requestedSpec
|
||||||
|
offerCid = toInterfaceContractId @IAsset cid
|
||||||
|
|
||||||
|
-- Bob accepts using a new asset.
|
||||||
|
(cid, _)::_ <- queryFilter @V2.Cash.Cash pBob (\posb -> posb.owner == pBob && posb.quantity == posa.quantity && posb.currency == "CHF")
|
||||||
|
submitUser uBob do
|
||||||
|
exerciseCmd swapCid Settle with requestedCid = toInterfaceContractId @IAsset cid
|
||||||
|
|
||||||
|
-- Bob can merge his old cash positions into the new cash.
|
||||||
|
[(new_cid, _)] <- queryFilter @V2.Cash.Cash pBob (\posb -> posb.owner == pBob && posb.currency == "USD")
|
||||||
|
old_cids <- map (toInterfaceContractId @IAsset . fst) <$>
|
||||||
|
queryFilter @V1.Cash.Cash pBob (\posb -> posb.owner == pBob)
|
||||||
|
submitUser uBob do
|
||||||
|
exerciseCmd (toInterfaceContractId @IAsset new_cid) Merge with
|
||||||
|
otherCids = old_cids
|
||||||
|
|
||||||
|
return ()
|
49
daml/Exercise3/Solutions/Currency/Bonus/Swap.daml
Normal file
49
daml/Exercise3/Solutions/Currency/Bonus/Swap.daml
Normal file
@ -0,0 +1,49 @@
|
|||||||
|
-- This should be its own package!
|
||||||
|
|
||||||
|
module Exercise3.Solutions.Currency.Bonus.Swap where
|
||||||
|
|
||||||
|
import Exercise3.Solutions.Currency.Bonus.Interfaces
|
||||||
|
|
||||||
|
import DA.Assert
|
||||||
|
|
||||||
|
-- This module is not really needed as part of the solution.
|
||||||
|
-- It demonstrates how to also upgrade in such a way that
|
||||||
|
-- "Cash" becomes "USD" and "Cash_V2 CHF" becomes merely "CHF".
|
||||||
|
|
||||||
|
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 ()
|
||||||
|
|
46
daml/Exercise3/Solutions/Currency/Cash.daml
Normal file
46
daml/Exercise3/Solutions/Currency/Cash.daml
Normal file
@ -0,0 +1,46 @@
|
|||||||
|
-- This should be its own package!
|
||||||
|
|
||||||
|
module Exercise3.Solutions.Currency.Cash where
|
||||||
|
|
||||||
|
import Exercise3.Solutions.Modularized.Interfaces
|
||||||
|
|
||||||
|
template Cash
|
||||||
|
with
|
||||||
|
issuer : Party
|
||||||
|
owner : Party
|
||||||
|
quantity : Decimal
|
||||||
|
currency : Text
|
||||||
|
obs : [Party]
|
||||||
|
where
|
||||||
|
signatory [issuer, owner]
|
||||||
|
observer obs
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- Make new cash backwards compatible in case currency is USD.
|
||||||
|
interface instance IAsset for Cash where
|
||||||
|
view = VAsset with
|
||||||
|
assetType = if currency == "USD" then "Cash" else "V2_Cash " <> currency
|
||||||
|
..
|
||||||
|
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
|
||||||
|
|
||||||
|
-- Make new transfer proposals backwards compatible in case currency is USD.
|
||||||
|
interface instance IAssetTransferProposal for CashTransferProposal where
|
||||||
|
view = VAssetTransferProposal with
|
||||||
|
newOwner = newOwner
|
||||||
|
vasset = myView (toInterface @IAsset cash)
|
||||||
|
asset = toInterface @IAsset cash
|
109
daml/Exercise3/Solutions/Currency/Scripts.daml
Normal file
109
daml/Exercise3/Solutions/Currency/Scripts.daml
Normal file
@ -0,0 +1,109 @@
|
|||||||
|
-- This should be its own package!
|
||||||
|
|
||||||
|
module Exercise3.Solutions.Currency.Scripts where
|
||||||
|
|
||||||
|
import Exercise3.Solutions.Currency.Cash qualified as V2.Cash
|
||||||
|
import Exercise3.Solutions.Modularized.Cash qualified as V1.Cash
|
||||||
|
import Exercise3.Solutions.Modularized.Interfaces
|
||||||
|
import Exercise3.Solutions.Modularized.Scripts
|
||||||
|
import Exercise3.Solutions.Modularized.Swap
|
||||||
|
|
||||||
|
import Daml.Script
|
||||||
|
|
||||||
|
import DA.Action
|
||||||
|
import DA.Foldable (forA_)
|
||||||
|
|
||||||
|
-- Scripts
|
||||||
|
|
||||||
|
init_cash_v2 : TestParties -> TestUsers -> Script ()
|
||||||
|
init_cash_v2 TestParties{..} TestUsers{..} = do
|
||||||
|
-- Bank issues some new assets in both USD and CHF
|
||||||
|
|
||||||
|
forA_ ["USD", "CHF"] (\currency -> do
|
||||||
|
-- Issue some cash in the form of transfer proposals.
|
||||||
|
let cash = V2.Cash.Cash with
|
||||||
|
issuer = pBank
|
||||||
|
owner = pBank
|
||||||
|
obs = []
|
||||||
|
quantity = 1.0
|
||||||
|
currency
|
||||||
|
|
||||||
|
-- 2 positions for Alice
|
||||||
|
replicateA_ 1 $ submitUser uBank do
|
||||||
|
replicateA_ 2 $ createCmd V2.Cash.CashTransferProposal with
|
||||||
|
cash
|
||||||
|
newOwner = pAlice
|
||||||
|
|
||||||
|
-- 2 positionsfor Bob
|
||||||
|
replicateA_ 1 $ submitUser uBank do
|
||||||
|
replicateA_ 2 $ createCmd V2.Cash.CashTransferProposal with
|
||||||
|
cash
|
||||||
|
newOwner = pBob
|
||||||
|
|
||||||
|
-- Accept all transfer proposals
|
||||||
|
let
|
||||||
|
accept_all p = do
|
||||||
|
proposals <- queryFilter @V2.Cash.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 <- queryFilter @V2.Cash.Cash pAlice (\pos -> pos.currency == currency)
|
||||||
|
forA_ (take 1 alicePositions) (\(cid, _) -> do
|
||||||
|
submitUser uAlice do
|
||||||
|
exerciseCmd (toInterfaceContractId @IAsset cid) Propose_Transfer with
|
||||||
|
newOwner = pBob
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
test_upgrade : Script (TestParties, TestUsers)
|
||||||
|
test_upgrade = script do
|
||||||
|
(tps@TestParties{..}, tus@TestUsers{..}) <- test_swap
|
||||||
|
|
||||||
|
init_cash_v2 tps tus
|
||||||
|
|
||||||
|
-- OLD SWAP, NEW ASSETS
|
||||||
|
-- Alice proposes an old swap, Cash for Cash, but allocates using a new asset.
|
||||||
|
(cid, posa)::_ <- queryFilter @V2.Cash.Cash pAlice (\pos -> pos.owner == pAlice && pos.currency == "CHF")
|
||||||
|
cid <- submitUser uAlice do
|
||||||
|
exerciseCmd (toInterfaceContractId @IAsset cid) Set_Observers with newObs = [pBob]
|
||||||
|
|
||||||
|
let offerSpec = (pBank, "V2_Cash CHF", posa.quantity)
|
||||||
|
requestedSpec = (pBank, "Cash", posa.quantity)
|
||||||
|
swapCid <- submitUser uAlice do
|
||||||
|
createCmd AssetSwapProposal with
|
||||||
|
requester = pAlice
|
||||||
|
receiver = pBob
|
||||||
|
offerSpec
|
||||||
|
requestedSpec
|
||||||
|
offerCid = toInterfaceContractId @IAsset cid
|
||||||
|
|
||||||
|
-- Bob accepts using a new asset.
|
||||||
|
(cid, _)::_ <- queryFilter @V2.Cash.Cash pBob (\posb -> posb.owner == pBob && posb.quantity == posa.quantity && posb.currency == "USD")
|
||||||
|
submitUser uBob do
|
||||||
|
exerciseCmd swapCid Settle with requestedCid = toInterfaceContractId @IAsset cid
|
||||||
|
|
||||||
|
-- OLD SWAP, MIX OF ASSETS
|
||||||
|
-- Alice proposes an old swap, Cash for Cash, and allocates using an old asset.
|
||||||
|
(cid, posa)::_ <- queryFilter @V1.Cash.Cash pAlice (\pos -> pos.owner == pAlice)
|
||||||
|
cid <- submitUser uAlice do
|
||||||
|
exerciseCmd (toInterfaceContractId @IAsset cid) Set_Observers with newObs = [pBob]
|
||||||
|
|
||||||
|
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 using a new asset.
|
||||||
|
(cid, _)::_ <- queryFilter @V2.Cash.Cash pBob (\posb -> posb.owner == pBob && posb.quantity == posa.quantity && posb.currency == "USD")
|
||||||
|
submitUser uBob do
|
||||||
|
exerciseCmd swapCid Settle with requestedCid = toInterfaceContractId @IAsset cid
|
||||||
|
|
||||||
|
|
||||||
|
return (tps, tus)
|
41
daml/Exercise3/Solutions/Modularized/Cash.daml
Normal file
41
daml/Exercise3/Solutions/Modularized/Cash.daml
Normal file
@ -0,0 +1,41 @@
|
|||||||
|
-- This should be its own package!
|
||||||
|
|
||||||
|
module Exercise3.Solutions.Modularized.Cash where
|
||||||
|
|
||||||
|
import Exercise3.Solutions.Modularized.Interfaces
|
||||||
|
|
||||||
|
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
|
||||||
|
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
|
88
daml/Exercise3/Solutions/Modularized/Interfaces.daml
Normal file
88
daml/Exercise3/Solutions/Modularized/Interfaces.daml
Normal file
@ -0,0 +1,88 @@
|
|||||||
|
-- This should be its own package!
|
||||||
|
|
||||||
|
module Exercise3.Solutions.Modularized.Interfaces where
|
||||||
|
|
||||||
|
import DA.Assert
|
||||||
|
|
||||||
|
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 ()
|
118
daml/Exercise3/Solutions/Modularized/Scripts.daml
Normal file
118
daml/Exercise3/Solutions/Modularized/Scripts.daml
Normal file
@ -0,0 +1,118 @@
|
|||||||
|
-- This should be its own package!
|
||||||
|
|
||||||
|
module Exercise3.Solutions.Modularized.Scripts where
|
||||||
|
|
||||||
|
import Exercise3.Solutions.Modularized.Cash
|
||||||
|
import Exercise3.Solutions.Modularized.Interfaces
|
||||||
|
import Exercise3.Solutions.Modularized.Swap
|
||||||
|
|
||||||
|
import Daml.Script
|
||||||
|
|
||||||
|
import DA.Action
|
||||||
|
import DA.Foldable (forA_)
|
||||||
|
|
||||||
|
-- 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
|
||||||
|
|
||||||
|
-- 3 positions of $1 for Alice
|
||||||
|
replicateA_ 1 $ submitUser uBank do
|
||||||
|
replicateA_ 3 $ createCmd CashTransferProposal with
|
||||||
|
cash
|
||||||
|
newOwner = pAlice
|
||||||
|
|
||||||
|
-- 2 positions for Bob
|
||||||
|
replicateA_ 1 $ submitUser uBank do
|
||||||
|
replicateA_ 2 $ 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 (TestParties, TestUsers)
|
||||||
|
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
|
||||||
|
|
||||||
|
return (tps, tus)
|
45
daml/Exercise3/Solutions/Modularized/Swap.daml
Normal file
45
daml/Exercise3/Solutions/Modularized/Swap.daml
Normal file
@ -0,0 +1,45 @@
|
|||||||
|
-- This should be its own package!
|
||||||
|
|
||||||
|
module Exercise3.Solutions.Modularized.Swap where
|
||||||
|
|
||||||
|
import Exercise3.Solutions.Modularized.Interfaces
|
||||||
|
|
||||||
|
import DA.Assert
|
||||||
|
|
||||||
|
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 ()
|
||||||
|
|
275
daml/Exercise3/Swaps.daml
Normal file
275
daml/Exercise3/Swaps.daml
Normal file
@ -0,0 +1,275 @@
|
|||||||
|
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 ()
|
78
daml/Initial/Cash.daml
Normal file
78
daml/Initial/Cash.daml
Normal file
@ -0,0 +1,78 @@
|
|||||||
|
module Initial.Cash where
|
||||||
|
|
||||||
|
import DA.Assert
|
||||||
|
|
||||||
|
template Position
|
||||||
|
with
|
||||||
|
issuer : Party
|
||||||
|
owner : Party
|
||||||
|
quantity : Decimal
|
||||||
|
obs : [Party]
|
||||||
|
where
|
||||||
|
signatory [issuer, owner]
|
||||||
|
observer obs
|
||||||
|
ensure quantity > 0.0
|
||||||
|
|
||||||
|
choice Transfer : ContractId Position
|
||||||
|
with
|
||||||
|
newOwner : Party
|
||||||
|
controller [owner, newOwner]
|
||||||
|
do
|
||||||
|
create this with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
choice Propose_Transfer : ContractId TransferProposal
|
||||||
|
with
|
||||||
|
newOwner : Party
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
create TransferProposal with
|
||||||
|
position = this
|
||||||
|
newOwner
|
||||||
|
|
||||||
|
choice Split : (ContractId Position, [ContractId Position])
|
||||||
|
with
|
||||||
|
splitQuantities : [Decimal]
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
remCid <- create this with quantity = this.quantity - sum splitQuantities
|
||||||
|
splitCids <- forA splitQuantities (\splitQuantity -> create this with
|
||||||
|
quantity = splitQuantity
|
||||||
|
)
|
||||||
|
return (remCid, splitCids)
|
||||||
|
|
||||||
|
choice Merge : ContractId Position
|
||||||
|
with
|
||||||
|
otherCids : [ContractId Position]
|
||||||
|
controller owner
|
||||||
|
do
|
||||||
|
quantities <- forA otherCids (\otherCid -> do
|
||||||
|
other <- fetch otherCid
|
||||||
|
other === this with
|
||||||
|
quantity = other.quantity
|
||||||
|
obs = other.obs
|
||||||
|
archive otherCid
|
||||||
|
return other.quantity)
|
||||||
|
create this with
|
||||||
|
quantity = quantity + sum quantities
|
||||||
|
|
||||||
|
template TransferProposal
|
||||||
|
with
|
||||||
|
position : Position
|
||||||
|
newOwner : Party
|
||||||
|
where
|
||||||
|
signatory (signatory position)
|
||||||
|
observer newOwner::(observer position)
|
||||||
|
|
||||||
|
choice Accept : ContractId Position
|
||||||
|
controller newOwner
|
||||||
|
do
|
||||||
|
create position with
|
||||||
|
owner = newOwner
|
||||||
|
obs = []
|
||||||
|
|
||||||
|
choice Cancel : ContractId Position
|
||||||
|
controller position.owner
|
||||||
|
do
|
||||||
|
create position
|
86
daml/Initial/Scripts.daml
Normal file
86
daml/Initial/Scripts.daml
Normal file
@ -0,0 +1,86 @@
|
|||||||
|
module Initial.Scripts where
|
||||||
|
|
||||||
|
import Initial.Cash
|
||||||
|
|
||||||
|
import Daml.Script
|
||||||
|
import DA.Action
|
||||||
|
import DA.Foldable (forA_)
|
||||||
|
|
||||||
|
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 position = Position with
|
||||||
|
issuer = pBank
|
||||||
|
owner = pBank
|
||||||
|
obs = []
|
||||||
|
quantity = 1.0
|
||||||
|
|
||||||
|
-- 200 positions of $1 for Alice
|
||||||
|
replicateA_ 20 $ submitUser uBank do
|
||||||
|
replicateA_ 10 $ createCmd TransferProposal with
|
||||||
|
position
|
||||||
|
newOwner = pAlice
|
||||||
|
|
||||||
|
-- 100 positions for Bob
|
||||||
|
replicateA_ 10 $ submitUser uBank do
|
||||||
|
replicateA_ 10 $ createCmd TransferProposal with
|
||||||
|
position
|
||||||
|
newOwner = pBob
|
||||||
|
|
||||||
|
-- Accept all transfer proposals
|
||||||
|
let
|
||||||
|
accept_all p = do
|
||||||
|
proposals <- queryFilter @TransferProposal p (\tp -> tp.newOwner == p)
|
||||||
|
submit p do
|
||||||
|
forA_ proposals (\(cid, _) -> exerciseCmd cid Accept)
|
||||||
|
forA_ [pAlice, pBob] accept_all
|
||||||
|
|
||||||
|
|
||||||
|
-- Alice transfers 50 of her positions to Bob
|
||||||
|
alicePositions <- query @Position pAlice
|
||||||
|
forA_ (take 50 alicePositions) (\(cid, _) -> do
|
||||||
|
submitUser uAlice do
|
||||||
|
exerciseCmd cid Propose_Transfer with
|
||||||
|
newOwner = pBob
|
||||||
|
)
|
||||||
|
|
||||||
|
return (ps, us)
|
Loading…
Reference in New Issue
Block a user