Get rid of lie that we do properly support >1 signer in API

mlabs-haskell · May 28, 2024 · 1881d35 · 1881d35
1 parent ec9b338
commit 1881d35
Show file tree

Hide file tree

Showing 8 changed files with 32 additions and 50 deletions.
diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs
@@ -120,8 +120,8 @@ class
 
 data TransitionSpec script = MkTransitionSpec
   { constraints :: [TxFanConstraint script]
-  -- List of additional signers (not enforced by TxIns)
-  , signers :: [PubKeyHash]
+  , -- List of additional signers (in addition to one required by TxIns)
+    signers :: [PubKeyHash]
   }
   deriving stock (Show)
 

diff --git a/src/Cardano/CEM/Monads.hs b/src/Cardano/CEM/Monads.hs
@@ -58,8 +58,8 @@ data ResolvedTx = MkResolvedTx
   , toMint :: TxMintValue BuildTx Era
   , interval :: Interval POSIXTime
   , additionalSigners :: [PubKeyHash]
-  , -- FIXME: rename
-    signer :: [SigningKey PaymentKey]
+  , -- FIXME
+    signer :: ~(SigningKey PaymentKey)
   }
   deriving stock (Show, Eq)
 

diff --git a/src/Cardano/CEM/Monads/L1Commons.hs b/src/Cardano/CEM/Monads/L1Commons.hs
@@ -26,12 +26,12 @@ cardanoTxBodyFromResolvedTx ::
   m (Either (TxBodyErrorAutoBalance Era) (TxBody Era, TxInMode))
 cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
   -- (lowerBound, upperBound) <- convertValidityBound validityBound
-  -- TODO
+  -- FIXME
   let keyWitnessedTxIns = [fst $ last txIns]
   MkBlockchainParams {protocolParameters} <- queryBlockchainParams
 
   let additionalSignersKeys =
-        filter (\x -> signingKeyToPKH x `elem` additionalSigners) signer
+        filter (\x -> signingKeyToPKH x `elem` additionalSigners) [signer]
 
   let preBody =
         TxBodyContent
@@ -72,11 +72,7 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
           , txVotingProcedures = Nothing
           }
 
-  let
-    mainSignor = signer !! 0
-    mainAddress' = signingKeyToAddress mainSignor
-
-  mainAddress <- fromPlutusAddressInMonad mainAddress'
+  signerAddress <- fromPlutusAddressInMonad $ signingKeyToAddress signer
   txInsUtxo <- queryUtxo $ ByTxIns $ map fst txIns
 
   runExceptT $ do
@@ -85,9 +81,9 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
         callBodyAutoBalance
           preBody
           txInsUtxo
-          mainAddress
+          signerAddress
     let
-      tx = makeSignedTransactionWithKeys signer body
+      tx = makeSignedTransactionWithKeys [signer] body
       txInMode = TxInMode ShelleyBasedEraBabbage tx
     return (body, txInMode)
 

diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs
@@ -61,21 +61,6 @@ awaitTx txId = do
         then return ()
         else go $ n - 1
 
-data TxSigner = MkTxSigner
-  { signerKey :: SigningKey PaymentKey
-  , allowTxInSpending :: Bool
-  , allowFeeCovering :: Bool
-  }
-  deriving stock (Show, Eq)
-
-mkMainSigner :: SigningKey PaymentKey -> TxSigner
-mkMainSigner signerKey =
-  MkTxSigner
-    { signerKey
-    , allowTxInSpending = True
-    , allowFeeCovering = True
-    }
-
 data CEMAction script
   = MkCEMAction (CEMParams script) (Transition script)
 
@@ -106,7 +91,7 @@ instance Show SomeCEMAction where
 
 data TxSpec = MkTxSpec
   { actions :: [SomeCEMAction]
-  , specSigners :: [TxSigner]
+  , specSigner :: SigningKey PaymentKey
   }
   deriving stock (Show)
 
@@ -227,7 +212,7 @@ resolveAction
           , txOuts
           , toMint = TxMintNone
           , additionalSigners = signers scriptTransition
-          , signer = []
+          , signer = error "TODO"
           , interval = always
           }
     where
@@ -280,10 +265,11 @@ resolveTxAndSubmit spec = runExceptT $ do
   -- Merge specs
   let
     mergedSpec' = head actionsSpecs
-    mergedSpec = mergedSpec' {signer = map signerKey $ specSigners spec}
+    mergedSpec = mergedSpec' {signer = specSigner spec}
 
-  -- TODO
-  !utxo <- lift $ queryUtxo $ ByAddresses [signingKeyToAddress $ head $ signer mergedSpec]
+  -- FIXME: more robust fee covering
+  !utxo <-
+    lift $ queryUtxo $ ByAddresses [signingKeyToAddress $ signer mergedSpec]
   let ins = map withKeyWitness $ Map.keys $ unUTxO utxo
   let result = submitResolvedTx $ mergedSpec {txIns = txIns mergedSpec ++ ins}
   ExceptT $ (bimap UnhandledSubmittingError id) <$> result
diff --git a/test/Auction.hs b/test/Auction.hs
@@ -42,7 +42,7 @@ auctionSpec = describe "Auction" $ do
         { actions =
             [ MkSomeCEMAction $ MkCEMAction auctionParams Create
             ]
-        , specSigners = [mkMainSigner seller]
+        , specSigner = seller
         }
 
     let
@@ -59,7 +59,7 @@ auctionSpec = describe "Auction" $ do
               [ MkSomeCEMAction $
                   MkCEMAction auctionParams (MakeBid bid1)
               ]
-          , specSigners = [mkMainSigner bidder1]
+          , specSigner = bidder1
           }
     ~( Left
         ( MkTransitionError
@@ -95,7 +95,7 @@ auctionSpec = describe "Auction" $ do
         { actions =
             [ MkSomeCEMAction $ MkCEMAction auctionParams Create
             ]
-        , specSigners = [mkMainSigner seller]
+        , specSigner = seller
         }
 
     submitAndCheck $
@@ -104,7 +104,7 @@ auctionSpec = describe "Auction" $ do
             [ MkSomeCEMAction $
                 MkCEMAction auctionParams Start
             ]
-        , specSigners = [mkMainSigner seller]
+        , specSigner = seller
         }
 
     let
@@ -121,7 +121,7 @@ auctionSpec = describe "Auction" $ do
               [ MkSomeCEMAction $
                   MkCEMAction auctionParams (MakeBid bid1)
               ]
-          , specSigners = [mkMainSigner bidder1]
+          , specSigner = bidder1
           }
     ~( Left
         ( MkTransitionError
@@ -160,7 +160,7 @@ auctionSpec = describe "Auction" $ do
         { actions =
             [ MkSomeCEMAction $ MkCEMAction auctionParams Create
             ]
-        , specSigners = [mkMainSigner seller]
+        , specSigner = seller
         }
 
     Just NotStarted <- queryScriptState auctionParams
@@ -183,7 +183,7 @@ auctionSpec = describe "Auction" $ do
             [ MkSomeCEMAction $
                 MkCEMAction auctionParams Start
             ]
-        , specSigners = [mkMainSigner seller]
+        , specSigner = seller
         }
 
     Just (CurrentBid currentBid') <- queryScriptState auctionParams
@@ -195,7 +195,7 @@ auctionSpec = describe "Auction" $ do
             [ MkSomeCEMAction $
                 MkCEMAction auctionParams (MakeBid bid1)
             ]
-        , specSigners = [mkMainSigner bidder1]
+        , specSigner = bidder1
         }
 
     Just (CurrentBid currentBid) <- queryScriptState auctionParams
@@ -207,7 +207,7 @@ auctionSpec = describe "Auction" $ do
             [ MkSomeCEMAction $
                 MkCEMAction auctionParams Close
             ]
-        , specSigners = [mkMainSigner seller]
+        , specSigner = seller
         }
 
     submitAndCheck $
@@ -216,5 +216,5 @@ auctionSpec = describe "Auction" $ do
             [ MkSomeCEMAction $
                 MkCEMAction auctionParams Buyout
             ]
-        , specSigners = [mkMainSigner bidder1]
+        , specSigner = bidder1
         }
diff --git a/test/OffChain.hs b/test/OffChain.hs
@@ -65,7 +65,7 @@ offChainSpec = describe "Checking monad works" $ do
           , toMint = TxMintNone
           , interval = always
           , additionalSigners = []
-          , signer = [key1]
+          , signer = key1
           }
     awaitEitherTx =<< submitResolvedTx tx
 

diff --git a/test/Utils.hs b/test/Utils.hs
@@ -78,7 +78,7 @@ mintTestTokens userSk numMint = do
               [(tokenToAsset testNftTokenName, fromInteger numMint)]
         , interval = always
         , additionalSigners = []
-        , signer = [userSk]
+        , signer = userSk
         }
   awaitEitherTx =<< submitResolvedTx tx
   return ()

diff --git a/test/Voting.hs b/test/Voting.hs
@@ -39,35 +39,35 @@ votingSpec = describe "Voting" $ do
       submitAndCheck $
         MkTxSpec
           { actions = [mkAction Create]
-          , specSigners = [mkMainSigner creator]
+          , specSigner = creator
           }
 
       submitAndCheck $
         MkTxSpec
           { actions = [mkAction Start]
-          , specSigners = [mkMainSigner creator]
+          , specSigner = creator
           }
 
       -- Vote
 
       submitAndCheck $
         MkTxSpec
           { actions = [mkAction $ Vote (signingKeyToPKH jury1) Yes]
-          , specSigners = [mkMainSigner jury1]
+          , specSigner = jury1
           }
 
       submitAndCheck $
         MkTxSpec
           { actions = [mkAction $ Vote (signingKeyToPKH jury2) No]
-          , specSigners = [mkMainSigner jury2]
+          , specSigner = jury2
           }
 
       -- Count result
 
       submitAndCheck $
         MkTxSpec
           { actions = [mkAction Finalize]
-          , specSigners = [mkMainSigner jury2]
+          , specSigner = jury2
           }
 
       Just state <- queryScriptState params