Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
9 changed files
with
217 additions
and
151 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
50 changes: 50 additions & 0 deletions
50
...we-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Contracts/Possibilities.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,50 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE GADTs #-} | ||
|
|
||
| -- | This module defines a server for the /contracts REST API. | ||
|
|
||
| module Language.Marlowe.Runtime.Web.Server.REST.Contracts.Possibilities | ||
| ( get | ||
| ) where | ||
|
|
||
| import Cardano.Api (BabbageEra, TxBody, getTxBody, makeSignedTransaction) | ||
| import qualified Cardano.Api as Cardano | ||
| import Cardano.Ledger.Alonzo.TxWitness (TxWitness(TxWitness)) | ||
| import Control.Monad (unless) | ||
| import Data.Aeson (Value(Null)) | ||
| import Data.List.NonEmpty as NEL | ||
| import qualified Data.Map as Map | ||
| import Data.Maybe (fromMaybe) | ||
| import qualified Data.Set as Set | ||
| import Data.Text (Text) | ||
| import Language.Marlowe (Environment) | ||
| import Language.Marlowe.Core.V1.Semantics.Possibilities (Possibilities, possibilities) | ||
| import Language.Marlowe.Protocol.Query.Types (ContractFilter(..), Page(..), SomeContractState(SomeContractState)) | ||
| import Language.Marlowe.Runtime.ChainSync.Api (Lovelace(..)) | ||
| import Language.Marlowe.Runtime.Core.Api | ||
| (ContractId, MarloweMetadataTag(..), MarloweTransactionMetadata(..), MarloweVersion(..), SomeMarloweVersion(..)) | ||
| import Language.Marlowe.Runtime.Transaction.Api (ContractCreated(..), WalletAddresses(..)) | ||
| import qualified Language.Marlowe.Runtime.Transaction.Api as Tx | ||
| import Language.Marlowe.Runtime.Web hiding (Unsigned) | ||
| import Language.Marlowe.Runtime.Web.Server.DTO | ||
| import Language.Marlowe.Runtime.Web.Server.Monad | ||
| (AppM, createContract, loadContract, loadContractHeaders, submitContract) | ||
| import Language.Marlowe.Runtime.Web.Server.REST.ApiError | ||
| (ApiError(ApiError), badRequest', notFound', rangeNotSatisfiable', throwDTOError) | ||
| import qualified Language.Marlowe.Runtime.Web.Server.REST.ApiError as ApiError | ||
| import qualified Language.Marlowe.Runtime.Web.Server.REST.Transactions as Transactions | ||
| import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx(TempTx), TempTxStatus(Unsigned)) | ||
| import Language.Marlowe.Runtime.Web.Server.Util (makeSignedTxWithWitnessKeys) | ||
| import Servant | ||
| import Servant.Pagination | ||
|
|
||
| get :: Environment -> TxOutRef -> AppM [Possibilities] | ||
| get environment contractId = do | ||
| contractId' <- fromDTOThrow (badRequest' "Invalid contract id value") contractId | ||
| loadContract contractId' >>= \case | ||
| Nothing -> throwError $ notFound' "Contract not found" | ||
| Just eitherTmpContractStateorContractState -> do | ||
| let ContractState {state,initialContract,currentContract} = either toDTO toDTO eitherTmpContractStateorContractState | ||
| pure $ NEL.toList $ fromMaybe [] $ possibilities environment state (fromMaybe initialContract currentContract) | ||
|
|
||
|
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,150 @@ | ||
| ----------------------------------------------------------------------------- | ||
| -- | ||
| -- Module : $Headers | ||
| -- License : Apache 2.0 | ||
| -- | ||
| -- Stability : Experimental | ||
| -- Portability : Portable | ||
| -- | ||
| -- | Types for Marlowe semantics | ||
| -- | ||
| ----------------------------------------------------------------------------- | ||
|
|
||
|
|
||
| {-# LANGUAGE BlockArguments #-} | ||
| {-# LANGUAGE DataKinds #-} | ||
|
|
||
| {-# LANGUAGE DeriveAnyClass #-} | ||
| {-# LANGUAGE DeriveGeneric #-} | ||
| {-# LANGUAGE DerivingVia #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
|
|
||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE MultiParamTypeClasses #-} | ||
|
|
||
| {-# LANGUAGE NoImplicitPrelude #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE RankNTypes #-} | ||
|
|
||
|
|
||
| module Language.Marlowe.Core.V1.Semantics.Next | ||
| ( Next(..) | ||
| , NextActionPossibility(..) | ||
| , next | ||
| ) where | ||
|
|
||
| import Control.Applicative ((<*>), (<|>)) | ||
| import qualified Data.Aeson as JSON | ||
| import Data.Aeson.Types hiding (Error, Value) | ||
| import Data.ByteString.Base16.Aeson (EncodeBase16(..)) | ||
| import Data.List.NonEmpty as NEL | ||
| import Data.Text (pack) | ||
| import Deriving.Aeson | ||
| import Language.Marlowe.Core.V1.Semantics | ||
| import Language.Marlowe.Core.V1.Semantics.Types | ||
| import Language.Marlowe.Pretty (Pretty(..)) | ||
| import PlutusTx.Prelude hiding (encodeUtf8, mapM, (<$>), (<*>), (<>)) | ||
| import Prelude ((<$>)) | ||
| import qualified Prelude as Haskell | ||
|
|
||
| -- | Description on What can be done next | ||
| data Next | ||
| = WaitingForInput (NonEmpty NextAction) | ||
| | ContractClosed | ||
| | SuspendedOnATimeOut | ||
| deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) | ||
| deriving anyclass (Pretty) | ||
|
|
||
| data NextContinuation | ||
| = NextContract Contract | ||
| | NextMerkleizedContract BuiltinByteString | ||
| deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) | ||
| deriving anyclass (Pretty) | ||
|
|
||
| instance FromJSON NextContinuation where | ||
| parseJSON (Object v) | ||
| = NextContract <$> v .: "contract" | ||
| <|> NextMerkleizedContract <$> do | ||
| mt <- v .: "merkleized_contract_hash" | ||
| EncodeBase16 bs <- parseJSON mt | ||
| return $ toBuiltin bs | ||
| parseJSON _ = Haskell.fail "NextAction must be an object with 2 fields \"action_possibility\" and \"continuation\"" | ||
|
|
||
| data NextAction = NextAction NextActionPossibility NextContinuation | ||
| deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) | ||
| deriving anyclass (Pretty) | ||
|
|
||
| instance FromJSON NextAction where | ||
| parseJSON (Object v) = NextAction <$> v .: "action_possibility" <*> v .: "continuation" | ||
| parseJSON _ = Haskell.fail "NextAction must be an object with 2 fields \"action_possibility\" and \"continuation\"" | ||
|
|
||
| -- | an Action that can be done out of several possible alternatives. | ||
| data NextActionPossibility | ||
| = CanDeposit Party AccountId Token Integer | ||
| | CanChoose ChoiceId [Bound] | ||
| | CanNotify | ||
| | CanAdvance | ||
| deriving stock (Haskell.Show,Haskell.Eq,Haskell.Ord,Generic) | ||
| deriving anyclass (Pretty) | ||
|
|
||
|
|
||
| instance FromJSON NextActionPossibility where | ||
| parseJSON (String "can_notify") = return CanNotify | ||
| parseJSON (String "can_advance") = return CanAdvance | ||
| parseJSON (Object v) = | ||
| CanChoose | ||
| <$> v .: "can_choose_id" | ||
| <*> v .: "within_bounds" | ||
| <|> CanDeposit | ||
| <$> v .: "party" | ||
| <*> v .: "into_account" | ||
| <*> v .: "of_token" | ||
| <*> v .: "can_deposit" | ||
| parseJSON _ = Haskell.fail "Action Possibility must be either an object or the string \"can_notify\" or \"can_advance\"" | ||
|
|
||
| instance ToJSON NextActionPossibility where | ||
| toJSON CanNotify = JSON.String $ pack "can_notify" | ||
| toJSON CanAdvance = JSON.String $ pack "can_advance" | ||
| toJSON (CanDeposit party accountId token quantity) = object | ||
| [ "party" .= party | ||
| , "can_deposit" .= quantity | ||
| , "of_token" .= token | ||
| , "into_account" .= accountId | ||
| ] | ||
| toJSON (CanChoose choiceId bounds) = object | ||
| [ "for_choice" .= choiceId | ||
| , "can_choose_between" .= bounds | ||
| ] | ||
|
|
||
|
|
||
| next :: Environment -> State -> Contract -> Next | ||
| next _ _ Close = ContractClosed | ||
| next environment _ (When _ timeout continuation) | isTimedOut timeout environment = WaitingForInput $ (NextAction CanAdvance $ NextContract continuation):| [] | ||
| next _ _ (When [] _ _) = SuspendedOnATimeOut | ||
| next environment state (When (x:xs) _ _) = WaitingForInput . caseContractsToNextAction environment state $ x :| xs | ||
| next _ _ (Pay _ _ _ _ continuation) = WaitingForInput $ (NextAction CanAdvance $ NextContract continuation):| [] | ||
| next _ _ (If _ _ continuation) = WaitingForInput $ (NextAction CanAdvance $ NextContract continuation):| [] | ||
| next _ _ (Let _ _ continuation) = WaitingForInput $ (NextAction CanAdvance $ NextContract continuation):| [] | ||
| next _ _ (Assert _ continuation) = WaitingForInput $ (NextAction CanAdvance $ NextContract continuation):| [] | ||
|
|
||
| caseContractsToNextAction :: Environment -> State -> NonEmpty (Case Contract) -> NonEmpty NextAction | ||
| caseContractsToNextAction environment state | ||
| = (caseContractToNextAction environment state <$>) | ||
|
|
||
| caseContractToNextAction :: Environment -> State -> Case Contract -> NextAction | ||
| caseContractToNextAction environment state | ||
| = \case | ||
| (Case action contract) -> NextAction (actionToNextPossibilities environment state action)(NextContract contract) | ||
| (MerkleizedCase action hash) -> NextAction (actionToNextPossibilities environment state action)(NextMerkleizedContract hash) | ||
|
|
||
| actionToNextPossibilities :: Environment -> State -> Action -> NextActionPossibility | ||
| actionToNextPossibilities environment state = \case | ||
| (Deposit accountId party token value) | ||
| -> CanDeposit | ||
| accountId | ||
| party | ||
| token | ||
| (evalValue environment state value) | ||
| (Choice choiceId bounds) -> CanChoose choiceId bounds | ||
| (Notify _) -> CanNotify |
Oops, something went wrong.