Skip to content
Permalink
Browse files

Move common test code to Spec.Common module.

  • Loading branch information...
nau committed Mar 14, 2019
1 parent bf07e6b commit fe1dd5345f5b55a68549e49f8dd1d510147ce2ad
Showing with 323 additions and 298 deletions.
  1. +2 −1 marlowe/marlowe.cabal
  2. +4 −1 marlowe/test/Spec.hs
  3. +84 −43 marlowe/test/Spec/Actus.hs
  4. +232 −0 marlowe/test/Spec/Common.hs
  5. +1 −253 marlowe/test/Spec/Marlowe.hs
@@ -2,7 +2,7 @@ cabal-version: 2.0
name: marlowe
version: 0.1.0.0
license: Apache-2.0
license-files:
license-files:
LICENSE
NOTICE
build-type: Simple
@@ -56,6 +56,7 @@ test-suite marlowe-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Spec.Common
Spec.Marlowe
Spec.Actus
build-depends:
@@ -17,4 +17,7 @@ limit :: HedgehogTestLimit
limit = HedgehogTestLimit (Just 30)

tests :: TestTree
tests = localOption limit $ testGroup "Marlowe Contract" [Spec.Actus.tests]
tests = localOption limit $ testGroup "Marlowe Contracts"
[ Spec.Marlowe.tests
, Spec.Actus.tests
]
@@ -11,71 +11,31 @@ module Spec.Actus
)
where

import Data.Either ( isRight )
import Data.Maybe
import Control.Monad ( void, when )
import Data.Set ( Set )
import qualified Data.List as List
import qualified Data.Set as Set
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map

import Hedgehog ( Gen
, Property
, Size(..)
, forAll
, property
)
import qualified Hedgehog.Range as Range
import Hedgehog.Gen ( element
, int
, choice
, list
, sized
import Hedgehog ( Property
)
import qualified Hedgehog
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.Hedgehog ( testProperty
, HedgehogTestLimit(..)
)

import Ledger hiding ( Value )
import qualified Ledger.Ada as Ada
import qualified Ledger
import Ledger.Validation ( OracleValue(..) )
import Wallet ( PubKey(..)
, startWatching
)
import Wallet.Emulator
import qualified Wallet.Generators as Gen
import Language.Marlowe hiding (insertCommit, discountFromPairList, mergeChoices)
import qualified Language.Marlowe as Marlowe
import Language.Marlowe.Client ( commit'
, commit
, redeem
, createContract
, spendDeposit
, receivePayment
, marloweValidator
, evalContract
)
import Language.Marlowe.Actus as Actus

newtype MarloweScenario = MarloweScenario { mlInitialBalances :: Map.Map PubKey Ledger.Value }
data Bounds = Bounds {
oracleBounds :: Map PubKey (Integer, Integer),
choiceBounds :: Map IdentChoice (Integer, Integer)
}

emptyBounds :: Bounds
emptyBounds = Bounds Map.empty Map.empty
import Spec.Common


tests :: TestTree
tests = testGroup "Actus"
[ testCase "Safe zero coupon bond" checkZeroCouponBond
, testCase "Trusted zero coupon bond" checkTrustedZeroCouponBond
, testProperty "Trusted zero coupon bond" zeroCouponBondTest
]


@@ -183,3 +143,84 @@ checkTrustedZeroCouponBond = do
state1
con1
v @?= False


zeroCouponBondTest :: Property
zeroCouponBondTest = checkMarloweTrace (MarloweScenario {
mlInitialBalances = Map.fromList [ (PubKey 1, Ada.adaValueOf 1000000), (PubKey 2, Ada.adaValueOf 1000000) ] }) $ do
-- Init a contract
let issuer = Wallet 1
issuerPk = PubKey 1
investor = Wallet 2
investorPk = PubKey 2
update = updateAll [issuer, investor]
notional = 1000
discount = 80
startDate = 50
maturityDate = 500
gracePeriod = 30240 -- about a week, 20sec * 3 * 60 * 24 * 7
update

let contract = zeroCouponBond (PubKey 1) (PubKey 2) notional discount startDate maturityDate gracePeriod

withContract [issuer, investor] contract $ \txOut validator -> do
txOut <- investor `performs` commit'
txOut
validator
[] []
(IdentCC 1)
(notional-discount)
(State [(IdentCC 1, (PubKey 1, NotRedeemed (notional-discount) maturityDate))] [])
(CommitCash (IdentCC 2) issuerPk (Value notional) startDate (maturityDate+1000)
(When FalseObs startDate Null
(Pay (IdentPay 1) investorPk issuerPk (Committed (IdentCC 1)) maturityDate
(When FalseObs maturityDate Null
(Pay (IdentPay 2) issuerPk investorPk (Committed (IdentCC 2)) (maturityDate+1000) Null)
)
)
)
Null
)

update

txOut <- issuer `performs` commit'
txOut
validator
[] []
(IdentCC 2)
notional
(State [ (IdentCC 1, (PubKey 1, NotRedeemed (notional-discount) maturityDate)),
(IdentCC 2, (PubKey 2, NotRedeemed notional maturityDate))] [])
(When FalseObs startDate Null
(Pay (IdentPay 1) investorPk issuerPk (Committed (IdentCC 1)) maturityDate
(When FalseObs maturityDate Null
(Pay (IdentPay 2) issuerPk investorPk (Committed (IdentCC 2)) (maturityDate+1000) Null)
)
)
)

addBlocksAndNotify [issuer, investor] startDate

txOut <- issuer `performs` receivePayment txOut
validator
[] []
(IdentPay 1)
(notional-discount)
(State [(IdentCC 2, (PubKey 2, NotRedeemed notional (maturityDate+1000)))] [])
(When FalseObs maturityDate Null
(Pay (IdentPay 2) issuerPk investorPk (Committed (IdentCC 2)) (maturityDate+1000) Null)
)

addBlocksAndNotify [issuer, investor] maturityDate

txOut <- investor `performs` receivePayment txOut
validator
[] []
(IdentPay 1)
notional
(State [] [])
Null

return (txOut, State [] [])
return ()
Oops, something went wrong.

0 comments on commit fe1dd53

Please sign in to comment.
You can’t perform that action at this time.