diff --git a/app/elm/Commands.elm b/app/elm/Commands.elm index 2230709..4979564 100644 --- a/app/elm/Commands.elm +++ b/app/elm/Commands.elm @@ -1,6 +1,6 @@ module Commands exposing (..) -import Models exposing (Address, Wei, PartyModel, BrehonModel) +import Models exposing (Address, Wei, PartyModel, BrehonModel, ContractCreatorModel) import Task exposing (perform) import Time as Time exposing (Time, now) import Msgs exposing (Msg) @@ -86,6 +86,7 @@ raiseAppeal : Address -> Cmd Msg raiseAppeal addr = requestRaiseAppeal addr + raiseSecondAppeal : Address -> Cmd Msg raiseSecondAppeal addr = requestRaiseSecondAppeal addr @@ -97,6 +98,15 @@ adjudicate addr awardPartyA awardPartyB = +{- Contract creator commands -} + + +createContract : ContractCreatorModel -> Cmd Msg +createContract model = + requestCreateContract model + + + {- For Debugging purposes -} diff --git a/app/elm/Main.elm b/app/elm/Main.elm index fb4365d..75dc717 100644 --- a/app/elm/Main.elm +++ b/app/elm/Main.elm @@ -1,34 +1,27 @@ port module Main exposing (..) -import Html exposing (Html, div, text, program) import Msgs exposing (Msg) -import Models exposing (Model, Party, zeroWei, initContractInfo, Brehon, PartyModel, BrehonModel, ContractInfo, Stage(..)) +import Models exposing (Model, Party, zeroWei, initContractModel, initContractCreatorModel, Brehon, PartyModel, BrehonModel, ContractInfo, Stage(..)) import Time exposing (every, minute, second) import View exposing (view) import Update exposing (update) import Web3.BrehonAPI exposing (..) import Commands exposing (..) +import Navigation +import UrlParser as Url +import UrlParsing exposing (..) -- MODEL -init : ( Model, Cmd Msg ) -init = +init : Navigation.Location -> ( Model, Cmd Msg ) +init location = ( Model - initContractInfo - 0 - [] - Nothing - zeroWei - zeroWei - zeroWei - zeroWei - (PartyModel (Party Nothing zeroWei False)) - (PartyModel (Party Nothing zeroWei False)) - (BrehonModel (Brehon Nothing False zeroWei zeroWei) Nothing) - (BrehonModel (Brehon Nothing False zeroWei zeroWei) Nothing) - (BrehonModel (Brehon Nothing False zeroWei zeroWei) Nothing) + [ Url.parseHash route location ] + (Just Create) + initContractCreatorModel + initContractModel , Cmd.batch [ loadWeb3Accounts , loadContractInfo @@ -72,7 +65,7 @@ subscriptions model = main : Program Never Model Msg main = - program + Navigation.program Msgs.UrlChange { init = init , view = view , update = update diff --git a/app/elm/Models.elm b/app/elm/Models.elm index 4a9a985..b880f15 100644 --- a/app/elm/Models.elm +++ b/app/elm/Models.elm @@ -2,6 +2,7 @@ module Models exposing (..) import Time.DateTime as DateTime exposing (DateTime, dateTime) import Time as Time exposing (Time, now) +import UrlParsing exposing (Route) zeroWei : Wei @@ -9,12 +10,61 @@ zeroWei = "0" +initContractModel : ContractModel +initContractModel = + ContractModel + initContractInfo + 0 + [] + Nothing + zeroWei + zeroWei + zeroWei + zeroWei + (PartyModel (Party Nothing zeroWei False)) + (PartyModel (Party Nothing zeroWei False)) + (BrehonModel (Brehon Nothing False zeroWei zeroWei) Nothing) + (BrehonModel (Brehon Nothing False zeroWei zeroWei) Nothing) + (BrehonModel (Brehon Nothing False zeroWei zeroWei) Nothing) + + initContractInfo : ContractInfo initContractInfo = ContractInfo Nothing Negotiation zeroWei zeroWei False False Nothing Nothing Nothing 0 False Nothing Nothing +initContractCreatorModel : ContractCreatorModel +initContractCreatorModel = + ContractCreatorModel + (Party (Just "0x90f8bf6a479f320ead074411a4b0e7944ea8c9c1") "0" False) + (Party (Just "0xffcf8fdee72ac11b5c542428b35eef5769c409f0") "0" False) + "500" + "Party A agrees to sell Party B a 1996 Rolex watch for 500 Wei." + (Brehon (Just "0x22d491bde2303f2f43325b2108d26f1eaba1e32b") False "10" "100") + (Brehon (Just "0xe11ba2b4d45eaed5996cd0823791e0c93114882d") False "10" "100") + (Brehon (Just "0xd03ea8624c8c5987235048901fb614fdca89b117") False "10" "100") + + type alias Model = + { history : List (Maybe Route) + , currentRoute : Maybe Route + , creatorModel : ContractCreatorModel + , contractModel : ContractModel + } + + +type alias ContractCreatorModel = + { partyA : Party + , partyB : Party + , transactionAmount : Wei + , termsAndConditions : String + , primaryBrehon : Brehon + , secondaryBrehon : Brehon + , tertiaryBrehon : Brehon + } + + +type alias ContractModel = { contractInfo : ContractInfo , currentTimestamp : Time , eventLog : List Event @@ -124,6 +174,7 @@ type Stage | SecondAppeal | Completed + type Event = ExecutionStartedEvent Int Address Address Wei | SettlementProposedEvent Int Address Address Wei Wei @@ -134,6 +185,7 @@ type Event | SecondAppealRaisedEvent Address Address | FundsClaimedEvent Address Wei + type AppealLevel = First | Second diff --git a/app/elm/Msgs.elm b/app/elm/Msgs.elm index b0c6a55..2631a51 100644 --- a/app/elm/Msgs.elm +++ b/app/elm/Msgs.elm @@ -13,11 +13,14 @@ import Models , Parties , Brehons , Event + , ContractCreatorModel ) +import Navigation type Msg - = LoadAccounts (List Address) + = UrlChange Navigation.Location + | LoadAccounts (List Address) | LoadContractInfo ( Address, Int, Wei, Wei, Int, Address, Maybe Awards ) | LoadAllParties Parties | LoadAllBrehons Brehons @@ -47,4 +50,19 @@ type Msg | RaiseSecondAppeal Address | Adjudicate BrehonModel | WithdrawFunds Address + -- ContractCreator Msgs + | PartyAAddrChanged String + | PartyBAddrChanged String + | TxAmountChanged Wei + | TermsChanged String + | PrimaryBrehonAddrChanged String + | PrimaryBrehonFixedFeeChanged Wei + | PrimaryBrehonDisputeFeeChanged Wei + | SecondaryBrehonAddrChanged String + | SecondaryBrehonFixedFeeChanged Wei + | SecondaryBrehonDisputeFeeChanged Wei + | TertiaryBrehonAddrChanged String + | TertiaryBrehonFixedFeeChanged Wei + | TertiaryBrehonDisputeFeeChanged Wei + | CreateContract ContractCreatorModel | None diff --git a/app/elm/Update.elm b/app/elm/Update.elm index 95b5f0c..41accf8 100644 --- a/app/elm/Update.elm +++ b/app/elm/Update.elm @@ -1,379 +1,171 @@ module Update exposing (..) +import Tuple exposing (first, second) import Msgs exposing (..) -import Time.DateTime as DateTime exposing (DateTime, dateTime, zero, addDays, fromISO8601, compare, fromTimestamp) -import Time as Time exposing (Time) -import Models exposing (Model, Stage(..), Event(..), ContractInfo, Settlement, Awards, Address, Wei, zeroWei, Parties, PartyModel, Party, Brehons, BrehonModel, Brehon) -import Commands exposing (..) +import Contract.Update exposing (updateContract) +import Create.Update exposing (updateCreateContract) +import Models exposing (Model, ContractCreatorModel, ContractModel, Stage(..), Event(..), ContractInfo, Settlement, Awards, Address, Wei, zeroWei, Parties, PartyModel, Party, Brehons, BrehonModel, Brehon) +import UrlParser as Url exposing (..) +import UrlParsing exposing (route) update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = - case msg of - LoadAccounts accounts -> - ( setLoadedAddress model (List.head accounts), Cmd.none ) - - LoadContractInfo ( deployedAddr, stage, transactionAmount, minimumContractAmt, appealPeriodInDays, activeBrehon, awards ) -> - ( { model - | contractInfo = updateContractInfo model.contractInfo deployedAddr stage transactionAmount minimumContractAmt appealPeriodInDays model.currentTimestamp activeBrehon awards - } - , updateTimestamp - ) - - LoadAllParties parties -> - ( { model - | partyA = updatePartyModel model.partyA parties.partyA - , partyB = updatePartyModel model.partyB parties.partyB - , totalDeposits = parties.totalDeposits - , depositField = zeroWei - , contractInfo = - getPartiesAcceptance parties - |> updatePartyAcceptance model.contractInfo - } - , Cmd.none - ) - - LoadAllBrehons brehons -> - ( { model - | primaryBrehon = updateBrehonModel model.primaryBrehon brehons.primaryBrehon - , secondaryBrehon = updateBrehonModel model.secondaryBrehon brehons.secondaryBrehon - , tertiaryBrehon = updateBrehonModel model.tertiaryBrehon brehons.tertiaryBrehon - , contractInfo = - getBrehonsAcceptance brehons - |> updateBrehonAcceptance model.contractInfo - } - , Cmd.none - ) - - AcceptContractByParty partyModel -> - ( model, acceptContractByParty partyModel ) - - AcceptContractByBrehon brehonModel -> - ( model, acceptContractByBrehon brehonModel ) - - DepositFieldChanged amount -> - ( { model | depositField = amount }, Cmd.none ) - - DepositFunds partyModel -> - ( model, depositFunds partyModel model.depositField ) - - SettlementPartyAFieldChanged amount -> - ( { model | settlementPartyAField = amount }, Cmd.none ) - - SettlementPartyBFieldChanged amount -> - ( { model | settlementPartyBField = amount }, Cmd.none ) - - StartContract party -> - ( model, startContract party.struct.addr ) - - LoadProposedSettlement proposedSettlement -> - ( { model | contractInfo = updateContractInfoSettlement model.contractInfo proposedSettlement }, Cmd.none ) - - LoadAwards awards -> - ( { model | contractInfo = updateAwards model.contractInfo awards }, Cmd.none ) - - ProposeSettlement party -> - ( model, proposeSettlement party.struct.addr model.settlementPartyAField model.settlementPartyBField ) - - AcceptSettlement party -> - case model.contractInfo.proposedSettlement of - Nothing -> - ( model, Cmd.none ) - - Just settlement -> - ( model - , acceptSettlement - party.struct.addr - settlement.settlementPartyA - settlement.settlementPartyB - ) - - LoadAllEvents -> - ( model, Cmd.none ) - - LoadExecutionStartedEvent ( blockNumber, txHash, caller, totalDeposits ) -> - ( { model - | eventLog = - ExecutionStartedEvent blockNumber - txHash - caller - totalDeposits - :: model.eventLog - } - , Cmd.none - ) - - LoadSettlementProposedEvent ( blockNumber, txHash, proposingParty, awardPartyA, awardPartyB ) -> - ( { model - | eventLog = - SettlementProposedEvent blockNumber - txHash - proposingParty - awardPartyA - awardPartyB - :: model.eventLog - } - , Cmd.none - ) - - LoadDisputeResolvedEvent ( blockNumber, txHash, awardPartyA, awardPartyB ) -> - ( { model - | eventLog = - DisputeResolvedEvent blockNumber - txHash - awardPartyA - awardPartyB - :: model.eventLog - } - , Cmd.none - ) - - LoadContractDisputedEvent ( disputingParty, activeBrehon ) -> - ( { model - | eventLog = - ContractDisputedEvent disputingParty - activeBrehon - :: model.eventLog - } - , Cmd.none - ) - - LoadAppealPeriodStartedEvent ( startTime, activeBrehon, awardPartyA, awardPartyB ) -> - ( { model - | eventLog = - AppealPeriodStartedEvent - (toDateTime startTime) - activeBrehon - awardPartyA - awardPartyB - :: model.eventLog - , primaryBrehon = updateBrehonAwards model.primaryBrehon activeBrehon awardPartyA awardPartyB - , secondaryBrehon = updateBrehonAwards model.secondaryBrehon activeBrehon awardPartyA awardPartyB - , contractInfo = updateAppealPeriodInfo model.contractInfo model.currentTimestamp (toDateTime startTime) - } - , Cmd.none - ) - - LoadAppealRaisedEvent ( appealingParty, activeBrehon ) -> - ( { model - | eventLog = - AppealRaisedEvent - appealingParty - activeBrehon - :: model.eventLog - } - , Cmd.none - ) - - LoadSecondAppealRaisedEvent ( appealingParty, activeBrehon ) -> - ( { model - | eventLog = - SecondAppealRaisedEvent - appealingParty - activeBrehon - :: model.eventLog - } - , Cmd.none - ) - - LoadFundsClaimed ( claimingParty, amount ) -> - ( { model - | eventLog = - FundsClaimedEvent claimingParty - amount - :: model.eventLog - } - , Cmd.none - ) - - UpdateTimestamp time -> - ( { model - | currentTimestamp = time - , contractInfo = updateAppealPeriodInProgress model.contractInfo time - } - , Cmd.none - ) - - Adjudicate brehon -> - ( model, adjudicate brehon.struct.addr model.settlementPartyAField model.settlementPartyBField ) - - WithdrawFunds addr -> - ( model, withdrawFunds addr ) - - RaiseDispute addr -> - ( model, raiseDispute addr ) - - RaiseAppeal addr -> - ( model, raiseAppeal addr ) - - RaiseSecondAppeal addr -> - ( model, raiseSecondAppeal addr ) - - None -> - ( model, Cmd.none ) - - -getPartiesAcceptance : Parties -> Bool -getPartiesAcceptance parties = - List.all (\p -> p.contractAccepted) - [ parties.partyA - , parties.partyB - ] - - -getBrehonsAcceptance : Brehons -> Bool -getBrehonsAcceptance brehons = - List.all (\b -> b.contractAccepted) - [ brehons.primaryBrehon - , brehons.secondaryBrehon - , brehons.tertiaryBrehon - ] - - -setLoadedAddress : Model -> Maybe Address -> Model -setLoadedAddress model address = - case address of - Nothing -> - model - - Just addr -> - { model | loadedAccount = addr } - - -updatePartyAcceptance : ContractInfo -> Bool -> ContractInfo -updatePartyAcceptance contractInfo partiesAccepted = - { contractInfo | partiesAccepted = partiesAccepted } - - -updateBrehonAcceptance : ContractInfo -> Bool -> ContractInfo -updateBrehonAcceptance contractInfo brehonsAccepted = - { contractInfo | brehonsAccepted = brehonsAccepted } - - -updateContractInfoSettlement : ContractInfo -> Maybe Settlement -> ContractInfo -updateContractInfoSettlement contractInfo settlement = - { contractInfo | proposedSettlement = settlement } - - -updateAwards : ContractInfo -> Maybe Awards -> ContractInfo -updateAwards contractInfo awards = - { contractInfo | awards = awards } - - -updateContractInfo : - ContractInfo - -> Address - -> Int - -> Wei - -> Wei - -> Int - -> Time - -> Address - -> Maybe Awards - -> ContractInfo -updateContractInfo contractInfo addr stageInt transactionAmount minimumContractAmt appealPeriodInDays time activeBrehon awards = let - appealPeriodEnd = - case contractInfo.appealPeriodStart of - Nothing -> - Nothing - - Just appealPeriodStart -> - Just (addDays appealPeriodInDays appealPeriodStart) - - contractInfoUpdated = - { contractInfo - | deployedAt = addr - , transactionAmount = transactionAmount - , minimumContractAmt = minimumContractAmt - , appealPeriodInDays = appealPeriodInDays - , activeBrehon = activeBrehon - , awards = awards - , appealPeriodEnd = appealPeriodEnd - } + updatedContractMsg = + updateContract msg model.contractModel + + updateCreateContractMsg = + updateCreateContract msg model.creatorModel in - case stageInt of - 1 -> - { contractInfoUpdated | stage = Execution } + case msg of + UrlChange location -> + let + nextRoute = + Url.parseHash route location + in + { model + | history = nextRoute :: model.history + , currentRoute = nextRoute + } + ! [] - 2 -> - { contractInfoUpdated | stage = Dispute } + {- This Horrible pattern (where I repeat these case handling here and + in updateContract method) exists because I want compiler to catch + any new Msgs added. In future maybe this can be refactored. + -} + LoadAccounts accounts -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) - 3 -> - { contractInfoUpdated | stage = Resolved } + LoadContractInfo ( deployedAddr, stage, transactionAmount, minimumContractAmt, appealPeriodInDays, activeBrehon, awards ) -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) - 4 -> - { contractInfoUpdated | stage = AppealPeriod } + LoadAllParties parties -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) - 5 -> - { contractInfoUpdated | stage = Appeal } + LoadAllBrehons brehons -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) - 6 -> - { contractInfoUpdated | stage = SecondAppealPeriod } + AcceptContractByParty partyModel -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) - 7 -> - { contractInfoUpdated | stage = SecondAppeal} + AcceptContractByBrehon brehonModel -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) - 8 -> - { contractInfoUpdated | stage = Completed} + DepositFieldChanged amount -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) - _ -> - { contractInfoUpdated | stage = Negotiation } + DepositFunds partyModel -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + SettlementPartyAFieldChanged amount -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) -updatePartyModel : PartyModel -> Party -> PartyModel -updatePartyModel partyModel party = - { partyModel | struct = party } + SettlementPartyBFieldChanged amount -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + StartContract partyModel -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) -updateBrehonModel : BrehonModel -> Brehon -> BrehonModel -updateBrehonModel brehonModel brehon = - { brehonModel | struct = brehon } + LoadProposedSettlement proposedSettlement -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + LoadAwards awards -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) -updateBrehonAwards : BrehonModel -> Address -> Wei -> Wei -> BrehonModel -updateBrehonAwards brehonModel activeBrehonAddr awardPartyA awardPartyB = - if brehonModel.struct.addr == activeBrehonAddr then - { brehonModel | awards = Just (Awards awardPartyA awardPartyB) } - else - brehonModel + ProposeSettlement partyModel -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + AcceptSettlement partyModel -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) -updateAppealPeriodInfo : ContractInfo -> Time -> DateTime -> ContractInfo -updateAppealPeriodInfo contractInfo time appealPeriodStart = - let - appealPeriodEnd = - addDays contractInfo.appealPeriodInDays appealPeriodStart - in - { contractInfo - | appealPeriodStart = Just appealPeriodStart - , appealPeriodEnd = Just appealPeriodEnd - } - - -updateAppealPeriodInProgress : ContractInfo -> Time -> ContractInfo -updateAppealPeriodInProgress contractInfo time = - { contractInfo - | appealPeriodInProgress = - case contractInfo.appealPeriodEnd of - Nothing -> - False - - Just appealPeriodEnd -> - case DateTime.compare appealPeriodEnd (fromTimestamp time) of - LT -> - False - - _ -> - True - } - - -toDateTime : String -> DateTime -toDateTime dateString = - case fromISO8601 dateString of - Err e -> - dateTime zero - - Ok r -> - r + LoadAllEvents -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + LoadExecutionStartedEvent ( blockNumber, txHash, caller, totalDeposits ) -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + LoadSettlementProposedEvent ( blockNumber, txHash, proposingParty, awardPartyA, awardPartyB ) -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + LoadDisputeResolvedEvent ( blockNumber, txHash, awardPartyA, awardPartyB ) -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + LoadContractDisputedEvent ( disputingParty, activeBrehon ) -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + LoadAppealPeriodStartedEvent ( startTime, activeBrehon, awardPartyA, awardPartyB ) -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + LoadAppealRaisedEvent ( appealingParty, activeBrehon ) -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + LoadSecondAppealRaisedEvent ( appealingParty, activeBrehon ) -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + LoadFundsClaimed ( claimingParty, amount ) -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + UpdateTimestamp time -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + RaiseDispute addr -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + RaiseAppeal addr -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + RaiseSecondAppeal addr -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + Adjudicate brehonModel -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + WithdrawFunds addr -> + ( { model | contractModel = first updatedContractMsg }, second updatedContractMsg ) + + -- ContractCreator Msgs + PartyAAddrChanged addr -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + PartyBAddrChanged addr -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + TxAmountChanged amount -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + TermsChanged termsAndConditions -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + PrimaryBrehonAddrChanged addr -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + PrimaryBrehonFixedFeeChanged fixedFee -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + PrimaryBrehonDisputeFeeChanged disputeFee -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + SecondaryBrehonAddrChanged addr -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + SecondaryBrehonFixedFeeChanged fixedFee -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + SecondaryBrehonDisputeFeeChanged disputeFee -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + TertiaryBrehonAddrChanged addr -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + TertiaryBrehonFixedFeeChanged fixedFee -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + TertiaryBrehonDisputeFeeChanged disputeFee -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + CreateContract creatorModel -> + ( { model | creatorModel = first updateCreateContractMsg }, second updateCreateContractMsg ) + + None -> + ( model, Cmd.none ) diff --git a/app/elm/UrlParsing.elm b/app/elm/UrlParsing.elm new file mode 100644 index 0000000..19f10cb --- /dev/null +++ b/app/elm/UrlParsing.elm @@ -0,0 +1,16 @@ +module UrlParsing exposing (..) + +import UrlParser as Url exposing (..) + + +type Route + = Create + | Contract String + + +route : Url.Parser (Route -> a) a +route = + Url.oneOf + [ Url.map Create top + , Url.map Contract (s "contract" string) + ] diff --git a/app/elm/View.elm b/app/elm/View.elm index 4cafbb2..15de6c0 100644 --- a/app/elm/View.elm +++ b/app/elm/View.elm @@ -1,747 +1,153 @@ module View exposing (..) -import Html exposing (Html, Attribute, a, button, div, ul, li, img, input, label, p, span, i, text) -import Html.Attributes exposing (class, href, src, type_, placeholder) +import ViewHelpers exposing (..) +import Html exposing (Html, div, text, label, form, input, textarea, button, a) +import Html.Attributes exposing (class, placeholder, type_, rows, value, href) import Html.Events exposing (onClick, onInput) -import Time.DateTime as DateTime exposing (toISO8601, fromTimestamp) import Msgs exposing (Msg) -import Models exposing (Model, Address, Event(..), ContractInfo, Settlement, Awards, Wei, PartyModel, BrehonModel, FilePath, AppealLevel(..), Stage(..)) +import Contract.View exposing (..) +import Models exposing (Model, initContractCreatorModel, ContractCreatorModel, ContractModel, Address, Event(..), ContractInfo, Settlement, Awards, Wei, PartyModel, BrehonModel, FilePath, AppealLevel(..), Stage(..)) +import UrlParsing exposing (..) view : Model -> Html Msg view model = - div [ class "main-container lg-h4 md-h4 sm-h4 clearfix" ] - [ contractDetailView model - , div [ class "col col-8" ] - [ div [ class "party-list flex flex-wrap" ] - [ partyView model.partyA "images/partyA.png" model - , partyView model.partyB "images/partyB.png" model - ] - , div [ class "brehon-list flex flex-wrap flex-column" ] - [ brehonView model.primaryBrehon "images/partyPrimaryBrehon.png" model - , brehonView model.secondaryBrehon "images/partySecondaryBrehon.png" model - , brehonView model.tertiaryBrehon "images/partyTertiaryBrehon.png" model - ] - ] - , div [ class "col col-2 lg-h4 sm-h6" ] [ logView model ] - ] - - -contractDetailView : Model -> Html Msg -contractDetailView model = - let - showProposedSettlement = - model.contractInfo.stage /= Completed - - showActiveBrehon = - model.contractInfo.stage == Dispute - in - ul [ class "contract-detail sm-h5 p2 col col-2 list-reset" ] - [ li [] - [ text "Contract Deployed At: " - , textAddress model.contractInfo.deployedAt - ] - , li [] - [ text "Current Time: " - , model.currentTimestamp - |> fromTimestamp - |> toISO8601 - |> text - ] - , li [] - [ text "Loaded Account: " - , textAddress model.loadedAccount - ] - , li [] - [ text "Total Deposits: " - , text model.totalDeposits - , text " Wei" - ] - , li [] - [ text "Minimum Amount to start the contract: " - , text model.contractInfo.minimumContractAmt - , text " Wei" - ] - , li [] - [ text "Contract Stage: " - , text (toString model.contractInfo.stage) - ] - , li [] - [ text "Transaction Amount : " - , text model.contractInfo.transactionAmount - ] - , li [] - [ text "Parties Accepted : " - , text (toString model.contractInfo.partiesAccepted) - ] - , li [] - [ text "Brehons Accepted : " - , text (toString model.contractInfo.brehonsAccepted) - ] - , li [] - [ proposedSettlementView model.contractInfo.proposedSettlement - ] - |> conditionalBlock showProposedSettlement - , li [] - [ text "Active Brehon: " - , textAddress model.contractInfo.activeBrehon - ] - |> conditionalBlock showActiveBrehon - , li [] - [ text "Appeal Period Start time: " - , text - (model.contractInfo.appealPeriodStart - |> toJustString toISO8601 - ) - ] - |> justValue model.contractInfo.appealPeriodStart - , li [] - [ text "Appeal Period Duration (days): " - , text (toString model.contractInfo.appealPeriodInDays) - ] - |> justValue model.contractInfo.appealPeriodEnd - , li [] - [ text "Appeal Period End time: " - , text - (model.contractInfo.appealPeriodEnd - |> toJustString toISO8601 - ) - ] - |> justValue model.contractInfo.appealPeriodEnd - , li [] - [ awardsView model.contractInfo.awards - ] - |> justValue model.contractInfo.awards - ] - - -canPartyStartContract : PartyModel -> ContractInfo -> Wei -> Bool -canPartyStartContract party contractInfo totalDeposits = - (contractInfo.partiesAccepted && contractInfo.brehonsAccepted) - && contractInfo.stage - == Negotiation - && party.struct.contractAccepted - && totalDeposits - >= contractInfo.minimumContractAmt - - -canPartyProposeSettlement : PartyModel -> ContractInfo -> Bool -canPartyProposeSettlement party contractInfo = - contractInfo.stage - /= Negotiation - && contractInfo.stage - /= Completed + case model.currentRoute of + Just Create -> + contractCreatorView model.creatorModel + Just (Contract contractAddr) -> + contractView model.contractModel -canPartyAcceptSettlement : PartyModel -> ContractInfo -> Bool -canPartyAcceptSettlement party contractInfo = - case contractInfo.proposedSettlement of Nothing -> - False - - Just settlement -> - settlement.proposingPartyAddr - /= party.struct.addr - && contractInfo.stage - /= Completed - - -isContractCompleted : ContractInfo -> Bool -isContractCompleted contractInfo = - contractInfo.stage - == Completed - || (contractInfo.stage - == AppealPeriod - && not contractInfo.appealPeriodInProgress - ) - - -canPartyRaiseDispute : PartyModel -> ContractInfo -> Bool -canPartyRaiseDispute party contractInfo = - contractInfo.stage - == Execution - - -canPartyAppeal : PartyModel -> ContractInfo -> Bool -canPartyAppeal party contractInfo = - (contractInfo.stage - == AppealPeriod - ) - - -canPartySecondAppeal : PartyModel -> ContractInfo -> Bool -canPartySecondAppeal party contractInfo = - (contractInfo.stage - == SecondAppealPeriod - ) - - -canDepositIntoContract : PartyModel -> ContractInfo -> Bool -canDepositIntoContract party contractInfo = - party.struct.contractAccepted - && contractInfo.stage - /= Completed - - -partyView : PartyModel -> FilePath -> Model -> Html Msg -partyView party profileImage model = - let - ownerView = - model.loadedAccount == party.struct.addr - - canDeposit = - ownerView - && canDepositIntoContract party model.contractInfo - - canStartContract = - ownerView - && canPartyStartContract party model.contractInfo model.totalDeposits - - canProposeSettlement = - ownerView - && canPartyProposeSettlement party model.contractInfo + div [] [ text "Not found 404" ] - canAcceptSettlement = - ownerView - && canPartyAcceptSettlement party model.contractInfo - canWithdrawFunds = - ownerView - && isContractCompleted model.contractInfo - - canRaiseDispute = - ownerView - && canPartyRaiseDispute party model.contractInfo - - canAppeal = - ownerView - && canPartyAppeal party model.contractInfo - - canSecondAppeal = - ownerView - && canPartySecondAppeal party model.contractInfo - - viewClass ownerView cssClass = - case ownerView of - True -> - cssClass ++ " white bg-maroon border-gray" - - False -> - cssClass - in - div - [ "party-view mx-auto max-width-1 border rounded m1 p2" - |> viewClass ownerView - |> class - ] - [ text "Party" - , div [ class "block p1" ] - [ img [ src profileImage ] [] - , text "Address: " - , textAddress party.struct.addr - ] - , div [ class "block p1" ] - [ contractAcceptanceView party.struct.contractAccepted ownerView (Msgs.AcceptContractByParty party) - ] - , div [ class "deposit-block block my1 p1" ] - [ div [ class "my1" ] - [ text "Deposit: " - , text party.struct.deposit - , text " Wei" +contractCreatorView : ContractCreatorModel -> Html Msg +contractCreatorView model = + div [ class "main-container lg-h4 md-h4 sm-h4 clearfix" ] + [ div [ class "col-4 mx-auto" ] + [ form [ class "contract-creator-form" ] + [ label [ class "label" ] [ text "Party A" ] + , input + [ class "input ethereum-address party-a-addr" + , onInput Msgs.PartyAAddrChanged + , placeholder "0x00000" + , value "0x90f8bf6a479f320ead074411a4b0e7944ea8c9c1" ] - , depositView party - ] - |> conditionalBlock canDeposit - , div - [ class "block my1 p1" ] - [ startContractView party - ] - |> conditionalBlock canStartContract - , div - [ class "block my2 p1 border" ] - [ label [ class "label label-title bg-maroon h4" ] [ text "Settlement" ] - , proposeSettlementView party - ] - |> conditionalBlock canProposeSettlement - , div - [ class "block my2 p1 border" ] - [ acceptSettlementView party model.contractInfo.proposedSettlement - ] - |> conditionalBlock canAcceptSettlement - , div - [ class "block my1 p1" ] - [ withdrawFundsView party.struct.addr ] - |> conditionalBlock canWithdrawFunds - , div - [ class "block my1 p1" ] - [ raiseDisputeView party.struct.addr ] - |> conditionalBlock canRaiseDispute - , div - [ class "block my1 p1" ] - [ appealView party.struct.addr First ] - |> conditionalBlock canAppeal - , div - [ class "block my1 p1" ] - [ appealView party.struct.addr Second ] - |> conditionalBlock canSecondAppeal - ] - - -withdrawFundsView : Address -> Html Msg -withdrawFundsView addr = - div [ class "withdraw-funds" ] - [ a - [ class "btn btn-big btn-primary block center rounded h2 black bg-yellow" - , href "#" - , onClick (Msgs.WithdrawFunds addr) - ] - [ text "Withdraw Funds" ] - ] - - -raiseDisputeView : Address -> Html Msg -raiseDisputeView addr = - div [ class "raise-dispute" ] - [ a - [ class "btn btn-big btn-primary block center rounded h2 white bg-red" - , href "#" - , onClick (Msgs.RaiseDispute addr) - ] - [ text "Raise Dispute" ] - ] - - -appealView : Address -> AppealLevel -> Html Msg -appealView addr appealLevel = - div [ class "appeal" ] - [ a - [ class "btn btn-big btn-primary block center rounded h2 black bg-aqua" - , href "#" - , onClick - (case appealLevel of - First -> - Msgs.RaiseAppeal addr - - Second -> - Msgs.RaiseSecondAppeal addr - ) - ] - [ text "Appeal" ] - ] - - -ctaButton : String -> String -> Msg -> Html Msg -ctaButton label cssClass msg = - a - [ class ("btn btn-big btn-primary block center rounded h2 " ++ cssClass) - , href "#" - , onClick msg - ] - [ text label ] - - -proposeSettlementView : PartyModel -> Html Msg -proposeSettlementView party = - div [ class "propose-settlement" ] - [ label [ class "label" ] [ text "Award for Party A" ] - , input - [ class "input" - , placeholder "0 Wei" - , onInput Msgs.SettlementPartyAFieldChanged - ] - [] - , label [ class "label" ] [ text "Award for Party B" ] - , input - [ class "input" - , placeholder "0 wei" - , onInput Msgs.SettlementPartyBFieldChanged - ] - [] - , button - [ class "btn btn-primary" - , onClick (Msgs.ProposeSettlement party) - ] - [ text "Propose Settlement" ] - ] - - -acceptSettlementView : PartyModel -> Maybe Settlement -> Html Msg -acceptSettlementView party proposedSettlement = - case proposedSettlement of - Nothing -> - div [] [] - - Just settlement -> - div [ class "accept-settlement" ] - [ label [ class "label h4" ] - [ text "Award for Party A: " - , text settlement.settlementPartyA + [] + , label [ class "label" ] [ text "Party B" ] + , input + [ class "input ethereum-address party-b-addr" + , onInput Msgs.PartyBAddrChanged + , placeholder "0x00000" + , value "0xffcf8fdee72ac11b5c542428b35eef5769c409f0" ] - , label [ class "label h4" ] - [ text "Award for Party B: " - , text settlement.settlementPartyB + [] + , label [ class "label" ] [ text "Transaction Amount" ] + , input + [ class "input tx-amount" + , type_ "number" + , placeholder "e.g. 1000 Wei" + , onInput Msgs.TxAmountChanged + , value "5000" ] - , button - [ class "btn btn-primary" - , onClick (Msgs.AcceptSettlement party) + [] + , label [ class "label" ] [ text "Terms and Conditions" ] + , textarea + [ class "textarea tx-amount" + , rows 6 + , placeholder "Party A agrees to sell Party B a 1996 Rolex watch for 500 Wei." + , onInput Msgs.TermsChanged + , value "Party A agrees to sell Party B a 1996 Rolex watch for 500 Wei." ] - [ text "Accept Settlement" ] - ] - - -proposedSettlementView : Maybe Settlement -> Html Msg -proposedSettlementView proposedSettlement = - case proposedSettlement of - Nothing -> - div [] [] - - Just settlement -> - div [] - [ div [] - [ text "Proposing Party: " - , textAddress settlement.proposingPartyAddr - ] - , div [] - [ text "Award Party A: " - , text settlement.settlementPartyA - ] - , div [] - [ text "Award Party B: " - , text settlement.settlementPartyB + [] + , div [ class "" ] + [ label [ class "label" ] [ text "Primary Brehon" ] + , input + [ class "input ethereum-address primary-brehon-addr" + , placeholder "0x00000" + , onInput Msgs.PrimaryBrehonAddrChanged + , value "0x22d491bde2303f2f43325b2108d26f1eaba1e32b" + ] + [] + , label [ class "label" ] [ text "Fixed Fee" ] + , input + [ class "input ethereum-address primary-brehon-addr" + , placeholder "e.g. 100 Wei" + , onInput Msgs.PrimaryBrehonFixedFeeChanged + , value "10" + ] + [] + , label [ class "label" ] [ text "Dispute Fee" ] + , input + [ class "input ethereum-address primary-brehon-addr" + , placeholder "e.g. 100 Wei" + , onInput Msgs.PrimaryBrehonDisputeFeeChanged + , value "100" + ] + [] ] - ] - - -awardsView : Maybe Awards -> Html Msg -awardsView awards = - case awards of - Nothing -> - div [] [] - - Just awards -> - div [] - [ div [] - [ text "Award Party A: " - , text awards.awardPartyA + , div [ class "" ] + [ label [ class "label" ] [ text "Secondary Brehon" ] + , input + [ class "input ethereum-address primary-brehon-addr" + , placeholder "0x00000" + , onInput Msgs.SecondaryBrehonAddrChanged + , value "0xe11ba2b4d45eaed5996cd0823791e0c93114882d" + ] + [] + , label [ class "label" ] [ text "Fixed Fee" ] + , input + [ class "input ethereum-address primary-brehon-addr" + , placeholder "e.g. 100 Wei" + , onInput Msgs.SecondaryBrehonFixedFeeChanged + , value "10" + ] + [] + , label [ class "label" ] [ text "Dispute Fee" ] + , input + [ class "input ethereum-address primary-brehon-addr" + , placeholder "e.g. 100 Wei" + , onInput Msgs.SecondaryBrehonDisputeFeeChanged + , value "100" + ] + [] ] - , div [] - [ text "Award Party B: " - , text awards.awardPartyB + , div [ class "" ] + [ label [ class "label" ] [ text "Tertiary Brehon" ] + , input + [ class "input ethereum-address primary-brehon-addr" + , placeholder "0x00000" + , onInput Msgs.TertiaryBrehonAddrChanged + , value "0xd03ea8624c8c5987235048901fb614fdca89b117" + ] + [] + , label [ class "label" ] [ text "Fixed Fee" ] + , input + [ class "input ethereum-address primary-brehon-addr" + , placeholder "e.g. 100 Wei" + , onInput Msgs.TertiaryBrehonFixedFeeChanged + , value "10" + ] + [] + , label [ class "label" ] [ text "Dispute Fee" ] + , input + [ class "input ethereum-address primary-brehon-addr" + , placeholder "e.g. 100 Wei" + , onInput Msgs.TertiaryBrehonDisputeFeeChanged + , value "100" + ] + [] ] - ] - - -brehonView : BrehonModel -> FilePath -> Model -> Html Msg -brehonView brehon profileImage model = - let - ownerView = - model.loadedAccount == brehon.struct.addr - - canWithdrawFunds = - ownerView - && isContractCompleted model.contractInfo - - canAdjudicate = - ownerView - && canBrehonAdjudicate brehon model.contractInfo - - brehonClass activeBrehon brehon cssClass = - if activeBrehon == brehon.struct.addr then - cssClass ++ " active-brehon" - else - cssClass - - brehonLabel activeBrehon brehon label = - if activeBrehon == brehon.struct.addr then - "Active " ++ label - else - label - - viewClass ownerView cssClass = - case ownerView of - True -> - cssClass ++ " owner white bg-maroon border-gray" + , a + [ class "btn btn-primary" + , onClick (Msgs.CreateContract model) - False -> - cssClass - in - div - [ "brehon-view mx-auto max-width-1 border rounded m1 p2" - |> viewClass ownerView - |> brehonClass model.contractInfo.activeBrehon brehon - |> class - ] - [ "Brehon" - |> brehonLabel model.contractInfo.activeBrehon brehon - |> text - , div [ class "block p1" ] - [ img [ src profileImage ] [] - , p [] - [ text "Address: " - , textAddress brehon.struct.addr + --, href ("#contract/" ++ toJustString identity model.partyA) ] - , p [] - [ text "Fixed Fee: " - , text brehon.struct.fixedFee - ] - , p [] - [ text "Dispute Fee: " - , text brehon.struct.disputeFee + [ text "Create" ] ] - , div - [ class "block my1 p1" ] - [ contractAcceptanceView brehon.struct.contractAccepted ownerView (Msgs.AcceptContractByBrehon brehon) ] - , div - [ class "block my1 p1" ] - [ adjudicateView brehon ] - |> conditionalBlock canAdjudicate - , div - [ class "block my1 p1" ] - [ withdrawFundsView brehon.struct.addr ] - |> conditionalBlock canWithdrawFunds - , div - [ class "block my1 p1" ] - [ awardsView brehon.awards ] - ] - - -canBrehonAdjudicate : BrehonModel -> ContractInfo -> Bool -canBrehonAdjudicate brehon contractInfo = - brehon.struct.addr - == contractInfo.activeBrehon - && ((contractInfo.stage - == Dispute - ) - || (contractInfo.stage - == Appeal - ) - || (contractInfo.stage - == SecondAppeal - ) - ) - - -adjudicateView : BrehonModel -> Html Msg -adjudicateView brehon = - div [ class "adjudicate" ] - [ label [ class "label" ] [ text "Award for Party A" ] - , input - [ class "input" - , placeholder "0 Wei" - , onInput Msgs.SettlementPartyAFieldChanged - ] - [] - , label [ class "label" ] [ text "Award for Party B" ] - , input - [ class "input" - , placeholder "0 wei" - , onInput Msgs.SettlementPartyBFieldChanged - ] - [] - , button - [ class "btn btn-primary" - , onClick (Msgs.Adjudicate brehon) - ] - [ text "Adjudicate" ] - ] - - -startContractView : PartyModel -> Html Msg -startContractView party = - a - [ class "btn btn-big btn-primary block center rounded h2 black bg-yellow" - , href "#" - , onClick (Msgs.StartContract party) - ] - [ text "Start Contract" ] - - -depositView : PartyModel -> Html Msg -depositView party = - div [ class "deposit-funds my1 clearfix flex" ] - [ input - [ class "input mb0 mr2" - , placeholder "0 Wei" - , type_ "number" - , onInput Msgs.DepositFieldChanged - ] - [] - , a - [ class "btn center rounded white bg-olive" - , href "#" - , onClick (Msgs.DepositFunds party) ] - [ text "Deposit" ] ] - - -contractAcceptanceView : Bool -> Bool -> Msg -> Html Msg -contractAcceptanceView isContractAccepted ownerView messageDispatch = - case isContractAccepted of - True -> - p [] - [ i [ class "fa fa-check-circle mr1 green" ] [] - , text "Contract Accepted" - ] - - False -> - if ownerView then - div [ class "fit" ] - [ button - [ class "btn btn-primary btn-big block mx-auto" - , type_ "button" - , onClick (messageDispatch) - ] - [ text "Accept Contract" ] - ] - else - p [] - [ i [ class "fa fa-minus-square mr1 red" ] [] - , text "Contract Not Accepted" - ] - - -logView : Model -> Html Msg -logView model = - ul [ class "list-reset" ] - (model.eventLog - |> List.map singleLogView - ) - - -singleLogView : Event -> Html Msg -singleLogView event = - case event of - ExecutionStartedEvent blockNumber txHash caller totalDeposits -> - li [ class "mb2" ] - [ i [ class "fa fa-paper-plane mr1" ] [] - , text "Contract started by " - , textAddress caller - , text " with a total deposit of " - , text totalDeposits - ] - - SettlementProposedEvent blockNumber txHash proposingParty awardPartyA awardPartyB -> - li [ class "mb2" ] - [ i [ class "fa fa-money mr1" ] [] - , text "Settlement proposed by " - , textAddress proposingParty - , text " with an award of " - , text awardPartyA - , text " for Party A and " - , text awardPartyB - , text " for Party B" - ] - - DisputeResolvedEvent blockNumber txHash awardPartyA awardPartyB -> - li [ class "mb2" ] - [ i [ class "fa fa-hand-peace-o mr1" ] [] - , text "Resolution reached " - , text " with an award of " - , text awardPartyA - , text " for Party A and " - , text awardPartyB - , text " for Party B" - ] - - ContractDisputedEvent disputingParty activeBrehon -> - li [ class "mb2" ] - [ i [ class "fa fa-fire mr1" ] [] - , text "Dispute raised " - , text " by " - , textAddress disputingParty - , text ". Brehon " - , textAddress activeBrehon - , text " is presiding." - ] - - AppealPeriodStartedEvent startTime activeBrehon awardPartyA awardPartyB -> - li [ class "mb2" ] - [ i [ class "fa fa-gavel mr1" ] [] - , text "Brehon " - , textAddress activeBrehon - , text " provided a judgment by awarding " - , text awardPartyA - , text " to partyA and " - , text awardPartyB - , text " to partyB at " - , text (toISO8601 startTime) - ] - - AppealRaisedEvent appealingParty activeBrehon -> - li [ class "mb2" ] - [ i [ class "fa fa-fire mr1" ] [] - , text "Appeal raised " - , text " by " - , textAddress appealingParty - , text ". Brehon " - , textAddress activeBrehon - , text " is presiding." - ] - - SecondAppealRaisedEvent appealingParty activeBrehon -> - li [ class "mb2" ] - [ i [ class "fa fa-fire mr1" ] [] - , i [ class "fa fa-fire mr1" ] [] - , text "Second Appeal raised " - , text " by " - , textAddress appealingParty - , text ". Brehon " - , textAddress activeBrehon - , text " is presiding." - ] - - FundsClaimedEvent claimingParty amount -> - li [ class "mb2" ] - [ i [ class "fa fa-money mr1" ] [] - , text "Funds claimed " - , text " by " - , textAddress claimingParty - , text " in the amount of " - , text amount - ] - - -textAddress : Address -> Html Msg -textAddress address = - case address of - Nothing -> - span [ class "" ] - [ text "" - ] - - Just val -> - span [ class "address char-10" ] - [ text val - ] - - -conditionalBlock : Bool -> Html Msg -> Html Msg -conditionalBlock flag htmlEl = - case flag of - True -> - htmlEl - - False -> - text "" - - -justValue : Maybe a -> Html Msg -> Html Msg -justValue a htmlEl = - case a of - Nothing -> - text "" - - Just a -> - htmlEl - - -toJustString : (a -> String) -> Maybe a -> String -toJustString fn a = - case a of - Nothing -> - "" - - Just a -> - fn a diff --git a/app/elm/ViewHelpers.elm b/app/elm/ViewHelpers.elm new file mode 100644 index 0000000..11f2f0a --- /dev/null +++ b/app/elm/ViewHelpers.elm @@ -0,0 +1,50 @@ +module ViewHelpers exposing (..) + +import Html exposing (Html, text, span) +import Html.Attributes exposing (class) +import Msgs exposing (Msg) +import Models exposing (Address) + + +textAddress : Address -> Html Msg +textAddress address = + case address of + Nothing -> + span [ class "" ] + [ text "" + ] + + Just val -> + span [ class "address char-10" ] + [ text val + ] + + +conditionalBlock : Bool -> Html Msg -> Html Msg +conditionalBlock flag htmlEl = + case flag of + True -> + htmlEl + + False -> + text "" + + +justValue : Maybe a -> Html Msg -> Html Msg +justValue a htmlEl = + case a of + Nothing -> + text "" + + Just a -> + htmlEl + + +toJustString : (a -> String) -> Maybe a -> String +toJustString fn a = + case a of + Nothing -> + "" + + Just a -> + fn a diff --git a/app/elm/Web3/BrehonAPI.elm b/app/elm/Web3/BrehonAPI.elm index abb40c3..b2f94a2 100644 --- a/app/elm/Web3/BrehonAPI.elm +++ b/app/elm/Web3/BrehonAPI.elm @@ -13,6 +13,7 @@ import Models , BrehonModel , Brehons , Wei + , ContractCreatorModel ) @@ -110,3 +111,6 @@ port receiveAwards : (Maybe Awards -> msg) -> Sub msg port requestWithdrawFunds : Address -> Cmd msg + + +port requestCreateContract : ContractCreatorModel -> Cmd msg diff --git a/app/elm/contract/Update.elm b/app/elm/contract/Update.elm new file mode 100644 index 0000000..eeb5dad --- /dev/null +++ b/app/elm/contract/Update.elm @@ -0,0 +1,379 @@ +module Contract.Update exposing (..) + +import Msgs exposing (..) +import Models exposing (Model, ContractCreatorModel, ContractModel, Stage(..), Event(..), ContractInfo, Settlement, Awards, Address, Wei, zeroWei, Parties, PartyModel, Party, Brehons, BrehonModel, Brehon) +import Time as Time exposing (Time) +import Time.DateTime as DateTime exposing (DateTime, dateTime, zero, addDays, fromISO8601, compare, fromTimestamp) +import Commands exposing (..) + + +updateContract : Msg -> ContractModel -> ( ContractModel, Cmd Msg ) +updateContract msg model = + case msg of + LoadAccounts accounts -> + ( setLoadedAddress model (List.head accounts), Cmd.none ) + + LoadContractInfo ( deployedAddr, stage, transactionAmount, minimumContractAmt, appealPeriodInDays, activeBrehon, awards ) -> + ( { model + | contractInfo = updateContractInfo model.contractInfo deployedAddr stage transactionAmount minimumContractAmt appealPeriodInDays model.currentTimestamp activeBrehon awards + } + , updateTimestamp + ) + + LoadAllParties parties -> + ( { model + | partyA = updatePartyModel model.partyA parties.partyA + , partyB = updatePartyModel model.partyB parties.partyB + , totalDeposits = parties.totalDeposits + , depositField = zeroWei + , contractInfo = + getPartiesAcceptance parties + |> updatePartyAcceptance model.contractInfo + } + , Cmd.none + ) + + LoadAllBrehons brehons -> + ( { model + | primaryBrehon = updateBrehonModel model.primaryBrehon brehons.primaryBrehon + , secondaryBrehon = updateBrehonModel model.secondaryBrehon brehons.secondaryBrehon + , tertiaryBrehon = updateBrehonModel model.tertiaryBrehon brehons.tertiaryBrehon + , contractInfo = + getBrehonsAcceptance brehons + |> updateBrehonAcceptance model.contractInfo + } + , Cmd.none + ) + + AcceptContractByParty partyModel -> + ( model, acceptContractByParty partyModel ) + + AcceptContractByBrehon brehonModel -> + ( model, acceptContractByBrehon brehonModel ) + + DepositFieldChanged amount -> + ( { model | depositField = amount }, Cmd.none ) + + DepositFunds partyModel -> + ( model, depositFunds partyModel model.depositField ) + + SettlementPartyAFieldChanged amount -> + ( { model | settlementPartyAField = amount }, Cmd.none ) + + SettlementPartyBFieldChanged amount -> + ( { model | settlementPartyBField = amount }, Cmd.none ) + + StartContract party -> + ( model, startContract party.struct.addr ) + + LoadProposedSettlement proposedSettlement -> + ( { model | contractInfo = updateContractInfoSettlement model.contractInfo proposedSettlement }, Cmd.none ) + + LoadAwards awards -> + ( { model | contractInfo = updateAwards model.contractInfo awards }, Cmd.none ) + + ProposeSettlement party -> + ( model, proposeSettlement party.struct.addr model.settlementPartyAField model.settlementPartyBField ) + + AcceptSettlement party -> + case model.contractInfo.proposedSettlement of + Nothing -> + ( model, Cmd.none ) + + Just settlement -> + ( model + , acceptSettlement + party.struct.addr + settlement.settlementPartyA + settlement.settlementPartyB + ) + + LoadAllEvents -> + ( model, Cmd.none ) + + LoadExecutionStartedEvent ( blockNumber, txHash, caller, totalDeposits ) -> + ( { model + | eventLog = + ExecutionStartedEvent blockNumber + txHash + caller + totalDeposits + :: model.eventLog + } + , Cmd.none + ) + + LoadSettlementProposedEvent ( blockNumber, txHash, proposingParty, awardPartyA, awardPartyB ) -> + ( { model + | eventLog = + SettlementProposedEvent blockNumber + txHash + proposingParty + awardPartyA + awardPartyB + :: model.eventLog + } + , Cmd.none + ) + + LoadDisputeResolvedEvent ( blockNumber, txHash, awardPartyA, awardPartyB ) -> + ( { model + | eventLog = + DisputeResolvedEvent blockNumber + txHash + awardPartyA + awardPartyB + :: model.eventLog + } + , Cmd.none + ) + + LoadContractDisputedEvent ( disputingParty, activeBrehon ) -> + ( { model + | eventLog = + ContractDisputedEvent disputingParty + activeBrehon + :: model.eventLog + } + , Cmd.none + ) + + LoadAppealPeriodStartedEvent ( startTime, activeBrehon, awardPartyA, awardPartyB ) -> + ( { model + | eventLog = + AppealPeriodStartedEvent + (toDateTime startTime) + activeBrehon + awardPartyA + awardPartyB + :: model.eventLog + , primaryBrehon = updateBrehonAwards model.primaryBrehon activeBrehon awardPartyA awardPartyB + , secondaryBrehon = updateBrehonAwards model.secondaryBrehon activeBrehon awardPartyA awardPartyB + , contractInfo = updateAppealPeriodInfo model.contractInfo model.currentTimestamp (toDateTime startTime) + } + , Cmd.none + ) + + LoadAppealRaisedEvent ( appealingParty, activeBrehon ) -> + ( { model + | eventLog = + AppealRaisedEvent + appealingParty + activeBrehon + :: model.eventLog + } + , Cmd.none + ) + + LoadSecondAppealRaisedEvent ( appealingParty, activeBrehon ) -> + ( { model + | eventLog = + SecondAppealRaisedEvent + appealingParty + activeBrehon + :: model.eventLog + } + , Cmd.none + ) + + LoadFundsClaimed ( claimingParty, amount ) -> + ( { model + | eventLog = + FundsClaimedEvent claimingParty + amount + :: model.eventLog + } + , Cmd.none + ) + + UpdateTimestamp time -> + ( { model + | currentTimestamp = time + , contractInfo = updateAppealPeriodInProgress model.contractInfo time + } + , Cmd.none + ) + + Adjudicate brehon -> + ( model, adjudicate brehon.struct.addr model.settlementPartyAField model.settlementPartyBField ) + + WithdrawFunds addr -> + ( model, withdrawFunds addr ) + + RaiseDispute addr -> + ( model, raiseDispute addr ) + + RaiseAppeal addr -> + ( model, raiseAppeal addr ) + + RaiseSecondAppeal addr -> + ( model, raiseSecondAppeal addr ) + + _ -> + ( model, Cmd.none ) + + +getPartiesAcceptance : Parties -> Bool +getPartiesAcceptance parties = + List.all (\p -> p.contractAccepted) + [ parties.partyA + , parties.partyB + ] + + +getBrehonsAcceptance : Brehons -> Bool +getBrehonsAcceptance brehons = + List.all (\b -> b.contractAccepted) + [ brehons.primaryBrehon + , brehons.secondaryBrehon + , brehons.tertiaryBrehon + ] + + +setLoadedAddress : ContractModel -> Maybe Address -> ContractModel +setLoadedAddress model address = + case address of + Nothing -> + model + + Just addr -> + { model | loadedAccount = addr } + + +updatePartyAcceptance : ContractInfo -> Bool -> ContractInfo +updatePartyAcceptance contractInfo partiesAccepted = + { contractInfo | partiesAccepted = partiesAccepted } + + +updateBrehonAcceptance : ContractInfo -> Bool -> ContractInfo +updateBrehonAcceptance contractInfo brehonsAccepted = + { contractInfo | brehonsAccepted = brehonsAccepted } + + +updateContractInfoSettlement : ContractInfo -> Maybe Settlement -> ContractInfo +updateContractInfoSettlement contractInfo settlement = + { contractInfo | proposedSettlement = settlement } + + +updateAwards : ContractInfo -> Maybe Awards -> ContractInfo +updateAwards contractInfo awards = + { contractInfo | awards = awards } + + +updateContractInfo : + ContractInfo + -> Address + -> Int + -> Wei + -> Wei + -> Int + -> Time + -> Address + -> Maybe Awards + -> ContractInfo +updateContractInfo contractInfo addr stageInt transactionAmount minimumContractAmt appealPeriodInDays time activeBrehon awards = + let + appealPeriodEnd = + case contractInfo.appealPeriodStart of + Nothing -> + Nothing + + Just appealPeriodStart -> + Just (addDays appealPeriodInDays appealPeriodStart) + + contractInfoUpdated = + { contractInfo + | deployedAt = addr + , transactionAmount = transactionAmount + , minimumContractAmt = minimumContractAmt + , appealPeriodInDays = appealPeriodInDays + , activeBrehon = activeBrehon + , awards = awards + , appealPeriodEnd = appealPeriodEnd + } + in + case stageInt of + 1 -> + { contractInfoUpdated | stage = Execution } + + 2 -> + { contractInfoUpdated | stage = Dispute } + + 3 -> + { contractInfoUpdated | stage = Resolved } + + 4 -> + { contractInfoUpdated | stage = AppealPeriod } + + 5 -> + { contractInfoUpdated | stage = Appeal } + + 6 -> + { contractInfoUpdated | stage = SecondAppealPeriod } + + 7 -> + { contractInfoUpdated | stage = SecondAppeal } + + 8 -> + { contractInfoUpdated | stage = Completed } + + _ -> + { contractInfoUpdated | stage = Negotiation } + + +updatePartyModel : PartyModel -> Party -> PartyModel +updatePartyModel partyModel party = + { partyModel | struct = party } + + +updateBrehonModel : BrehonModel -> Brehon -> BrehonModel +updateBrehonModel brehonModel brehon = + { brehonModel | struct = brehon } + + +updateBrehonAwards : BrehonModel -> Address -> Wei -> Wei -> BrehonModel +updateBrehonAwards brehonModel activeBrehonAddr awardPartyA awardPartyB = + if brehonModel.struct.addr == activeBrehonAddr then + { brehonModel | awards = Just (Awards awardPartyA awardPartyB) } + else + brehonModel + + +updateAppealPeriodInfo : ContractInfo -> Time -> DateTime -> ContractInfo +updateAppealPeriodInfo contractInfo time appealPeriodStart = + let + appealPeriodEnd = + addDays contractInfo.appealPeriodInDays appealPeriodStart + in + { contractInfo + | appealPeriodStart = Just appealPeriodStart + , appealPeriodEnd = Just appealPeriodEnd + } + + +updateAppealPeriodInProgress : ContractInfo -> Time -> ContractInfo +updateAppealPeriodInProgress contractInfo time = + { contractInfo + | appealPeriodInProgress = + case contractInfo.appealPeriodEnd of + Nothing -> + False + + Just appealPeriodEnd -> + case DateTime.compare appealPeriodEnd (fromTimestamp time) of + LT -> + False + + _ -> + True + } + + +toDateTime : String -> DateTime +toDateTime dateString = + case fromISO8601 dateString of + Err e -> + dateTime zero + + Ok r -> + r diff --git a/app/elm/contract/View.elm b/app/elm/contract/View.elm new file mode 100644 index 0000000..2bb2e57 --- /dev/null +++ b/app/elm/contract/View.elm @@ -0,0 +1,696 @@ +module Contract.View exposing (..) + +import ViewHelpers exposing (..) +import Html exposing (Html, Attribute, a, button, div, ul, li, img, input, label, p, span, i, text) +import Html.Attributes exposing (class, href, src, type_, placeholder) +import Html.Events exposing (onClick, onInput) +import Time.DateTime as DateTime exposing (toISO8601, fromTimestamp) +import Msgs exposing (Msg) +import Models exposing (Model, ContractCreatorModel, ContractModel, Address, Event(..), ContractInfo, Settlement, Awards, Wei, PartyModel, BrehonModel, FilePath, AppealLevel(..), Stage(..)) + + +contractView : ContractModel -> Html Msg +contractView model = + div [ class "main-container lg-h4 md-h4 sm-h4 clearfix" ] + [ contractDetailView model + , div [ class "col col-8" ] + [ div [ class "party-list flex flex-wrap" ] + [ partyView model.partyA "images/partyA.png" model + , partyView model.partyB "images/partyB.png" model + ] + , div [ class "brehon-list flex flex-wrap flex-column" ] + [ brehonView model.primaryBrehon "images/partyPrimaryBrehon.png" model + , brehonView model.secondaryBrehon "images/partySecondaryBrehon.png" model + , brehonView model.tertiaryBrehon "images/partyTertiaryBrehon.png" model + ] + ] + , div [ class "col col-2 lg-h4 sm-h6" ] [ logView model ] + ] + + +contractDetailView : ContractModel -> Html Msg +contractDetailView model = + let + showProposedSettlement = + model.contractInfo.stage /= Completed + + showActiveBrehon = + model.contractInfo.stage == Dispute + in + ul [ class "contract-detail sm-h5 p2 col col-2 list-reset" ] + [ li [] + [ text "Contract Deployed At: " + , textAddress model.contractInfo.deployedAt + ] + , li [] + [ text "Current Time: " + , model.currentTimestamp + |> fromTimestamp + |> toISO8601 + |> text + ] + , li [] + [ text "Loaded Account: " + , textAddress model.loadedAccount + ] + , li [] + [ text "Total Deposits: " + , text model.totalDeposits + , text " Wei" + ] + , li [] + [ text "Minimum Amount to start the contract: " + , text model.contractInfo.minimumContractAmt + , text " Wei" + ] + , li [] + [ text "Contract Stage: " + , text (toString model.contractInfo.stage) + ] + , li [] + [ text "Transaction Amount : " + , text model.contractInfo.transactionAmount + ] + , li [] + [ text "Parties Accepted : " + , text (toString model.contractInfo.partiesAccepted) + ] + , li [] + [ text "Brehons Accepted : " + , text (toString model.contractInfo.brehonsAccepted) + ] + , li [] + [ proposedSettlementView model.contractInfo.proposedSettlement + ] + |> conditionalBlock showProposedSettlement + , li [] + [ text "Active Brehon: " + , textAddress model.contractInfo.activeBrehon + ] + |> conditionalBlock showActiveBrehon + , li [] + [ text "Appeal Period Start time: " + , text + (model.contractInfo.appealPeriodStart + |> toJustString toISO8601 + ) + ] + |> justValue model.contractInfo.appealPeriodStart + , li [] + [ text "Appeal Period Duration (days): " + , text (toString model.contractInfo.appealPeriodInDays) + ] + |> justValue model.contractInfo.appealPeriodEnd + , li [] + [ text "Appeal Period End time: " + , text + (model.contractInfo.appealPeriodEnd + |> toJustString toISO8601 + ) + ] + |> justValue model.contractInfo.appealPeriodEnd + , li [] + [ awardsView model.contractInfo.awards + ] + |> justValue model.contractInfo.awards + ] + + +canPartyStartContract : PartyModel -> ContractInfo -> Wei -> Bool +canPartyStartContract party contractInfo totalDeposits = + (contractInfo.partiesAccepted && contractInfo.brehonsAccepted) + && contractInfo.stage + == Negotiation + && party.struct.contractAccepted + && totalDeposits + >= contractInfo.minimumContractAmt + + +canPartyProposeSettlement : PartyModel -> ContractInfo -> Bool +canPartyProposeSettlement party contractInfo = + contractInfo.stage + /= Negotiation + && contractInfo.stage + /= Completed + + +canPartyAcceptSettlement : PartyModel -> ContractInfo -> Bool +canPartyAcceptSettlement party contractInfo = + case contractInfo.proposedSettlement of + Nothing -> + False + + Just settlement -> + settlement.proposingPartyAddr + /= party.struct.addr + && contractInfo.stage + /= Completed + + +canPartyWithdrawFunds : PartyModel -> ContractInfo -> Bool +canPartyWithdrawFunds party contractInfo = + contractInfo.stage + == Completed + || (contractInfo.stage + == AppealPeriod + && not contractInfo.appealPeriodInProgress + ) + + +canPartyRaiseDispute : PartyModel -> ContractInfo -> Bool +canPartyRaiseDispute party contractInfo = + contractInfo.stage + == Execution + + +canPartyAppeal : PartyModel -> ContractInfo -> Bool +canPartyAppeal party contractInfo = + (contractInfo.stage + == AppealPeriod + ) + + +canPartySecondAppeal : PartyModel -> ContractInfo -> Bool +canPartySecondAppeal party contractInfo = + (contractInfo.stage + == SecondAppealPeriod + ) + + +canDepositIntoContract : PartyModel -> ContractInfo -> Bool +canDepositIntoContract party contractInfo = + party.struct.contractAccepted + && contractInfo.stage + /= Completed + + +partyView : PartyModel -> FilePath -> ContractModel -> Html Msg +partyView party profileImage model = + let + ownerView = + model.loadedAccount == party.struct.addr + + canDeposit = + ownerView + && canDepositIntoContract party model.contractInfo + + canStartContract = + ownerView + && canPartyStartContract party model.contractInfo model.totalDeposits + + canProposeSettlement = + ownerView + && canPartyProposeSettlement party model.contractInfo + + canAcceptSettlement = + ownerView + && canPartyAcceptSettlement party model.contractInfo + + canWithdrawFunds = + ownerView + && canPartyWithdrawFunds party model.contractInfo + + canRaiseDispute = + ownerView + && canPartyRaiseDispute party model.contractInfo + + canAppeal = + ownerView + && canPartyAppeal party model.contractInfo + + canSecondAppeal = + ownerView + && canPartySecondAppeal party model.contractInfo + + viewClass ownerView cssClass = + case ownerView of + True -> + cssClass ++ " white bg-maroon border-gray" + + False -> + cssClass + in + div + [ "party-view mx-auto max-width-1 border rounded m1 p2" + |> viewClass ownerView + |> class + ] + [ text "Party" + , div [ class "block p1" ] + [ img [ src profileImage ] [] + , text "Address: " + , textAddress party.struct.addr + ] + , div [ class "block p1" ] + [ contractAcceptanceView party.struct.contractAccepted ownerView (Msgs.AcceptContractByParty party) + ] + , div [ class "deposit-block block my1 p1" ] + [ div [ class "my1" ] + [ text "Deposit: " + , text party.struct.deposit + , text " Wei" + ] + , depositView party + ] + |> conditionalBlock canDeposit + , div + [ class "block my1 p1" ] + [ startContractView party + ] + |> conditionalBlock canStartContract + , div + [ class "block my2 p1 border" ] + [ label [ class "label label-title bg-maroon h4" ] [ text "Settlement" ] + , proposeSettlementView party + ] + |> conditionalBlock canProposeSettlement + , div + [ class "block my2 p1 border" ] + [ acceptSettlementView party model.contractInfo.proposedSettlement + ] + |> conditionalBlock canAcceptSettlement + , div + [ class "block my1 p1" ] + [ withdrawFundsView party.struct.addr ] + |> conditionalBlock canWithdrawFunds + , div + [ class "block my1 p1" ] + [ raiseDisputeView party.struct.addr ] + |> conditionalBlock canRaiseDispute + , div + [ class "block my1 p1" ] + [ appealView party.struct.addr First ] + |> conditionalBlock canAppeal + , div + [ class "block my1 p1" ] + [ appealView party.struct.addr Second ] + |> conditionalBlock canSecondAppeal + ] + + +withdrawFundsView : Address -> Html Msg +withdrawFundsView addr = + div [ class "withdraw-funds" ] + [ a + [ class "btn btn-big btn-primary block center rounded h2 black bg-yellow" + , href "#" + , onClick (Msgs.WithdrawFunds addr) + ] + [ text "Withdraw Funds" ] + ] + + +raiseDisputeView : Address -> Html Msg +raiseDisputeView addr = + div [ class "raise-dispute" ] + [ a + [ class "btn btn-big btn-primary block center rounded h2 white bg-red" + , href "#" + , onClick (Msgs.RaiseDispute addr) + ] + [ text "Raise Dispute" ] + ] + + +appealView : Address -> AppealLevel -> Html Msg +appealView addr appealLevel = + div [ class "appeal" ] + [ a + [ class "btn btn-big btn-primary block center rounded h2 black bg-aqua" + , href "#" + , onClick + (case appealLevel of + First -> + Msgs.RaiseAppeal addr + + Second -> + Msgs.RaiseSecondAppeal addr + ) + ] + [ text "Appeal" ] + ] + + +ctaButton : String -> String -> Msg -> Html Msg +ctaButton label cssClass msg = + a + [ class ("btn btn-big btn-primary block center rounded h2 " ++ cssClass) + , href "#" + , onClick msg + ] + [ text label ] + + +proposeSettlementView : PartyModel -> Html Msg +proposeSettlementView party = + div [ class "propose-settlement" ] + [ label [ class "label" ] [ text "Award for Party A" ] + , input + [ class "input" + , placeholder "0 Wei" + , onInput Msgs.SettlementPartyAFieldChanged + ] + [] + , label [ class "label" ] [ text "Award for Party B" ] + , input + [ class "input" + , placeholder "0 wei" + , onInput Msgs.SettlementPartyBFieldChanged + ] + [] + , button + [ class "btn btn-primary" + , onClick (Msgs.ProposeSettlement party) + ] + [ text "Propose Settlement" ] + ] + + +acceptSettlementView : PartyModel -> Maybe Settlement -> Html Msg +acceptSettlementView party proposedSettlement = + case proposedSettlement of + Nothing -> + div [] [] + + Just settlement -> + div [ class "accept-settlement" ] + [ label [ class "label h4" ] + [ text "Award for Party A: " + , text settlement.settlementPartyA + ] + , label [ class "label h4" ] + [ text "Award for Party B: " + , text settlement.settlementPartyB + ] + , button + [ class "btn btn-primary" + , onClick (Msgs.AcceptSettlement party) + ] + [ text "Accept Settlement" ] + ] + + +proposedSettlementView : Maybe Settlement -> Html Msg +proposedSettlementView proposedSettlement = + case proposedSettlement of + Nothing -> + div [] [] + + Just settlement -> + div [] + [ div [] + [ text "Proposing Party: " + , textAddress settlement.proposingPartyAddr + ] + , div [] + [ text "Award Party A: " + , text settlement.settlementPartyA + ] + , div [] + [ text "Award Party B: " + , text settlement.settlementPartyB + ] + ] + + +awardsView : Maybe Awards -> Html Msg +awardsView awards = + case awards of + Nothing -> + div [] [] + + Just awards -> + div [] + [ div [] + [ text "Award Party A: " + , text awards.awardPartyA + ] + , div [] + [ text "Award Party B: " + , text awards.awardPartyB + ] + ] + + +brehonView : BrehonModel -> FilePath -> ContractModel -> Html Msg +brehonView brehon profileImage model = + let + ownerView = + model.loadedAccount == brehon.struct.addr + + canAdjudicate = + ownerView + && canBrehonAdjudicate brehon model.contractInfo + + brehonClass activeBrehon brehon cssClass = + if activeBrehon == brehon.struct.addr then + cssClass ++ " active-brehon" + else + cssClass + + brehonLabel activeBrehon brehon label = + if activeBrehon == brehon.struct.addr then + "Active " ++ label + else + label + + viewClass ownerView cssClass = + case ownerView of + True -> + cssClass ++ " owner white bg-maroon border-gray" + + False -> + cssClass + in + div + [ "brehon-view mx-auto max-width-1 border rounded m1 p2" + |> viewClass ownerView + |> brehonClass model.contractInfo.activeBrehon brehon + |> class + ] + [ "Brehon" + |> brehonLabel model.contractInfo.activeBrehon brehon + |> text + , div [ class "block p1" ] + [ img [ src profileImage ] [] + , p [] + [ text "Address: " + , textAddress brehon.struct.addr + ] + , p [] + [ text "Fixed Fee: " + , text brehon.struct.fixedFee + ] + , p [] + [ text "Dispute Fee: " + , text brehon.struct.disputeFee + ] + ] + , div + [ class "block my1 p1" ] + [ contractAcceptanceView brehon.struct.contractAccepted ownerView (Msgs.AcceptContractByBrehon brehon) ] + , div + [ class "block my1 p1" ] + [ adjudicateView brehon ] + |> conditionalBlock canAdjudicate + , div + [ class "block my1 p1" ] + [ awardsView brehon.awards ] + ] + + +canBrehonAdjudicate : BrehonModel -> ContractInfo -> Bool +canBrehonAdjudicate brehon contractInfo = + brehon.struct.addr + == contractInfo.activeBrehon + && ((contractInfo.stage + == Dispute + ) + || (contractInfo.stage + == Appeal + ) + || (contractInfo.stage + == SecondAppeal + ) + ) + + +adjudicateView : BrehonModel -> Html Msg +adjudicateView brehon = + div [ class "adjudicate" ] + [ label [ class "label" ] [ text "Award for Party A" ] + , input + [ class "input" + , placeholder "0 Wei" + , onInput Msgs.SettlementPartyAFieldChanged + ] + [] + , label [ class "label" ] [ text "Award for Party B" ] + , input + [ class "input" + , placeholder "0 wei" + , onInput Msgs.SettlementPartyBFieldChanged + ] + [] + , button + [ class "btn btn-primary" + , onClick (Msgs.Adjudicate brehon) + ] + [ text "Adjudicate" ] + ] + + +startContractView : PartyModel -> Html Msg +startContractView party = + a + [ class "btn btn-big btn-primary block center rounded h2 black bg-yellow" + , href "#" + , onClick (Msgs.StartContract party) + ] + [ text "Start Contract" ] + + +depositView : PartyModel -> Html Msg +depositView party = + div [ class "deposit-funds my1 clearfix flex" ] + [ input + [ class "input mb0 mr2" + , placeholder "0 Wei" + , type_ "number" + , onInput Msgs.DepositFieldChanged + ] + [] + , a + [ class "btn center rounded white bg-olive" + , href "#" + , onClick (Msgs.DepositFunds party) + ] + [ text "Deposit" ] + ] + + +contractAcceptanceView : Bool -> Bool -> Msg -> Html Msg +contractAcceptanceView isContractAccepted ownerView messageDispatch = + case isContractAccepted of + True -> + p [] + [ i [ class "fa fa-check-circle mr1 green" ] [] + , text "Contract Accepted" + ] + + False -> + if ownerView then + div [ class "fit" ] + [ button + [ class "btn btn-primary btn-big block mx-auto" + , type_ "button" + , onClick (messageDispatch) + ] + [ text "Accept Contract" ] + ] + else + p [] + [ i [ class "fa fa-minus-square mr1 red" ] [] + , text "Contract Not Accepted" + ] + + +logView : ContractModel -> Html Msg +logView model = + ul [ class "list-reset" ] + (model.eventLog + |> List.map singleLogView + ) + + +singleLogView : Event -> Html Msg +singleLogView event = + case event of + ExecutionStartedEvent blockNumber txHash caller totalDeposits -> + li [ class "mb2" ] + [ i [ class "fa fa-paper-plane mr1" ] [] + , text "Contract started by " + , textAddress caller + , text " with a total deposit of " + , text totalDeposits + ] + + SettlementProposedEvent blockNumber txHash proposingParty awardPartyA awardPartyB -> + li [ class "mb2" ] + [ i [ class "fa fa-money mr1" ] [] + , text "Settlement proposed by " + , textAddress proposingParty + , text " with an award of " + , text awardPartyA + , text " for Party A and " + , text awardPartyB + , text " for Party B" + ] + + DisputeResolvedEvent blockNumber txHash awardPartyA awardPartyB -> + li [ class "mb2" ] + [ i [ class "fa fa-hand-peace-o mr1" ] [] + , text "Resolution reached " + , text " with an award of " + , text awardPartyA + , text " for Party A and " + , text awardPartyB + , text " for Party B" + ] + + ContractDisputedEvent disputingParty activeBrehon -> + li [ class "mb2" ] + [ i [ class "fa fa-fire mr1" ] [] + , text "Dispute raised " + , text " by " + , textAddress disputingParty + , text ". Brehon " + , textAddress activeBrehon + , text " is presiding." + ] + + AppealPeriodStartedEvent startTime activeBrehon awardPartyA awardPartyB -> + li [ class "mb2" ] + [ i [ class "fa fa-gavel mr1" ] [] + , text "Brehon " + , textAddress activeBrehon + , text " provided a judgment by awarding " + , text awardPartyA + , text " to partyA and " + , text awardPartyB + , text " to partyB at " + , text (toISO8601 startTime) + ] + + AppealRaisedEvent appealingParty activeBrehon -> + li [ class "mb2" ] + [ i [ class "fa fa-fire mr1" ] [] + , text "Appeal raised " + , text " by " + , textAddress appealingParty + , text ". Brehon " + , textAddress activeBrehon + , text " is presiding." + ] + + SecondAppealRaisedEvent appealingParty activeBrehon -> + li [ class "mb2" ] + [ i [ class "fa fa-fire mr1" ] [] + , i [ class "fa fa-fire mr1" ] [] + , text "Second Appeal raised " + , text " by " + , textAddress appealingParty + , text ". Brehon " + , textAddress activeBrehon + , text " is presiding." + ] + + FundsClaimedEvent claimingParty amount -> + li [ class "mb2" ] + [ i [ class "fa fa-money mr1" ] [] + , text "Funds claimed " + , text " by " + , textAddress claimingParty + , text " in the amount of " + , text amount + ] diff --git a/app/elm/create/Update.elm b/app/elm/create/Update.elm new file mode 100644 index 0000000..fa23ff3 --- /dev/null +++ b/app/elm/create/Update.elm @@ -0,0 +1,74 @@ +module Create.Update exposing (..) + +import Msgs exposing (..) +import Models exposing (ContractCreatorModel, Wei, Address, Brehon, Party) +import Commands exposing (..) + + +updateCreateContract : Msg -> ContractCreatorModel -> ( ContractCreatorModel, Cmd Msg ) +updateCreateContract msg model = + case msg of + PartyAAddrChanged addr -> + ( { model | partyA = updatePartyAddr model.partyA (Just addr) }, Cmd.none ) + + PartyBAddrChanged addr -> + ( { model | partyB = updatePartyAddr model.partyB (Just addr) }, Cmd.none ) + + TxAmountChanged amount -> + ( { model | transactionAmount = amount }, Cmd.none ) + + TermsChanged termsAndConditions -> + ( { model | termsAndConditions = termsAndConditions }, Cmd.none ) + + PrimaryBrehonAddrChanged addr -> + ( { model | primaryBrehon = updateBrehonAddr model.primaryBrehon (Just addr) }, Cmd.none ) + + PrimaryBrehonFixedFeeChanged fixedFee -> + ( { model | primaryBrehon = updateBrehonFixedFee model.primaryBrehon fixedFee }, Cmd.none ) + + PrimaryBrehonDisputeFeeChanged disputeFee -> + ( { model | primaryBrehon = updateBrehonDisputeFee model.primaryBrehon disputeFee }, Cmd.none ) + + SecondaryBrehonAddrChanged addr -> + ( { model | secondaryBrehon = updateBrehonAddr model.secondaryBrehon (Just addr) }, Cmd.none ) + + SecondaryBrehonFixedFeeChanged fixedFee -> + ( { model | secondaryBrehon = updateBrehonFixedFee model.secondaryBrehon fixedFee }, Cmd.none ) + + SecondaryBrehonDisputeFeeChanged disputeFee -> + ( { model | secondaryBrehon = updateBrehonDisputeFee model.secondaryBrehon disputeFee }, Cmd.none ) + + TertiaryBrehonAddrChanged addr -> + ( { model | tertiaryBrehon = updateBrehonAddr model.tertiaryBrehon (Just addr) }, Cmd.none ) + + TertiaryBrehonFixedFeeChanged fixedFee -> + ( { model | tertiaryBrehon = updateBrehonFixedFee model.tertiaryBrehon fixedFee }, Cmd.none ) + + TertiaryBrehonDisputeFeeChanged disputeFee -> + ( { model | tertiaryBrehon = updateBrehonDisputeFee model.tertiaryBrehon disputeFee }, Cmd.none ) + + CreateContract creatorModel -> + ( model, createContract creatorModel ) + + _ -> + ( model, Cmd.none ) + + +updatePartyAddr : Party -> Address -> Party +updatePartyAddr party addr = + { party | addr = addr } + + +updateBrehonAddr : Brehon -> Address -> Brehon +updateBrehonAddr brehon addr = + { brehon | addr = addr } + + +updateBrehonFixedFee : Brehon -> Wei -> Brehon +updateBrehonFixedFee brehon fixedFee = + { brehon | fixedFee = fixedFee } + + +updateBrehonDisputeFee : Brehon -> Wei -> Brehon +updateBrehonDisputeFee brehon disputeFee = + { brehon | disputeFee = disputeFee } diff --git a/app/javascripts/index.js b/app/javascripts/index.js index 9dd9319..ba443ec 100644 --- a/app/javascripts/index.js +++ b/app/javascripts/index.js @@ -271,9 +271,12 @@ function portHooks(elmApp, currentProvider) { ports.requestWithdrawFunds.subscribe(withdrawingAddress => brehonApp.withdrawFunds(withdrawingAddress) .then(() => updateContractInfo(ports, brehonApp))); + + ports.requestCreateContract.subscribe(partyAAddr => + console.info(partyAAddr)); } -document.addEventListener('DOMContentLoaded', () => { +window.addEventListener('load', () => { const mountNode = document.getElementById('main'); const brehonElmApp = Elm.Main.embed(mountNode); diff --git a/contracts/BrehonContract.sol b/contracts/BrehonContract.sol index c882fea..c21f081 100644 --- a/contracts/BrehonContract.sol +++ b/contracts/BrehonContract.sol @@ -54,7 +54,7 @@ contract BrehonContract is event DisputeResolved(uint awardPartyA, uint awardPartyB); event FundsClaimed(address claimingParty, uint amount); - modifier byEitherEntities() { + modifier byAnyEntity() { if (msg.sender != primaryBrehon.addr && msg.sender != secondaryBrehon.addr && msg.sender != tertiaryBrehon.addr && @@ -240,7 +240,7 @@ contract BrehonContract is } function claimFunds() - byEitherEntities() + byAnyEntity() { if (stage != Stages.Completed) { if (stage != Stages.AppealPeriod && stage != Stages.SecondAppealPeriod) { diff --git a/contracts/BrehonContractFactory.sol b/contracts/BrehonContractCreator.sol similarity index 100% rename from contracts/BrehonContractFactory.sol rename to contracts/BrehonContractCreator.sol diff --git a/elm-package.json b/elm-package.json index e6599e2..e85aa17 100644 --- a/elm-package.json +++ b/elm-package.json @@ -11,7 +11,9 @@ "debois/elm-mdl": "8.1.0 <= v < 9.0.0", "elm-community/elm-time": "1.0.3 <= v < 2.0.0", "elm-lang/core": "5.1.1 <= v < 6.0.0", - "elm-lang/html": "2.0.0 <= v < 3.0.0" + "elm-lang/html": "2.0.0 <= v < 3.0.0", + "elm-lang/navigation": "2.1.0 <= v < 3.0.0", + "evancz/url-parser": "2.0.1 <= v < 3.0.0" }, "elm-version": "0.18.0 <= v < 0.19.0" } diff --git a/migrations/3_deploy_factory_contract.js b/migrations/3_deploy_creator_contract.js similarity index 100% rename from migrations/3_deploy_factory_contract.js rename to migrations/3_deploy_creator_contract.js diff --git a/test/BrehonContractFactory_Constructor.spec.js b/test/BrehonContractCreator_Constructor.spec.js similarity index 100% rename from test/BrehonContractFactory_Constructor.spec.js rename to test/BrehonContractCreator_Constructor.spec.js diff --git a/test/BrehonContractFactory_newBrehonContract.spec.js b/test/BrehonContractCreator_newBrehonContract.spec.js similarity index 100% rename from test/BrehonContractFactory_newBrehonContract.spec.js rename to test/BrehonContractCreator_newBrehonContract.spec.js