Merge branch 'master' of https://github.com/input-output-hk/plutus in…

…to effectfully/builtins/add-lists-and-tuples

marlowe-dashboard-client/package.json

@@ -2,10 +2,8 @@
   "name": "marlowe-dashboard-client",
   "version": "1.0.0",
   "scripts": {
-    "webpack": "NODE_ENV=production NODE_OPTIONS=\"--max-old-space-size=8192\" DEBUG=purs-loader* DEBUG_DEPTH=100 webpack --progress --bail --mode=production -p",
-    "webpack:watch": "PATH=$PATH:../releases/psc-package DEBUG=purs-loader* DEBUG_DEPTH=100 webpack --progress --display-error-details --display verbose --watch",
-    "webpack:server": "webpack-dev-server --progress --inline --hot --mode=development --host 0.0.0.0 --display verbose",
-    "webpack:server:debug": "DEBUG=purs-loader* DEBUG_DEPTH=100 webpack-dev-server --progress --inline --hot",
+    "webpack": "webpack --progress --bail --mode=production --node-env=production",
+    "webpack:server": "webpack-cli serve --progress --inline --hot --mode=development --node-env=development",
     "purs:compile": "spago build",
     "purs:ide": "purs ide server --log-level=debug 'src/**/*.purs' 'generated/**/*.purs' 'test/**/*.purs' 'web-common/**/*.purs' 'web-common-marlowe/**/*.purs'",
     "test": "spago --no-psa test",
@@ -17,32 +15,29 @@
     "install-contracts": "nix-build ../default.nix -A marlowe-dashboard.install-marlowe-contracts",
     "setup-contracts": "npm run install-contracts && npm run link-contracts"
   },
-  "dependencies": {
-    "json-bigint": "^1.0.0"
-  },
   "resolutions": {},
   "license": "Apache-2.0",
+  "dependencies": {
+    "json-bigint": "^1.0.0",
+    "uuid": "^8.3.2",
+    "xhr2": "^0.2.1"
+  },
   "devDependencies": {
-    "@tailwindcss/forms": "^0.2.1",
+    "@tailwindcss/forms": "^0.3.2",
     "autoprefixer": "^10.2.5",
-    "css-loader": "^1.0.0",
+    "css-loader": "^5.2.4",
     "cssnano": "^5.0.2",
-    "file-loader": "^2.0.0",
-    "html-webpack-plugin": "^3.2.0",
+    "html-webpack-plugin": "^5.3.1",
     "mini-css-extract-plugin": "^1.5.1",
     "postcss": "^8.2.13",
-    "postcss-import": "^14.0.0",
-    "postcss-loader": "^4.2.0",
-    "precss": "^4.0.0",
-    "purs-loader": "^3.6.0",
-    "raw-loader": "^4.0.1",
-    "tailwindcss": "^2.0.2",
-    "url-loader": "^1.1.2",
-    "uuid-validate": "^0.0.3",
-    "webpack": "^4.41.0",
-    "webpack-cli": "^3.1.2",
-    "webpack-dev-server": "^3.1.10",
-    "webpack-node-externals": "^1.7.2",
-    "xhr2": "^0.1.4"
+    "postcss-import": "^14.0.1",
+    "postcss-loader": "^5.2.0",
+    "purescript-psa": "^0.8.2",
+    "purs-loader": "^3.7.2",
+    "raw-loader": "^4.0.2",
+    "tailwindcss": "^2.1.2",
+    "webpack": "^5.36.2",
+    "webpack-cli": "^4.6.0",
+    "webpack-dev-server": "^3.11.2"
   }
 }

marlowe-dashboard-client/packages.dhall

@@ -121,7 +121,20 @@ let additions =
 let upstream =
       https://github.com/purescript/package-sets/releases/download/psc-0.13.6-20200502/packages.dhall sha256:1e1ecbf222c709b76cc7e24cf63af3c2089ffd22bbb1e3379dfd3c07a1787694
 
-let overrides = {=}
+let overrides =
+      {- The package set we're using has `purescript-uuid` v6. This depends on the `uuid-validate` node
+         module, which only works in node (it uses node's Buffer API). This was fine when we were using
+         webpack 4, which provides polyfills for node stuff automatically. But webpack 5 - rightly, in
+         my opinion - no longer provides these polyfills. I was going to add it back in manually when I
+         noticed that the newer versions of `purescript-uuid` use the `uuid` node module, which works
+         in the browser out of the box. :tada:
+      -}
+      { uuid =
+          { dependencies = [ "effect", "maybe", "foreign-generic", "console", "spec" ]
+          , repo = "https://github.com/spicydonuts/purescript-uuid.git"
+          , version = "v8.0.0"
+          }
+      }
 
 let additions =
       { servant-support =

marlowe-dashboard-client/plutus-pab.yaml

@@ -29,9 +29,6 @@ nodeServerConfig:
   mscSlotConfig:
     scZeroSlotTime: "2020-06-07T21:44:51Z" # see note [Datetime to slot] in Marlowe.Slot
     scSlotLength: 1
-  mscBlockReaper:
-    brcInterval: 600
-    brcBlocksToKeep: 100
   mscInitialTxWallets:
     - getWallet: 1
     - getWallet: 2

marlowe-dashboard-client/postcss.config.js

@@ -1,4 +1,5 @@
-'use strict';
+"use strict";
+
 const extraPlugins =
   process.env.NODE_ENV === "production"
     ? [
@@ -17,10 +18,9 @@ const extraPlugins =
 
 module.exports = {
   plugins: [
-    require('postcss-import'),
-    require('precss'),
-    require('tailwindcss'),
-    require('autoprefixer'),
+    require("postcss-import"),
+    require("tailwindcss"),
+    require("autoprefixer"),
     ...extraPlugins
   ]
 };

marlowe-dashboard-client/spago-packages.nix

@@ -1147,11 +1147,11 @@ let
 
     "uuid" = pkgs.stdenv.mkDerivation {
         name = "uuid";
-        version = "v6.1.0";
+        version = "v8.0.0";
         src = pkgs.fetchgit {
           url = "https://github.com/spicydonuts/purescript-uuid.git";
-          rev = "e5d74beef8b33aad9f9b0824950152c46ac2c7f1";
-          sha256 = "1ldrhjavv9vngdnh9i7pbg93iwaslrs6rfcv8jh5cjywpin8n6zx";
+          rev = "b99a5e66235d773cdd45657ff3d3c320ecf3711a";
+          sha256 = "0b6swi5xxgjsps70ci2v4mr3yrqrb7gb0smmia0iq2w077j92d89";
         };
         phases = "installPhase";
         installPhase = "ln -s $src $out";

marlowe-dashboard-client/src/Capability/Marlowe.purs

@@ -113,6 +113,8 @@ instance monadMarloweAppM :: ManageMarlowe AppM where
         wallet = view (_walletInfo <<< _wallet) walletDetails
       contractInstanceId <- ExceptT $ Contract.activateContract (plutusAppPath MarloweApp) wallet
       result <- ExceptT $ Contract.invokeEndpoint contractInstanceId endpoint payload
+      -- FIXME: this plan didn't work - deactivating the contract right away stops the endpoint invocation
+      -- from doing what it needs to do
       void $ ExceptT $ Contract.deactivateContract contractInstanceId
       pure result
   -- "create" a Marlowe contract on the blockchain

marlowe-dashboard-client/src/Capability/Websocket.purs

@@ -11,7 +11,8 @@ import AppM (AppM)
 import Data.Either (Either(..))
 import Halogen (HalogenM, raise)
 import MainFrame.Types (Msg(..))
-import Plutus.PAB.Webserver.Types (CombinedWSStreamToServer(..))
+import Marlowe.PAB (CombinedWSStreamToServer(..))
+--import Plutus.PAB.Webserver.Types (CombinedWSStreamToServer(..))
 import Wallet.Emulator.Wallet (Wallet)
 import Wallet.Types (ContractInstanceId)
 

marlowe-dashboard-client/src/Contract/State.purs

@@ -13,7 +13,7 @@ import Prelude
 import Capability.Marlowe (class ManageMarlowe, applyTransactionInput)
 import Capability.Toast (class Toast, addToast)
 import Contract.Lenses (_executionState, _marloweParams, _namedActions, _previousSteps, _selectedStep, _tab)
-import Contract.Types (Action(..), PreviousStep, PreviousStepState(..), State, Tab(..), scrollContainerRef)
+import Contract.Types (Action(..), Input, PreviousStep, PreviousStepState(..), State, Tab(..), scrollContainerRef)
 import Control.Monad.Reader (class MonadAsk, asks)
 import Data.Array (difference, foldl, head, index, length, mapMaybe)
 import Data.Either (Either(..))
@@ -44,9 +44,8 @@ import Marlowe.HasParties (getParties)
 import Marlowe.Execution (ExecutionState, NamedAction(..), PreviousState, _currentContract, _currentState, _pendingTimeouts, _previousState, _previousTransactions, expandBalances, extractNamedActions, initExecution, isClosed, mkTx, nextState, timeoutState)
 import Marlowe.Extended.Metadata (emptyContractMetadata)
 import Marlowe.PAB (PlutusAppId(..), History, MarloweParams)
-import Marlowe.Semantics (Contract(..), Input(..), Party(..), Slot, SlotInterval(..), Token(..), TransactionInput(..))
-import Marlowe.Semantics as Semantic
-import Marlowe.Slot (currentSlot)
+import Marlowe.Semantics (Contract(..), Party(..), Slot, SlotInterval(..), Token(..), TransactionInput(..))
+import Marlowe.Semantics (Input(..), State(..)) as Semantic
 import Plutus.V1.Ledger.Value (CurrencySymbol(..))
 import Toast.Types (ajaxErrorToast, successToast)
 import WalletData.Lenses (_assets, _pubKeyHash, _walletInfo)
@@ -164,19 +163,18 @@ handleAction ::
   MonadAsk Env m =>
   ManageMarlowe m =>
   Toast m =>
-  WalletDetails -> Action -> HalogenM State Action ChildSlots Msg m Unit
-handleAction walletDetails (ConfirmAction namedAction) = do
+  Input -> Action -> HalogenM State Action ChildSlots Msg m Unit
+handleAction input@{ currentSlot, walletDetails } (ConfirmAction namedAction) = do
   currentExeState <- use _executionState
   marloweParams <- use _marloweParams
-  slot <- liftEffect currentSlot
   let
-    input = toInput namedAction
+    contractInput = toInput namedAction
 
-    txInput = mkTx slot (currentExeState ^. _currentContract) (Unfoldable.fromMaybe input)
+    txInput = mkTx currentSlot (currentExeState ^. _currentContract) (Unfoldable.fromMaybe contractInput)
   -- FIXME: remove the next four lines and uncomment the code below when things are working in the PAB
-  modify_ $ applyTx slot txInput
+  modify_ $ applyTx currentSlot txInput
   stepNumber <- gets currentStep
-  handleAction walletDetails (MoveToStep stepNumber)
+  handleAction input (MoveToStep stepNumber)
   addToast $ successToast "Payment received, step completed."
 
 --ajaxApplyInputs <- applyTransactionInput walletDetails marloweParams txInput
@@ -249,10 +247,10 @@ applyTimeout currentSlot state =
       # regenerateStepCards currentSlot
       # selectLastStep
 
-toInput :: NamedAction -> Maybe Input
-toInput (MakeDeposit accountId party token value) = Just $ IDeposit accountId party token value
+toInput :: NamedAction -> Maybe Semantic.Input
+toInput (MakeDeposit accountId party token value) = Just $ Semantic.IDeposit accountId party token value
 
-toInput (MakeChoice choiceId _ (Just chosenNum)) = Just $ IChoice choiceId chosenNum
+toInput (MakeChoice choiceId _ (Just chosenNum)) = Just $ Semantic.IChoice choiceId chosenNum
 
 -- WARNING:
 --       This is possible in the types but should never happen in runtime. And I prefer to explicitly throw
@@ -265,7 +263,7 @@ toInput (MakeChoice choiceId _ (Just chosenNum)) = Just $ IChoice choiceId chose
 --       seems like an overkill.
 toInput (MakeChoice _ _ Nothing) = unsafeThrow "A choice action has been triggered"
 
-toInput (MakeNotify _) = Just $ INotify
+toInput (MakeNotify _) = Just $ Semantic.INotify
 
 toInput _ = Nothing
 

marlowe-dashboard-client/src/Contract/Types.purs

@@ -3,6 +3,7 @@ module Contract.Types
   , PreviousStep
   , PreviousStepState(..)
   , Tab(..)
+  , Input
   , Action(..)
   , scrollContainerRef
   ) where
@@ -17,7 +18,7 @@ import Marlowe.Execution (ExecutionState, NamedAction)
 import Marlowe.Extended.Metadata (MetaData)
 import Marlowe.PAB (PlutusAppId, MarloweParams)
 import Marlowe.Semantics (ChoiceId, ChosenNum, Party, Slot, TransactionInput, Accounts)
-import WalletData.Types (WalletNickname)
+import WalletData.Types (WalletDetails, WalletNickname)
 
 type State
   = { tab :: Tab
@@ -53,6 +54,11 @@ data Tab
 
 derive instance eqTab :: Eq Tab
 
+type Input
+  = { currentSlot :: Slot
+    , walletDetails :: WalletDetails
+    }
+
 data Action
   = ConfirmAction NamedAction
   | ChangeChoice ChoiceId (Maybe ChosenNum)

marlowe-dashboard-client/src/Contract/View.purs

@@ -100,7 +100,7 @@ cardNavigationButtons state =
       | selectedStep == lastStep =
         Just
           $ div
-              [ classNames [ "px-6", "py-4", "rounded-lg", "bg-white", "font-semibold", "ml-auto" ] ]
+              [ classNames [ "px-6", "py-4", "rounded-full", "bg-white", "font-semibold", "ml-auto" ] ]
               [ text "Waiting..." ]
       | otherwise =
         Just
@@ -250,7 +250,7 @@ renderContractCard stepNumber state cardBody =
 statusIndicator :: forall p a. Maybe Icon -> String -> Array String -> HTML p a
 statusIndicator mIcon status extraClasses =
   div
-    [ classNames $ [ "flex-grow", "rounded-lg", "h-10", "flex", "items-center" ] <> extraClasses ]
+    [ classNames $ [ "flex-grow", "rounded-full", "h-10", "flex", "items-center" ] <> extraClasses ]
     $ Array.catMaybes
         [ mIcon <#> \anIcon -> icon anIcon [ "pl-3" ]
         , Just $ span [ classNames [ "text-xs", "flex-grow", "text-center", "font-semibold" ] ] [ text status ]
@@ -277,7 +277,7 @@ renderPastStep state stepNumber step =
               TimeoutStep _ -> statusIndicator (Just Timer) "Timed out" [ "bg-red", "text-white" ]
               TransactionStep _ -> statusIndicator (Just Done) "Completed" [ "bg-green", "text-white" ]
           ]
-      , div [ classNames [ "overflow-y-auto", "px-4" ] ]
+      , div [ classNames [ "overflow-y-auto", "px-4", "h-full" ] ]
           [ renderBody currentTab step
           ]
       ]
@@ -408,7 +408,7 @@ renderCurrentStep currentSlot state =
             else
               statusIndicator (Just Timer) timeoutStr [ "bg-lightgray" ]
           ]
-      , div [ classNames [ "overflow-y-auto", "px-4" ] ]
+      , div [ classNames [ "overflow-y-auto", "px-4", "h-full" ] ]
           [ case currentTab /\ contractIsClosed of
               Tasks /\ false -> renderTasks state
               Tasks /\ true -> renderContractClose
@@ -502,7 +502,7 @@ renderParty state party =
   in
     -- FIXME: mb-2 should not belong here
     div [ classNames [ "text-xs", "flex", "mb-2" ] ]
-      [ div [ classNames [ "bg-gradient-to-r", "from-purple", "to-lightpurple", "text-white", "rounded-full", "w-5", "h-5", "text-center", "mr-1" ] ] [ text $ String.take 1 participantName ]
+      [ div [ classNames [ "bg-gradient-to-r", "from-purple", "to-lightpurple", "text-white", "rounded-full", "w-5", "h-5", "text-center", "mr-1", "font-semibold" ] ] [ text $ String.take 1 participantName ]
       , div [ classNames [ "font-semibold" ] ] [ text participantName ]
       ]
 
@@ -553,12 +553,11 @@ renderAction state party namedAction@(MakeDeposit intoAccountOf by token value)
     div_
       [ shortDescription isActiveParticipant description
       , button
-          -- TODO: adapt to use button classes from Css module
-          [ classNames $ [ "flex", "justify-between", "px-6", "font-bold", "w-full", "py-4", "mt-2", "rounded-lg", "shadow" ]
+          [ classNames $ Css.button <> [ "flex", "justify-between", "w-full", "mt-2" ]
               <> if isActiveParticipant || debugMode then
-                  [ "bg-gradient-to-r", "from-purple", "to-lightpurple", "text-white" ]
+                  Css.bgBlueGradient <> Css.withShadow
                 else
-                  [ "bg-gray", "text-black", "opacity-50", "cursor-default" ]
+                  [ "text-black", "cursor-default" ]
           , enabled $ isActiveParticipant || debugMode
           , onClick_ $ AskConfirmation namedAction
           ]
@@ -590,10 +589,19 @@ renderAction state party namedAction@(MakeChoice choiceId bounds mChosenNum) =
 
     multipleInput = \_ ->
       div
-        [ classNames [ "flex", "w-full", "shadow", "rounded-lg", "mt-2", "overflow-hidden", "focus-within:ring-1", "ring-black" ]
+        [ classNames
+            $ [ "flex"
+              , "w-full"
+              , "rounded"
+              , "mt-2"
+              , "overflow-hidden"
+              , "focus-within:ring-1"
+              , "ring-black"
+              ]
+            <> applyWhen (isActiveParticipant || debugMode) Css.withShadow
         ]
         [ input
-            [ classNames [ "border-0", "py-4", "pl-4", "pr-1", "flex-grow", "focus:ring-0" ]
+            [ classNames [ "border-0", "py-4", "pl-4", "pr-1", "flex-grow", "focus:ring-0", "min-w-0", "text-sm", "disabled:bg-lightgray" ]
             , type_ InputNumber
             , enabled $ isActiveParticipant || debugMode
             , maybe'
@@ -606,9 +614,9 @@ renderAction state party namedAction@(MakeChoice choiceId bounds mChosenNum) =
             [ classNames
                 ( [ "px-5", "font-bold" ]
                     <> if isValid then
-                        [ "bg-gradient-to-b", "from-purple", "to-lightpurple", "text-white" ]
+                        Css.bgBlueGradient
                       else
-                        [ "bg-gray", "text-black", "opacity-50", "cursor-default" ]
+                        [ "bg-darkgray", "text-white", "opacity-50", "cursor-default" ]
                 )
             , onClick_ $ AskConfirmation namedAction
             , enabled $ isValid && isActiveParticipant
@@ -618,12 +626,11 @@ renderAction state party namedAction@(MakeChoice choiceId bounds mChosenNum) =
 
     singleInput = \_ ->
       button
-        -- TODO: adapt to use button classes from Css module
-        [ classNames $ [ "px-6", "font-bold", "w-full", "py-4", "mt-2", "rounded-lg", "shadow" ]
+        [ classNames $ Css.button <> [ "w-full", "mt-2" ]
             <> if isActiveParticipant || debugMode then
-                [ "bg-gradient-to-r", "from-purple", "to-lightpurple", "text-white" ]
+                Css.bgBlueGradient <> Css.withShadow
               else
-                [ "bg-gray", "text-black", "opacity-50", "cursor-default" ]
+                [ "text-black", "cursor-default" ]
         , enabled $ isActiveParticipant || debugMode
         , onClick_ $ AskConfirmation $ MakeChoice choiceId bounds $ Just minBound
         ]
@@ -653,11 +660,11 @@ renderAction state party CloseContract =
       [ shortDescription isActiveParticipant "The contract is still open and needs to be manually closed by any participant for the remainder of the balances to be distributed (charges may apply)"
       , button
           -- TODO: adapt to use button classes from Css module
-          [ classNames $ [ "font-bold", "w-full", "py-4", "mt-2", "rounded-lg", "shadow" ]
+          [ classNames $ Css.button <> [ "w-full", "mt-2" ]
               <> if isActiveParticipant || debugMode then
-                  [ "bg-gradient-to-r", "from-purple", "to-lightpurple", "text-white" ]
+                  Css.bgBlueGradient <> Css.withShadow
                 else
-                  [ "bg-gray", "text-black", "opacity-50", "cursor-default" ]
+                  [ "text-black", "cursor-default" ]
           , enabled $ isActiveParticipant || debugMode
           , onClick_ $ AskConfirmation CloseContract
           ]