Merge branch 'master' into marlowe-dash-remodel

cabal.project

@@ -1,5 +1,5 @@
 -- Bump this if you need newer packages
-index-state: 2021-02-17T00:00:00Z
+index-state: 2021-02-24T00:00:00Z
 
 packages: doc
           freer-extras

infrastructure/aws-accounts/private/tobias.pflug.password

@@ -0,0 +1 @@
+wcFMAxN/6UuqwT7KARAAqcZiII85mNnH85I3QrpkKhpdNutboYszxOHGiUGWNqBh/ur3e60yrIPBaN84gVaXVHfV1jFD3+6L12sm5+Q1pjWy3CA2renpVcayFbToTkbA2GupmX6dKq7XU1vWhIQR6L/JD+we/ld0j82C/MRyuQvaHBGQVuzKeGAcS3+I1j8nK50ZrkWBZNAwdjVx1lxHnsMzpTvRGpRJJOKbZ4xEFMvtBKrQkpyLNSXb1LGcf7/slq5Zshc8iGH8WRgGIW5/oo4rcNH3L1OjzyRx+VYsHRfiLpFIkQq4DJcL+UdpLUfbwCvMq+pHBp44Yp9Lm+VdKS98XcSeb51kn1f67tn2L+Asfky2kKF/MteQ1Z4B03Kl+9ZaRfjeR2PFk8NERXaomh5HOcn+O68AcJ/TltzHu9YDcmBZdYkFp3iFvkQgA24k3p7I4FpMGDeWoOAY1QFQJyXYp9oFliHXrFRNpy1vcaRTV+4aggqh1mM7VKYonhdT75eX6TvEi5rfQql+JO7EOcoIvKCo0FlhK5b8jM7g3g7BKql7JWbkr868+iXlU9zr/fFpypLiT16qrNRS9VxeeLMY8p9MwdXRBoHvy/ACBCSZ/VaOdGo1D/KmhVgSywQnosK8N/n3M+1VRreqnZFTQM6irgJYztU2VQx2s8XFxieSsp7k21V/a2dXr5SZzmLS4AHkzS49v+ht/BbhQwgriw5YnuHGO+Ds4OXhp5Dg5uJbaszp4GLkrvc57MYQ+gJBjF4Dz0Hl8+CV4vhSu+HgheSEQ1PSuRyxz8O4Htos38U+4s8wDjXhQx4A

infrastructure/aws-accounts/private/tobias.pflug.secret

@@ -0,0 +1 @@
+wcFMAxN/6UuqwT7KARAAC6PgPixd0BbkY73JR2DhPMmcoo1LgR2mawvR7m7YVf29d9PgLNWuF0i/lRIklldwcs4ydsyaPipNu40tWkdhXJo/9bWFVuVNxeM1auya1qDZRV6XBkt0zd/6mgT69v3qR+DxDWLMR2mx0NC7CGFRT+I6ySjAzbxCF73IhakAJEZWoaj5AImPI2OX4W4WOn2ILYOF1myOIpO5YhsOXL5Q5TPdRPmMLKPLBF1ik7EC/McPXsecdbQ9qAm11nKHOU3yU4EZyrY7nANCippVLQ+2nC/nDcegsf9Xb7OqImKXnta1ywapC1QxrIr8pc4p4M4MCS91/Y2cOrB2gjg0itmzANqOrJpMHcrNKVl74xVIxbzxKHI0WD3vEA3jB5KHeDsgGR216BVa2Fq5DycPHFn4M3NDZCtmEvaWzdfbRdhpbkfmuarWfj9E1+adTzsKgJVFPnxUPbrFJ+J052JFip8MiHFIk7ut2lwQNUs9bXF2hc8nu0EV9aN6B6vcIZXSr2Tbl4A+FE/4crn9FlFlmpjLLusqmI9qYIpY//CNFydxm4fY3HZwQPNX0vT4ZjzHBwN0g2cWZJpeqKWuJwngVmeCKIdwug5n07B0IZNlVSevS0ijMpAquGZ5z1CEhWajh3Ss0fcpl1TrHVTiS+97RLeoqIxyejNFagxBixbkjsXctWLS4AHkJBtbNTlJ7AdmdaO8MFWGd+FMzuAP4FjhCDbgZeIc4PYO4OjlZ2300WIk8f4fu3GYm3Wx7BRrXGWIHyJ6LQqblLGx79Dg9+MHh7PDF4JDHODe5H6mX+SM56SsXP4Ug5/hudXiBPmKCuEDGAA=

infrastructure/aws-accounts/users.tf

@@ -30,11 +30,6 @@ module "alexander_nemish" {
   policy_arn = "arn:aws:iam::aws:policy/AdministratorAccess"
 }
 
-module "tobias_pflug" {
-  source     = "../modules/existing-user"
-  username   = "tobias.pflug"
-  policy_arn = "arn:aws:iam::aws:policy/AdministratorAccess"
-}
 
 # Users that are in the AWS account but that I am unable to import
 
@@ -62,3 +57,9 @@ module "amyas_merivale" {
   username   = "amyas.merivale"
   policy_arn = "arn:aws:iam::aws:policy/AdministratorAccess"
 }
+
+module "tobias_pflug" {
+  source     = "../modules/user"
+  username   = "tobias.pflug"
+  policy_arn = "arn:aws:iam::aws:policy/AdministratorAccess"
+}

marlowe-dashboard-client/src/AppM.purs

@@ -0,0 +1,38 @@
+module AppM where
+
+import Prelude
+import Control.Monad.Reader.Trans (class MonadAsk, ReaderT, asks, runReaderT)
+import Effect.Aff (Aff)
+import Effect.Aff.Class (class MonadAff)
+import Effect.Class (class MonadEffect)
+import Env (Env)
+import Type.Equality (class TypeEquals, from)
+
+newtype AppM a
+  = AppM (ReaderT Env Aff a)
+
+runAppM :: Env -> AppM ~> Aff
+runAppM env (AppM m) = runReaderT m env
+
+derive newtype instance functorAppM :: Functor AppM
+
+derive newtype instance applyAppM :: Apply AppM
+
+derive newtype instance applicativeAppM :: Applicative AppM
+
+derive newtype instance bindAppM :: Bind AppM
+
+derive newtype instance monadAppM :: Monad AppM
+
+derive newtype instance monadEffectAppM :: MonadEffect AppM
+
+derive newtype instance monadAffAppM :: MonadAff AppM
+
+-- | We can't write instances for type synonyms, and we defined our environment (`Env`) as
+-- | a type synonym for convenience. To get around this, we can use `TypeEquals` to assert that
+-- | types `a` and `b` are in fact the same.
+-- |
+-- | In our case, we'll write a `MonadAsk` instance for the type `e`, and assert it is our `Env` type.
+-- | This is how we can write a type class instance for a type synonym, which is otherwise disallowed.
+instance monadAskAppM :: TypeEquals e Env => MonadAsk e AppM where
+  ask = AppM $ asks from

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

@@ -6,15 +6,25 @@ module Contract.State
   ) where
 
 import Prelude
-import Contract.Types (Action(..), Query(..), Side(..), State, Tab(..), _confirmation, _executionState, _side, _step, _tab)
+import Contract.Types (Action(..), Query(..), Side(..), State, Tab(..), _confirmation, _contractId, _executionState, _side, _step, _tab)
+import Control.Monad.Except (runExceptT)
+import Control.Monad.Maybe.Trans (runMaybeT)
+import Control.Monad.Reader (class MonadAsk)
+import Control.Monad.Reader.Extra (mapEnvReaderT)
+import Data.Foldable (for_)
 import Data.Lens (assign, modifying, use)
 import Data.Maybe (Maybe(..))
+import Data.RawJson (RawJson(..))
 import Data.Unfoldable as Unfoldable
 import Effect.Aff.Class (class MonadAff)
+import Env (Env)
+import Foreign.Generic (encode)
+import Foreign.JSON (unsafeStringify)
 import Halogen (HalogenM)
 import MainFrame.Types (ChildSlots, Msg)
 import Marlowe.Execution (NamedAction(..), _namedActions, _state, initExecution, merge, mkTx, nextState)
 import Marlowe.Semantics (Contract(..), Slot, _minSlot)
+import Plutus.PAB.Webserver (postApiContractByContractinstanceidEndpointByEndpointname)
 
 defaultState :: State
 defaultState = mkInitialState zero Close
@@ -25,6 +35,7 @@ mkInitialState slot contract =
   , executionState: initExecution slot contract
   , side: Overview
   , confirmation: Nothing
+  , contractId: Nothing
   , step: 0
   }
 
@@ -37,14 +48,25 @@ handleQuery (ApplyTx tx next) = do
   modifying _executionState \currentExeState -> merge (nextState currentExeState tx) currentExeState
   pure $ Just next
 
-handleAction :: forall m. MonadAff m => Action -> HalogenM State Action ChildSlots Msg m Unit
+handleAction ::
+  forall m.
+  MonadAff m =>
+  MonadAsk Env m =>
+  Action -> HalogenM State Action ChildSlots Msg m Unit
 handleAction (ConfirmInput input) = do
   currentExeState <- use _executionState
-  let
-    txInput = mkTx currentExeState (Unfoldable.fromMaybe input)
+  mContractId <- use _contractId
+  for_ mContractId \contractId -> do
+    let
+      txInput = mkTx currentExeState (Unfoldable.fromMaybe input)
 
-    executionState = nextState currentExeState txInput
-  assign _executionState executionState
+      json = RawJson <<< unsafeStringify <<< encode $ input
+    -- TODO: currently we just ignore errors but we probably want to do something better in the future
+    runMaybeT do
+      void $ mapEnvReaderT _.ajaxSettings $ runExceptT $ postApiContractByContractinstanceidEndpointByEndpointname json contractId "apply-inputs"
+      let
+        executionState = nextState currentExeState txInput
+      assign _executionState executionState
 
 -- raise (SendWebSocketMessage (ServerMsg true)) -- FIXME: send txInput to the server to apply to the on-chain contract
 handleAction (ChooseInput input) = assign _confirmation input

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

@@ -42,6 +42,7 @@ instance actionIsEvent :: IsEvent Action where
 type State
   = { tab :: Tab
     , executionState :: ExecutionState
+    , contractId :: Maybe String -- FIXME: what is a contract instance identified by
     , side :: Side
     , confirmation :: Maybe Input
     , step :: Int
@@ -61,3 +62,6 @@ _confirmation = prop (SProxy :: SProxy "confirmation")
 
 _step :: Lens' State Int
 _step = prop (SProxy :: SProxy "step")
+
+_contractId :: Lens' State (Maybe String)
+_contractId = prop (SProxy :: SProxy "contractId")

marlowe-dashboard-client/src/Env.purs

@@ -0,0 +1,9 @@
+module Env where
+
+import Servant.PureScript.Settings (SPSettings_)
+import Plutus.PAB.Webserver (SPParams_)
+
+-- Application enviroment configuration
+type Env
+  = { ajaxSettings :: SPSettings_ SPParams_
+    }

marlowe-dashboard-client/src/Main.purs

@@ -1,28 +1,35 @@
 module Main where
 
 import Prelude
+import AppM (runAppM)
 import Control.Coroutine (Consumer, Process, connect, consumer, runProcess)
 import Data.Maybe (Maybe(..))
 import Effect (Effect)
 import Effect.Aff (Aff, forkAff)
 import Effect.Class (liftEffect)
 import Effect.Console (log)
 import Effect.Unsafe (unsafePerformEffect)
+import Env (Env)
 import Foreign.Generic (defaultOptions)
+import Halogen (Component, hoist)
 import Halogen.Aff (awaitBody, runHalogenAff)
+import Halogen.HTML (HTML)
 import Halogen.VDom.Driver (runUI)
 import LocalStorage (RawStorageEvent)
 import LocalStorage as LocalStorage
 import MainFrame.State (mkMainFrame)
 import MainFrame.Types (Action(..), Msg(..), Query(..))
+import MainFrame.Types as MainFrame
 import Plutus.PAB.Webserver (SPParams_(SPParams_))
-import Servant.PureScript.Settings (SPSettingsDecodeJson_(..), SPSettingsEncodeJson_(..), SPSettings_(..), defaultSettings)
 import Plutus.PAB.Webserver.Types (StreamToClient, StreamToServer)
+import Servant.PureScript.Settings (SPSettingsDecodeJson_(..), SPSettingsEncodeJson_(..), SPSettings_(..), defaultSettings)
 import WebSocket.Support (WebSocketManager, mkWebSocketManager)
 import WebSocket.Support as WS
 
-ajaxSettings :: SPSettings_ SPParams_
-ajaxSettings = SPSettings_ $ (settings { decodeJson = decodeJson, encodeJson = encodeJson })
+environment :: Env
+environment =
+  { ajaxSettings: SPSettings_ (settings { decodeJson = decodeJson, encodeJson = encodeJson })
+  }
   where
   SPSettings_ settings = defaultSettings $ SPParams_ { baseURL: "/" }
 
@@ -35,7 +42,8 @@ ajaxSettings = SPSettings_ $ (settings { decodeJson = decodeJson, encodeJson = e
 main :: Effect Unit
 main = do
   let
-    mainFrame = mkMainFrame
+    mainFrame :: Component HTML MainFrame.Query MainFrame.Action MainFrame.Msg Aff
+    mainFrame = hoist (runAppM environment) mkMainFrame
   runHalogenAff do
     body <- awaitBody
     driver <- runUI mainFrame Init body

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

@@ -2,6 +2,7 @@ module MainFrame.State (mkMainFrame) where
 
 import Prelude
 import Control.Monad.Except (runExcept)
+import Control.Monad.Reader (class MonadAsk)
 import Data.Either (Either(..))
 import Data.Foldable (for_)
 import Data.Lens (assign, over, set, use)
@@ -11,6 +12,7 @@ import Data.Maybe (Maybe(..))
 import Data.Tuple (fst, snd)
 import Effect.Aff.Class (class MonadAff)
 import Effect.Random (random)
+import Env (Env)
 import Foreign.Generic (decodeJSON, encodeJSON)
 import Halogen (Component, HalogenM, liftEffect, mkComponent, mkEval, modify_)
 import Halogen.HTML (HTML)
@@ -29,7 +31,11 @@ import WalletData.Lenses (_key, _nickname)
 import WalletData.Types (WalletDetails)
 import WebSocket.Support as WS
 
-mkMainFrame :: forall m. MonadAff m => Component HTML Query Action Msg m
+mkMainFrame ::
+  forall m.
+  MonadAff m =>
+  MonadAsk Env m =>
+  Component HTML Query Action Msg m
 mkMainFrame =
   mkComponent
     { initialState: const initialState
@@ -81,7 +87,11 @@ handleQuery (ReceiveWebSocketMessage msg next) = do
 -- or our `render` functions a bit awkward. I prefer the former. Hence some
 -- submodule actions (triggered straightforwardly in the submodule's `render`
 -- functions) are handled by their parent module's `handleAction` function.
-handleAction :: forall m. MonadAff m => Action -> HalogenM State Action ChildSlots Msg m Unit
+handleAction ::
+  forall m.
+  MonadAff m =>
+  MonadAsk Env m =>
+  Action -> HalogenM State Action ChildSlots Msg m Unit
 handleAction Init = do
   mCachedWalletsJson <- liftEffect $ getItem walletsLocalStorageKey
   for_ mCachedWalletsJson \json ->

nix/pkgs/haskell/extra.nix

@@ -18,7 +18,7 @@
   Agda = haskell-nix.hackage-package {
     name = "Agda";
     version = "2.6.1.1";
-    plan-sha256 = "03gmq1gbbq7w870qjqbr9aiyyxmj1xl182k3cjnby2w59np6isyl";
+    plan-sha256 = "1mj425brxp4zvbpj04ixzmpdrb7i6mcg54y8q4396s1mzy74k1xw";
     # Should use the index-state from the target cabal.project, but that disables plan-sha256. Fixed
     # in recent haskell.nix, delete the index-state passing when we update.
     inherit compiler-nix-name index-state checkMaterialization;
@@ -52,24 +52,24 @@
   };
   cabal-install = haskell-nix.hackage-package {
     name = "cabal-install";
-    version = "3.2.0.0";
+    version = "3.4.0.0";
     inherit compiler-nix-name index-state checkMaterialization;
     # Invalidate and update if you change the version or index-state
-    plan-sha256 = "0n8vpjj8477f50kab9h4pgh92q49260r78fc3pfh2l56lmc6ngfi";
+    plan-sha256 = "12qb9j99zkav8df91s9wsigqcj6h8wzlq95ci5qgj263rkm112a9";
   };
   stylish-haskell = haskell-nix.hackage-package {
     name = "stylish-haskell";
     version = "0.12.2.0";
     inherit compiler-nix-name index-state checkMaterialization;
     # Invalidate and update if you change the version or index-state
-    plan-sha256 = "1wdpv3n1lz4dwkw2mvhnbyqq2haskcjiz1py9h1i0www2valm1lj";
+    plan-sha256 = "12falax0q7hqsgjvirpn8nnf97pl7a17kfwf9jp0j3k1plwlv8fy";
   };
   hlint = haskell-nix.hackage-package {
     name = "hlint";
     version = "3.2.1";
     inherit compiler-nix-name index-state checkMaterialization;
     # Invalidate and update if you change the version or index-state
-    plan-sha256 = "06zc8rs4rbsfjrixy2mazy7rlkxk1smgjrhkp4d3krmabmfqm2wd";
+    plan-sha256 = "15dx7l2ilp4w0jvczvpn5c8gjyh8cx3qgaq92d2r2570ml49im2z";
     modules = [{ reinstallableLibGhc = false; }];
   };
 }
@@ -91,8 +91,8 @@
     plan-sha256 =
       # See https://github.com/input-output-hk/nix-tools/issues/97
       if stdenv.isLinux
-      then "137f0k6dvf1m8zpykqfcrrn9dmnypryhhqpaa9jgx6wvn7ra6061"
-      else "1dvp46l6c91v2581pwjybvlg65ppbmpc37f7afvm0qbwrrdncvid";
+      then "09cbs77xcxmfsv1vxdbaj31r3d1mnwci7061vcrn5fkncsx827xq"
+      else "1ypvxgvwzgh1jm4cfk6y0c6iqnrinkcha76rmnchim2y9zz070pj";
     modules = [{
       packages.ghcide.patches = [ ../../patches/ghcide_partial_iface.patch ];
     }];

nix/pkgs/haskell/materialized-musl/.plan.nix/plutus-pab.nix

@@ -182,7 +182,6 @@
           "Plutus/PAB/Events/Wallet"
           "Plutus/PAB/ParseStringifiedJSON"
           "Plutus/PAB/Query"
-          "Plutus/PAB/Relation"
           "Plutus/PAB/PABLogMsg"
           "Plutus/PAB/Types"
           ];
@@ -389,7 +388,6 @@
           buildable = true;
           modules = [
             "Plutus/PAB/CoreSpec"
-            "Plutus/PAB/RelationSpec"
             "Plutus/PAB/Events/ContractSpec"
             "Cardano/Metadata/ServerSpec"
             "Cardano/Metadata/TypesSpec"