IntersectMBO · michaelpj · Apr 4, 2019 · Feb 28, 2019 · Mar 27, 2019 · Mar 31, 2019
diff --git a/.hlint.yaml b/.hlint.yaml
@@ -1,7 +1,7 @@
 ---
 - functions:
   - {name: unsafePerformIO, within: [PlutusPrelude, Language.PlutusCore.Generators.Internal.Entity, Language.PlutusCore.Constant.Dynamic.Call, Language.PlutusCore.Constant.Dynamic.Emit, Language.PlutusCore.Constant.Dynamic.Instances, Language.PlutusCore.StdLib.Type, Language.PlutusTx.Plugin, Language.PlutusTx.Evaluation]}
-  - {name: error, within: [Main, PlutusPrelude, Language.PlutusCore.StdLib.Meta, Evaluation.Constant.Success, Language.PlutusCore.Constant.Apply, Language.PlutusCore.Evaluation.CkMachine, Language.PlutusCore.TypeSynthesis, Language.PlutusCore.Generators.Internal.Dependent, Language.PlutusCore.Generators.Internal.Entity, Language.PlutusCore.Generators.Internal.Utils, Language.PlutusCore.Constant.Make, DynamicBuiltins.Definition, Language.PlutusCore.TH, Language.PlutusTx.Utils, Language.PlutusIR.Compiler.Datatype]}
+  - {name: error, within: [Main, PlutusPrelude, Language.PlutusCore.StdLib.Meta, Evaluation.Constant.Success, Language.PlutusCore.Constant.Apply, Language.PlutusCore.Evaluation.CkMachine, Language.PlutusCore.TypeSynthesis, Language.PlutusCore.Generators.Internal.Dependent, Language.PlutusCore.Generators.Internal.Entity, Language.PlutusCore.Generators.Internal.Utils, Language.PlutusCore.Constant.Make, DynamicBuiltins.Definition, Language.PlutusCore.TH, Language.PlutusTx.Utils, Language.PlutusIR.Compiler.Datatype, KeyBytes]}
   - {name: undefined, within: [Language.PlutusCore.Constant.Apply, Language.PlutusTx.Lift.Class, Language.PlutusTx.Lift.Instances]}
   - {name: fromJust, within: [Language.PlutusTx.Lift]}
   - {name: foldl, within: []}

diff --git a/marlowe/marlowe.cabal b/marlowe/marlowe.cabal
@@ -26,7 +26,9 @@ library
   hs-source-dirs: src
   build-depends:
     base -any,
+    bytestring -any,
     containers -any,
+    memory -any,
     mtl -any,
     template-haskell -any,
     plutus-tx -any,
@@ -65,6 +67,8 @@ test-suite marlowe-test
         base >=4.9 && <5,
         containers -any,
         hedgehog -any,
+        memory -any,
+        bytestring -any,
         tasty -any,
         tasty-hunit -any,
         tasty-hedgehog >=0.2.0.0,

diff --git a/marlowe/src/Language/Marlowe/Client.hs b/marlowe/src/Language/Marlowe/Client.hs
@@ -32,13 +32,12 @@ import           Wallet                         ( WalletAPI(..)
                                                 , intervalFrom
                                                 , throwOtherError
                                                 , createTxAndSubmit
-                                                , signature
                                                 , ownPubKeyTxOut
                                                 )
 import           Ledger                         ( DataScript(..)
                                                 , PubKey(..)
-                                                , Signature(..)
                                                 , Slot(..)
+                                                , Tx
                                                 , TxOutRef
                                                 , TxIn
                                                 , TxOut
@@ -51,6 +50,7 @@ import qualified Ledger                         as Ledger
 import           Ledger.Ada.TH                  (Ada)
 import qualified Ledger.Ada                     as Ada
 import           Ledger.Validation
+import qualified Language.PlutusTx.Builtins     as Builtins
 import           Language.Marlowe
 
 {- Mockchain instantiation of Marlowe Interpreter functions. -}
@@ -74,12 +74,14 @@ interpretObs inputOracles blockNumber state obs = let
     ev = evalValue (Slot blockNumber) inputOracles
     in $$(interpretObservation) ev blockNumber state obs
 
-evalContract :: PubKey -> Input -> Slot
+evalContract :: PubKey -> TxHash -> Input -> Slot
     -> Ada -> Ada
     -> State -> Contract
     -> (State, Contract, Bool)
 evalContract = $$(evaluateContract)
 
+getScriptOutFromTx :: Tx -> (TxOut, TxOutRef)
+getScriptOutFromTx = head . filter (Ledger.isPayToScriptOut . fst) . Ledger.txOutRefs
 
 {-| Create Marlowe 'ValidatorScript' that remembers its owner.
 
@@ -91,7 +93,6 @@ marloweValidator creator = ValidatorScript result where
     result = Ledger.applyScript inner (Ledger.lifted creator)
     inner  = $$(Ledger.compileScript validatorScript)
 
-
 {-| Create and submit a transaction that creates a Marlowe Contract @contract@
     using @validator@ script, and put @value@ Ada as a deposit.
 -}
@@ -105,7 +106,7 @@ createContract :: (
 createContract validator contract value = do
     _ <- if value <= 0 then throwOtherError "Must contribute a positive value" else pure ()
     slot <- slot
-    let ds = DataScript $ Ledger.lifted (Input (SpendDeposit (Signature 1)) [] [], MarloweData {
+    let ds = DataScript $ Ledger.lifted (Input CreateContract [] [], MarloweData {
             marloweContract = contract,
             marloweState = emptyState })
     let v' = Ada.adaValueOf value
@@ -151,7 +152,7 @@ createRedeemer inputCommand oracles choices expectedState expectedCont =
 commit :: (
     MonadError WalletAPIError m,
     WalletAPI m)
-    => (TxOut, TxOutRef)
+    => Tx
     -- ^ reference to Marlowe contract UTxO
     -> ValidatorScript
     -- ^ actuall contract script
@@ -168,11 +169,13 @@ commit :: (
     -> Contract
     -- ^ expected 'Contract' after commit
     -> m ()
-commit txOut validator oracles choices identCC value expectedState expectedCont = do
+commit tx validator oracles choices identCC value expectedState expectedCont = do
     when (value <= 0) $ throwOtherError "Must commit a positive value"
-    sig <- signature <$> myKeyPair
+    let (TxHash hash) = plcTxHash . Ledger.hashTx $ tx
+    sig <- sign $ Builtins.unSizedByteString hash
     slot <- slot
     let redeemer = createRedeemer (Commit identCC sig) oracles choices expectedState expectedCont
+    let txOut = getScriptOutFromTx tx
     marloweTx redeemer txOut validator $ \ contractTxIn getTxOut contractValue -> do
         (payment, change) <- createPaymentWithChange (Ada.adaValueOf value)
         void $ createTxAndSubmit
@@ -189,7 +192,9 @@ commit txOut validator oracles choices identCC value expectedState expectedCont
 commit' :: (
     MonadError WalletAPIError m,
     WalletAPI m)
-    => (TxOut, TxOutRef)
+    => PubKey
+    -- ^ contract creator
+    -> Tx
     -- ^ reference to Marlowe contract UTxO
     -> ValidatorScript
     -- ^ actuall contract script
@@ -206,25 +211,28 @@ commit' :: (
     -> Contract
     -- ^ 'Contract' before commit
     -> m ()
-commit' txOut validator oracles choices identCC value inputState inputContract = do
+commit' contractCreatorPK tx validator oracles choices identCC value inputState inputContract = do
     bh <- slot
-    sig <- signature <$> myKeyPair
+    let txHash@(TxHash hash) = plcTxHash . Ledger.hashTx $ tx
+    sig <- sign $ Builtins.unSizedByteString hash
     let inputCommand = Commit identCC sig
     let input = Input inputCommand oracles choices
+    let txOut = getScriptOutFromTx tx
     let scriptInValue = Ada.fromValue . txOutValue . fst $ txOut
     let scriptOutValue = scriptInValue + Ada.fromInt value
     let (expectedState, expectedCont, isValid) =
-            evalContract (PubKey 1) input bh scriptInValue scriptOutValue inputState inputContract
+            evalContract contractCreatorPK txHash
+            input bh scriptInValue scriptOutValue inputState inputContract
     when (not isValid) $ throwOtherError "Invalid commit"
-    commit txOut validator oracles choices identCC value expectedState expectedCont
+    commit tx validator oracles choices identCC value expectedState expectedCont
 
 
 {-| Create a Marlowe Payment input transaction.
 -}
 receivePayment :: (
     MonadError WalletAPIError m,
     WalletAPI m)
-    => (TxOut, TxOutRef)
+    => Tx
     -- ^ reference to Marlowe contract UTxO
     -> ValidatorScript
     -- ^ actuall contract script
@@ -241,10 +249,12 @@ receivePayment :: (
     -> Contract
     -- ^ expected 'Contract' after commit
     -> m ()
-receivePayment txOut validator oracles choices identPay value expectedState expectedCont = do
+receivePayment tx validator oracles choices identPay value expectedState expectedCont = do
     _ <- if value <= 0 then throwOtherError "Must commit a positive value" else pure ()
-    sig <- signature <$> myKeyPair
+    let (TxHash hash) = plcTxHash . Ledger.hashTx $ tx
+    sig <- sign $ Builtins.unSizedByteString hash
     slot <- slot
+    let txOut = getScriptOutFromTx tx
     let redeemer = createRedeemer (Payment identPay sig) oracles choices expectedState expectedCont
     marloweTx redeemer txOut validator $ \ contractTxIn getTxOut contractValue -> do
         let out = getTxOut (contractValue - value)
@@ -257,7 +267,7 @@ receivePayment txOut validator oracles choices identPay value expectedState expe
 redeem :: (
     MonadError WalletAPIError m,
     WalletAPI m)
-    => (TxOut, TxOutRef)
+    => Tx
     -- ^ reference to Marlowe contract UTxO
     -> ValidatorScript
     -- ^ actuall contract script
@@ -274,10 +284,12 @@ redeem :: (
     -> Contract
     -- ^ expected 'Contract' after commit
     -> m ()
-redeem txOut validator oracles choices identCC value expectedState expectedCont = do
+redeem tx validator oracles choices identCC value expectedState expectedCont = do
     _ <- if value <= 0 then throwOtherError "Must commit a positive value" else pure ()
-    sig <- signature <$> myKeyPair
+    let (TxHash hash) = plcTxHash . Ledger.hashTx $ tx
+    sig <- sign $ Builtins.unSizedByteString hash
     slot <- slot
+    let txOut = getScriptOutFromTx tx
     let redeemer = createRedeemer (Redeem identCC sig) oracles choices expectedState expectedCont
     marloweTx redeemer txOut validator $ \ contractTxIn getTxOut contractValue -> do
         let out = getTxOut (contractValue - value)
@@ -290,16 +302,18 @@ redeem txOut validator oracles choices identCC value expectedState expectedCont
     Spend the initial contract deposit payment.
 -}
 spendDeposit :: (Monad m, WalletAPI m)
-    => (TxOut, TxOutRef)
+    => Tx
     -- ^ reference to Marlowe contract UTxO
     -> ValidatorScript
     -- ^ actuall contract script
     -> State
     -- ^ current contract 'State'
     -> m ()
-spendDeposit txOut validator state = do
-    sig <- signature <$> myKeyPair
+spendDeposit tx validator state = do
+    let (TxHash hash) = plcTxHash . Ledger.hashTx $ tx
+    sig <- sign $ Builtins.unSizedByteString hash
     slot <- slot
+    let txOut = getScriptOutFromTx tx
     let redeemer = createRedeemer (SpendDeposit sig) [] [] state Null
     marloweTx redeemer txOut validator $ \ contractTxIn _ contractValue -> do
         oo <- ownPubKeyTxOut (Ada.adaValueOf contractValue)

diff --git a/marlowe/src/Language/Marlowe/Common.hs b/marlowe/src/Language/Marlowe/Common.hs
@@ -90,7 +90,6 @@ import           Prelude                        ( Show(..)
                                                 , Ord(..)
                                                 , Int
                                                 , Maybe(..)
-                                                , Either(..)
                                                 , (.)
                                                 )
 
@@ -109,6 +108,7 @@ import           Language.PlutusTx.Lift         ( makeLift )
 import           Language.Haskell.TH            ( Q
                                                 , TExp
                                                 )
+import           KeyBytes                       (KeyBytes(..))
 import GHC.Generics (Generic)
 import Language.Marlowe.Pretty (Pretty, prettyFragment)
 import Text.PrettyPrint.Leijen (text)
@@ -248,6 +248,7 @@ data InputCommand = Commit IdentCC Signature
     | Payment IdentPay Signature
     | Redeem IdentCC Signature
     | SpendDeposit Signature
+    | CreateContract
 makeLift ''InputCommand
 
 {-|
@@ -606,6 +607,7 @@ findAndRemove = [|| \ predicate commits -> let
 -}
 evaluateContract ::
     Q (TExp (PubKey
+    -> TxHash
     -> Input
     -> Slot
     -> Ada
@@ -614,6 +616,7 @@ evaluateContract ::
     -> Contract -> (State, Contract, Bool)))
 evaluateContract = [|| \
     contractCreatorPK
+    txHash
     (Input inputCommand inputOracles _)
     blockHeight
     scriptInValue'
@@ -634,9 +637,6 @@ evaluateContract = [|| \
     (||) :: Bool -> Bool -> Bool
     (||) = $$(PlutusTx.or)
 
-    signedBy :: Signature -> PubKey -> Bool
-    signedBy (Signature sig) (PubKey pk) = sig `Builtins.equalsInteger` pk
-
     eqIdentCC :: IdentCC -> IdentCC -> Bool
     eqIdentCC (IdentCC a) (IdentCC b) = a `Builtins.equalsInteger` b
 
@@ -650,6 +650,11 @@ evaluateContract = [|| \
     interpretObs :: Int -> State -> Observation -> Bool
     interpretObs = $$(interpretObservation) evalValue
 
+    signedBy :: Signature -> PubKey -> Bool
+    signedBy (Signature sig) (PubKey (KeyBytes pk)) = let
+        TxHash msg = txHash
+        in $$(PlutusTx.verifySignature) pk msg sig
+
     eval :: InputCommand -> State -> Contract -> (State, Contract, Bool)
     eval input state@(State commits choices) contract = case (contract, input) of
         (When obs timeout con con2, _)
@@ -767,7 +772,7 @@ validatorScript = [|| \
         creator
         (_ :: Input, MarloweData{..} :: MarloweData)
         (input@(Input inputCommand _ inputChoices :: Input), MarloweData expectedState expectedContract)
-        (PendingTx{ pendingTxOutputs, pendingTxValidRange, pendingTxIn } :: PendingTx) -> let
+        (PendingTx{ pendingTxOutputs, pendingTxValidRange, pendingTxIn, pendingTxHash } :: PendingTx) -> let
 
         {-  Embed contract creator public key. This makes validator script unique,
             which makes a particular contract to have a unique script address.
@@ -819,7 +824,7 @@ validatorScript = [|| \
 
         -- TxIn we're validating is obviously a Script TxIn.
         (inputValidatorHash, redeemerHash, scriptInValue) = case pendingTxIn of
-            PendingTxIn _ (Left (vHash, RedeemerHash rHash)) value -> (vHash, rHash, value)
+            PendingTxIn _ (Just (vHash, RedeemerHash rHash)) value -> (vHash, rHash, value)
             _ -> Builtins.error ()
 
         scriptInAdaValue = $$(Ada.fromValue) scriptInValue
@@ -837,7 +842,7 @@ validatorScript = [|| \
                     then $$(Ada.fromValue) change else Builtins.error ()
 
         eval :: Input -> Slot -> Ada -> Ada -> State -> Contract -> (State, Contract, Bool)
-        eval = $$(evaluateContract) contractCreatorPK
+        eval = $$(evaluateContract) contractCreatorPK pendingTxHash
 
         contractIsValid = $$(validateContract) marloweState marloweContract minSlot scriptInAdaValue
 

diff --git a/marlowe/src/Language/Marlowe/Escrow.hs b/marlowe/src/Language/Marlowe/Escrow.hs
@@ -1,7 +1,7 @@
 module Language.Marlowe.Escrow where
 
 import           Language.Marlowe
-import           Wallet.API       (PubKey (..))
+import           Ledger
 
 {-
 ------------------------------------------
@@ -20,23 +20,14 @@ import           Wallet.API       (PubKey (..))
    the money will be refunded to person 1.
 -}
 
-alice :: Person
-alice = PubKey 1
-
-bob :: Person
-bob = PubKey 2
-
-carol :: Person
-carol = PubKey 3
-
 escrowContract :: Contract
 escrowContract = CommitCash iCC1 alice
                     (Value 450)
                     10 100
-                    (When (OrObs (twoChose alice bob carol 0)
-                                 (twoChose alice bob carol 1))
+                    (When (OrObs (twoChose aliceId alice bobId bob carolId carol 0)
+                                 (twoChose aliceId alice bobId bob carolId carol 1))
                           90
-                          (Choice (twoChose alice bob carol 1)
+                          (Choice (twoChose aliceId alice bobId bob carolId carol 1)
                                   (Pay iP1 alice bob
                                        (Committed iCC1)
                                        100
@@ -45,16 +36,16 @@ escrowContract = CommitCash iCC1 alice
                           redeemOriginal)
                     Null
 
-chose :: Person -> ConcreteChoice -> Observation
-chose per@(PubKey i) = PersonChoseThis (IdentChoice i) per
+chose :: IdentChoice -> Person -> ConcreteChoice -> Observation
+chose = PersonChoseThis
 
-oneChose :: Person -> Person -> ConcreteChoice -> Observation
-oneChose per per' val = OrObs (chose per val) (chose per' val)
+oneChose :: IdentChoice -> Person -> IdentChoice -> Person -> ConcreteChoice -> Observation
+oneChose ident per ident' per' val = OrObs (chose ident per val) (chose ident' per' val)
 
-twoChose :: Person -> Person -> Person -> ConcreteChoice -> Observation
-twoChose p1 p2 p3 c =
-        OrObs (AndObs (chose p1 c) (oneChose p2 p3 c))
-              (AndObs (chose p2 c) (chose p3 c))
+twoChose :: IdentChoice -> Person -> IdentChoice -> Person -> IdentChoice -> Person -> ConcreteChoice -> Observation
+twoChose i1 p1 i2 p2 i3 p3 c =
+        OrObs (AndObs (chose i1 p1 c) (oneChose i2 p2 i3 p3 c))
+              (AndObs (chose i2 p2 c) (chose i3 p3 c))
 
 redeemOriginal :: Contract
 redeemOriginal = RedeemCC iCC1 Null
@@ -64,3 +55,21 @@ iCC1 = IdentCC 1
 
 iP1 :: IdentPay
 iP1 = IdentPay 1
+
+alice :: Person
+alice = toPublicKey privateKey1
+
+aliceId :: IdentChoice
+aliceId = IdentChoice 1
+
+bob :: Person
+bob = toPublicKey privateKey2
+
+bobId :: IdentChoice
+bobId = IdentChoice 2
+
+carol :: Person
+carol = toPublicKey privateKey3
+
+carolId :: IdentChoice
+carolId = IdentChoice 3