Add contract setup form

marlowe-dashboard-client/src/Component/Contacts/State.purs

@@ -86,7 +86,7 @@ handleAction addressBook (SetCardSection cardSection) = do
         $ InputField.SetValidator
         $ either Just (const Nothing)
             <<< lmap walletNicknameErrorToLegacyError
-            <<< WN.fromString (AddressBook.nicknames addressBook)
+            <<< WN.fromStringExclusive (AddressBook.nicknames addressBook)
       handleAction addressBook $ AddressInputAction InputField.Reset
       handleAction addressBook
         $ AddressInputAction
@@ -102,7 +102,7 @@ handleAction _ (SaveWallet mTokenName) = do
   addressString <- use (_addressInput <<< _value)
   let
     result = Tuple
-      <$> hush (WN.fromString Set.empty walletNicknameString)
+      <$> hush (WN.fromString walletNicknameString)
       <*> hush (A.fromString Set.empty addressString)
   case result of
     Just (Tuple walletNickname address) -> do
@@ -189,6 +189,7 @@ walletNicknameErrorToLegacyError
 walletNicknameErrorToLegacyError = case _ of
   WN.Empty -> EmptyWalletNickname
   WN.Exists -> DuplicateWalletNickname
+  WN.DoesNotExist -> DuplicateWalletNickname
   WN.ContainsNonAlphaNumeric -> BadWalletNickname
 
 addressErrorToLegacyError :: A.AddressError -> AddressError

marlowe-dashboard-client/src/Component/ContractSetupForm.purs

@@ -0,0 +1,161 @@
+module Component.ContractSetupForm where
+
+import Prologue
+
+import Data.Address (Address)
+import Data.AddressBook (AddressBook)
+import Data.AddressBook as AddressBook
+import Data.ContractNickname (ContractNickname)
+import Data.ContractNickname as CN
+import Data.ContractTimeout (ContractTimeout)
+import Data.ContractTimeout as CT
+import Data.ContractValue (ContractValue)
+import Data.ContractValue as CV
+import Data.Either (note)
+import Data.Lens (Lens')
+import Data.Lens.Record (prop)
+import Data.Map (Map)
+import Data.Map as Map
+import Data.Set (Set)
+import Data.Set as Set
+import Data.Validation.Semigroup (V(..))
+import Data.WalletNickname (WalletNicknameError(..))
+import Data.WalletNickname as WN
+import Effect.Aff.Class (class MonadAff)
+import Forms (InputSlots)
+import Forms as Forms
+import Halogen as H
+import Halogen.Form (Form, subform, useForm)
+import Halogen.Form as Form
+import Halogen.Hooks as Hooks
+import Marlowe.Semantics (TokenName)
+import Polyform.Validator (liftFnV)
+import Type.Proxy (Proxy(..))
+
+type Input =
+  { roles :: Set TokenName
+  , timeouts :: Set String
+  , values :: Set String
+  , addressBook :: AddressBook
+  }
+
+type ContractInput =
+  { nickname :: String
+  , roles :: Map TokenName String
+  , timeouts :: Map String String
+  , values :: Map String String
+  }
+
+_nickname :: Lens' ContractInput String
+_nickname = prop (Proxy :: _ "nickname")
+
+_roles :: Lens' ContractInput (Map TokenName String)
+_roles = prop (Proxy :: _ "roles")
+
+_timeouts :: Lens' ContractInput (Map String String)
+_timeouts = prop (Proxy :: _ "timeouts")
+
+_values :: Lens' ContractInput (Map String String)
+_values = prop (Proxy :: _ "values")
+
+data ContractParams =
+  ContractParams
+    ContractNickname
+    (Map TokenName Address)
+    (Map String ContractTimeout)
+    (Map String ContractValue)
+
+derive instance Eq ContractParams
+
+data Msg
+  = Back
+  | Next ContractParams
+
+type Component q m =
+  H.Component q Input Msg m
+
+contractNicknameForm
+  :: forall s m. Monad m => Form (InputSlots s) m String ContractNickname
+contractNicknameForm =
+  Forms.input "contract-nickname" "Contract title" CN.validator case _ of
+    CN.Empty -> "Required."
+
+roleAssignmentForm
+  :: forall s m
+   . Monad m
+  => AddressBook
+  -> TokenName
+  -> Form (InputSlots s) m String Address
+roleAssignmentForm addressBook roleName =
+  Forms.input ("role-input-" <> roleName) roleName validator case _ of
+    WN.Empty -> "Required."
+    WN.Exists -> "Already exists."
+    WN.DoesNotExist -> "Not found."
+    WN.ContainsNonAlphaNumeric -> "Can only contain letters and digits."
+  where
+  validator =
+    liftFnV $
+      V <<<
+        ( note WN.DoesNotExist <<< flip AddressBook.lookupAddress addressBook
+            <=< WN.fromString
+        )
+
+roleForms
+  :: forall s m
+   . Monad m
+  => AddressBook
+  -> Form (InputSlots s) m (Map TokenName String) (Map TokenName Address)
+roleForms addressBook =
+  Form.multiWithIndex $ roleAssignmentForm $ addressBook
+
+timeoutForm
+  :: forall s m
+   . Monad m
+  => String
+  -> Form (InputSlots s) m String ContractTimeout
+timeoutForm name =
+  Forms.input ("slot-input-" <> name) name CT.validator case _ of
+    CT.Empty -> "Required."
+    CT.Past -> "Must be in the future."
+    CT.Invalid -> "Must be a number of slots from contract start."
+
+valueForm
+  :: forall s m
+   . Monad m
+  => String
+  -> Form (InputSlots s) m String ContractValue
+valueForm name =
+  Forms.input ("value-input-" <> name) name CV.validator case _ of
+    CV.Empty -> "Required."
+    CV.Negative -> "Must by positive."
+    CV.Invalid -> "Must by a number."
+
+mkForm
+  :: forall slots m
+   . Monad m
+  => AddressBook
+  -> Form (InputSlots slots) m ContractInput ContractParams
+mkForm addressBook =
+  ContractParams
+    <$> subform _nickname contractNicknameForm
+    <*> subform _roles (roleForms addressBook)
+    <*> subform _timeouts (Form.multiWithIndex timeoutForm)
+    <*> subform _values (Form.multiWithIndex valueForm)
+
+initialFormInput :: Set TokenName -> Set String -> Set String -> ContractInput
+initialFormInput roles timeouts values =
+  { nickname: ""
+  , roles: Map.fromFoldable $ Set.map (flip Tuple "") roles
+  , timeouts: Map.fromFoldable $ Set.map (flip Tuple "") timeouts
+  , values: Map.fromFoldable $ Set.map (flip Tuple "") values
+  }
+
+component :: forall q m. MonadAff m => Component q m
+component = Hooks.component \{ outputToken } input -> Hooks.do
+  let { addressBook, roles, timeouts, values } = input
+  form <- Hooks.captures { addressBook } Hooks.useMemo \_ -> mkForm addressBook
+  { result, html } <- useForm form (initialFormInput roles timeouts values)
+  let back = Hooks.raise outputToken Back
+  let next = Hooks.raise outputToken <<< Next <$> result
+  Hooks.pure do
+    html []

marlowe-dashboard-client/src/Component/Template/State.purs

@@ -146,7 +146,7 @@ handleAction _ (ContractNicknameInputAction inputFieldAction) =
 
 handleAction input@{ addressBook } UpdateRoleWalletValidators =
   setInputValidators input _roleWalletInputs RoleWalletInputAction
-    $ roleError addressBook <<< hush <<< WN.fromString mempty
+    $ roleError addressBook <<< hush <<< WN.fromString
 
 handleAction _ (RoleWalletInputAction tokenName inputFieldAction) =
   toRoleWalletInput tokenName $ InputField.handleAction inputFieldAction

marlowe-dashboard-client/src/Data/ContractNickname.purs

@@ -0,0 +1,103 @@
+module Data.ContractNickname
+  ( ContractNickname
+  , ContractNicknameError(..)
+  , dual
+  , fromFoldable
+  , fromString
+  , validator
+  , toString
+  ) where
+
+import Prologue
+
+import Data.Argonaut
+  ( class DecodeJson
+  , class EncodeJson
+  , JsonDecodeError(..)
+  , decodeJson
+  )
+import Data.Bifunctor (lmap)
+import Data.Bounded.Generic (genericBottom, genericTop)
+import Data.Enum (class BoundedEnum, class Enum)
+import Data.Enum.Generic
+  ( genericCardinality
+  , genericFromEnum
+  , genericPred
+  , genericSucc
+  , genericToEnum
+  )
+import Data.Foldable (class Foldable)
+import Data.Generic.Rep (class Generic)
+import Data.Set (Set)
+import Data.Set as Set
+import Data.Show.Generic (genericShow)
+import Data.String (null)
+import Data.Validation.Semigroup (V(..))
+import Polyform (Validator)
+import Polyform.Dual as Dual
+import Polyform.Validator (liftFnV)
+import Polyform.Validator.Dual (Dual)
+
+data ContractNicknameError = Empty
+
+derive instance genericContractNicknameError :: Generic ContractNicknameError _
+derive instance eqContractNicknameError :: Eq ContractNicknameError
+derive instance ordContractNicknameError :: Ord ContractNicknameError
+
+instance semigroupContractNicknameError :: Semigroup ContractNicknameError where
+  append _ _ = Empty
+
+instance boundedContractNicknameError :: Bounded ContractNicknameError where
+  bottom = genericBottom
+  top = genericTop
+
+instance enumContractNicknameError :: Enum ContractNicknameError where
+  succ = genericSucc
+  pred = genericPred
+
+instance boundedEnumContractNicknameError :: BoundedEnum ContractNicknameError where
+  cardinality = genericCardinality
+  toEnum = genericToEnum
+  fromEnum = genericFromEnum
+
+instance showContractNicknameError :: Show ContractNicknameError where
+  show = genericShow
+
+newtype ContractNickname = ContractNickname String
+
+derive instance Eq ContractNickname
+derive instance Ord ContractNickname
+derive newtype instance Show ContractNickname
+derive newtype instance EncodeJson ContractNickname
+
+instance DecodeJson ContractNickname where
+  decodeJson =
+    lmap (const $ TypeMismatch "ContractNickname") <<< fromString
+      <=< decodeJson
+
+fromFoldable :: forall f. Foldable f => f String -> Set ContractNickname
+fromFoldable = Set.map ContractNickname <<< Set.fromFoldable
+
+fromString :: String -> Either ContractNicknameError ContractNickname
+fromString s
+  | null s = Left Empty
+  | otherwise = Right $ ContractNickname s
+
+toString :: ContractNickname -> String
+toString (ContractNickname s) = s
+
+-------------------------------------------------------------------------------
+-- Polyform adapters
+-------------------------------------------------------------------------------
+
+validator
+  :: forall m
+   . Applicative m
+  => Validator m ContractNicknameError String ContractNickname
+validator = liftFnV \s -> V $ fromString s
+
+dual
+  :: forall m
+   . Applicative m
+  => Dual m ContractNicknameError String ContractNickname
+dual = Dual.dual validator (pure <<< toString)