From 4038235ee1fa980336299f9200f84727f099ca3f Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 7 Sep 2023 18:02:46 +0200 Subject: [PATCH 01/10] PLT-7412: new repos --- package-lock.json | 2 +- packages.dhall | 136 ++ spago.dhall | 3 + src/Component/Types/ContractInfo.purs | 2 +- src/Contrib/CardanoMultiplatformLib.js | 12 - src/Contrib/CardanoMultiplatformLib.purs | 194 --- .../CardanoMultiplatformLib/Address.purs | 253 ---- src/Contrib/CardanoMultiplatformLib/Lib.purs | 30 - .../CardanoMultiplatformLib/Transaction.purs | 1349 ----------------- .../CardanoMultiplatformLib/Types.purs | 76 - src/Contrib/Data/Argonaut.js | 8 - src/Contrib/Data/Argonaut.purs | 51 - src/Contrib/Data/Argonaut/Decode/Record.purs | 60 - .../Data/Argonaut/Decode/Record/Field.purs | 149 -- src/Contrib/Data/Argonaut/Generic/Record.purs | 143 -- src/Contrib/Data/Argonaut/Record.purs | 23 - src/Contrib/Data/Argonaut/Traversals.purs | 35 - src/Contrib/Data/Map.purs | 29 - src/Contrib/Data/String.purs | 27 - src/Contrib/Effect.purs | 22 - src/Contrib/Effect/SequenceRef.purs | 18 - src/Contrib/Fetch.purs | 59 - src/Contrib/HexString.js | 2 - src/Contrib/HexString.purs | 35 - src/Contrib/Language/Marlowe/Core/V1.purs | 47 - .../Language/Marlowe/Normalization.purs | 141 -- src/Contrib/Record/BuilderT.purs | 45 - src/Main.purs | 3 +- src/Marlowe/Runtime/Web.purs | 8 - src/Marlowe/Runtime/Web/Client.purs | 386 ----- src/Marlowe/Runtime/Web/Streaming.purs | 402 ----- src/Marlowe/Runtime/Web/Types.purs | 939 ------------ 32 files changed, 143 insertions(+), 4546 deletions(-) delete mode 100644 src/Contrib/CardanoMultiplatformLib.js delete mode 100644 src/Contrib/CardanoMultiplatformLib.purs delete mode 100644 src/Contrib/CardanoMultiplatformLib/Address.purs delete mode 100644 src/Contrib/CardanoMultiplatformLib/Lib.purs delete mode 100644 src/Contrib/CardanoMultiplatformLib/Transaction.purs delete mode 100644 src/Contrib/CardanoMultiplatformLib/Types.purs delete mode 100644 src/Contrib/Data/Argonaut.js delete mode 100644 src/Contrib/Data/Argonaut.purs delete mode 100644 src/Contrib/Data/Argonaut/Decode/Record.purs delete mode 100644 src/Contrib/Data/Argonaut/Decode/Record/Field.purs delete mode 100644 src/Contrib/Data/Argonaut/Generic/Record.purs delete mode 100644 src/Contrib/Data/Argonaut/Record.purs delete mode 100644 src/Contrib/Data/Argonaut/Traversals.purs delete mode 100644 src/Contrib/Data/Map.purs delete mode 100644 src/Contrib/Data/String.purs delete mode 100644 src/Contrib/Effect.purs delete mode 100644 src/Contrib/Effect/SequenceRef.purs delete mode 100644 src/Contrib/Fetch.purs delete mode 100644 src/Contrib/HexString.js delete mode 100644 src/Contrib/HexString.purs delete mode 100644 src/Contrib/Language/Marlowe/Core/V1.purs delete mode 100644 src/Contrib/Language/Marlowe/Normalization.purs delete mode 100644 src/Contrib/Record/BuilderT.purs delete mode 100644 src/Marlowe/Runtime/Web.purs delete mode 100644 src/Marlowe/Runtime/Web/Client.purs delete mode 100644 src/Marlowe/Runtime/Web/Streaming.purs delete mode 100644 src/Marlowe/Runtime/Web/Types.purs diff --git a/package-lock.json b/package-lock.json index de1f6082..4e4e4321 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,5 +1,5 @@ { - "name": "marlowe-pure-light", + "name": "marlowe-runner", "lockfileVersion": 2, "requires": true, "packages": { diff --git a/packages.dhall b/packages.dhall index 0e062e86..8bca70f2 100644 --- a/packages.dhall +++ b/packages.dhall @@ -268,3 +268,139 @@ in upstream ] "https://github.com/paluh/purescript-foreign-generic.git" "a5c23d29e72619624978446293ac9bb45ccd2fde" + + with cardano-multiplatform-lib = + mkPackage + [ "argonaut" + , "arraybuffer-types" + , "arrays" + , "debug" + , "effect" + , "either" + , "exceptions" + , "foldable-traversable" + , "js-object" + , "js-promise-aff" + , "lists" + , "marlowe" + , "maybe" + , "newtype" + , "nullable" + , "ordered-collections" + , "partial" + , "prelude" + , "refs" + , "strings" + , "transformers" + , "tuples" + , "typelevel-prelude" + , "undefined-is-not-a-problem" + , "web-encoding" + ] + "https://github.com/input-output-hk/purescript-cardano-multiplatform-lib.git" + "main" + + with marlowe-runtime-client = + mkPackage + [ "aff" + , "aff-promise" + , "argonaut" + , "argonaut-codecs" + , "argonaut-core" + , "arraybuffer" + , "arraybuffer-types" + , "arrays" + , "atleast" + , "avar" + , "bifunctors" + , "bigints" + , "cardano-multiplatform-lib" + , "checked-exceptions" + , "console" + , "control" + , "convertable-options" + , "datetime" + , "datetime-iso" + , "debug" + , "decimals" + , "effect" + , "either" + , "enums" + , "errors" + , "exceptions" + , "fetch" + , "fetch-core" + , "filterable" + , "foldable-traversable" + , "foreign" + , "foreign-generic" + , "foreign-object" + , "formatters" + , "free" + , "freeap" + , "functions" + , "functors" + , "halogen-subscriptions" + , "heterogeneous" + , "http-methods" + , "identity" + , "indexed-monad" + , "integers" + , "js-date" + , "js-object" + , "js-promise" + , "js-promise-aff" + , "js-timers" + , "js-unsafe-stringify" + , "lists" + , "marlowe" + , "maybe" + , "monad-loops" + , "newtype" + , "node-process" + , "nonempty" + , "now" + , "nullable" + , "ordered-collections" + , "parallel" + , "parsing" + , "partial" + , "posix-types" + , "prelude" + , "profunctor" + , "profunctor-lenses" + , "random" + , "record" + , "refs" + , "row-joins" + , "safe-coerce" + , "strings" + , "tailrec" + , "transformers" + , "tuples" + , "typelevel-eval" + , "typelevel-prelude" + , "uint" + , "undefined-is-not-a-problem" + , "unfoldable" + , "unsafe-coerce" + , "uri" + , "validation" + , "variant" + , "web-dom" + , "web-encoding" + , "web-file" + , "web-html" + ] + "https://github.com/input-output-hk/purescript-marlowe-runtime-client.git" + "main" + + with + errors = + mkPackage + [ "control", "effect", "either", "maybe", "prelude" + , "transformers" + ] + "https://github.com/CarstenKoenig/purescript-errors.git" + "edfd8b1a285920e725a7fec32e736c5d59561772" + diff --git a/spago.dhall b/spago.dhall index fc33fdc2..787ee067 100644 --- a/spago.dhall +++ b/spago.dhall @@ -13,6 +13,7 @@ , "avar" , "bifunctors" , "bigints" + , "cardano-multiplatform-lib" , "console" , "control" , "convertable-options" @@ -23,6 +24,7 @@ , "effect" , "either" , "enums" + , "errors" , "exceptions" , "fetch" , "fetch-argonaut" @@ -50,6 +52,7 @@ , "lazy" , "lists" , "marlowe" + , "marlowe-runtime-client" , "maybe" , "monad-loops" , "newtype" diff --git a/src/Component/Types/ContractInfo.purs b/src/Component/Types/ContractInfo.purs index 94f0df48..38394a7e 100644 --- a/src/Component/Types/ContractInfo.purs +++ b/src/Component/Types/ContractInfo.purs @@ -80,7 +80,7 @@ updatedAt ci@(ContractInfo { _runtime: { transactions } }) = fetchAppliedInputs :: ServerURL -> Array Runtime.TransactionEndpoint -> Aff (V (Array (Runtime.ClientError String)) (Array ((Maybe V1.InputContent) /\ V1.TimeInterval))) fetchAppliedInputs serverURL transactionEndpoints = do results <- transactionEndpoints `flip parTraverse` \transactionEndpoint -> do - Runtime.getResource' serverURL transactionEndpoint {} + Runtime.getResource' serverURL transactionEndpoint {} {} pure $ results `foldMapFlipped` case _ of Left err -> V (Left [err]) diff --git a/src/Contrib/CardanoMultiplatformLib.js b/src/Contrib/CardanoMultiplatformLib.js deleted file mode 100644 index f9f7377a..00000000 --- a/src/Contrib/CardanoMultiplatformLib.js +++ /dev/null @@ -1,12 +0,0 @@ -import browserOrNode from 'browser-or-node'; - -export const importLibImpl = function() { - if(browserOrNode.isNode) { - console.log("RETURNING NODE LIB"); - return import('@dcspark/cardano-multiplatform-lib-nodejs'); - } else if(browserOrNode.isBrowser) { - console.log("RETURNING BROWSER LIB"); - return import('@dcspark/cardano-multiplatform-lib-browser'); - } - return null; -}; diff --git a/src/Contrib/CardanoMultiplatformLib.purs b/src/Contrib/CardanoMultiplatformLib.purs deleted file mode 100644 index 7f3cf3d8..00000000 --- a/src/Contrib/CardanoMultiplatformLib.purs +++ /dev/null @@ -1,194 +0,0 @@ -module CardanoMultiplatformLib - ( askLib - , asksLib - , importLib - , module Exports - , GarbageCollector - , allocate - , bech32FromCbor - , bech32FromCborHex - , bech32FromString - , runGarbageCollector - , transactionWitnessSetFromBytes - , valueFromCbor - ) where - -import Prelude - -import CardanoMultiplatformLib.Address (Address, AddressObject, addressObject, address) as Exports -import CardanoMultiplatformLib.Address (AddressObject, addressObject) -import CardanoMultiplatformLib.Address as Address -import CardanoMultiplatformLib.Lib (Lib) -import CardanoMultiplatformLib.Lib (Lib) as Exports -import CardanoMultiplatformLib.Lib as Lib -import CardanoMultiplatformLib.Transaction (TransactionWitnessSetObject, ValueObject, assetNameObject, assetNamesObject, assetsObject, bigNumObject, multiAssetObject, scriptHashObject, scriptHashesObject, value, valueObject) -import CardanoMultiplatformLib.Transaction as Transaction -import CardanoMultiplatformLib.Types (Bech32, Cbor, CborHex, cborHexToCbor, cborHexToHex, unsafeBech32) -import CardanoMultiplatformLib.Types (CborHex(..), Bech32, cborToCborHex, cborHexToHex, bech32ToString) as Exports -import Control.Monad.Error.Class (throwError) -import Control.Monad.Except (catchError) -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.Reader.Class (asks) -import Data.Array as Array -import Data.BigInt.Argonaut as BigInt.Argonaut -import Data.Foldable (sequence_) -import Data.List (List) -import Data.List as List -import Data.Map (Map) -import Data.Map as Map -import Data.Maybe (Maybe(..)) -import Data.Newtype (class Newtype, unwrap) -import Data.Nullable (Nullable) -import Data.Nullable as Nullable -import Data.TraversableWithIndex (forWithIndex) -import Data.Tuple.Nested ((/\)) -import Data.Undefined.NoProblem (Opt, toMaybe) -import Effect (Effect) -import Effect.Aff (Aff) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Exception as Effect.Exception -import Effect.Ref (Ref) -import Effect.Ref as Ref -import HexString (hexToString) -import JS.Object (EffectMth0, JSObject, runEffectMth0) -import Promise.Aff (Promise, toAff) -import Type.Prelude (Proxy(..)) -import Web.Encoding.TextDecoder as TextDecoder -import Web.Encoding.UtfLabel (utf8) - --- TODO: Move to Lib module -foreign import importLibImpl :: Effect (Nullable (Promise Lib)) - -importLib :: Aff (Maybe Lib) -importLib = liftEffect importLibImpl >>= Nullable.toMaybe >>> case _ of - Nothing -> pure Nothing - Just promise -> - (Just <$> toAff promise) `catchError` const (pure Nothing) - -type Ctx = { lib :: Lib, frees :: Ref (List (Effect Unit)) } - --- | StateT is not sufficient because it is not exception --- | safe. We need to use `Ref` to store the release actions. --- | --- | FIXME: We should probably introduce a scope phantom --- | to avoid leaks. -newtype GarbageCollector a = GarbageCollector - (ReaderT Ctx Effect a) - -derive newtype instance Functor GarbageCollector -derive newtype instance Apply GarbageCollector -derive newtype instance Applicative GarbageCollector -derive newtype instance Bind GarbageCollector -derive newtype instance Monad GarbageCollector -derive newtype instance MonadEffect GarbageCollector - -runGarbageCollector :: forall a. Lib -> GarbageCollector a -> Effect a -runGarbageCollector lib (GarbageCollector action) = do - freesRef <- Ref.new List.Nil - let - release = do - frees <- Ref.read freesRef - sequence_ frees - run = do - a <- runReaderT action { frees: freesRef, lib } - release - pure a - run `catchError` \err -> do - release - throwError err - --- | The API allocates objects which provide `free` method. --- | We use it to release the resources. -type UnmanagedObject r = JSObject (free :: EffectMth0 Unit | r) - -allocate :: forall r t. Newtype t (UnmanagedObject r) => Effect t -> GarbageCollector t -allocate alloc = GarbageCollector do - freesRef <- asks _.frees - obj <- liftEffect alloc - let - jsobj = unwrap obj - _free = Proxy :: Proxy "free" - liftEffect $ Ref.modify_ (List.Cons (runEffectMth0 _free jsobj)) freesRef - pure obj - -allocateOpt :: forall r t. Newtype t (UnmanagedObject r) => Effect (Opt t) -> GarbageCollector (Opt t) -allocateOpt alloc = GarbageCollector do - freesRef <- asks _.frees - possibleObj <- liftEffect alloc - case toMaybe possibleObj of - Just obj -> do - let - jsobj = unwrap obj - _free = Proxy :: Proxy "free" - liftEffect $ Ref.modify_ (List.Cons (runEffectMth0 _free jsobj)) freesRef - Nothing -> pure unit - pure possibleObj - -askLib :: GarbageCollector Lib -askLib = GarbageCollector do - asks _.lib - -asksLib :: forall a. (Lib.Props -> a) -> GarbageCollector a -asksLib f = askLib <#> (f <<< Lib.props) - -transactionWitnessSetFromBytes :: Cbor TransactionWitnessSetObject -> GarbageCollector TransactionWitnessSetObject -transactionWitnessSetFromBytes twCbor = do - { "TransactionWitnessSet": tws } <- GarbageCollector $ asks (Lib.props <<< _.lib) - allocate $ Transaction.transactionWitnessSet.from_bytes tws twCbor - -type ValueMap = Map String (Map String BigInt.Argonaut.BigInt) - -valueFromCbor :: Cbor ValueObject -> GarbageCollector ValueMap -valueFromCbor cbor = do - textDecoder <- liftEffect $ TextDecoder.new utf8 - { "Value": valueClass } <- GarbageCollector $ asks (Lib.props <<< _.lib) - valObj <- allocate $ value.from_bytes valueClass cbor - possibleMultiAssetObj <- allocateOpt $ valueObject.multiasset valObj - case toMaybe possibleMultiAssetObj of - Nothing -> pure Map.empty - Just multiAssetObj -> do - scriptHashesObj <- allocate $ multiAssetObject.keys multiAssetObj - len <- liftEffect $ scriptHashesObject.len scriptHashesObj - Map.fromFoldable <$> forWithIndex (Array.replicate len unit) \idx _ -> do - scriptHashObj <- allocate $ scriptHashesObject.get scriptHashesObj idx - hex <- liftEffect $ scriptHashObject.to_hex scriptHashObj - let - policyId = (hexToString <<< cborHexToHex $ hex) - possibleAssets <- allocateOpt $ multiAssetObject.get multiAssetObj scriptHashObj - case toMaybe possibleAssets of - Nothing -> pure $ policyId /\ Map.empty - Just assetsObj -> do - assetNamesObj <- allocate $ assetsObject.keys assetsObj - assetNamesLen <- liftEffect $ assetNamesObject.len assetNamesObj - ((policyId /\ _) <<< Map.fromFoldable) <$> forWithIndex (Array.replicate assetNamesLen unit) \idx' _ -> do - assetNameObj <- allocate $ assetNamesObject.get assetNamesObj idx' - nameUint8Array <- liftEffect $ assetNameObject.name assetNameObj - assetName <- liftEffect $ TextDecoder.decode nameUint8Array textDecoder - - bigNumObj <- allocate $ multiAssetObject.get_asset multiAssetObj scriptHashObj assetNameObj - numStr <- liftEffect $ bigNumObject.to_str bigNumObj - case BigInt.Argonaut.fromString numStr of - Nothing -> liftEffect $ throwError $ Effect.Exception.error $ "CardanoMultiplatformLib.valueFromCbor: Failed to parse BigInt: " <> numStr - Just num -> pure $ assetName /\ num - -bech32FromCbor :: Cbor AddressObject -> Opt String -> GarbageCollector Bech32 -bech32FromCbor cbor prefix = do - { "Address": addrClass } <- GarbageCollector $ asks (Lib.props <<< _.lib) - addrObject <- allocate $ Address.address.from_bytes addrClass cbor - liftEffect $ addressObject.to_bech32 addrObject prefix - -bech32FromCborHex :: CborHex AddressObject -> Opt String -> GarbageCollector Bech32 -bech32FromCborHex cborHex prefix = do - let - cbor = cborHexToCbor cborHex - bech32FromCbor cbor prefix - -bech32FromString :: Lib -> String -> Effect (Maybe Bech32) -bech32FromString lib addrStr = do - let - { "Address": addressClass } = Lib.props lib - Address.address.is_valid_bech32 addressClass addrStr >>= - if _ then - pure $ Just $ unsafeBech32 addrStr - else - pure Nothing diff --git a/src/Contrib/CardanoMultiplatformLib/Address.purs b/src/Contrib/CardanoMultiplatformLib/Address.purs deleted file mode 100644 index 1c9624fa..00000000 --- a/src/Contrib/CardanoMultiplatformLib/Address.purs +++ /dev/null @@ -1,253 +0,0 @@ -module CardanoMultiplatformLib.Address where - -import Prelude - -import CardanoMultiplatformLib.Types (Bech32, Cbor) -import Data.Argonaut (Json) -import Data.Newtype (class Newtype) -import Data.Undefined.NoProblem (Opt) -import Effect (Effect) -import JS.Object (EffectMth0, EffectMth1, EffectMth2, JSObject) -import JS.Object.Generic (mkNewtypedFFI) -import Type.Prelude (Proxy(..)) - --- export class Address { --- free(): void; --- /** --- * @param {Uint8Array} data --- * @returns {Address} --- */ --- static from_bytes(data: Uint8Array): Address; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {AddressJSON} --- */ --- to_js_value(): AddressJSON; --- /** --- * @param {string} json --- * @returns {Address} --- */ --- static from_json(json: string): Address; --- /** --- * header has 4 bits addr type discrim then 4 bits network discrim. --- * Copied from shelley.cddl: --- * --- * base address --- * bits 7-6: 00 --- * bit 5: stake cred is keyhash/scripthash --- * bit 4: payment cred is keyhash/scripthash --- * bits 3-0: network id --- * --- * pointer address --- * bits 7-5: 010 --- * bit 4: payment cred is keyhash/scripthash --- * bits 3-0: network id --- * --- * enterprise address --- * bits 7-5: 010 --- * bit 4: payment cred is keyhash/scripthash --- * bits 3-0: network id --- * --- * reward addresses: --- * bits 7-5: 111 --- * bit 4: credential is keyhash/scripthash --- * bits 3-0: network id --- * --- * byron addresses: --- * bits 7-4: 1000 --- * bits 3-0: unrelated data (recall: no network ID in Byron addresses) --- * @returns {number} --- */ --- header(): number; --- /** --- * @param {number} header --- * @param {number} kind --- * @returns {boolean} --- */ --- static header_matches_kind(header: number, kind: number): boolean; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {string | undefined} prefix --- * @returns {string} --- */ --- to_bech32(prefix?: string): string; --- /** --- * @param {string} bech_str --- * @returns {Address} --- */ --- static from_bech32(bech_str: string): Address; --- /** --- * --- * * Note: bech32-encoded Byron addresses will also pass validation here --- * --- * @param {string} bech_str --- * @returns {boolean} --- */ --- static is_valid_bech32(bech_str: string): boolean; --- /** --- * @param {string} base58 --- * @returns {boolean} --- */ --- static is_valid_byron(base58: string): boolean; --- /** --- * @param {string} bech_str --- * @returns {boolean} --- */ --- static is_valid(bech_str: string): boolean; --- /** --- * @returns {number} --- */ --- network_id(): number; --- /** --- * @returns {ByronAddress | undefined} --- */ --- as_byron(): ByronAddress | undefined; --- /** --- * @returns {RewardAddress | undefined} --- */ --- as_reward(): RewardAddress | undefined; --- /** --- * @returns {PointerAddress | undefined} --- */ --- as_pointer(): PointerAddress | undefined; --- /** --- * @returns {EnterpriseAddress | undefined} --- */ --- as_enterprise(): EnterpriseAddress | undefined; --- /** --- * @returns {BaseAddress | undefined} --- */ --- as_base(): BaseAddress | undefined; --- /** --- * Note: by convention, the key inside reward addresses are considered payment credentials --- * @returns {StakeCredential | undefined} --- */ --- payment_cred(): StakeCredential | undefined; --- /** --- * Note: by convention, the key inside reward addresses are NOT considered staking credentials --- * Note: None is returned pointer addresses as the chain history is required to resolve its associated cred --- * @returns {StakeCredential | undefined} --- */ --- staking_cred(): StakeCredential | undefined; --- } - -newtype Address = Address - ( JSObject - ( from_bytes :: EffectMth1 (Cbor AddressObject) AddressObject - , from_json :: EffectMth1 String AddressObject - , from_bech32 :: EffectMth1 String AddressObject - , header_matches_kind :: EffectMth2 Number Number Boolean - , is_valid_bech32 :: EffectMth1 String Boolean - , is_valid_byron :: EffectMth1 String Boolean - , is_valid :: EffectMth1 String Boolean - ) - ) - -derive instance Newtype Address _ - -address - :: { from_bytes :: Address -> (Cbor AddressObject) -> Effect AddressObject - , from_json :: Address -> String -> Effect AddressObject - , from_bech32 :: Address -> String -> Effect AddressObject - , header_matches_kind :: Address -> Number -> Number -> Effect Boolean - , is_valid_bech32 :: Address -> String -> Effect Boolean - , is_valid_byron :: Address -> String -> Effect Boolean - , is_valid :: Address -> String -> Effect Boolean - } -address = mkNewtypedFFI (Proxy :: Proxy Address) - -newtype AddressObject = AddressObject - ( JSObject - ( free :: EffectMth0 Unit - , to_json :: EffectMth0 String - , to_js_value :: EffectMth0 Json -- AddressJSON - , header :: EffectMth0 Number - , to_bytes :: EffectMth0 (Cbor AddressObject) - , to_bech32 :: EffectMth1 (Opt String) Bech32 - , network_id :: EffectMth0 Number - -- , as_byron :: EffectMth0 (Maybe ByronAddressObject) - -- , as_reward :: EffectMth0 (Maybe RewardAddressObject) - -- , as_pointer :: EffectMth0 (Maybe PointerAddressObject) - -- , as_enterprise :: EffectMth0 (Maybe EnterpriseAddressObject) - -- , as_base :: EffectMth0 (Maybe BaseAddressObject) - -- , payment_cred :: EffectMth0 (Maybe StakeCredentialObject) - -- , staking_cred :: EffectMth0 (Maybe StakeCredentialObject) - ) - ) - -derive instance Newtype AddressObject _ - -addressObject - :: { free :: AddressObject -> Effect Unit - , to_json :: AddressObject -> Effect String - , to_js_value :: AddressObject -> Effect Json -- AddressJSON - , header :: AddressObject -> Effect Number - , to_bytes :: AddressObject -> Effect (Cbor AddressObject) - , to_bech32 :: AddressObject -> Opt String -> Effect Bech32 - , network_id :: AddressObject -> Effect Number - -- , as_byron :: AddressObject -> EffectMth0 (Maybe ByronAddressObject) - -- , as_reward :: AddressObject -> EffectMth0 (Maybe RewardAddressObject) - -- , as_pointer :: AddressObject -> EffectMth0 (Maybe PointerAddressObject) - -- , as_enterprise :: AddressObject -> EffectMth0 (Maybe EnterpriseAddressObject) - -- , as_base :: AddressObject -> EffectMth0 (Maybe BaseAddressObject) - -- , payment_cred :: AddressObject -> EffectMth0 (Maybe StakeCredentialObject) - -- , staking_cred :: AddressObject -> EffectMth0 (Maybe StakeCredentialObject) - } -addressObject = mkNewtypedFFI (Proxy :: Proxy AddressObject) - --- foreign import data Address :: Type --- --- -- | We allocate the `Address` in the memory. If we don't `free` it up then --- -- | we gonna leak memory. --- foreign import fromBytesImpl :: EffectFn2 Lib Uint8Array Address --- --- fromBytes :: Lib -> Uint8Array -> Effect Address --- fromBytes lib bytes = runEffectFn2 fromBytesImpl lib bytes --- --- foreign import fromBech32Impl :: EffectFn2 Lib String Address --- --- fromBech32 :: Lib -> Bech32 -> Effect Address --- fromBech32 lib (Bech32 bech32) = runEffectFn2 fromBech32Impl lib bech32 --- --- newtype Bech32 = Bech32 String --- --- bech32ToString :: Bech32 -> String --- bech32ToString (Bech32 str) = str --- --- foreign import toBech32Impl :: EffectFn1 Address Bech32 --- --- toBech32 :: Address -> Effect Bech32 --- toBech32 = runEffectFn1 toBech32Impl --- --- foreign import toJsonImpl :: EffectFn1 Address Json --- --- toJson :: Address -> Effect Json --- toJson = runEffectFn1 toJsonImpl --- --- foreign import freeImpl :: EffectFn1 Address Unit --- --- free :: Address -> Effect Unit --- free = runEffectFn1 freeImpl - --- bech32FromBytes :: Lib -> Uint8Array -> Effect (Maybe Bech32) --- bech32FromBytes lib bytes = do --- let --- go = Effect.bracket (fromBytes lib bytes) free \addr -> --- toBech32 addr --- (Just <$> go) `catchError` (const $ pure Nothing) --- --- bech32FromHex :: Lib -> String -> Effect (Maybe Bech32) --- bech32FromHex lib str = case HexString.hex str <#> HexString.decode of --- Just bytes -> bech32FromBytes lib bytes --- Nothing -> pure Nothing --- --- foreign import isValidBech32Impl :: EffectFn2 Lib String Boolean --- isValidBech32 :: Lib -> String -> Effect Boolean --- isValidBech32 lib str = runEffectFn2 isValidBech32Impl lib str - diff --git a/src/Contrib/CardanoMultiplatformLib/Lib.purs b/src/Contrib/CardanoMultiplatformLib/Lib.purs deleted file mode 100644 index 4ea0d879..00000000 --- a/src/Contrib/CardanoMultiplatformLib/Lib.purs +++ /dev/null @@ -1,30 +0,0 @@ -module CardanoMultiplatformLib.Lib - ( props - , Lib - , Props - ) where - -import CardanoMultiplatformLib.Address as Address -import CardanoMultiplatformLib.Transaction as Transaction - -type Props = - { "Address" :: Address.Address - , "Value" :: Transaction.Value - , "Transaction" :: Transaction.Transaction - , "TransactionWitnessSet" :: Transaction.TransactionWitnessSet - , "TransactionBody" :: Transaction.TransactionBody - , "TransactionUnspentOutput" :: Transaction.TransactionUnspentOutput - } - -newtype Lib = Lib - { "Address" :: Address.Address - , "Value" :: Transaction.Value - , "Transaction" :: Transaction.Transaction - , "TransactionWitnessSet" :: Transaction.TransactionWitnessSet - , "TransactionBody" :: Transaction.TransactionBody - , "TransactionUnspentOutput" :: Transaction.TransactionUnspentOutput - } - -props :: Lib -> Props -props (Lib r) = r - diff --git a/src/Contrib/CardanoMultiplatformLib/Transaction.purs b/src/Contrib/CardanoMultiplatformLib/Transaction.purs deleted file mode 100644 index 64aaee55..00000000 --- a/src/Contrib/CardanoMultiplatformLib/Transaction.purs +++ /dev/null @@ -1,1349 +0,0 @@ -module CardanoMultiplatformLib.Transaction where - -import Prelude - -import CardanoMultiplatformLib.Address (AddressObject) -import CardanoMultiplatformLib.Types (Bech32, Cbor, CborHex, JsonString) -import Data.Argonaut (Json) -import Data.ArrayBuffer.Types (Uint8Array) -import Data.Newtype (class Newtype) -import Data.Undefined.NoProblem (Opt) -import Effect (Effect) -import JS.Object (EffectMth0, EffectMth1, EffectMth2, EffectMth3, JSObject) -import JS.Object.Generic (mkNewtypedFFI) -import Type.Prelude (Proxy(..)) - --- export class Transaction { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {Transaction} --- */ --- static from_bytes(bytes: Uint8Array): Transaction; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {TransactionJSON} --- */ --- to_js_value(): TransactionJSON; --- /** --- * @param {string} json --- * @returns {Transaction} --- */ --- static from_json(json: string): Transaction; --- /** --- * @returns {TransactionBody} --- */ --- body(): TransactionBody; --- /** --- * @returns {TransactionWitnessSet} --- */ --- witness_set(): TransactionWitnessSet; --- /** --- * @returns {boolean} --- */ --- is_valid(): boolean; --- /** --- * @returns {AuxiliaryData | undefined} --- */ --- auxiliary_data(): AuxiliaryData | undefined; --- /** --- * @param {boolean} valid --- */ --- set_is_valid(valid: boolean): void; --- /** --- * @param {TransactionBody} body --- * @param {TransactionWitnessSet} witness_set --- * @param {AuxiliaryData | undefined} auxiliary_data --- * @returns {Transaction} --- */ --- static new(body: TransactionBody, witness_set: TransactionWitnessSet, auxiliary_data?: AuxiliaryData): Transaction; --- } - -newtype AuxiliaryData = AuxiliaryData (JSObject ()) - -derive instance Newtype AuxiliaryData _ - -newtype Transaction = Transaction - ( JSObject - ( from_bytes :: EffectMth1 (Cbor TransactionObject) TransactionObject - , from_json :: EffectMth1 JsonString TransactionObject - , new :: EffectMth3 TransactionBodyObject TransactionWitnessSetObject (Opt AuxiliaryData) TransactionObject - ) - ) - -derive instance Newtype Transaction _ - -transaction - :: { from_bytes :: Transaction -> Cbor TransactionObject -> Effect TransactionObject - , from_json :: Transaction -> JsonString -> Effect TransactionObject - , new :: Transaction -> TransactionBodyObject -> TransactionWitnessSetObject -> Opt AuxiliaryData -> Effect TransactionObject - } -transaction = mkNewtypedFFI (Proxy :: Proxy Transaction) - -newtype TransactionObject = TransactionObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 (Cbor TransactionObject) - , to_json :: EffectMth0 JsonString - , auxiliary_data :: EffectMth0 (Opt AuxiliaryData) - -- | Clone the tx body - , body :: EffectMth0 TransactionBodyObject - ) - ) - -derive instance Newtype TransactionObject _ - -transactionObject - :: { free :: TransactionObject -> Effect Unit - , to_bytes :: TransactionObject -> Effect (Cbor TransactionObject) - , to_json :: TransactionObject -> Effect JsonString - , auxiliary_data :: TransactionObject -> Effect (Opt AuxiliaryData) - , body :: TransactionObject -> Effect TransactionBodyObject - } -transactionObject = mkNewtypedFFI (Proxy :: Proxy TransactionObject) - --- export class TransactionBody { --- free(): void; --- to_bytes(): Uint8Array; --- --- static from_bytes(bytes: Uint8Array): TransactionBody; --- --- to_js_value(): TransactionBodyJSON; --- --- static from_json(json: string): TransactionBody; --- --- inputs(): TransactionInputs; --- --- outputs(): TransactionOutputs; --- --- fee(): BigNum; --- --- ttl(): BigNum | undefined; --- --- set_certs(certs: Certificates): void; --- --- certs(): Certificates | undefined; --- --- set_withdrawals(withdrawals: Withdrawals): void; --- --- withdrawals(): Withdrawals | undefined; --- --- set_update(update: Update): void; --- --- update(): Update | undefined; --- --- set_auxiliary_data_hash(auxiliary_data_hash: AuxiliaryDataHash): void; --- --- auxiliary_data_hash(): AuxiliaryDataHash | undefined; --- --- set_validity_start_interval(validity_start_interval: BigNum): void; --- --- validity_start_interval(): BigNum | undefined; --- --- set_mint(mint: Mint): void; --- --- mint(): Mint | undefined; --- --- multiassets(): Mint | undefined; --- --- set_script_data_hash(script_data_hash: ScriptDataHash): void; --- --- script_data_hash(): ScriptDataHash | undefined; --- --- set_collateral(collateral: TransactionInputs): void; --- --- collateral(): TransactionInputs | undefined; --- --- set_required_signers(required_signers: Ed25519KeyHashes): void; --- --- required_signers(): Ed25519KeyHashes | undefined; --- --- set_network_id(network_id: NetworkId): void; --- --- network_id(): NetworkId | undefined; --- --- set_collateral_return(collateral_return: TransactionOutput): void; --- --- collateral_return(): TransactionOutput | undefined; --- --- set_total_collateral(total_collateral: BigNum): void; --- --- total_collateral(): BigNum | undefined; --- --- set_reference_inputs(reference_inputs: TransactionInputs): void; --- --- reference_inputs(): TransactionInputs | undefined; --- --- static new(inputs: TransactionInputs, outputs: TransactionOutputs, fee: BigNum, ttl?: BigNum): TransactionBody; --- } - -newtype TransactionBody = TransactionBody - ( JSObject - ( from_bytes :: EffectMth1 Uint8Array TransactionBodyObject - , from_json :: EffectMth1 JsonString TransactionBodyObject - ) - ) - -derive instance Newtype TransactionBody _ - -transactionBody - :: { from_bytes :: TransactionBody -> Uint8Array -> Effect TransactionBodyObject - , from_json :: TransactionBody -> JsonString -> Effect TransactionBodyObject - } -transactionBody = mkNewtypedFFI (Proxy :: Proxy TransactionBody) - -newtype TransactionBodyObject = TransactionBodyObject - ( JSObject - ( free :: EffectMth0 Unit - , to_js_value :: EffectMth0 Json -- TransactionBodyJSON - ) - ) - -derive instance Newtype TransactionBodyObject _ - -transactionBodyObject - :: { free :: TransactionBodyObject -> Effect Unit - , to_js_value :: TransactionBodyObject -> Effect Json - } -transactionBodyObject = mkNewtypedFFI (Proxy :: Proxy TransactionBodyObject) - --- export class TransactionWitnessSet { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {TransactionWitnessSet} --- */ --- static from_bytes(bytes: Uint8Array): TransactionWitnessSet; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {TransactionWitnessSetJSON} --- */ --- to_js_value(): TransactionWitnessSetJSON; --- /** --- * @param {string} json --- * @returns {TransactionWitnessSet} --- */ --- static from_json(json: string): TransactionWitnessSet; --- /** --- * @param {Vkeywitnesses} vkeys --- */ --- set_vkeys(vkeys: Vkeywitnesses): void; --- /** --- * @returns {Vkeywitnesses | undefined} --- */ --- vkeys(): Vkeywitnesses | undefined; --- /** --- * @param {NativeScripts} native_scripts --- */ --- set_native_scripts(native_scripts: NativeScripts): void; --- /** --- * @returns {NativeScripts | undefined} --- */ --- native_scripts(): NativeScripts | undefined; --- /** --- * @param {BootstrapWitnesses} bootstraps --- */ --- set_bootstraps(bootstraps: BootstrapWitnesses): void; --- /** --- * @returns {BootstrapWitnesses | undefined} --- */ --- bootstraps(): BootstrapWitnesses | undefined; --- /** --- * @param {PlutusV1Scripts} plutus_v1_scripts --- */ --- set_plutus_v1_scripts(plutus_v1_scripts: PlutusV1Scripts): void; --- /** --- * @returns {PlutusV1Scripts | undefined} --- */ --- plutus_v1_scripts(): PlutusV1Scripts | undefined; --- /** --- * @param {PlutusList} plutus_data --- */ --- set_plutus_data(plutus_data: PlutusList): void; --- /** --- * @returns {PlutusList | undefined} --- */ --- plutus_data(): PlutusList | undefined; --- /** --- * @param {Redeemers} redeemers --- */ --- set_redeemers(redeemers: Redeemers): void; --- /** --- * @returns {Redeemers | undefined} --- */ --- redeemers(): Redeemers | undefined; --- /** --- * @param {PlutusV2Scripts} plutus_v2_scripts --- */ --- set_plutus_v2_scripts(plutus_v2_scripts: PlutusV2Scripts): void; --- /** --- * @returns {PlutusV2Scripts | undefined} --- */ --- plutus_v2_scripts(): PlutusV2Scripts | undefined; --- /** --- * @returns {TransactionWitnessSet} --- */ --- static new(): TransactionWitnessSet; --- } - -newtype TransactionWitnessSet = TransactionWitnessSet - ( JSObject - ( from_bytes :: EffectMth1 (Cbor TransactionWitnessSetObject) TransactionWitnessSetObject - , from_json :: EffectMth1 JsonString TransactionWitnessSetObject - ) - ) - -derive instance Newtype TransactionWitnessSet _ - -transactionWitnessSet - :: { from_bytes :: TransactionWitnessSet -> (Cbor TransactionWitnessSetObject) -> Effect TransactionWitnessSetObject - , from_json :: TransactionWitnessSet -> JsonString -> Effect TransactionWitnessSetObject - } -transactionWitnessSet = mkNewtypedFFI (Proxy :: Proxy TransactionWitnessSet) - -newtype TransactionWitnessSetObject = TransactionWitnessSetObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 Uint8Array - , to_json :: EffectMth0 JsonString - , to_js_value :: EffectMth0 Json -- TransactionWitnessSetJSON - -- , set_vkeys :: Vkeywitnesses -> Effect Unit - -- , vkeys :: Effect (Maybe Vkeywitnesses) - -- , set_native_scripts :: NativeScripts -> Effect Unit - -- , native_scripts :: Effect (Maybe NativeScripts) - -- , set_bootstraps :: BootstrapWitnesses -> Effect Unit - -- , bootstraps :: Effect (Maybe BootstrapWitnesses) - -- , set_plutus_v1_scripts :: PlutusV1Scripts -> Effect Unit - -- , plutus_v1_scripts :: Effect (Maybe PlutusV1Scripts) - -- , set_plutus_data :: PlutusList -> Effect Unit - -- , plutus_data :: Effect (Maybe PlutusList) - ) - ) - -derive instance Newtype TransactionWitnessSetObject _ - -transactionWitnessSetObject - :: { free :: TransactionWitnessSetObject -> Effect Unit - , to_bytes :: TransactionWitnessSetObject -> Effect Uint8Array - , to_json :: TransactionWitnessSetObject -> Effect JsonString - , to_js_value :: TransactionWitnessSetObject -> Effect Json - } -transactionWitnessSetObject = mkNewtypedFFI (Proxy :: Proxy TransactionWitnessSetObject) - --- export class Value { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {Value} --- */ --- static from_bytes(bytes: Uint8Array): Value; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {ValueJSON} --- */ --- to_js_value(): ValueJSON; --- /** --- * @param {string} json --- * @returns {Value} --- */ --- static from_json(json: string): Value; --- /** --- * @param {BigNum} coin --- * @returns {Value} --- */ --- static new(coin: BigNum): Value; --- /** --- * @param {MultiAsset} multiasset --- * @returns {Value} --- */ --- static new_from_assets(multiasset: MultiAsset): Value; --- /** --- * @returns {Value} --- */ --- static zero(): Value; --- /** --- * @returns {boolean} --- */ --- is_zero(): boolean; --- /** --- * @returns {BigNum} --- */ --- coin(): BigNum; --- /** --- * @param {BigNum} coin --- */ --- set_coin(coin: BigNum): void; --- /** --- * @returns {MultiAsset | undefined} --- */ --- multiasset(): MultiAsset | undefined; --- /** --- * @param {MultiAsset} multiasset --- */ --- set_multiasset(multiasset: MultiAsset): void; --- /** --- * @param {Value} rhs --- * @returns {Value} --- */ --- checked_add(rhs: Value): Value; --- /** --- * @param {Value} rhs_value --- * @returns {Value} --- */ --- checked_sub(rhs_value: Value): Value; --- /** --- * @param {Value} rhs_value --- * @returns {Value} --- */ --- clamped_sub(rhs_value: Value): Value; --- /** --- * note: values are only partially comparable --- * @param {Value} rhs_value --- * @returns {number | undefined} --- */ --- compare(rhs_value: Value): number | undefined; --- } - -newtype Value = Value - (JSObject - ( from_bytes :: EffectMth1 (Cbor ValueObject) ValueObject - , from_json :: EffectMth1 JsonString ValueObject - , new_from_assets :: EffectMth1 MultiAssetObject ValueObject - -- , new :: EffectMth1 BigNum Value - ) - ) - -derive instance Newtype Value _ - -value - :: { from_bytes :: Value -> (Cbor ValueObject) -> Effect ValueObject - , from_json :: Value -> JsonString -> Effect ValueObject - , new_from_assets :: Value -> MultiAssetObject -> Effect ValueObject - -- , new :: BigNum -> Effect Value - } -value = mkNewtypedFFI (Proxy :: Proxy Value) - -newtype ValueObject = ValueObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 (Cbor ValueObject) - , to_json :: EffectMth0 JsonString - , to_js_value :: EffectMth0 Json - , is_zero :: EffectMth0 Boolean - , coin :: EffectMth0 BigNum - , set_coin :: EffectMth1 BigNum Unit - , multiasset :: EffectMth0 (Opt MultiAssetObject) - , set_multiasset :: EffectMth1 MultiAssetObject Unit - , checked_add :: EffectMth1 ValueObject ValueObject - , checked_sub :: EffectMth1 ValueObject ValueObject - , clamped_sub :: EffectMth1 ValueObject ValueObject - , compare :: EffectMth1 ValueObject (Opt Int) - ) - ) - -derive instance Newtype ValueObject _ - -valueObject - :: { free :: ValueObject -> Effect Unit - , to_bytes :: ValueObject -> Effect (Cbor ValueObject) - , to_json :: ValueObject -> Effect JsonString - , to_js_value :: ValueObject -> Effect Json - , is_zero :: ValueObject -> Effect Boolean - , coin :: ValueObject -> Effect BigNum - , set_coin :: ValueObject -> BigNum -> Effect Unit - , multiasset :: ValueObject -> Effect (Opt MultiAssetObject) - , set_multiasset :: ValueObject -> MultiAssetObject -> Effect Unit - , checked_add :: ValueObject -> ValueObject -> Effect ValueObject - , checked_sub :: ValueObject -> ValueObject -> Effect ValueObject - , clamped_sub :: ValueObject -> ValueObject -> Effect ValueObject - , compare :: ValueObject -> ValueObject -> Effect (Opt Int) - } -valueObject = mkNewtypedFFI (Proxy :: Proxy ValueObject) - --- export class MultiAsset { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {MultiAsset} --- */ --- static from_bytes(bytes: Uint8Array): MultiAsset; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {MultiAssetJSON} --- */ --- to_js_value(): MultiAssetJSON; --- /** --- * @param {string} json --- * @returns {MultiAsset} --- */ --- static from_json(json: string): MultiAsset; --- /** --- * @returns {MultiAsset} --- */ --- static new(): MultiAsset; --- /** --- * the number of unique policy IDs in the multiasset --- * @returns {number} --- */ --- len(): number; --- /** --- * set (and replace if it exists) all assets with policy {policy_id} to a copy of {assets} --- * @param {ScriptHash} policy_id --- * @param {Assets} assets --- * @returns {Assets | undefined} --- */ --- insert(policy_id: ScriptHash, assets: Assets): Assets | undefined; --- /** --- * all assets under {policy_id}, if any exist, or else None (undefined in JS) --- * @param {ScriptHash} policy_id --- * @returns {Assets | undefined} --- */ --- get(policy_id: ScriptHash): Assets | undefined; --- /** --- * sets the asset {asset_name} to {value} under policy {policy_id} --- * returns the previous amount if it was set, or else None (undefined in JS) --- * @param {ScriptHash} policy_id --- * @param {AssetName} asset_name --- * @param {BigNum} value --- * @returns {BigNum | undefined} --- */ --- set_asset(policy_id: ScriptHash, asset_name: AssetName, value: BigNum): BigNum | undefined; --- /** --- * returns the amount of asset {asset_name} under policy {policy_id} --- * If such an asset does not exist, 0 is returned. --- * @param {ScriptHash} policy_id --- * @param {AssetName} asset_name --- * @returns {BigNum} --- */ --- get_asset(policy_id: ScriptHash, asset_name: AssetName): BigNum; --- /** --- * returns all policy IDs used by assets in this multiasset --- * @returns {ScriptHashes} --- */ --- keys(): ScriptHashes; --- /** --- * removes an asset from the list if the result is 0 or less --- * does not modify this object, instead the result is returned --- * @param {MultiAsset} rhs_ma --- * @returns {MultiAsset} --- */ --- sub(rhs_ma: MultiAsset): MultiAsset; --- } - -newtype MultiAsset = MultiAsset - ( JSObject - ( from_bytes :: EffectMth1 (Cbor MultiAsset) MultiAssetObject - , from_json :: EffectMth1 JsonString MultiAssetObject - , new :: EffectMth0 MultiAssetObject - ) - ) - -derive instance Newtype MultiAsset _ - -multiAsset - :: { from_bytes :: MultiAsset -> Cbor MultiAsset -> Effect MultiAssetObject - , from_json :: MultiAsset -> JsonString -> Effect MultiAssetObject - , new :: MultiAsset -> Effect MultiAssetObject - } -multiAsset = mkNewtypedFFI (Proxy :: Proxy MultiAsset) - -newtype MultiAssetObject = MultiAssetObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 (Cbor MultiAssetObject) - , to_json :: EffectMth0 JsonString - , to_js_value :: EffectMth0 Json - , len :: EffectMth0 Int - , insert :: EffectMth2 ScriptHashObject AssetsObject (Opt AssetsObject) - , get :: EffectMth1 ScriptHashObject (Opt AssetsObject) - , set_asset :: EffectMth3 ScriptHashObject AssetNameObject BigNumObject (Opt BigNumObject) - , get_asset :: EffectMth2 ScriptHashObject AssetNameObject BigNumObject - , keys :: EffectMth0 ScriptHashesObject - , sub :: EffectMth1 MultiAssetObject MultiAssetObject - ) - ) - -derive instance Newtype MultiAssetObject _ - -multiAssetObject - :: { free :: MultiAssetObject -> Effect Unit - , to_bytes :: MultiAssetObject -> Effect (Cbor MultiAssetObject) - , to_json :: MultiAssetObject -> Effect JsonString - , to_js_value :: MultiAssetObject -> Effect Json - , len :: MultiAssetObject -> Effect Int - , insert :: MultiAssetObject -> ScriptHashObject -> AssetsObject -> Effect (Opt AssetsObject) - , get :: MultiAssetObject -> ScriptHashObject -> Effect (Opt AssetsObject) - , set_asset :: MultiAssetObject -> ScriptHashObject -> AssetNameObject -> BigNumObject -> Effect (Opt BigNumObject) - , get_asset :: MultiAssetObject -> ScriptHashObject -> AssetNameObject -> Effect BigNumObject - , keys :: MultiAssetObject -> Effect ScriptHashesObject - , sub :: MultiAssetObject -> MultiAssetObject -> Effect MultiAssetObject - } -multiAssetObject = mkNewtypedFFI (Proxy :: Proxy MultiAssetObject) - --- export class ScriptHash { --- free(): void; --- /** --- * @param {Uint8Array} bytes --- * @returns {ScriptHash} --- */ --- static from_bytes(bytes: Uint8Array): ScriptHash; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {string} prefix --- * @returns {string} --- */ --- to_bech32(prefix: string): string; --- /** --- * @param {string} bech_str --- * @returns {ScriptHash} --- */ --- static from_bech32(bech_str: string): ScriptHash; --- /** --- * @returns {string} --- */ --- to_hex(): string; --- /** --- * @param {string} hex --- * @returns {ScriptHash} --- */ --- static from_hex(hex: string): ScriptHash; --- } - -newtype ScriptHash = ScriptHash - ( JSObject - ( from_bytes :: EffectMth1 (Cbor ScriptHashObject) ScriptHashObject - , from_bech32 :: EffectMth1 Bech32 ScriptHashObject - , from_hex :: EffectMth1 (CborHex ScriptHashObject) ScriptHashObject - ) - ) - -derive instance Newtype ScriptHash _ - -scriptHash - :: { from_bytes :: ScriptHash -> Cbor ScriptHashObject -> Effect ScriptHashObject - , from_bech32 :: ScriptHash -> Bech32 -> Effect ScriptHashObject - , from_hex :: ScriptHash -> CborHex ScriptHashObject -> Effect ScriptHashObject - } -scriptHash = mkNewtypedFFI (Proxy :: Proxy ScriptHash) - -newtype ScriptHashObject = ScriptHashObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 (Cbor ScriptHashObject) - , to_bech32 :: EffectMth1 Bech32 String - , to_hex :: EffectMth0 (CborHex ScriptHashObject) - ) - ) - -derive instance Newtype ScriptHashObject _ - -scriptHashObject - :: { free :: ScriptHashObject -> Effect Unit - , to_bytes :: ScriptHashObject -> Effect (Cbor ScriptHashObject) - , to_bech32 :: ScriptHashObject -> Bech32 -> Effect String - , to_hex :: ScriptHashObject -> Effect (CborHex ScriptHashObject) - } -scriptHashObject = mkNewtypedFFI (Proxy :: Proxy ScriptHashObject) - --- export class ScriptHashes { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {ScriptHashes} --- */ --- static from_bytes(bytes: Uint8Array): ScriptHashes; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {ScriptHashesJSON} --- */ --- to_js_value(): ScriptHashesJSON; --- /** --- * @param {string} json --- * @returns {ScriptHashes} --- */ --- static from_json(json: string): ScriptHashes; --- /** --- * @returns {ScriptHashes} --- */ --- static new(): ScriptHashes; --- /** --- * @returns {number} --- */ --- len(): number; --- /** --- * @param {number} index --- * @returns {ScriptHash} --- */ --- get(index: number): ScriptHash; --- /** --- * @param {ScriptHash} elem --- */ --- add(elem: ScriptHash): void; --- } - -newtype ScriptHashes = ScriptHashes - ( JSObject - ( from_bytes :: EffectMth1 (Cbor ScriptHashesObject) ScriptHashesObject - , from_json :: EffectMth1 JsonString ScriptHashesObject - , new :: EffectMth0 ScriptHashesObject - ) - ) - -derive instance Newtype ScriptHashes _ - -scriptHashes - :: { from_bytes :: ScriptHashes -> Cbor ScriptHashesObject -> Effect ScriptHashesObject - , from_json :: ScriptHashes -> JsonString -> Effect ScriptHashesObject - , new :: ScriptHashes -> Effect ScriptHashesObject - } -scriptHashes = mkNewtypedFFI (Proxy :: Proxy ScriptHashes) - -newtype ScriptHashesObject = ScriptHashesObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 (Cbor ScriptHashesObject) - , to_json :: EffectMth0 JsonString - , to_js_value :: EffectMth0 Json - , len :: EffectMth0 Int - , get :: EffectMth1 Int ScriptHashObject - , add :: EffectMth1 ScriptHashObject Unit - ) - ) - -derive instance Newtype ScriptHashesObject _ - -scriptHashesObject - :: { free :: ScriptHashesObject -> Effect Unit - , to_bytes :: ScriptHashesObject -> Effect (Cbor ScriptHashesObject) - , to_json :: ScriptHashesObject -> Effect JsonString - , to_js_value :: ScriptHashesObject -> Effect Json - , len :: ScriptHashesObject -> Effect Int - , get :: ScriptHashesObject -> Int -> Effect ScriptHashObject - , add :: ScriptHashesObject -> ScriptHashObject -> Effect Unit - } -scriptHashesObject = mkNewtypedFFI (Proxy :: Proxy ScriptHashesObject) - - --- export class Assets { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {Assets} --- */ --- static from_bytes(bytes: Uint8Array): Assets; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {AssetsJSON} --- */ --- to_js_value(): AssetsJSON; --- /** --- * @param {string} json --- * @returns {Assets} --- */ --- static from_json(json: string): Assets; --- /** --- * @returns {Assets} --- */ --- static new(): Assets; --- /** --- * @returns {number} --- */ --- len(): number; --- /** --- * @param {AssetName} key --- * @param {BigNum} value --- * @returns {BigNum | undefined} --- */ --- insert(key: AssetName, value: BigNum): BigNum | undefined; --- /** --- * @param {AssetName} key --- * @returns {BigNum | undefined} --- */ --- get(key: AssetName): BigNum | undefined; --- /** --- * @returns {AssetNames} --- */ --- keys(): AssetNames; --- } - -newtype Assets = Assets - ( JSObject - ( from_bytes :: EffectMth1 (Cbor AssetsObject) AssetsObject - , from_json :: EffectMth1 JsonString AssetsObject - , new :: EffectMth0 AssetsObject - ) - ) - -derive instance Newtype Assets _ - -assets - :: { from_bytes :: Assets -> Cbor AssetsObject -> Effect AssetsObject - , from_json :: Assets -> JsonString -> Effect AssetsObject - , new :: Assets -> Effect AssetsObject - } -assets = mkNewtypedFFI (Proxy :: Proxy Assets) - -newtype AssetsObject = AssetsObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 (Cbor AssetsObject) - , to_json :: EffectMth0 JsonString - , to_js_value :: EffectMth0 Json - , len :: EffectMth0 Int - , insert :: EffectMth2 AssetNameObject BigNum (Opt BigNum) - , get :: EffectMth1 AssetNameObject (Opt BigNum) - , keys :: EffectMth0 AssetNamesObject - ) - ) - -derive instance Newtype AssetsObject _ - -assetsObject - :: { free :: AssetsObject -> Effect Unit - , to_bytes :: AssetsObject -> Effect (Cbor AssetsObject) - , to_json :: AssetsObject -> Effect JsonString - , to_js_value :: AssetsObject -> Effect Json - , len :: AssetsObject -> Effect Int - , insert :: AssetsObject -> AssetNameObject -> BigNum -> Effect (Opt BigNum) - , get :: AssetsObject -> AssetNameObject -> Effect (Opt BigNum) - , keys :: AssetsObject -> Effect AssetNamesObject - } -assetsObject = mkNewtypedFFI (Proxy :: Proxy AssetsObject) - --- export class AssetName { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {AssetName} --- */ --- static from_bytes(bytes: Uint8Array): AssetName; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {AssetNameJSON} --- */ --- to_js_value(): AssetNameJSON; --- /** --- * @param {string} json --- * @returns {AssetName} --- */ --- static from_json(json: string): AssetName; --- /** --- * @param {Uint8Array} name --- * @returns {AssetName} --- */ --- static new(name: Uint8Array): AssetName; --- /** --- * @returns {Uint8Array} --- */ --- name(): Uint8Array; --- } - -newtype AssetName = AssetName - ( JSObject - ( from_bytes :: EffectMth1 (Cbor AssetNameObject) AssetNameObject - , from_json :: EffectMth1 JsonString AssetNameObject - , new :: EffectMth1 Uint8Array AssetNameObject - ) - ) - -derive instance Newtype AssetName _ - -assetName :: - { from_bytes :: AssetName -> Cbor AssetNameObject -> Effect AssetNameObject - , from_json :: AssetName -> JsonString -> Effect AssetNameObject - , new :: AssetName -> Uint8Array -> Effect AssetNameObject - } -assetName = mkNewtypedFFI (Proxy :: Proxy AssetName) - -newtype AssetNameObject = AssetNameObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 (Cbor AssetNameObject) - , to_json :: EffectMth0 JsonString - , to_js_value :: EffectMth0 Json - , name :: EffectMth0 Uint8Array - ) - ) - -derive instance Newtype AssetNameObject _ - -assetNameObject - :: { free :: AssetNameObject -> Effect Unit - , to_bytes :: AssetNameObject -> Effect (Cbor AssetNameObject) - , to_json :: AssetNameObject -> Effect JsonString - , to_js_value :: AssetNameObject -> Effect Json - , name :: AssetNameObject -> Effect Uint8Array - } -assetNameObject = mkNewtypedFFI (Proxy :: Proxy AssetNameObject) - - --- export class AssetNames { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {AssetNames} --- */ --- static from_bytes(bytes: Uint8Array): AssetNames; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {AssetNamesJSON} --- */ --- to_js_value(): AssetNamesJSON; --- /** --- * @param {string} json --- * @returns {AssetNames} --- */ --- static from_json(json: string): AssetNames; --- /** --- * @returns {AssetNames} --- */ --- static new(): AssetNames; --- /** --- * @returns {number} --- */ --- len(): number; --- /** --- * @param {number} index --- * @returns {AssetName} --- */ --- get(index: number): AssetName; --- /** --- * @param {AssetName} elem --- */ --- add(elem: AssetName): void; --- } - -newtype AssetNames = AssetNames - ( JSObject - ( from_bytes :: EffectMth1 (Cbor AssetNamesObject) AssetNamesObject - , from_json :: EffectMth1 JsonString AssetNamesObject - , new :: EffectMth0 AssetNamesObject - ) - ) - -derive instance Newtype AssetNames _ - -assetNames :: - { from_bytes :: AssetNames -> Cbor AssetNamesObject -> Effect AssetNamesObject - , from_json :: AssetNames -> JsonString -> Effect AssetNamesObject - , new :: AssetNames -> Effect AssetNamesObject - } -assetNames = mkNewtypedFFI (Proxy :: Proxy AssetNames) - -newtype AssetNamesObject = AssetNamesObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 (Cbor AssetNamesObject) - , to_json :: EffectMth0 JsonString - , to_js_value :: EffectMth0 Json - , len :: EffectMth0 Int - , get :: EffectMth1 Int AssetNameObject - , add :: EffectMth1 AssetNameObject Unit - ) - ) - -derive instance Newtype AssetNamesObject _ - -assetNamesObject :: - { free :: AssetNamesObject -> Effect Unit - , to_bytes :: AssetNamesObject -> Effect (Cbor AssetNamesObject) - , to_json :: AssetNamesObject -> Effect JsonString - , to_js_value :: AssetNamesObject -> Effect Json - , len :: AssetNamesObject -> Effect Int - , get :: AssetNamesObject -> Int -> Effect AssetNameObject - , add :: AssetNamesObject -> AssetNameObject -> Effect Unit - } -assetNamesObject = mkNewtypedFFI (Proxy :: Proxy AssetNamesObject) - - --- export class TransactionOutput { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {TransactionOutput} --- */ --- static from_bytes(bytes: Uint8Array): TransactionOutput; --- /** --- * @returns {string} --- */ --- to_json(): string; --- /** --- * @returns {TransactionOutputJSON} --- */ --- to_js_value(): TransactionOutputJSON; --- /** --- * @param {string} json --- * @returns {TransactionOutput} --- */ --- static from_json(json: string): TransactionOutput; --- /** --- * @returns {Address} --- */ --- address(): Address; --- /** --- * @returns {Value} --- */ --- amount(): Value; --- /** --- * @returns {Datum | undefined} --- */ --- datum(): Datum | undefined; --- /** --- * @param {Datum} data --- */ --- set_datum(data: Datum): void; --- /** --- * @returns {ScriptRef | undefined} --- */ --- script_ref(): ScriptRef | undefined; --- /** --- * @param {ScriptRef} script_ref --- */ --- set_script_ref(script_ref: ScriptRef): void; --- /** --- * @param {Address} address --- * @param {Value} amount --- * @returns {TransactionOutput} --- */ --- static new(address: Address, amount: Value): TransactionOutput; --- } -newtype TransactionOutput = TransactionOutput - ( JSObject - ( from_bytes :: EffectMth1 (Cbor TransactionOutputObject) TransactionOutputObject - , from_json :: EffectMth1 JsonString TransactionOutputObject - , new :: EffectMth2 AddressObject ValueObject TransactionOutputObject - ) - ) - -derive instance Newtype TransactionOutput _ - -transactionOutput - :: { from_bytes :: TransactionOutput -> (Cbor TransactionOutputObject) -> Effect TransactionOutputObject - , from_json :: TransactionOutput -> JsonString -> Effect TransactionOutputObject - , new :: TransactionOutput -> AddressObject -> ValueObject -> Effect TransactionOutputObject - } -transactionOutput = mkNewtypedFFI (Proxy :: Proxy TransactionOutput) - -newtype TransactionOutputObject = TransactionOutputObject - ( JSObject - ( free :: EffectMth0 Unit - , address :: EffectMth0 AddressObject - ) - ) - -derive instance Newtype TransactionOutputObject _ - -transactionOutputObject - :: { free :: TransactionOutputObject -> Effect Unit - , address :: TransactionOutputObject -> Effect AddressObject - } -transactionOutputObject = mkNewtypedFFI (Proxy :: Proxy TransactionOutputObject) - --- export class TransactionUnspentOutput { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {TransactionUnspentOutput} --- */ --- static from_bytes(bytes: Uint8Array): TransactionUnspentOutput; --- /** --- * @param {TransactionInput} input --- * @param {TransactionOutput} output --- * @returns {TransactionUnspentOutput} --- */ --- static new(input: TransactionInput, output: TransactionOutput): TransactionUnspentOutput; --- /** --- * @returns {TransactionInput} --- */ --- input(): TransactionInput; --- /** --- * @returns {TransactionOutput} --- */ --- output(): TransactionOutput; --- } - --- FIXME: missing binding. -foreign import data TransactionInputObject :: Type - -newtype TransactionUnspentOutput = TransactionUnspentOutput - ( JSObject - ( from_bytes :: EffectMth1 (Cbor TransactionUnspentOutputObject) TransactionUnspentOutputObject - , new :: EffectMth2 TransactionInputObject TransactionOutput TransactionUnspentOutputObject - ) - ) - -derive instance Newtype TransactionUnspentOutput _ - -transactionUnspentOutput - :: { from_bytes :: TransactionUnspentOutput -> (Cbor TransactionUnspentOutputObject) -> Effect TransactionUnspentOutputObject - , new :: TransactionUnspentOutput -> TransactionInputObject -> TransactionOutput -> Effect TransactionUnspentOutputObject - } -transactionUnspentOutput = mkNewtypedFFI (Proxy :: Proxy TransactionUnspentOutput) - -newtype TransactionUnspentOutputObject = TransactionUnspentOutputObject - ( JSObject - ( free :: EffectMth0 Unit - , input :: EffectMth0 TransactionInputObject - , output :: EffectMth0 TransactionOutputObject - ) - ) - -derive instance Newtype TransactionUnspentOutputObject _ - -transactionUnspentOutputObject - :: { free :: TransactionUnspentOutputObject -> Effect Unit - , input :: TransactionUnspentOutputObject -> Effect TransactionInputObject - , output :: TransactionUnspentOutputObject -> Effect TransactionOutputObject - } -transactionUnspentOutputObject = mkNewtypedFFI (Proxy :: Proxy TransactionUnspentOutputObject) - --- Just a stub -foreign import data TransactionHashObject :: Type - --- export class BigNum { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {BigNum} --- */ --- static from_bytes(bytes: Uint8Array): BigNum; --- /** --- * @param {string} string --- * @returns {BigNum} --- */ --- static from_str(string: string): BigNum; --- /** --- * @returns {string} --- */ --- to_str(): string; --- /** --- * @returns {BigNum} --- */ --- static zero(): BigNum; --- /** --- * @returns {boolean} --- */ --- is_zero(): boolean; --- /** --- * @param {BigNum} other --- * @returns {BigNum} --- */ --- checked_mul(other: BigNum): BigNum; --- /** --- * @param {BigNum} other --- * @returns {BigNum} --- */ --- checked_add(other: BigNum): BigNum; --- /** --- * @param {BigNum} other --- * @returns {BigNum} --- */ --- checked_sub(other: BigNum): BigNum; --- /** --- * returns 0 if it would otherwise underflow --- * @param {BigNum} other --- * @returns {BigNum} --- */ --- clamped_sub(other: BigNum): BigNum; --- /** --- * @param {BigNum} other --- * @returns {BigNum} --- */ --- checked_div(other: BigNum): BigNum; --- /** --- * @param {BigNum} other --- * @returns {BigNum} --- */ --- checked_div_ceil(other: BigNum): BigNum; --- /** --- * @param {BigNum} rhs_value --- * @returns {number} --- */ --- compare(rhs_value: BigNum): number; --- } - -newtype BigNum = BigNum - ( JSObject - ( from_bytes :: EffectMth1 (Cbor BigNumObject) BigNumObject - , from_str :: EffectMth1 String BigNumObject - ) - ) - -derive instance Newtype BigNum _ - -bigNum - :: { from_bytes :: BigNum -> (Cbor BigNumObject) -> Effect BigNumObject - , from_str :: BigNum -> String -> Effect BigNumObject - } -bigNum = mkNewtypedFFI (Proxy :: Proxy BigNum) - -newtype BigNumObject = BigNumObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 Uint8Array - , to_str :: EffectMth0 String - , is_zero :: EffectMth0 Boolean - , checked_mul :: EffectMth1 BigNum BigNum - , checked_add :: EffectMth1 BigNum BigNum - , checked_sub :: EffectMth1 BigNum BigNum - , clamped_sub :: EffectMth1 BigNum BigNum - , checked_div :: EffectMth1 BigNum BigNum - , checked_div_ceil :: EffectMth1 BigNum BigNum - , compare :: EffectMth1 BigNum Number - ) - ) - -derive instance Newtype BigNumObject _ - -bigNumObject - :: { free :: BigNumObject -> Effect Unit - , to_bytes :: BigNumObject -> Effect Uint8Array - , to_str :: BigNumObject -> Effect String - , is_zero :: BigNumObject -> Effect Boolean - , checked_mul :: BigNumObject -> BigNum -> Effect BigNum - , checked_add :: BigNumObject -> BigNum -> Effect BigNum - , checked_sub :: BigNumObject -> BigNum -> Effect BigNum - , clamped_sub :: BigNumObject -> BigNum -> Effect BigNum - , checked_div :: BigNumObject -> BigNum -> Effect BigNum - , checked_div_ceil :: BigNumObject -> BigNum -> Effect BigNum - , compare :: BigNumObject -> BigNum -> Effect Number - } -bigNumObject = mkNewtypedFFI (Proxy :: Proxy BigNumObject) - --- export class BigInt { --- free(): void; --- /** --- * @returns {Uint8Array} --- */ --- to_bytes(): Uint8Array; --- /** --- * @param {Uint8Array} bytes --- * @returns {BigInt} --- */ --- static from_bytes(bytes: Uint8Array): BigInt; --- /** --- * @returns {BigNum | undefined} --- */ --- as_u64(): BigNum | undefined; --- /** --- * @returns {Int | undefined} --- */ --- as_int(): Int | undefined; --- /** --- * @param {string} string --- * @returns {BigInt} --- */ --- static from_str(string: string): BigInt; --- /** --- * @returns {string} --- */ --- to_str(): string; --- } - -newtype BigInt = BigInt - ( JSObject - ( from_bytes :: EffectMth1 (Cbor BigIntObject) BigIntObject - , from_str :: EffectMth1 String BigIntObject - ) - ) - -derive instance Newtype BigInt _ - -bigInt :: - { from_bytes :: BigInt -> (Cbor BigIntObject) -> Effect BigIntObject - , from_str :: BigInt -> String -> Effect BigIntObject - } -bigInt = mkNewtypedFFI (Proxy :: Proxy BigInt) - -newtype BigIntObject = BigIntObject - ( JSObject - ( free :: EffectMth0 Unit - , to_bytes :: EffectMth0 Uint8Array - , as_u64 :: EffectMth0 (Opt BigNumObject) - , as_int :: EffectMth0 (Opt BigIntObject) - , to_str :: EffectMth0 String - ) - ) - -derive instance Newtype BigIntObject _ - -bigIntObject :: - { free :: BigIntObject -> Effect Unit - , to_bytes :: BigIntObject -> Effect Uint8Array - , as_u64 :: BigIntObject -> Effect (Opt BigNumObject) - , as_int :: BigIntObject -> Effect (Opt BigIntObject) - , to_str :: BigIntObject -> Effect String - } -bigIntObject = mkNewtypedFFI (Proxy :: Proxy BigIntObject) - diff --git a/src/Contrib/CardanoMultiplatformLib/Types.purs b/src/Contrib/CardanoMultiplatformLib/Types.purs deleted file mode 100644 index 69f338e4..00000000 --- a/src/Contrib/CardanoMultiplatformLib/Types.purs +++ /dev/null @@ -1,76 +0,0 @@ -module CardanoMultiplatformLib.Types - ( JsonString - , jsonStringToString - , jsonStringFromString - , unsafeJsonString - , cborHexToHex - , cborHexToCbor - , cborToCborHex - , unsafeCborHex - -- FIXME: Import only the type - , CborHex(..) - , Cbor - , Bech32 - , bech32ToString - , unsafeBech32 - ) where - -import Prelude - -import Data.Argonaut (class DecodeJson, class EncodeJson, parseJson, stringify) -import Data.ArrayBuffer.Types (Uint8Array) -import Data.Either (hush) -import Data.Maybe (Maybe) -import HexString (Hex) -import HexString as HexString - -newtype CborHex :: Type -> Type -newtype CborHex a = CborHex Hex - -derive instance Eq (CborHex a) -derive newtype instance EncodeJson (CborHex a) -derive newtype instance DecodeJson (CborHex a) - -cborHexToHex :: forall a. CborHex a -> Hex -cborHexToHex (CborHex h) = h - -cborHexToCbor :: forall a. CborHex a -> Cbor a -cborHexToCbor = Cbor <<< HexString.decode <<< cborHexToHex - -cborToCborHex :: forall a. Cbor a -> CborHex a -cborToCborHex = CborHex <<< HexString.encode <<< unCbor - -unsafeCborHex :: forall a. Hex -> CborHex a -unsafeCborHex = CborHex - -newtype Cbor :: Type -> Type -newtype Cbor a = Cbor Uint8Array - -unCbor :: forall a. Cbor a -> Uint8Array -unCbor (Cbor a) = a - -newtype JsonString = JsonString String - -unsafeJsonString :: String -> JsonString -unsafeJsonString = JsonString - -jsonStringFromString :: String -> Maybe JsonString -jsonStringFromString = map (JsonString <<< stringify) <<< hush <<< parseJson - -jsonStringToString :: JsonString -> String -jsonStringToString (JsonString s) = s - -newtype Bech32 = Bech32 String - -derive newtype instance Eq Bech32 -derive newtype instance Ord Bech32 -derive newtype instance EncodeJson Bech32 -derive newtype instance DecodeJson Bech32 -derive newtype instance Show Bech32 - -bech32ToString :: Bech32 -> String -bech32ToString (Bech32 str) = str - -unsafeBech32 :: String -> Bech32 -unsafeBech32 = Bech32 - diff --git a/src/Contrib/Data/Argonaut.js b/src/Contrib/Data/Argonaut.js deleted file mode 100644 index c7cdc811..00000000 --- a/src/Contrib/Data/Argonaut.js +++ /dev/null @@ -1,8 +0,0 @@ -export function parseImpl(resultHandlers, reviver, jsonStr) { - try { - return resultHandlers.success(JSON.parse(jsonStr, reviver)); - } - catch (e) { - return resultHandlers.failure(e.message); - } -} diff --git a/src/Contrib/Data/Argonaut.purs b/src/Contrib/Data/Argonaut.purs deleted file mode 100644 index eb7af5f4..00000000 --- a/src/Contrib/Data/Argonaut.purs +++ /dev/null @@ -1,51 +0,0 @@ -module Contrib.Data.Argonaut where - -import Prelude - -import Contrib.Data.String as S -import Data.Argonaut (Json, JsonDecodeError(..), caseJsonString, fromString, stringify) -import Data.Either (Either(..), note) -import Data.Enum (class BoundedEnum) -import Data.Function.Uncurried (Fn3, runFn3) -import Data.Maybe (Maybe) - - -type JsonParserResult a = Either JsonDecodeError a -type JsonParser a = Json -> JsonParserResult a - -decodeFromString :: forall a. (String -> Maybe a) -> JsonParser a -decodeFromString decode json = do - let - decode' str = do - let - err = TypeMismatch $ "Unexpected constructor name:" <> str - note err $ decode str - caseJsonString - (Left $ TypeMismatch $ "Unexpected json value: " <> stringify json) - decode' - json - -decodeJsonEnumWith :: forall a. Show a => BoundedEnum a => (String -> String) -> JsonParser a -decodeJsonEnumWith adaptConstructorName = do - decodeFromString (S.decodeEnumWith adaptConstructorName) - -encodeJsonEnumWith :: forall a. Show a => (String -> String) -> a -> Json -encodeJsonEnumWith adaptConstructorName = fromString <<< adaptConstructorName <<< show - - -type Reviver = String -> Json -> Json - -type ParseResultHandlers a = { failure :: String -> a, success :: Json -> a} - -newtype JsonString = JsonString String - -foreign import parseImpl :: forall a. Fn3 (ParseResultHandlers a) Reviver JsonString a - -eitherHandlers :: ParseResultHandlers (Either String Json) -eitherHandlers = { failure: Left, success: Right } - --- | Original argonaut binding doesn't provide a way to pass a custom reviver. -parse :: Reviver -> JsonString -> Either String Json -parse = runFn3 parseImpl eitherHandlers - - diff --git a/src/Contrib/Data/Argonaut/Decode/Record.purs b/src/Contrib/Data/Argonaut/Decode/Record.purs deleted file mode 100644 index 93fa8cd1..00000000 --- a/src/Contrib/Data/Argonaut/Decode/Record.purs +++ /dev/null @@ -1,60 +0,0 @@ -module Contrib.Data.Argonaut.Decode.Record where - -import Prelude - -import Contrib.Record.BuilderT (BuilderT(..)) -import Data.Argonaut (class DecodeJson, Json, JsonDecodeError) -import Data.Argonaut as A -import Data.Either (Either) -import Data.Maybe (Maybe) -import Data.Symbol (class IsSymbol, reflectSymbol) -import Data.Tuple.Nested ((/\)) -import Foreign.Object (Object) -import Prim.Row as Row -import Record as R -import Type.Proxy (Proxy) - -getField - :: forall a l r r' - . DecodeJson a - => IsSymbol l - => Row.Lacks l r - => Row.Cons l a r r' - => Object Json - -> Proxy l - -> BuilderT (Either JsonDecodeError) { | r } { | r' } Unit -getField obj l = BuilderT do - v <- A.getField obj (reflectSymbol l) - pure $ (R.insert l v /\ unit) - -infixl 7 getField as .: - -getFieldOptional - :: forall a l r r' - . DecodeJson a - => IsSymbol l - => Row.Lacks l r - => Row.Cons l (Maybe a) r r' - => Object Json - -> Proxy l - -> BuilderT (Either JsonDecodeError) { | r } { | r' } Unit -getFieldOptional obj l = BuilderT do - v <- A.getFieldOptional obj (reflectSymbol l) - pure $ (R.insert l v /\ unit) - -infix 7 getFieldOptional as .:! - -getFieldOptional' - :: forall a l r r' - . DecodeJson a - => IsSymbol l - => Row.Lacks l r - => Row.Cons l (Maybe a) r r' - => Object Json - -> Proxy l - -> BuilderT (Either JsonDecodeError) { | r } { | r' } Unit -getFieldOptional' obj l = BuilderT do - v <- A.getFieldOptional' obj (reflectSymbol l) - pure $ (R.insert l v /\ unit) - -infix 7 getFieldOptional' as .:? diff --git a/src/Contrib/Data/Argonaut/Decode/Record/Field.purs b/src/Contrib/Data/Argonaut/Decode/Record/Field.purs deleted file mode 100644 index ce555d87..00000000 --- a/src/Contrib/Data/Argonaut/Decode/Record/Field.purs +++ /dev/null @@ -1,149 +0,0 @@ -module Contrib.Data.Argonaut.Decode.Record.Field where - -import Prelude - -import Contrib.Record.BuilderT (BuilderT(..), execBuilderT) -import Control.Monad.Indexed.Qualified as Ix -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.Reader.Class (ask) -import Control.Monad.Trans.Class (lift) -import Data.Argonaut (class DecodeJson, Json, JsonDecodeError(..), decodeJson) -import Data.Argonaut as A -import Data.Argonaut.Decode.Decoders as Decoders -import Data.Bifunctor (lmap) -import Data.Either (Either) -import Data.Maybe (Maybe(..), maybe) -import Data.Symbol (class IsSymbol, reflectSymbol) -import Data.Traversable (for) -import Data.Tuple.Nested ((/\)) -import Foreign.Object (Object) -import Foreign.Object as Object -import Prim.Row as Row -import Record as R -import Type.Proxy (Proxy) - -type DecodeM = ReaderT (Object Json) (Either JsonDecodeError) - -type RecordBuilderM r r' = BuilderT DecodeM { | r } { | r' } - -askFieldOptional :: forall r. String -> RecordBuilderM r r (Maybe Json) -askFieldOptional fieldName = BuilderT do - obj <- ask - pure $ (identity /\ Object.lookup fieldName obj) - -askObject :: forall r. RecordBuilderM r r (Object Json) -askObject = BuilderT do - obj <- ask - pure (identity /\ obj) - -askField :: forall r. String -> RecordBuilderM r r Json -askField fieldName = BuilderT do - obj <- ask - lift $ Decoders.getField (\json -> pure (identity /\ json)) obj fieldName - -liftEither :: forall a r. Either JsonDecodeError a -> RecordBuilderM r r a -liftEither v = BuilderT do - v' <- lift v - pure (identity /\ v') - -insertProp - :: forall a l r r' - . IsSymbol l - => Row.Lacks l r - => Row.Cons l a r r' - => Proxy l - -> a - -> BuilderT DecodeM { | r } { | r' } Unit -insertProp l a = BuilderT $ do - pure (R.insert l a /\ unit) - -decodeJsonProp - :: forall a l r r' - . IsSymbol l - => Row.Lacks l r - => Row.Cons l a r r' - => DecodeJson a - => Proxy l - -> BuilderT DecodeM { | r } { | r' } Unit -decodeJsonProp l = Ix.do - obj <- askObject - v <- liftEither $ A.getField obj (reflectSymbol l) - insertProp l v - -execRecordBuilderM :: forall a r. Json -> RecordBuilderM () r a -> Either JsonDecodeError { | r } -execRecordBuilderM json builder = do - obj <- decodeJson json - runReaderT (execBuilderT builder {}) obj - -decodeField - :: forall a l r r' - . IsSymbol l - => Row.Lacks l r - => Row.Cons l a r r' - => Proxy l - -> (Json -> Either JsonDecodeError a) - -> RecordBuilderM r r' Unit -decodeField l decode = BuilderT do - obj <- ask - json <- lift $ A.getField obj (reflectSymbol l) - v <- lift $ decode json - pure $ (R.insert l v /\ unit) - -infixl 7 decodeField as := - -decodeFieldDefault - :: forall a l r r' - . IsSymbol l - => Row.Lacks l r - => Row.Cons l a r r' - => Proxy l - -> (Json -> Either JsonDecodeError a) - -> a - -> RecordBuilderM r r' Unit -decodeFieldDefault l decode default = BuilderT do - obj <- ask - let - l' = reflectSymbol l - json <- lift $ A.getFieldOptional obj l' - v <- lift $ lmap (AtKey l') $ maybe (pure default) decode json - pure $ (R.insert l v /\ unit) - -infixl 1 decodeFieldDefault as :=! - --- null | missing -> Nothing -decodeFieldOptional - :: forall a l r r' - . IsSymbol l - => Row.Lacks l r - => Row.Cons l (Maybe a) r r' - => Proxy l - -> (Json -> Either JsonDecodeError a) - -> RecordBuilderM r r' Unit -decodeFieldOptional l decode = BuilderT do - obj <- ask - let - l' = reflectSymbol l - json <- lift $ A.getFieldOptional' obj l' - v <- lift $ lmap (AtKey l') $ for json decode - pure $ (R.insert l v /\ unit) - -infixl 7 decodeFieldOptional as :=? - -decodeFieldOptionalDefault - :: forall a l r r' - . IsSymbol l - => Row.Lacks l r - => Row.Cons l (Maybe a) r r' - => Proxy l - -> (Json -> Either JsonDecodeError a) - -> a - -> RecordBuilderM r r' Unit -decodeFieldOptionalDefault l decode default = BuilderT do - obj <- ask - let - l' = reflectSymbol l - json <- lift $ A.getFieldOptional obj l' - v <- lift $ lmap (AtKey l') $ maybe (pure default) decode json - pure $ (R.insert l (Just v) /\ unit) - -infixl 7 decodeFieldOptionalDefault as :=?! diff --git a/src/Contrib/Data/Argonaut/Generic/Record.purs b/src/Contrib/Data/Argonaut/Generic/Record.purs deleted file mode 100644 index 3dfbdb21..00000000 --- a/src/Contrib/Data/Argonaut/Generic/Record.purs +++ /dev/null @@ -1,143 +0,0 @@ -module Contrib.Data.Argonaut.Generic.Record where - -import Prelude - -import Data.Argonaut (Json, JsonDecodeError(..), decodeJson) -import Data.Argonaut.Decode.Class (class DecodeJsonField, decodeJsonField) -import Data.Bifunctor (lmap) -import Data.Either (Either(..)) -import Data.Maybe (Maybe(..)) -import Data.Newtype (class Newtype, wrap) -import Data.Symbol (reflectSymbol) -import Foreign.Object (Object) -import Foreign.Object as Object -import Heterogeneous.Folding (class FoldingWithIndex, class HFoldlWithIndex, hfoldlWithIndex) -import Prim.Row (class Cons, class Lacks) as Row -import Prim.RowList (class RowToList) -import Record (get, insert) as Record -import Row.Joins.Outer (NULL, OuterJoin') -import Type.Eval (class Eval) -import Type.Eval.Tuple (Tuple') -import Type.Prelude (class IsSymbol) -import Type.Proxy (Proxy(..)) - -type DecodeRecordFn r = Object Json -> Either JsonDecodeError { | r } - -newtype DecodeStep decoders = DecodeStep { | decoders } - -type DecodeJsonFieldFn a = Maybe Json -> Maybe (Either JsonDecodeError a) - -instance - ( IsSymbol l - , Row.Lacks l r - , Row.Cons l a r r' - , DecodeJsonField a - ) => - FoldingWithIndex (DecodeStep d) (Proxy l) (DecodeRecordFn r) (Proxy (Tuple' NULL a)) (DecodeRecordFn r') where - foldingWithIndex _ l acc _ = \obj -> do - r <- acc obj - let - key = reflectSymbol l - case decodeJsonField $ Object.lookup key obj of - Just val -> do - val' <- lmap (AtKey key) val - Right $ Record.insert l val' r - Nothing -> - Left $ AtKey key MissingValue -else instance - FoldingWithIndex (DecodeStep d) (Proxy l) (DecodeRecordFn r) (Proxy (Tuple' a NULL)) (DecodeRecordFn r) where - foldingWithIndex _ _ acc _ = acc -else instance - ( IsSymbol l - , Row.Lacks l r - , Row.Cons l a r r' - , Row.Cons l (DecodeJsonFieldFn a) _d d - ) => - FoldingWithIndex (DecodeStep d) (Proxy l) (DecodeRecordFn r) (Proxy (Tuple' (DecodeJsonFieldFn a) a)) (DecodeRecordFn r') where - foldingWithIndex (DecodeStep d) l acc _ = \obj -> do - r <- acc obj - let - key = reflectSymbol l - decodeJsonFieldFn = Record.get l d - case decodeJsonFieldFn $ Object.lookup key obj of - Just val -> do - val' <- lmap (AtKey key) val - Right $ Record.insert l val' r - Nothing -> - Left $ AtKey key MissingValue - --- | The belowe type classes are aliases which hide the gory type level details (row join, folding etc.) --- --- An nearly complete example could look like this: --- ``` --- type Result = --- { int :: Int --- , string :: String --- , decimal :: Decimal --- } --- --- main :: Effect Unit --- main = do --- let --- json :: Json --- json = A.fromObject $ Object.fromHomogeneous --- { int: A.fromNumber 8.0 --- , string: A.fromString "test" --- , decimal: A.fromString "0.8" --- } --- --- decodeDecimal :: Json -> Either JsonDecodeError Decimal --- decodeDecimal = decodeFromString (String.trimStart >>> Decimal.fromString) --- --- -- Field decoders follow internal argonaut strategy and work over `Maybe` --- decoders = { decimal: map decodeDecimal :: Maybe _ -> Maybe _ } --- --- traceM $ ((decodeRecord decoders json) :: Either JsonDecodeError Result) --- ``` --- -class DecodeRecord decoders r where - decodeRecord :: { | decoders } -> Json -> Either JsonDecodeError { | r } - -instance - ( Eval (OuterJoin' decoders r) join - , RowToList join joinL - , HFoldlWithIndex (DecodeStep decoders) (DecodeRecordFn ()) (Proxy joinL) (DecodeRecordFn r) - ) => - DecodeRecord decoders r where - decodeRecord decoders = do - let - empty :: DecodeRecordFn () - empty _ = Right {} - decodeObject = hfoldlWithIndex (DecodeStep decoders) empty (Proxy :: Proxy joinL) - \json -> do - obj <- decodeJson json - decodeObject obj - --- This helper works over a `newtype` with `Record` value inside - the above example should be --- nearly the same but we could have: --- ``` --- newtype Result = Result --- { int :: Int --- , string :: String --- , decimal :: Decimal --- } --- --- ... --- --- main = do --- ... --- traceM $ ((decodeNewtypedRecord decoders json) :: Either JsonDecodeError Result) --- ``` --- -class DecodeNewtypedRecord decoders n where - decodeNewtypedRecord :: { | decoders } -> Json -> Either JsonDecodeError n - -instance - ( Newtype n { | r } - , Eval (OuterJoin' decoders r) join - , RowToList join joinL - , HFoldlWithIndex (DecodeStep decoders) (DecodeRecordFn ()) (Proxy joinL) (DecodeRecordFn r) - ) => - DecodeNewtypedRecord decoders n where - decodeNewtypedRecord decoders = map wrap <$> decodeRecord decoders - diff --git a/src/Contrib/Data/Argonaut/Record.purs b/src/Contrib/Data/Argonaut/Record.purs deleted file mode 100644 index 10e8951d..00000000 --- a/src/Contrib/Data/Argonaut/Record.purs +++ /dev/null @@ -1,23 +0,0 @@ -module Contrib.Data.Argonaut.Record where - -import Prelude - -import Data.Argonaut (Json, JsonDecodeError(..), decodeJson) -import Data.Argonaut.Decode.Class (class DecodeJsonField, decodeJsonField) -import Data.Bifunctor (lmap) -import Data.Either (Either(..)) -import Data.Maybe (Maybe(..)) -import Data.Newtype (class Newtype, wrap) -import Data.Symbol (reflectSymbol) -import Foreign.Object (Object) -import Foreign.Object as Object -import Heterogeneous.Folding (class FoldingWithIndex, class HFoldlWithIndex, hfoldlWithIndex) -import Prim.Row (class Cons, class Lacks) as Row -import Record (get, insert) as Record -import Row.Joins.Outer (NULL, OuterJoin') -import Type.Eval (class Eval) -import Type.Eval.Tuple (Tuple') -import Type.Prelude (class IsSymbol) -import Type.Proxy (Proxy(..)) - -type DecodeRecordFn r = Object Json -> Either JsonDecodeError { | r } diff --git a/src/Contrib/Data/Argonaut/Traversals.purs b/src/Contrib/Data/Argonaut/Traversals.purs deleted file mode 100644 index bd581968..00000000 --- a/src/Contrib/Data/Argonaut/Traversals.purs +++ /dev/null @@ -1,35 +0,0 @@ -module Contrib.Data.Argonaut.Traversals where - -import Prelude - -import Data.Argonaut (Json, caseJsonArray, caseJsonObject, fromArray, fromObject) -import Data.Traversable (traverse) - -traverseJson :: forall f. Monad f => (Json -> f Json) -> Json -> f Json -traverseJson f = do - let - traverseArray = do - let - go arr = fromArray <$> (traverse f arr) - \json -> caseJsonArray (pure json) go json - traverseObject = do - let - go obj = fromObject <$> (traverse f obj) - \json -> caseJsonObject (pure json) go json - traverseObject <=< traverseArray - -rewriteBottomUp :: forall m. Monad m => (Json -> m Json) -> Json -> m Json -rewriteBottomUp f = do - let - visitor json = do - json' <- traverseJson visitor json - f json' - visitor - -rewriteTopDown :: forall m. Monad m => (Json -> m Json) -> Json -> m Json -rewriteTopDown f = do - let - visitor json = do - json' <- f json - traverseJson visitor json' - visitor diff --git a/src/Contrib/Data/Map.purs b/src/Contrib/Data/Map.purs deleted file mode 100644 index be811714..00000000 --- a/src/Contrib/Data/Map.purs +++ /dev/null @@ -1,29 +0,0 @@ -module Contrib.Data.Map where - -import Prelude - -import Data.Foldable (class Foldable) -import Data.Map (Map) -import Data.Map as Map -import Data.Newtype (class Newtype, un) -import Data.Profunctor.Strong ((&&&)) - -fromFoldableBy :: forall f k v. Functor f => Foldable f => Ord k => (v -> k) -> f v -> Map k v -fromFoldableBy f = Map.fromFoldable <<< map (f &&& identity) - -newtype Old k v = Old (Map k v) - -derive instance Newtype (Old k v) _ - -newtype New k v = New (Map k v) - -derive instance Newtype (New k v) _ - -additions :: forall k v. Ord k => Old k v -> New k v -> Map k v -additions (Old old) (New new) = new `Map.difference` old - -deletions :: forall k v. Ord k => Old k v -> New k v -> Map k v -deletions (Old old) (New new) = old `Map.difference` new - -updates :: forall k v. Eq v => Ord k => Old k v -> New k v -> Map k { old :: v, new :: v } -updates (Old oldMap) = Map.filter (\{ old, new } -> old /= new) <<< Map.intersectionWith { old: _, new: _ } oldMap <<< un New diff --git a/src/Contrib/Data/String.purs b/src/Contrib/Data/String.purs deleted file mode 100644 index 7ac860df..00000000 --- a/src/Contrib/Data/String.purs +++ /dev/null @@ -1,27 +0,0 @@ -module Contrib.Data.String where - -import Prelude - -import Data.Enum (class BoundedEnum, upFromIncluding) -import Data.Map as Map -import Data.Maybe (Maybe, fromMaybe, isJust) -import Data.Profunctor.Strong ((&&&)) -import Data.String (Pattern, stripPrefix) -import Data.String as String - -tryStripPrefix :: Pattern -> String -> String -tryStripPrefix pattern str = fromMaybe str (stripPrefix pattern str) - -isPrefixOf :: Pattern -> String -> Boolean -isPrefixOf prefixPattern = isJust <<< String.stripPrefix prefixPattern - -decodeEnumWith :: forall a. Show a => BoundedEnum a => (String -> String) -> String -> Maybe a -decodeEnumWith adaptConstructorName = do - let - -- Let's precompute this `Map` - values = Map.fromFoldable <<< map (adaptConstructorName <<< show &&& identity) $ (upFromIncluding bottom :: Array a) - \v -> do - flip Map.lookup values v - -encodeEnumWith :: forall a. Show a => (String -> String) -> a -> String -encodeEnumWith adaptConstructorName = adaptConstructorName <<< show diff --git a/src/Contrib/Effect.purs b/src/Contrib/Effect.purs deleted file mode 100644 index c040e9c3..00000000 --- a/src/Contrib/Effect.purs +++ /dev/null @@ -1,22 +0,0 @@ -module Contrib.Effect where - -import Prelude - -import Control.Monad.Error.Class (catchError) -import Control.Monad.Except (throwError) -import Data.Either (Either, either) -import Effect (Effect) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Exception (throw) - -bracket :: forall a b. Effect a -> (a -> Effect Unit) -> (a -> Effect b) -> Effect b -bracket acquire release action = do - resource <- acquire - b <- action resource `catchError` \error -> do - void $ release resource - throwError error - release resource - pure b - -liftEither :: forall a m err. MonadEffect m => Show err => Either err a -> m a -liftEither = either (liftEffect <<< throw <<< show) pure diff --git a/src/Contrib/Effect/SequenceRef.purs b/src/Contrib/Effect/SequenceRef.purs deleted file mode 100644 index 65322aee..00000000 --- a/src/Contrib/Effect/SequenceRef.purs +++ /dev/null @@ -1,18 +0,0 @@ -module Contrib.Effect.SequenceRef where - -import Prelude - -import Effect (Effect) -import Effect.Ref (Ref) -import Effect.Ref as Ref - -newtype SequenceRef a = SequenceRef (Ref a) - -new :: forall a. a -> Effect (SequenceRef a) -new seed = do - ref <- Ref.new seed - pure $ SequenceRef ref - -next :: forall a. Semiring a => SequenceRef a -> Effect a -next (SequenceRef ref) = Ref.modify (_ + one) ref - diff --git a/src/Contrib/Fetch.purs b/src/Contrib/Fetch.purs deleted file mode 100644 index bdb6ee24..00000000 --- a/src/Contrib/Fetch.purs +++ /dev/null @@ -1,59 +0,0 @@ -module Contrib.Fetch where - -import Prelude - -import Control.Monad.Error.Class (catchError, throwError) -import Control.Monad.Except (ExceptT(..), runExceptT) -import Control.Promise as Promise -import Data.Argonaut (Json) -import Data.Array as A -import Data.Either (Either(..)) -import Data.Generic.Rep (class Generic) -import Effect.Aff (Aff) -import Effect.Class (liftEffect) -import Effect.Exception (Error) -import Fetch.Core as Core -import Fetch.Core.Request as CoreRequest -import Fetch.Internal.Request (class ToCoreRequestOptions, HighlevelRequestOptions, new) -import Fetch.Internal.Request as Request -import Fetch.Internal.Response (Response) -import Fetch.Internal.Response as Response -import Prim.Row (class Union) -import Unsafe.Coerce (unsafeCoerce) - -type StatusCode = Int - -data FetchError - = InvalidStatusCode Response - | FetchError Error - -derive instance Generic FetchError _ -instance Show FetchError where - show (InvalidStatusCode _) = "InvalidStatusCode" - show (FetchError error) = "FetchError " <> show error - -fetchEither - :: forall input output thruIn thruOut headers err - . Union input thruIn (HighlevelRequestOptions headers String) - => Union output thruOut CoreRequest.UnsafeRequestOptions - => ToCoreRequestOptions input output - => String - -> { | input } - -> Array StatusCode - -> (FetchError -> err) - -> Aff (Either err Response) -fetchEither url r allowedStatusCodes handleError = runExceptT do - let - fetch = do - request <- liftEffect $ new url $ Request.convert r - cResponse <- Promise.toAffE $ Response.promiseToPromise <$> Core.fetch request - pure $ Response.convert cResponse - res <- ExceptT $ (Right <$> fetch) `catchError` \err -> do - pure $ Left $ handleError $ FetchError err - - if res.status `A.elem` allowedStatusCodes then pure res - else throwError $ handleError $ InvalidStatusCode res - --- For the full safety we should introduce a newtype wrapper for the Response record -jsonBody :: Response -> Aff Json -jsonBody response = unsafeCoerce <$> response.json diff --git a/src/Contrib/HexString.js b/src/Contrib/HexString.js deleted file mode 100644 index e6c9e2fd..00000000 --- a/src/Contrib/HexString.js +++ /dev/null @@ -1,2 +0,0 @@ -export { decode, encode } from 'hex-string'; - diff --git a/src/Contrib/HexString.purs b/src/Contrib/HexString.purs deleted file mode 100644 index b3f9925e..00000000 --- a/src/Contrib/HexString.purs +++ /dev/null @@ -1,35 +0,0 @@ -module HexString where - -import Prelude - -import Data.Argonaut (class DecodeJson, class EncodeJson) -import Data.ArrayBuffer.Types (Uint8Array) -import Data.Maybe (Maybe(..)) -import Data.String.Common (toLower) -import Data.String.Regex as Regex -import Data.String.Regex.Unsafe (unsafeRegex) - -newtype Hex = Hex String - -derive newtype instance Eq Hex -derive newtype instance EncodeJson Hex -derive newtype instance DecodeJson Hex - -hexToString :: Hex -> String -hexToString (Hex str) = str - -hex :: String -> Maybe Hex -hex = do - let - lowerCaseHexPattern = unsafeRegex "^[0-9a-f]+$" mempty - anyHexPattern = unsafeRegex "^[0-9a-fA-F]+$" mempty - - case _ of - str | Regex.test lowerCaseHexPattern str -> Just $ Hex str - str | Regex.test anyHexPattern str -> Just $ Hex $ toLower str - _ -> Nothing - -foreign import decode :: Hex -> Uint8Array - -foreign import encode :: Uint8Array -> Hex - diff --git a/src/Contrib/Language/Marlowe/Core/V1.purs b/src/Contrib/Language/Marlowe/Core/V1.purs deleted file mode 100644 index 83b4e13c..00000000 --- a/src/Contrib/Language/Marlowe/Core/V1.purs +++ /dev/null @@ -1,47 +0,0 @@ -module Contrib.Language.Marlowe.Core.V1 where - -import Prelude - -import Data.FunctorWithIndex (mapWithIndex) -import Data.Map (Map) -import Data.Map as Map -import Data.Maybe (Maybe(..)) -import Data.Tuple.Nested ((/\)) - -compareMarloweJsonKeys :: String -> String -> Ordering -compareMarloweJsonKeys = do - let - -- Tiny optimization - let's cache in the closure the ordering - marloweKeysOrdering :: Map String Int - marloweKeysOrdering = Map.fromFoldable $ mapWithIndex (flip (/\)) - [ - -- deposit: - "party" - , "deposits" - , "of_token" - , "into_account" - -- when: - , "when" - , "timeout" - , "timeout_continuation" - -- choice: - , "for_choice" - , "choose_between" - -- pay: - , "pay" - , "token" - , "from_account" - , "to" - , "then" - ] - \a b -> do - let - possibleOrdering = do - aV <- Map.lookup a marloweKeysOrdering - bV <- Map.lookup b marloweKeysOrdering - pure $ compare aV bV - -- Lazily compute the fallback, default ordering - case possibleOrdering of - Just ordering -> ordering - Nothing -> compare a b - diff --git a/src/Contrib/Language/Marlowe/Normalization.purs b/src/Contrib/Language/Marlowe/Normalization.purs deleted file mode 100644 index f2518e07..00000000 --- a/src/Contrib/Language/Marlowe/Normalization.purs +++ /dev/null @@ -1,141 +0,0 @@ -module Contrib.Language.Marlowe.Normalization where - -import Prelude - -import Control.Monad.Rec.Class (Step(..), tailRec) -import Data.Map as Map -import Data.Maybe (maybe) -import Data.Tuple.Nested ((/\)) -import Language.Marlowe.Core.V1.Semantics.Types as V1 - -fix :: forall a. Eq a => (a -> a) -> a -> a -fix f = tailRec \a -> let result = f a in if result == a then Done a else Loop result - --- | Rewrite rules for Value -rewriteValue :: V1.State -> V1.Value -> V1.Value -rewriteValue state@(V1.State s) = - let - loop :: V1.Value -> V1.Value - loop = case _ of - v@(V1.Constant _) -> v - v@V1.TimeIntervalStart -> v - v@V1.TimeIntervalEnd -> v - v@(V1.UseValue var) -> maybe v V1.Constant $ Map.lookup var s.boundValues - v@(V1.ChoiceValue var) -> maybe v V1.Constant $ Map.lookup var s.choices - v@(V1.AvailableMoney account token) -> maybe v V1.Constant $ Map.lookup (account /\ token) s.accounts - V1.AddValue (V1.Constant a) (V1.Constant b) -> V1.Constant (a + b) - V1.AddValue a b -> V1.AddValue (loop a) (loop b) - V1.SubValue (V1.Constant a) (V1.Constant b) -> V1.Constant (a - b) - V1.SubValue a b -> V1.SubValue (loop a) (loop b) - V1.MulValue (V1.Constant a) (V1.Constant b) -> V1.Constant (a * b) - V1.MulValue a b -> V1.MulValue (loop a) (loop b) - V1.DivValue (V1.Constant a) (V1.Constant b) -> V1.Constant (a / b) - V1.DivValue a b -> V1.DivValue (loop a) (loop b) - V1.NegValue (V1.Constant a) -> V1.Constant (-a) - V1.NegValue a -> V1.NegValue (loop a) - V1.Cond V1.TrueObs a _ -> loop a - V1.Cond V1.FalseObs _ b -> loop b - V1.Cond obs a b -> V1.Cond (rewriteObservation state obs) (loop a) (loop b) - in - fix loop - --- | Rewrite rules for Observation -rewriteObservation :: V1.State -> V1.Observation -> V1.Observation -rewriteObservation state@(V1.State s) = - let - loop :: V1.Observation -> V1.Observation - loop = case _ of - V1.AndObs V1.TrueObs b -> loop b - V1.AndObs V1.FalseObs _ -> V1.FalseObs - V1.AndObs a b -> V1.AndObs (loop a) (loop b) - V1.OrObs V1.FalseObs b -> loop b - V1.OrObs V1.TrueObs _ -> V1.TrueObs - V1.OrObs a b -> V1.OrObs (loop a) (loop b) - V1.NotObs V1.TrueObs -> V1.FalseObs - V1.NotObs V1.FalseObs -> V1.TrueObs - V1.NotObs a -> V1.NotObs (loop a) - V1.ChoseSomething var - | Map.member var s.choices -> V1.TrueObs - | otherwise -> V1.FalseObs - V1.ValueGE (V1.Constant a) (V1.Constant b) - | a >= b -> V1.TrueObs - | otherwise -> V1.FalseObs - V1.ValueGE a b -> V1.ValueGE (rewriteValue state a) (rewriteValue state b) - V1.ValueGT (V1.Constant a) (V1.Constant b) - | a > b -> V1.TrueObs - | otherwise -> V1.FalseObs - V1.ValueGT a b -> V1.ValueGT (rewriteValue state a) (rewriteValue state b) - V1.ValueLT (V1.Constant a) (V1.Constant b) - | a < b -> V1.TrueObs - | otherwise -> V1.FalseObs - V1.ValueLT a b -> V1.ValueLT (rewriteValue state a) (rewriteValue state b) - V1.ValueLE (V1.Constant a) (V1.Constant b) - | a <= b -> V1.TrueObs - | otherwise -> V1.FalseObs - V1.ValueLE a b -> V1.ValueLE (rewriteValue state a) (rewriteValue state b) - V1.ValueEQ (V1.Constant a) (V1.Constant b) - | a == b -> V1.TrueObs - | otherwise -> V1.FalseObs - V1.ValueEQ a b -> V1.ValueEQ (rewriteValue state a) (rewriteValue state b) - v@V1.TrueObs -> v - v@V1.FalseObs -> v - in - fix loop - --- | Rewrite rules for Case -rewriteCase :: V1.State -> V1.Case -> V1.Case -rewriteCase state = - let - loop :: V1.Case -> V1.Case - loop = case _ of - V1.Case action contract -> V1.Case action (rewriteContract state contract) - v@(V1.MerkleizedCase _ _) -> v - in - fix loop - --- | Rewrite rules for Contract -rewriteContract :: V1.State -> V1.Contract -> V1.Contract -rewriteContract state@(V1.State s) = - let - loop :: V1.Contract -> V1.Contract - loop = case _ of - v@V1.Close -> v - v@(V1.Assert _ _) -> v - V1.Pay accountid payee token val a -> V1.Pay accountid payee token (rewriteValue state val) (loop a) - V1.If V1.TrueObs a _ -> loop a - V1.If V1.FalseObs _ b -> loop b - V1.If obs a b -> V1.If (rewriteObservation state obs) (loop a) (loop b) - -- TODO 😎 This needs to be cooler: - V1.When cases t a -> V1.When (rewriteCase state <$> cases) t (loop a) - V1.Let var (V1.Constant val) a -> rewriteContract (V1.State s { boundValues = Map.insert var val s.boundValues }) a - V1.Let var val a -> V1.Let var (rewriteValue state val) (loop a) - in - fix loop - -{- DEMO -spago repl - -exit -:q -:r - -:paste -t = unsafePartial $ fromJust (Date.canonicalDate <$> (toEnum 2023) <*> (toEnum 6) <*> (toEnum 1)) -state = State { accounts: Map.empty, choices: Map.empty, boundValues: Map.empty, minTime: fromDate t } -c = Constant <<< fromInt -ada = Token "" "" - -exampleContract1 :: Contract -exampleContract1 = - If (AndObs (ValueGT (c 2) (c 1)) FalseObs) - (Pay (Role "A") (Party (Role "B")) ada (AddValue (c 5) (c 4)) Close) - (Pay (Role "C") (Party (Role "D")) ada (AddValue (c 1) (c 2)) Close) - -exampleContract2 :: Contract -exampleContract2 = - Let (ValueId "x") (c 4) - (Pay (Role "A") (Party (Role "B")) ada (AddValue (c 5) (UseValue (ValueId "x"))) Close) - -rewriteContract state exampleContract1 -rewriteContract state exampleContract2 --} diff --git a/src/Contrib/Record/BuilderT.purs b/src/Contrib/Record/BuilderT.purs deleted file mode 100644 index 6d7abfab..00000000 --- a/src/Contrib/Record/BuilderT.purs +++ /dev/null @@ -1,45 +0,0 @@ -module Contrib.Record.BuilderT where - -import Prelude - -import Control.Alt (class Alt, (<|>)) -import Control.Applicative.Indexed (class IxApplicative) -import Control.Apply.Indexed (class IxApply) -import Control.Monad.Indexed (class IxMonad) -import Control.Bind.Indexed (class IxBind) -import Data.Bifunctor (lmap) -import Data.Functor.Indexed (class IxFunctor) -import Data.Newtype (un, class Newtype) -import Data.Profunctor.Strong ((***)) -import Data.Tuple (fst, uncurry) -import Data.Tuple.Nested ((/\), type (/\)) - -newtype BuilderT m r r' a = BuilderT (m ((r -> r') /\ a)) - -derive instance Newtype (BuilderT m r r' a) _ - -instance Functor m => IxFunctor (BuilderT m) where - imap f (BuilderT a) = BuilderT $ map f <$> a - -instance Apply m => IxApply (BuilderT m) where - iapply (BuilderT f) (BuilderT a) = BuilderT $ apply (uncurry (***) <<< lmap (>>>) <$> f) a - -instance Applicative m => IxApplicative (BuilderT m) where - ipure a = BuilderT $ pure (identity /\ a) - -instance (Applicative m, Bind m) => IxBind (BuilderT m) where - ibind (BuilderT ma) f = BuilderT $ do - (r2r' /\ a) <- ma - (r'2r'' /\ b) <- un BuilderT $ f a - pure (r'2r'' <<< r2r' /\ b) - -instance (Monad m) => IxMonad (BuilderT m) - -instance Functor m => Functor (BuilderT m i i) where - map f (BuilderT ma) = BuilderT $ map f <$> ma - -instance Alt m => Alt (BuilderT m i i) where - alt (BuilderT ma) (BuilderT ma') = BuilderT (ma <|> ma') - -execBuilderT :: forall a i o m. Applicative m => BuilderT m i o a -> i -> m o -execBuilderT (BuilderT mt) i = ((#) i <<< fst) <$> mt diff --git a/src/Main.purs b/src/Main.purs index 352b322f..553c764c 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -92,7 +92,8 @@ main configJson = do { block: Nothing } -> true { block: Just (BlockHeader { blockNo: BlockNumber blockNo }) } -> blockNo > 909000 -- 904279 maxPages = Just (MaxPages 1) - Streaming.mkContractsWithTransactions pollInterval reqInterval filterContracts maxPages config.marloweWebServerUrl + params = { partyAddresses: [], tags: [], partyRoles: [] } + Streaming.mkContractsWithTransactions pollInterval reqInterval params filterContracts maxPages config.marloweWebServerUrl CardanoMultiplatformLib.importLib >>= case _ of Nothing -> liftEffect $ logger "Cardano serialization lib loading failed" diff --git a/src/Marlowe/Runtime/Web.purs b/src/Marlowe/Runtime/Web.purs deleted file mode 100644 index d1830c5b..00000000 --- a/src/Marlowe/Runtime/Web.purs +++ /dev/null @@ -1,8 +0,0 @@ -module Marlowe.Runtime.Web - ( module Client - , module Types - ) where - -import Marlowe.Runtime.Web.Client (getPage', getPage, post, post') as Client -import Marlowe.Runtime.Web.Types (runtime, Runtime) as Types - diff --git a/src/Marlowe/Runtime/Web/Client.purs b/src/Marlowe/Runtime/Web/Client.purs deleted file mode 100644 index 5deda69b..00000000 --- a/src/Marlowe/Runtime/Web/Client.purs +++ /dev/null @@ -1,386 +0,0 @@ -module Marlowe.Runtime.Web.Client where - -import Prelude - -import Contrib.Data.Argonaut (JsonParser) -import Contrib.Data.Argonaut.Generic.Record (class DecodeRecord, DecodeJsonFieldFn) -import Contrib.Fetch (FetchError, StatusCode, fetchEither, jsonBody) -import Control.Alt ((<|>)) -import Control.Monad.Except (ExceptT(..), runExceptT, throwError) -import Control.Monad.Loops (unfoldrM) -import Control.Monad.Trans.Class (lift) -import Data.Argonaut (class DecodeJson, Json, JsonDecodeError, decodeJson, stringify) -import Data.Argonaut.Decode ((.:)) -import Data.Bifunctor (lmap) -import Data.Either (Either(..), either) -import Data.Foldable (fold, foldMap) -import Data.Generic.Rep (class Generic) -import Data.HTTP.Method (Method(..)) -import Data.List (List) -import Data.List as List -import Data.Map (fromFoldable, lookup) -import Data.Maybe (Maybe(..)) -import Data.Newtype (class Newtype, unwrap) -import Data.Show.Generic (genericShow) -import Data.String.CaseInsensitive (CaseInsensitiveString(..)) -import Data.Tuple.Nested ((/\)) -import Effect.Aff (Aff) -import Effect.Aff.Class (class MonadAff, liftAff) -import Fetch (RequestMode(..)) -import Fetch.Core.Headers (Headers, toArray) -import Marlowe.Runtime.Web.Types (class EncodeHeaders, class EncodeJsonBody, class ToResourceLink, ApiError, GetContractsResponse, IndexEndpoint(..), PostMerkleizationRequest, PostMerkleizationResponse, ResourceEndpoint(..), ResourceLink(..), ResourceWithLinks, ResourceWithLinksRow, ServerURL(..), decodeResourceWithLink, encodeHeaders, encodeJsonBody, toResourceLink) -import Prim.Row (class Lacks) as Row -import Record as R -import Safe.Coerce (coerce) -import Type.Prelude (Proxy(..)) -import Type.Row.Homogeneous (class Homogeneous) as Row - -data ClientError err - = FetchError FetchError - | ResponseDecodingError JsonDecodeError - | MerkleizationError - | ServerApiError (ApiError err) - -derive instance Generic (ClientError err) _ -instance Show err => Show (ClientError err) where - show = genericShow - -type GetResourceResponse err res = Either (ClientError err) res - -allowedStatusCodes :: Array Int -allowedStatusCodes = [ 200, 201, 202, 206, 400, 401, 403, 404, 500 ] - -newtype Range = Range String - -type DecodeJson a = Json -> Either JsonDecodeError a - -decodeResponse :: forall a err. DecodeJson (ApiError err) => JsonParser a -> StatusCode -> Json -> Either (ClientError err) a -decodeResponse parseA = do - let - -- decodePossibleResults :: Json -> JsonParser a - decodePossibleResults json = do - obj <- decodeJson json - res <- obj .: "results" - parseA res - case _, _ of - statusCode, json | statusCode >= 200 && statusCode < 300 -> - lmap ResponseDecodingError (decodePossibleResults json <|> parseA json) - _, json -> Left $ - either ResponseDecodingError ServerApiError (decodeJson json) - -decodeResponse' :: forall a err. DecodeJson a => DecodeJson (ApiError err) => StatusCode -> Json -> Either (ClientError err) a -decodeResponse' = decodeResponse decodeJson - -decodeResponseWithLink - :: forall a err linksRow - . DecodeRecord (resource :: DecodeJsonFieldFn a) (ResourceWithLinksRow a linksRow) - => DecodeJson (ApiError err) - => DecodeJsonFieldFn a - -> StatusCode - -> Json - -> Either (ClientError err) (ResourceWithLinks a linksRow) -decodeResponseWithLink decodeResource statusCode = decodeResponse (decodeResourceWithLink decodeResource) statusCode - -getResource - :: forall a err extraHeaders - . DecodeJson a - => DecodeJson (ApiError err) - => Row.Lacks "Access-Control-Request-Headers" extraHeaders - => Row.Homogeneous ("Access-Control-Request-Headers" :: String | extraHeaders) String - => ServerURL - -> ResourceLink a - -> { | extraHeaders } - -> Aff (GetResourceResponse err { headers :: Headers, payload :: a, status :: Int }) -getResource (ServerURL serverUrl) (ResourceLink path) extraHeaders = do - let - url = serverUrl <> "/" <> path - - reqHeaders = - R.insert (Proxy :: Proxy "Access-Control-Request-Headers") "Range, Accept" - -- $ R.insert (Proxy :: Proxy "Accept") "application/json" - $ extraHeaders - - runExceptT do - res@{ status, headers: resHeaders } <- ExceptT $ fetchEither url { headers: reqHeaders, mode: Cors } allowedStatusCodes FetchError - lift (jsonBody res) >>= decodeResponse' status >>> case _ of - Left err -> throwError err - Right payload -> pure { payload, headers: resHeaders, status } - -merkleize - :: forall err - . DecodeJson (ApiError err) - => ServerURL - -> PostMerkleizationRequest - -> Aff - ( Either - (ClientError err) - { headers :: Headers - , payload :: PostMerkleizationResponse - , status :: Int - } - ) -merkleize (ServerURL serverUrl) req = runExceptT do - let - url = serverUrl <> "/contracts/merkleize" - body = stringify $ encodeJsonBody req - - headers :: { "Accept" :: String, "Content-Type" :: String } - headers = - { "Accept": "application/json" - , "Content-Type": "application/json" - } - - res@{ status, headers: resHeaders } <- ExceptT $ fetchEither url { method: POST, body, headers } allowedStatusCodes FetchError - lift (jsonBody res) >>= decodeResponse' status >>> case _ of - Left err -> throwError err - Right payload -> pure { payload, headers: resHeaders, status } - -getPage - :: forall a err - . DecodeJson a - => DecodeJson (ApiError err) - => ServerURL - -> ResourceLink a - -> Maybe Range - -> Aff (GetResourceResponse err ({ page :: a, nextRange :: Maybe Range })) -getPage serverUrl path possibleRange = runExceptT do - { headers, payload, status } <- ExceptT - $ case possibleRange of - Just range -> getResource serverUrl path { "Range": coerce range } - Nothing -> getResource serverUrl path {} - pure - { page: payload - , nextRange: - if status == 206 then map Range $ lookup (CaseInsensitiveString "Next-Range") - $ fromFoldable - $ map (lmap CaseInsensitiveString) - $ toArray headers - else Nothing - } - --- TODO generalize -foldMapMContractPages - :: forall @err endpoint - . ToResourceLink endpoint (Array GetContractsResponse) - => DecodeJson (ApiError err) - => ServerURL - -> endpoint - -> Maybe Range - -> (Array GetContractsResponse -> Aff { result :: Array GetContractsResponse, stopFetching :: Boolean }) - -> Aff (Either (ClientError err) (Array GetContractsResponse)) -foldMapMContractPages serverUrl endpoint start f = - foldMapMPages' serverUrl endpoint (f <<< _.page) start - -data FoldPageStep = FetchPage (Maybe Range) | StopFetching - -foldMapMPages - :: forall a b err m - . DecodeJson a - => DecodeJson (ApiError err) - => MonadAff m - => Monoid b - => ServerURL - -> ResourceLink a - -> ({ page :: a, currRange :: Maybe Range } -> m { result :: b, stopFetching :: Boolean }) - -> Maybe Range - -> m (GetResourceResponse err b) -foldMapMPages serverUrl path f startRange = do - bs <- runExceptT $ flip unfoldrM (FetchPage startRange) case _ of - StopFetching -> pure Nothing - FetchPage currRange -> do - { page, nextRange } <- ExceptT $ liftAff $ getPage serverUrl path currRange - { result: b, stopFetching } <- lift $ f { page, currRange } - pure $ Just case nextRange of - Just _ -> b /\ - if stopFetching then StopFetching - else (FetchPage nextRange) - Nothing -> b /\ StopFetching - pure (fold <$> bs) - -getPages - :: forall a err m - . DecodeJson a - => DecodeJson (ApiError err) - => MonadAff m - => ServerURL - -> ResourceLink a - -> Maybe Range - -> m (GetResourceResponse err (List { page :: a, currRange :: Maybe Range })) -getPages serverUrl path = foldMapMPages serverUrl path (List.singleton >>> \result -> pure { result, stopFetching: false }) - -getPages' - :: forall @err endpoint a m - . DecodeJson a - => DecodeJson (ApiError err) - => MonadAff m - => ToResourceLink endpoint a - => ServerURL - -> endpoint - -> Maybe Range - -> m (GetResourceResponse err (List { page :: a, currRange :: Maybe Range })) -getPages' serverUrl endpoint = getPages serverUrl (toResourceLink endpoint) - -getItems - :: forall err f t b - . DecodeJson b - => DecodeJson (ApiError err) - => MonadAff f - => ToResourceLink t b - => Monoid b - => ServerURL - -> t - -> Maybe Range - -> f (Either (ClientError err) b) -getItems serverUrl endpoint range = do - getPages serverUrl (toResourceLink endpoint) range <#> case _ of - Left err -> Left err - Right pages -> Right $ foldMap _.page pages - -getItems' - :: forall @err f endpoint b - . MonadAff f - => DecodeJson b - => DecodeJson (ApiError err) - => ToResourceLink endpoint b - => Monoid b - => ServerURL - -> endpoint - -> Maybe Range - -> f (Either (ClientError err) b) -getItems' serverUrl endpoint range = do - getPages' serverUrl endpoint range <#> case _ of - Left err -> Left err - Right pages -> Right $ foldMap _.page pages - -getResource' - :: forall @err a extraHeaders endpoint - . DecodeJson a - => DecodeJson (ApiError err) - -- => Row.Lacks "Accept" extraHeaders - => Row.Lacks "Access-Control-Request-Headers" extraHeaders - => Row.Homogeneous ("Access-Control-Request-Headers" :: String | extraHeaders) String - => ToResourceLink endpoint a - => ServerURL - -> endpoint - -> Record extraHeaders - -> Aff (GetResourceResponse err { headers :: Headers, payload :: a, status :: Int }) -getResource' serverUrl path = getResource serverUrl (toResourceLink path) - -getPage' - :: forall a endpoint err - . DecodeJson a - => DecodeJson (ApiError err) - => ToResourceLink endpoint a - => ServerURL - -> endpoint - -> Maybe Range - -> Aff (GetResourceResponse err ({ page :: a, nextRange :: Maybe Range })) -getPage' serverUrl path = getPage serverUrl (toResourceLink path) - -foldMapMPages' - :: forall a b err m t - . DecodeJson a - => DecodeJson (ApiError err) - => MonadAff m - => Monoid b - => ToResourceLink t a - => ServerURL - -> t - -> ({ currRange :: Maybe Range, page :: a } -> m { result :: b, stopFetching :: Boolean }) - -> Maybe Range - -> m (Either (ClientError err) b) -foldMapMPages' serverUrl path = foldMapMPages serverUrl (toResourceLink path) - -post - :: forall err postRequest postResponse postResponseLinks getResponse getResponseLinks extraHeaders - . DecodeJson postResponse - => DecodeJson (ApiError err) - => EncodeHeaders postRequest extraHeaders - => EncodeJsonBody postRequest - => DecodeRecord (resource :: DecodeJsonFieldFn postResponse) (ResourceWithLinksRow postResponse postResponseLinks) - => Row.Homogeneous extraHeaders String - => Row.Homogeneous ("Content-Type" :: String | extraHeaders) String - -- => Row.Lacks "Accept" extraHeaders - => Row.Lacks "Content-Type" extraHeaders - => ServerURL - -> IndexEndpoint postRequest postResponse postResponseLinks getResponse getResponseLinks - -> postRequest - -> Aff (GetResourceResponse err (ResourceWithLinks postResponse postResponseLinks)) -post (ServerURL serverUrl) (IndexEndpoint (ResourceLink path)) req = runExceptT do - let - url = serverUrl <> "/" <> path - body = stringify $ encodeJsonBody req - - headers :: { "Content-Type" :: String | extraHeaders } - headers = - -- R.insert (Proxy :: Proxy "Accept") "application/json" - R.insert (Proxy :: Proxy "Content-Type") "application/json" - $ (encodeHeaders req :: { | extraHeaders }) - - response@{ status } <- ExceptT $ fetchEither url { method: POST, body, headers } allowedStatusCodes FetchError - (lift (jsonBody response)) >>= decodeResponseWithLink (map decodeJson :: Maybe _ -> Maybe _) status >>> case _ of - Left err -> throwError err - Right payload -> pure payload - -post' - :: forall t @err postRequest postResponse postResponseLinks getResponse getResponseLinks extraHeaders - . Newtype t (IndexEndpoint postRequest postResponse postResponseLinks getResponse getResponseLinks) - => DecodeJson postResponse - => DecodeJson (ApiError err) - => DecodeRecord (resource :: DecodeJsonFieldFn postResponse) (ResourceWithLinksRow postResponse postResponseLinks) - => EncodeHeaders postRequest extraHeaders - => EncodeJsonBody postRequest - => Row.Homogeneous extraHeaders String - => Row.Homogeneous ("Content-Type" :: String | extraHeaders) String - -- => Row.Lacks "Accept" extraHeaders - => Row.Lacks "Content-Type" extraHeaders - => ServerURL - -> t - -> postRequest - -> Aff (Either (ClientError err) (ResourceWithLinks postResponse postResponseLinks)) -post' serverUrl endpoint req = do - let - endpoint' = unwrap endpoint - post serverUrl endpoint' req - -put - :: forall links putRequest getResponse extraHeaders - . EncodeHeaders putRequest extraHeaders - => EncodeJsonBody putRequest - => Row.Homogeneous extraHeaders String - => Row.Homogeneous ("Content-Type" :: String | extraHeaders) String - -- => Row.Lacks "Accept" extraHeaders - => Row.Lacks "Content-Type" extraHeaders - => ServerURL - -> ResourceEndpoint putRequest getResponse links - -> putRequest - -> Aff (Either FetchError Unit) -put (ServerURL serverUrl) (ResourceEndpoint (ResourceLink path)) req = runExceptT do - let - url = serverUrl <> "/" <> path - body = stringify $ encodeJsonBody req - - headers :: { "Content-Type" :: String | extraHeaders } - headers = - -- R.insert (Proxy :: Proxy "Accept") "application/json" - R.insert (Proxy :: Proxy "Content-Type") "application/json" - $ (encodeHeaders req :: { | extraHeaders }) - void $ ExceptT $ fetchEither url { method: PUT, body, headers } allowedStatusCodes identity - -put' - :: forall links putRequest getResponse extraHeaders t - . EncodeHeaders putRequest extraHeaders - => EncodeJsonBody putRequest - => Newtype t (ResourceEndpoint putRequest getResponse links) - => Row.Homogeneous extraHeaders String - => Row.Homogeneous ("Content-Type" :: String | extraHeaders) String - -- => Row.Lacks "Accept" extraHeaders - => Row.Lacks "Content-Type" extraHeaders - => ServerURL - -> t - -> putRequest - -> Aff (Either FetchError Unit) -put' serverUrl endpoint req = do - let - endpoint' = unwrap endpoint - put serverUrl endpoint' req diff --git a/src/Marlowe/Runtime/Web/Streaming.purs b/src/Marlowe/Runtime/Web/Streaming.purs deleted file mode 100644 index 35b14924..00000000 --- a/src/Marlowe/Runtime/Web/Streaming.purs +++ /dev/null @@ -1,402 +0,0 @@ -module Marlowe.Runtime.Web.Streaming - ( contracts - , contractsTransactions - , contractsStates - , contractsWithTransactions - , mkContractsWithTransactions - , ContractEvent - , ContractMap - , ContractStream(..) - , ContractStateStream(..) - , ContractStateEvent(..) - , ContractStateMap(..) - , ContractTransactionsEvent - , ContractTransactionsMap - , ContractTransactionsStream(..) - , ContractWithTransactionsEvent(..) - , ContractWithTransactionsMap - , ContractWithTransactions - , ContractWithTransactionsStream(..) - , MaxPages(..) - , PollingInterval(..) - , RequestInterval(..) - , TxHeaderWithEndpoint(..) - ) where - -import Prelude - -import Contrib.Data.Map (New(..), Old(..), additions, deletions, fromFoldableBy, updates) as Map -import Contrib.Effect as Effect -import Control.Alt ((<|>)) -import Control.Monad.Error.Class (catchError) -import Control.Monad.Rec.Class (forever) -import Control.Parallel (parSequence) -import Data.Filterable (filter) -import Data.Foldable (foldMap) -import Data.Map (Map) -import Data.Map (catMaybes, empty, filter, fromFoldable, lookup, union) as Map -import Data.Maybe (Maybe(..), fromMaybe) -import Data.Newtype as Newtype -import Data.Traversable (for_) -import Data.TraversableWithIndex (forWithIndex) -import Data.Tuple (fst, snd) -import Data.Tuple.Nested (type (/\), (/\)) -import Effect (Effect) -import Effect.Aff (Aff, Milliseconds, delay) -import Effect.Aff.AVar as AVar -import Effect.Class (liftEffect) -import Effect.Ref as Ref -import Halogen.Subscription (Listener) -import Halogen.Subscription as Subscription -import Marlowe.Runtime.Web.Client (foldMapMContractPages, getPages', getResource') -import Marlowe.Runtime.Web.Types (ContractEndpoint, ContractId, ContractState, GetContractResponse, GetContractsResponse, ServerURL, TransactionEndpoint, TransactionsEndpoint, TxHeader, api) - --- | API CAUTION: We update the state in chunks but send the events one by one. This means that --- | the event handler can see some state changes (in `getLiveState`) before it receives some notifications. --- | `getState` provides a consistent but possibly blocking view of the state. - -data ContractEvent - = Addition GetContractsResponse - | Deletion GetContractsResponse - | Update { old :: GetContractsResponse, new :: GetContractsResponse } - -contractsById :: Array GetContractsResponse -> Map ContractId GetContractsResponse -contractsById = Map.fromFoldableBy $ _.contractId <<< Newtype.unwrap <<< _.resource - -newtype RequestInterval = RequestInterval Milliseconds - -newtype PollingInterval = PollingInterval Milliseconds - --- | TODO: Provide nicer types. -type ContractMap = Map ContractId GetContractsResponse - -newtype ContractStream = ContractStream - { emitter :: Subscription.Emitter ContractEvent - , getLiveState :: Effect ContractMap - , getState :: Aff ContractMap - , start :: Aff Unit - } - -newtype MaxPages = MaxPages Int - --- | FIXME: take closer at error handling woudn't this component break in the case of network error? --- | TODO: we should return `Aff` or fiber and allow more flexible "threading" management. --- Use constraint at the end: `Warn (Text "pushPullContractsStreams is deprecated, use web socket based implementation instead!")` -contracts - :: PollingInterval - -> RequestInterval - -> (GetContractsResponse -> Boolean) - -> Maybe MaxPages - -> ServerURL - -> Aff ContractStream -contracts (PollingInterval pollingInterval) (RequestInterval requestInterval) filterContracts possibleMaxPages serverUrl = do - contractsRef <- liftEffect $ Ref.new Map.empty - pageNumberRef <- liftEffect $ Ref.new 0 - contractsAVar <- AVar.empty - - { emitter, listener } <- liftEffect Subscription.create - - let - range = Nothing - - let - start = forever do - liftEffect $ Ref.write 0 pageNumberRef - void $ AVar.tryTake contractsAVar - previousContracts <- liftEffect $ Ref.read contractsRef - nextContracts :: Map ContractId GetContractsResponse <- - map contractsById $ Effect.liftEither =<< foldMapMContractPages @String serverUrl api range \pageContracts -> do - let - pageContracts' = filter filterContracts pageContracts - liftEffect do - let - cs :: Map ContractId GetContractsResponse - cs = contractsById pageContracts' - Ref.modify_ (Map.union cs) contractsRef - for_ (Map.additions (Map.Old previousContracts) (Map.New cs)) $ Subscription.notify listener <<< Addition - for_ (Map.updates (Map.Old previousContracts) (Map.New cs)) $ Subscription.notify listener <<< Update - pageNumber <- liftEffect $ Ref.modify (add 1) pageNumberRef - delay requestInterval - pure - { result: pageContracts' - , stopFetching: case possibleMaxPages of - Nothing -> false - Just (MaxPages maxPages) -> pageNumber >= maxPages - } - liftEffect do - Ref.write nextContracts contractsRef - for_ (Map.deletions (Map.Old previousContracts) (Map.New nextContracts)) $ Subscription.notify listener <<< Deletion - AVar.put nextContracts contractsAVar - delay pollingInterval - - pure $ ContractStream - { emitter - , getLiveState: Ref.read contractsRef - , getState: AVar.read contractsAVar - , start - } - --- | The input set of endpoints which should be used for quering transactions. -type TransactionsEndpointsSource = Map ContractId TransactionsEndpoint - --- | The resuling set of txs per contract. -type ContractTransactionsMap = Map ContractId (Array TxHeaderWithEndpoint) - -type ContractTransactionsEvent - = ContractId - /\ { new :: Array TxHeaderWithEndpoint, old :: Maybe (Array TxHeaderWithEndpoint) } - -newtype ContractTransactionsStream = ContractTransactionsStream - { emitter :: Subscription.Emitter ContractTransactionsEvent - , getLiveState :: Effect ContractTransactionsMap - , getState :: Aff ContractTransactionsMap - , start :: Aff Unit - } - --- | FIXME: take closer at error handling woudn't this component break in the case of network error? -contractsTransactions - :: PollingInterval - -> RequestInterval - -> Aff TransactionsEndpointsSource - -> ServerURL - -> Aff ContractTransactionsStream -contractsTransactions (PollingInterval pollingInterval) requestInterval getEndpoints serverUrl = do - stateRef <- liftEffect $ Ref.new Map.empty - stateAVar <- AVar.empty - - { emitter, listener } <- liftEffect Subscription.create - - let - start = forever do - void $ AVar.tryTake stateAVar - previousState <- liftEffect $ Ref.read stateRef - endpoints <- getEndpoints - { contractsTransactions: newState, notify } <- fetchContractsTransactions endpoints previousState listener requestInterval serverUrl - - liftEffect do - Ref.write newState stateRef - notify - AVar.put newState stateAVar - delay pollingInterval - - pure $ ContractTransactionsStream - { emitter - , getLiveState: Ref.read stateRef - , getState: AVar.read stateAVar - , start - } - -fetchContractsTransactions - :: TransactionsEndpointsSource - -> ContractTransactionsMap - -> Listener ContractTransactionsEvent - -> RequestInterval - -> ServerURL - -> Aff - { contractsTransactions :: ContractTransactionsMap - , notify :: Effect Unit - } -fetchContractsTransactions endpoints prevContractTransactionMap listener (RequestInterval requestInterval) serverUrl = do - items <- map Map.catMaybes $ forWithIndex endpoints \contractId transactionEndpoint -> do - let - action = do - let - getTransactions = do - pages <- getPages' @String serverUrl transactionEndpoint Nothing >>= Effect.liftEither - pure $ foldMap _.page pages - (txHeaders :: Array { resource :: TxHeader, links :: { transaction :: TransactionEndpoint } }) <- getTransactions - delay requestInterval - let - prevTransactions = Map.lookup contractId prevContractTransactionMap - newTransactions = txHeaders <#> \{ resource, links: { transaction: transactionEndpoint' }} -> - resource /\ transactionEndpoint' - change = - if Just (map fst newTransactions) == (map fst <$> prevTransactions) then - Nothing - else - Just { old: prevTransactions, new: newTransactions } - pure $ Just $ change /\ contractId /\ newTransactions - action `catchError` \_ -> do - pure Nothing - - let - doNotify = - for_ items $ case _ of - (Just change /\ contractId /\ _) -> do - Subscription.notify listener (contractId /\ change) - _ -> pure unit - - pure - { contractsTransactions: Map.fromFoldable (items <#> snd) - , notify: doNotify - } - --- | The input set of endpoints which should be used for quering transactions. -type ContractEndpointsSource = Map ContractId ContractEndpoint - --- | The resuling set of txs per contract. -type ContractStateMap = Map ContractId ContractState - -type ContractStateEvent = ContractId /\ { new :: ContractState, old :: Maybe ContractState } - -newtype ContractStateStream = ContractStateStream - { emitter :: Subscription.Emitter ContractStateEvent - , getLiveState :: Effect ContractStateMap - , getState :: Aff ContractStateMap - , start :: Aff Unit - } - --- | FIXME: the same as above - take closer at error handling woudn't this component break in the case of network error? -contractsStates - :: PollingInterval - -> RequestInterval - -> Aff ContractEndpointsSource - -> ServerURL - -> Aff ContractStateStream -contractsStates (PollingInterval pollingInterval) requestInterval getEndpoints serverUrl = do - stateRef <- liftEffect $ Ref.new Map.empty - stateAVar <- AVar.empty - - { emitter, listener } <- liftEffect Subscription.create - - let - start = forever do - void $ AVar.tryTake stateAVar - previousState <- liftEffect $ Ref.read stateRef - endpoints <- getEndpoints - { contractsStates: newState, notify } <- fetchContractsStates endpoints previousState listener requestInterval serverUrl - - liftEffect do - Ref.write newState stateRef - notify - AVar.put newState stateAVar - - delay pollingInterval - pure $ ContractStateStream - { emitter - , getLiveState: Ref.read stateRef - , getState: AVar.read stateAVar - , start - } - -fetchContractsStates - :: ContractEndpointsSource - -> ContractStateMap - -> Listener ContractStateEvent - -> RequestInterval - -> ServerURL - -> Aff - { contractsStates :: ContractStateMap - , notify :: Effect Unit - } -fetchContractsStates endpoints prevContractStateMap listener (RequestInterval requestInterval) serverUrl = do - items <- map Map.catMaybes $ forWithIndex endpoints \contractId endpoint -> do - let - action = do - let - getContractState = (getResource' @String serverUrl endpoint {} >>= Effect.liftEither) <#> _.payload.resource -- <#> foldMap _.page - (newContractState :: ContractState) <- getContractState - delay requestInterval - let - oldContractState = Map.lookup contractId prevContractStateMap - change = if oldContractState /= Just newContractState - then Nothing - else pure { old: oldContractState, new: newContractState } - pure $ Just $ change /\ contractId /\ newContractState - action `catchError` \_ -> do - pure Nothing - - let - doNotify = - for_ items $ case _ of - (Just change /\ contractId /\ _) -> do - Subscription.notify listener (contractId /\ change) - _ -> pure unit - - pure - { contractsStates: Map.fromFoldable (items <#> snd) - , notify: doNotify - } - -type TxHeaderWithEndpoint = TxHeader /\ TransactionEndpoint - -type ContractWithTransactions = - { contract :: GetContractsResponse - -- | This fetch is done for every contract - -- | but we don't want to wait with the updates - -- | until all the states are fetched. - , contractState :: Maybe GetContractResponse - , transactions :: Array TxHeaderWithEndpoint - } - -type ContractWithTransactionsMap = Map ContractId ContractWithTransactions - -data ContractWithTransactionsEvent - = ContractEvent ContractEvent - | ContractStateEvent ContractStateEvent - | ContractTransactionsEvent ContractTransactionsEvent - -newtype ContractWithTransactionsStream = ContractWithTransactionsStream - { emitter :: Subscription.Emitter ContractWithTransactionsEvent - , getLiveState :: Effect ContractWithTransactionsMap - , getState :: Aff ContractWithTransactionsMap - , start :: Aff Unit - } - -contractsWithTransactions :: ContractStream -> ContractStateStream -> ContractTransactionsStream -> ContractWithTransactionsStream -contractsWithTransactions (ContractStream contractStream) (ContractStateStream contractStateStream) (ContractTransactionsStream contractTransactionsStream) = do - let - getLiveState = do - contractMap <- contractStream.getLiveState - contractTransactionsMap <- contractTransactionsStream.getLiveState - contractStateMap <- contractStateStream.getLiveState - - forWithIndex contractMap \contractId contract -> do - let - transactions = fromMaybe [] $ Map.lookup contractId contractTransactionsMap - contractState = Map.lookup contractId contractStateMap - pure { contract, contractState, transactions } - - getState = do - contractMap <- contractStream.getState - contractStateMap <- contractStateStream.getState - contractTransactionsMap <- contractTransactionsStream.getState - - forWithIndex contractMap \contractId contract -> do - let - transactions = fromMaybe [] $ Map.lookup contractId contractTransactionsMap - contractState = Map.lookup contractId contractStateMap - pure { contract, contractState, transactions } - - emitter = (ContractEvent <$> contractStream.emitter) - <|> (ContractTransactionsEvent <$> contractTransactionsStream.emitter) - <|> (ContractStateEvent <$> contractStateStream.emitter) - - start = map (const unit) $ parSequence - [ void $ contractStateStream.start - , void $ contractTransactionsStream.start - , void $ contractStream.start - ] - - ContractWithTransactionsStream { emitter, getLiveState, getState, start } - -mkContractsWithTransactions :: PollingInterval -> RequestInterval -> (GetContractsResponse -> Boolean) -> Maybe MaxPages -> ServerURL -> Aff ContractWithTransactionsStream -mkContractsWithTransactions pollingInterval requestInterval filterContracts possibleMaxPages serverUrl = do - contractStream@(ContractStream { getState }) <- contracts pollingInterval requestInterval filterContracts possibleMaxPages serverUrl - let - transactionEndpointsSource = Map.catMaybes <<< map (_.links.transactions) <<< Map.filter filterContracts <$> getState - contractEndpointsSource = map (_.links.contract) <<< Map.filter filterContracts <$> getState - - contractStateStream <- contractsStates - pollingInterval - requestInterval - contractEndpointsSource - serverUrl - - contractTransactionsStream <- contractsTransactions - pollingInterval - requestInterval - transactionEndpointsSource - serverUrl - - pure $ contractsWithTransactions contractStream contractStateStream contractTransactionsStream diff --git a/src/Marlowe/Runtime/Web/Types.purs b/src/Marlowe/Runtime/Web/Types.purs deleted file mode 100644 index 245d3556..00000000 --- a/src/Marlowe/Runtime/Web/Types.purs +++ /dev/null @@ -1,939 +0,0 @@ -module Marlowe.Runtime.Web.Types where - -import Prelude - -import CardanoMultiplatformLib (Bech32, CborHex, bech32ToString) -import CardanoMultiplatformLib.Transaction (TransactionObject, TransactionWitnessSetObject) -import CardanoMultiplatformLib.Types (unsafeBech32) -import Contrib.Data.Argonaut (JsonParser, JsonParserResult, decodeFromString) -import Contrib.Data.Argonaut.Generic.Record (class DecodeRecord, DecodeJsonFieldFn, decodeRecord, decodeNewtypedRecord) -import Data.Argonaut (class DecodeJson, class EncodeJson, Json, JsonDecodeError(..), decodeJson, encodeJson, stringify) -import Data.Argonaut.Core (isString) -import Data.Argonaut.Decode.Combinators ((.:)) -import Data.Argonaut.Decode.Decoders (decodeJObject, decodeMaybe) -import Data.DateTime (DateTime) -import Data.DateTime.ISO (ISO(..)) -import Data.Either (Either, note) -import Data.Generic.Rep (class Generic) -import Data.Int as Int -import Data.JSDate as JSDate -import Data.Map (Map) -import Data.Map as Map -import Data.Maybe (Maybe(..)) -import Data.Newtype (class Newtype, un, unwrap) -import Data.Profunctor.Strong ((***)) -import Data.Set (Set) -import Data.Show.Generic (genericShow) -import Data.String as String -import Data.Traversable (for) -import Data.Tuple.Nested (type (/\), (/\)) -import Effect.Unsafe (unsafePerformEffect) -import Foreign.Object (Object) -import Foreign.Object as Object -import Language.Marlowe.Core.V1.Semantics.Types as V1 -import Record as Record -import Type.Row (type (+)) -import Type.Row.Homogeneous as Row - --- Lower level error representation which we get from the API. --- We turn this into a well typed error on a case by case basis. --- Currently API returns back this encoding for errors: --- ``` --- { message :: String --- , errorCode :: String --- , details :: Json --- } --- ``` -newtype ApiError error = ApiError - { message :: String - , error :: error - } -derive instance Generic (ApiError err) _ -derive instance Newtype (ApiError err) _ - -decodeApiError :: forall err. (String -> Json -> err) -> Json -> JsonParserResult (ApiError err) -decodeApiError decodeError json = do - obj <- decodeJson json - message <- obj .: "message" - errorCode <- obj .: "errorCode" - details <- obj .: "details" - pure $ ApiError { message, error: decodeError errorCode details } - -instance DecodeJson (ApiError String) where - decodeJson = decodeApiError $ \errorCode details -> errorCode <> ": " <> stringify details - -instance Show err => Show (ApiError err) where - show (ApiError { message, error }) = - "ApiError { message: " <> show message <> ", error: " <> show error <> " }" - -newtype TxId = TxId String - -derive instance Generic TxId _ -derive instance Newtype TxId _ -derive instance Eq TxId -derive instance Ord TxId -instance DecodeJson TxId where - decodeJson = map TxId <$> decodeJson - -newtype TxOutRef = TxOutRef - { txId :: TxId - , txIx :: Int - } - -derive instance Generic TxOutRef _ -derive instance Eq TxOutRef -derive instance Ord TxOutRef -derive instance Newtype TxOutRef _ -instance DecodeJson TxOutRef where - decodeJson = decodeFromString $ String.split (String.Pattern "#") >>> case _ of - [ txId, txIxStr ] -> do - txIx <- Int.fromString txIxStr - pure $ TxOutRef { txId: TxId txId, txIx } - _ -> Nothing - -txOutRefFromString :: String -> Maybe TxOutRef -txOutRefFromString = String.split (String.Pattern "#") >>> case _ of - [ txId, txIxStr ] -> do - txIx <- Int.fromString txIxStr - pure $ TxOutRef { txId: TxId txId, txIx } - _ -> Nothing - -txOutRefToString :: TxOutRef -> String -txOutRefToString (TxOutRef { txId: TxId txId, txIx }) = txId <> "#" <> show txIx - -txOutRefToUrlEncodedString :: TxOutRef -> String -txOutRefToUrlEncodedString (TxOutRef { txId: TxId txId, txIx }) = txId <> "%23" <> show txIx - -type ContractId = TxOutRef - -newtype PolicyId = PolicyId String - -derive instance Generic PolicyId _ -derive instance Newtype PolicyId _ -derive instance Eq PolicyId -derive instance Ord PolicyId - -instance Show PolicyId where - show = genericShow - -instance EncodeJson PolicyId where - encodeJson (PolicyId id) = encodeJson id - -instance DecodeJson PolicyId where - decodeJson = map PolicyId <$> decodeJson - -data MarloweVersion = V1 - -derive instance Generic MarloweVersion _ -derive instance Eq MarloweVersion -derive instance Ord MarloweVersion -instance EncodeJson MarloweVersion where - encodeJson = encodeJson <<< case _ of - V1 -> "v1" - -instance DecodeJson MarloweVersion where - decodeJson = decodeFromString case _ of - "v1" -> Just V1 - _ -> Nothing - -data RolesConfig - = UsePolicy PolicyId - | Mint (Map String RoleTokenConfig) - -instance EncodeJson RolesConfig where - encodeJson (UsePolicy policyId) = encodeJson policyId - encodeJson (Mint configs) = - encodeJson <<< Object.fromFoldable <<< (Map.toUnfoldable :: _ -> Array _) $ configs - -instance DecodeJson RolesConfig where - decodeJson json | isString json = UsePolicy <$> decodeJson json - decodeJson json = Mint <$> decodeJson json - -data RoleTokenConfig - = RoleTokenSimple Bech32 - | RoleTokenAdvanced Bech32 TokenMetadata - -instance EncodeJson RoleTokenConfig where - encodeJson (RoleTokenSimple addr) = encodeJson addr - encodeJson (RoleTokenAdvanced addr metadata) = - encodeJson - { address: encodeJson addr - , metadata: encodeJson metadata - } - -instance DecodeJson RoleTokenConfig where - decodeJson json | isString json = RoleTokenSimple <$> decodeJson json - decodeJson json = do - obj <- decodeJObject json - address <- obj .: "address" - metadata <- obj .: "metadata" - pure $ RoleTokenAdvanced address metadata - -newtype TokenMetadata = TokenMetadata - { name :: String - , image :: String -- URI - , mediaType :: Maybe String - , description :: Maybe String - , files :: Maybe (Array TokenMetadataFile) - } - -derive instance Generic TokenMetadata _ -derive instance Newtype TokenMetadata _ -derive instance Eq TokenMetadata -derive instance Ord TokenMetadata -derive newtype instance EncodeJson TokenMetadata -derive newtype instance DecodeJson TokenMetadata - -newtype TokenMetadataFile = TokenMetadataFile - { name :: String - , src :: String -- URI - , mediaType :: String - } - -derive instance Generic TokenMetadataFile _ -derive instance Newtype TokenMetadataFile _ -derive instance Eq TokenMetadataFile -derive instance Ord TokenMetadataFile -derive newtype instance EncodeJson TokenMetadataFile -derive newtype instance DecodeJson TokenMetadataFile - -data TxStatus - = Unsigned - | Submitted - | Confirmed - -derive instance Eq TxStatus -derive instance Ord TxStatus - -instance Show TxStatus where - show Unsigned = "Unsigned" - show Submitted = "Submitted" - show Confirmed = "Confirmed" - -instance DecodeJson TxStatus where - decodeJson = decodeFromString case _ of - "unsigned" -> Just Unsigned - "submitted" -> Just Submitted - "confirmed" -> Just Confirmed - _ -> Nothing - -newtype BlockNumber = BlockNumber Int - -derive instance Generic BlockNumber _ -derive instance Newtype BlockNumber _ -derive instance Eq BlockNumber -derive instance Ord BlockNumber -instance DecodeJson BlockNumber where - decodeJson json = BlockNumber <$> decodeJson json - -newtype SlotNumber = SlotNumber Int - -derive instance Generic SlotNumber _ -derive instance Newtype SlotNumber _ -derive instance Eq SlotNumber -derive instance Ord SlotNumber -instance DecodeJson SlotNumber where - decodeJson json = SlotNumber <$> decodeJson json - -newtype BlockHeader = BlockHeader - { slotNo :: SlotNumber - , blockNo :: BlockNumber - , blockHeaderHash :: String - } - -derive instance Generic BlockHeader _ -derive instance Newtype BlockHeader _ -derive instance Eq BlockHeader -derive instance Ord BlockHeader -instance DecodeJson BlockHeader where - decodeJson json = BlockHeader <$> decodeJson json - -newtype Metadata = Metadata (Map Int Json) - -derive instance Generic Metadata _ -derive instance Newtype Metadata _ -derive instance Eq Metadata -instance Semigroup Metadata where - append (Metadata a) (Metadata b) = Metadata (Map.union a b) - -instance Monoid Metadata where - mempty = Metadata Map.empty - -instance EncodeJson Metadata where - encodeJson = encodeJson - <<< Object.fromFoldable - <<< map (show *** identity) - <<< (Map.toUnfoldable :: _ -> Array _) - <<< un Metadata - -instance DecodeJson Metadata where - decodeJson json = do - (obj :: Object Json) <- decodeJson json - - (arr :: Array (Int /\ Json)) <- for (Object.toUnfoldable obj) \(idx /\ value) -> do - idx' <- do - let - err = TypeMismatch $ "Expecting an integer metadata label but got: " <> show idx - note err $ Int.fromString idx - pure (idx' /\ value) - pure <<< Metadata <<< Map.fromFoldable $ arr - -metadataFieldDecoder :: { metadata :: DecodeJsonFieldFn Metadata } -metadataFieldDecoder = { metadata: map decodeJson :: Maybe Json -> Maybe (JsonParserResult Metadata) } - -newtype Tags = Tags (Map String Json) - -derive instance Generic Tags _ -derive instance Newtype Tags _ -derive instance Eq Tags -instance Semigroup Tags where - append (Tags a) (Tags b) = Tags (Map.union a b) - -instance Monoid Tags where - mempty = Tags Map.empty - -instance EncodeJson Tags where - encodeJson = encodeJson - <<< Object.fromFoldable - <<< (Map.toUnfoldable :: _ -> Array _) - <<< un Tags - -instance DecodeJson Tags where - decodeJson json = do - (obj :: Object Json) <- decodeJson json - pure <<< Tags <<< Map.fromFoldableWithIndex $ obj - -type ContractHeadersRowBase r = - ( contractId :: TxOutRef - , roleTokenMintingPolicyId :: PolicyId - , version :: MarloweVersion - , metadata :: Metadata - , tags :: Tags - , status :: TxStatus - , block :: Maybe BlockHeader - | r - ) - -newtype ContractHeader = ContractHeader { | ContractHeadersRowBase () } - -derive instance Generic ContractHeader _ -derive instance Newtype ContractHeader _ -derive instance Eq ContractHeader - -instance DecodeJson ContractHeader where - decodeJson = decodeNewtypedRecord metadataFieldDecoder - -type WithdrawalHeadersRowBase r = - ( withdrawalId :: TxId - , status :: TxStatus - , block :: Maybe BlockHeader - | r - ) - -newtype WithdrawalHeader = WithdrawalHeader { | WithdrawalHeadersRowBase () } - -derive instance Generic WithdrawalHeader _ -derive instance Newtype WithdrawalHeader _ -derive instance Eq WithdrawalHeader - -instance DecodeJson WithdrawalHeader where - decodeJson = decodeNewtypedRecord metadataFieldDecoder - -newtype PayoutRef = PayoutRef - { contractId :: TxOutRef - , payout :: TxOutRef - , roleTokenMintingPolicyId :: PolicyId - , role :: String - } - -derive instance Generic PayoutRef _ -derive instance Newtype PayoutRef _ -derive instance Eq PayoutRef - -newtype Withdrawal = Withdrawal - { payouts :: Set PayoutRef - , withdrawalId :: TxId - , status :: TxStatus - , block :: Maybe BlockHeader - } - -derive instance Generic Withdrawal _ -derive instance Newtype Withdrawal _ -derive instance Eq Withdrawal - -newtype TextEnvelope (a :: Type) = TextEnvelope - { type_ :: String - , description :: String - , cborHex :: CborHex a - } - -derive instance Generic (TextEnvelope a) _ -derive instance Newtype (TextEnvelope a) _ -derive instance Eq (TextEnvelope a) - -instance DecodeJson (TextEnvelope a) where - decodeJson = unsafeDecodeTextEnvelope - --- We don't loook under the hood so it is a bit "unsafe" - in a given --- context when we know what `a` "should be" we can use this function --- or the above instance. -unsafeDecodeTextEnvelope :: forall a. JsonParser (TextEnvelope a) -unsafeDecodeTextEnvelope json = TextEnvelope <$> do - (obj :: Object Json) <- decodeJson json - type_ <- obj .: "type" - description <- obj .: "description" - cborHex <- obj .: "cborHex" - pure { type_, description, cborHex } - -instance EncodeJson (TextEnvelope a) where - encodeJson (TextEnvelope { type_, description, cborHex }) = encodeJson { "type": type_, description, cborHex } - -decodeTransactionObjectTextEnvelope :: JsonParser (TextEnvelope TransactionObject) -decodeTransactionObjectTextEnvelope = unsafeDecodeTextEnvelope - -class HasTextEnvelope :: Type -> Constraint -class HasTextEnvelope a where - textEnvelopeType :: forall proxy. proxy a -> String - -instance HasTextEnvelope TransactionWitnessSetObject where - textEnvelopeType _ = "ShelleyTxWitness BabbageEra" - -instance HasTextEnvelope TransactionObject where - textEnvelopeType _ = "Tx BabbageEra" - -toTextEnvelope :: forall a. HasTextEnvelope a => CborHex a -> String -> TextEnvelope a -toTextEnvelope cborHex description = TextEnvelope - { type_: textEnvelopeType cborHex, description, cborHex } - -newtype TxBody = TxBody String - -derive instance Generic TxBody _ -derive instance Newtype TxBody _ -derive instance Eq TxBody - -newtype Payout = Payout - { payoutId :: TxOutRef - , role :: String - } - -derive instance Generic Payout _ -derive instance Newtype Payout _ -derive instance Eq Payout -derive instance Ord Payout -derive newtype instance DecodeJson Payout - -type ContractStateRow = ContractHeadersRowBase - ( initialContract :: V1.Contract - , currentContract :: Maybe V1.Contract - , state :: Maybe V1.State - , utxo :: Maybe TxOutRef - , txBody :: Maybe (TextEnvelope TransactionObject) - , unclaimedPayouts :: Array Payout - ) - -newtype ContractState = ContractState { | ContractStateRow } - -derive instance Generic ContractState _ -derive instance Newtype ContractState _ -derive instance Eq ContractState - -instance DecodeJson ContractState where - decodeJson = decodeNewtypedRecord decoders - where - decoders = - metadataFieldDecoder - `Record.merge` - { txBody: map (decodeMaybe decodeTransactionObjectTextEnvelope) :: Maybe _ -> Maybe _ } - -type TxRowBase r = - ( contractId :: TxOutRef - , transactionId :: TxId - , status :: TxStatus - , block :: Maybe BlockHeader - | r - ) - -type TxHeadersRow = TxRowBase (utxo :: Maybe TxOutRef) -newtype TxHeader = TxHeader { | TxHeadersRow } - -derive instance Generic TxHeader _ -derive instance Newtype TxHeader _ -derive instance Eq TxHeader -derive instance Ord TxHeader -instance DecodeJson TxHeader where - decodeJson = map TxHeader <$> decodeJson - -decodeUTCDateTime :: Json -> Either JsonDecodeError DateTime -decodeUTCDateTime json = do - str <- decodeJson json - -- We handle only a string with "Z" suffix - -- at the end ("Z(ero)" time shift) - note (UnexpectedValue json) $ do - -- This is `hasSuffix` check equivalent. - _ <- String.stripSuffix (String.Pattern "Z") str - let - jsDate = unsafePerformEffect $ JSDate.parse $ str - JSDate.toDateTime jsDate - -type TxRow = TxRowBase - ( inputUtxo :: TxOutRef - -- , inputContract :: V1.Contract - -- , inputState :: V1.State - , inputs :: Array V1.Input - , outputUtxo :: Maybe TxOutRef - , outputContract :: Maybe V1.Contract - , outputState :: Maybe V1.State - , consumingTx :: Maybe TxId - , invalidBefore :: DateTime - , invalidHereafter :: DateTime - , txBody :: Maybe (TextEnvelope TransactionObject) - ) - -newtype Tx = Tx { | TxRow } - -derive instance Generic Tx _ -derive instance Newtype Tx _ -derive instance Eq Tx -instance DecodeJson Tx where - decodeJson = do - decodeNewtypedRecord - { invalidBefore: map decodeUTCDateTime :: Maybe _ -> Maybe _ - , invalidHereafter: map decodeUTCDateTime :: Maybe _ -> Maybe _ - , txBody: map (decodeMaybe decodeTransactionObjectTextEnvelope) :: Maybe _ -> Maybe _ - } - -newtype ServerURL = ServerURL String - -bech32ToParty :: Bech32 -> V1.Party -bech32ToParty bech32 = V1.Address (bech32ToString bech32) - -partyToBech32 :: V1.Party -> Maybe Bech32 -partyToBech32 (V1.Address str) = Just $ unsafeBech32 str -partyToBech32 _ = Nothing - -newtype ResourceLink :: Type -> Type -newtype ResourceLink resource = ResourceLink String - -derive instance Generic (ResourceLink resource) _ -derive instance Newtype (ResourceLink resource) _ -derive instance Eq (ResourceLink resource) -derive instance Ord (ResourceLink resource) -instance DecodeJson (ResourceLink resource) where - decodeJson json = ResourceLink <$> decodeJson json - -type ResourceWithLinksRow resource linksRow = - ( links :: { | linksRow } - , resource :: resource - ) - -type ResourceWithLinks :: Type -> Row Type -> Type -type ResourceWithLinks resource linksRow = { | ResourceWithLinksRow resource linksRow } - --- | We perform GET and POST against this endpoint. Links structure is shared between response and resource. -newtype IndexEndpoint :: Type -> Type -> Row Type -> Type -> Row Type -> Type -newtype IndexEndpoint postRequest postResponse postResponseLinks getResponse getResponseLinks = - IndexEndpoint (ResourceLink (Array (ResourceWithLinks getResponse getResponseLinks))) - -type IndexEndpoint' postRequest postResponse getResponse links = - IndexEndpoint postRequest postResponse links getResponse links - -derive instance Eq (IndexEndpoint postRequest postResponse postResponseLinks getResponse getResponseLinks) -derive instance Newtype (IndexEndpoint postRequest postResponse postResponseLinks getResponse getResponseLinks) _ -derive newtype instance DecodeJson (IndexEndpoint postRequest postResponse postResponseLinks getResponse getResponseLinks) - --- | We perform GET and PUT against this endpoint. -newtype ResourceEndpoint :: Type -> Type -> Row Type -> Type -newtype ResourceEndpoint putRequest getResponse links = - ResourceEndpoint (ResourceLink (ResourceWithLinks getResponse links)) - -derive instance Eq (ResourceEndpoint putRequest getResponse links) -derive instance Newtype (ResourceEndpoint putRequest getResponse links) _ -derive newtype instance DecodeJson (ResourceEndpoint putRequest getResponse links) - -class ToResourceLink t a | t -> a where - toResourceLink :: t -> ResourceLink a - -instance ToResourceLink (ResourceLink a) a where - toResourceLink = identity -else instance ToResourceLink (ResourceEndpoint putRequest getResponse links) (ResourceWithLinks getResponse links) where - toResourceLink (ResourceEndpoint link) = toResourceLink link -else instance ToResourceLink (IndexEndpoint postRequest postResponse postResponsLinks getResponse getResponseLinks) (Array (ResourceWithLinks getResponse getResponseLinks)) where - toResourceLink (IndexEndpoint link) = toResourceLink link --- | I'm closing the type class here for convenience. If we want to have other instances we can drop this approach. -else instance (Newtype n t, ToResourceLink t a) => ToResourceLink n a where - toResourceLink = toResourceLink <<< unwrap - -decodeResourceWithLink - :: forall a linksRow - . DecodeRecord (resource :: DecodeJsonFieldFn a) (ResourceWithLinksRow a linksRow) - => DecodeJsonFieldFn a - -> Json - -> Either JsonDecodeError (ResourceWithLinks a linksRow) -decodeResourceWithLink decodeResource = decodeRecord { resource: decodeResource } - -class EncodeHeaders a r | a -> r where - encodeHeaders :: Row.Homogeneous r String => a -> { | r } - -class EncodeJsonBody a where - encodeJsonBody :: a -> Json - --- API Endpoints -newtype PostMerkleizationRequest = PostMerkleizationRequest - { contract :: V1.Contract - } - -instance EncodeJsonBody PostMerkleizationRequest where - encodeJsonBody (PostMerkleizationRequest r) = encodeJson - { contract: r.contract - } - -newtype PostMerkleizationResponse = PostMerkleizationResponse - { contract :: V1.Contract - , continuations :: Map String V1.Contract - } - -derive instance Newtype PostMerkleizationResponse _ - -derive newtype instance DecodeJson PostMerkleizationResponse - -newtype PostContractsRequest = PostContractsRequest - { metadata :: Metadata - -- , version :: MarloweVersion - , roles :: Maybe RolesConfig - , tags :: Tags - , contract :: V1.Contract - , minUTxODeposit :: V1.Ada - , changeAddress :: Bech32 - , addresses :: Array Bech32 - , collateralUTxOs :: Array TxOutRef - } - -instance EncodeJsonBody PostContractsRequest where - encodeJsonBody (PostContractsRequest r) = encodeJson - { metadata: r.metadata - , tags: r.tags - , version: V1 - , roles: r.roles - , contract: r.contract - , minUTxODeposit: r.minUTxODeposit - } - -type PostContractsHeadersRow = - ( "X-Change-Address" :: String - , "X-Address" :: String - , "Accept" :: String - -- , "X-Collateral-UTxO" :: String - ) - -instance EncodeHeaders PostContractsRequest PostContractsHeadersRow where - encodeHeaders (PostContractsRequest { changeAddress, addresses }) = - { "X-Change-Address": bech32ToString changeAddress - , "X-Address": String.joinWith "," (map bech32ToString addresses) - , "Accept": "application/vendor.iog.marlowe-runtime.contract-tx-json" - -- FIXME: Empty collateral causes request rejection so ... this header record representation - -- gonna be hard to maintain and we should switch to `Object String` probably and use - -- lower level fetch API. - -- , "X-Collateral-UTxO": String.joinWith "," (map txOutRefToString collateralUTxOs) - } - --- FIXME: paluh. Change `txBody` to `tx` because we send(ing) on our branch the actual transaction and not --- just the body. -newtype PostContractsResponseContent = PostContractsResponseContent - { contractId :: TxOutRef - , tx :: TextEnvelope TransactionObject - } - -derive instance Newtype PostContractsResponseContent _ - -instance DecodeJson PostContractsResponseContent where - decodeJson = decodeNewtypedRecord - { tx: map decodeTransactionObjectTextEnvelope :: Maybe _ -> Maybe _ } - -type ContractEndpointRow r = ("contract" :: ContractEndpoint | r) - -type TransactionsEndpointRow r = ("transactions" :: Maybe TransactionsEndpoint | r) - -type PostContractsResponse = ResourceWithLinks PostContractsResponseContent (ContractEndpointRow + ()) - -data PostContractsError - = MintingUtxoNotFound - | RoleTokenNotFound - | ToCardanoError - | MissingMarloweInput - | PayoutInputNotFound - | CalculateMinUtxoFailed - | CoinSelectionFailed - | BalancingError - | MarloweContractNotFound - | MarloweContractVersionMismatch - | LoadMarloweContextToCardanoError - | MarloweScriptNotPublished - | PayoutScriptNotPublished - | ExtractCreationError - | ExtractMarloweTransactionError - | MintingUtxoSelectionFailed - | AddressDecodingFailed - | MintingScriptDecodingFailed - | CreateToCardanoError - | InternalError - | UnknownError String - -postContractsFromString :: String -> PostContractsError -postContractsFromString = case _ of - "MintingUtxoNotFound" -> MintingUtxoNotFound - "RoleTokenNotFound" -> RoleTokenNotFound - "ToCardanoError" -> ToCardanoError - "MissingMarloweInput" -> MissingMarloweInput - "PayoutInputNotFound" -> PayoutInputNotFound - "CalculateMinUtxoFailed" -> CalculateMinUtxoFailed - "CoinSelectionFailed" -> CoinSelectionFailed - "BalancingError" -> BalancingError - "MarloweContractNotFound" -> MarloweContractNotFound - "MarloweContractVersionMismatch" -> MarloweContractVersionMismatch - "LoadMarloweContextToCardanoError" -> LoadMarloweContextToCardanoError - "MarloweScriptNotPublished" -> MarloweScriptNotPublished - "PayoutScriptNotPublished" -> PayoutScriptNotPublished - "ExtractCreationError" -> ExtractCreationError - "ExtractMarloweTransactionError" -> ExtractMarloweTransactionError - "MintingUtxoSelectionFailed" -> MintingUtxoSelectionFailed - "AddressDecodingFailed" -> AddressDecodingFailed - "MintingScriptDecodingFailed" -> MintingScriptDecodingFailed - "CreateToCardanoError" -> CreateToCardanoError - "InternalError" -> InternalError - msg -> UnknownError msg - -instance Show PostContractsError where - show = case _ of - MintingUtxoNotFound -> "MintingUtxoNotFound" - RoleTokenNotFound -> "RoleTokenNotFound" - ToCardanoError -> "ToCardanoError" - MissingMarloweInput -> "MissingMarloweInput" - PayoutInputNotFound -> "PayoutInputNotFound" - CalculateMinUtxoFailed -> "CalculateMinUtxoFailed" - CoinSelectionFailed -> "CoinSelectionFailed" - BalancingError -> "BalancingError" - MarloweContractNotFound -> "MarloweContractNotFound" - MarloweContractVersionMismatch -> "MarloweContractVersionMismatch" - LoadMarloweContextToCardanoError -> "LoadMarloweContextToCardanoError" - MarloweScriptNotPublished -> "MarloweScriptNotPublished" - PayoutScriptNotPublished -> "PayoutScriptNotPublished" - ExtractCreationError -> "ExtractCreationError" - ExtractMarloweTransactionError -> "ExtractMarloweTransactionError" - MintingUtxoSelectionFailed -> "MintingUtxoSelectionFailed" - AddressDecodingFailed -> "AddressDecodingFailed" - MintingScriptDecodingFailed -> "MintingScriptDecodingFailed" - CreateToCardanoError -> "CreateToCardanoError" - InternalError -> "InternalError" - UnknownError msg -> "(UnknownError " <> msg <> ")" - -instance DecodeJson (ApiError PostContractsError) where - decodeJson = decodeApiError \code _ -> postContractsFromString code - -type GetContractsResponseContent = ContractHeader - -type GetContractsResponse = ResourceWithLinks GetContractsResponseContent (ContractEndpointRow + TransactionsEndpointRow + ()) - -newtype ContractsEndpoint = ContractsEndpoint - ( IndexEndpoint PostContractsRequest PostContractsResponseContent (ContractEndpointRow + ()) GetContractsResponseContent - (ContractEndpointRow + TransactionsEndpointRow + ()) - ) - -derive instance Eq ContractsEndpoint -derive instance Newtype ContractsEndpoint _ -derive newtype instance DecodeJson ContractsEndpoint - -newtype PutContractRequest = PutContractRequest (TextEnvelope TransactionWitnessSetObject) - -instance EncodeHeaders PutContractRequest () where - encodeHeaders (PutContractRequest _) = {} - -instance EncodeJsonBody PutContractRequest where - encodeJsonBody (PutContractRequest textEnvelope) = encodeJson textEnvelope - -type GetContractResponse = ContractState - -newtype ContractEndpoint = ContractEndpoint - (ResourceEndpoint PutContractRequest GetContractResponse (transactions :: TransactionsEndpoint)) - -derive instance Eq ContractEndpoint -derive instance Newtype ContractEndpoint _ -derive newtype instance DecodeJson ContractEndpoint - -newtype PostTransactionsRequest = PostTransactionsRequest - { inputs :: Array V1.Input - , invalidBefore :: DateTime - , invalidHereafter :: DateTime - , metadata :: Metadata - , tags :: Tags - , changeAddress :: Bech32 - , addresses :: Array Bech32 - , collateralUTxOs :: Array TxOutRef - } - -instance EncodeJsonBody PostTransactionsRequest where - encodeJsonBody (PostTransactionsRequest r) = encodeJson - { inputs: r.inputs - , invalidBefore: ISO r.invalidBefore - , invalidHereafter: ISO r.invalidHereafter - , metadata: r.metadata - , tags: r.tags - , version: V1 - } - -type PostTransactionsRequestRow = - ( "X-Change-Address" :: String - , "X-Address" :: String - , "Accept" :: String - -- , "X-Collateral-UTxO" :: String - ) - -instance EncodeHeaders PostTransactionsRequest PostTransactionsRequestRow where - encodeHeaders (PostTransactionsRequest { changeAddress, addresses }) = -- , collateralUTxOs }) = - { "X-Change-Address": bech32ToString changeAddress - , "X-Address": String.joinWith "," (map bech32ToString addresses) - , "Accept": "application/vendor.iog.marlowe-runtime.apply-inputs-tx-json" - -- FIXME: Check comment above regarding the same header and contraacts endpoint request. - -- , "X-Collateral-UTxO": String.joinWith "," (map txOutRefToString collateralUTxOs) - } - -newtype PostTransactionsResponse = PostTransactionsResponse - { contractId :: TxOutRef - , transactionId :: TxId - , tx :: TextEnvelope TransactionObject - } - -derive instance Newtype PostTransactionsResponse _ - -instance DecodeJson PostTransactionsResponse where - decodeJson = decodeNewtypedRecord - { txBody: map decodeTransactionObjectTextEnvelope :: Maybe _ -> Maybe _ } - -type GetTransactionsResponse = TxHeader - -newtype TransactionsEndpoint = TransactionsEndpoint - (IndexEndpoint' PostTransactionsRequest PostTransactionsResponse GetTransactionsResponse (transaction :: TransactionEndpoint)) - -derive instance Eq TransactionsEndpoint -derive instance Newtype TransactionsEndpoint _ -derive newtype instance DecodeJson TransactionsEndpoint - -newtype PutTransactionRequest = PutTransactionRequest (TextEnvelope TransactionWitnessSetObject) - -instance EncodeHeaders PutTransactionRequest () where - encodeHeaders (PutTransactionRequest _) = {} - -instance EncodeJsonBody PutTransactionRequest where - encodeJsonBody (PutTransactionRequest textEnvelope) = encodeJson textEnvelope - -type GetTransactionResponse = Tx - -newtype TransactionEndpoint = TransactionEndpoint - (ResourceEndpoint PutTransactionRequest GetTransactionResponse (previous :: Maybe TransactionEndpoint, next :: Maybe TransactionEndpoint)) - -derive instance Eq TransactionEndpoint -derive instance Newtype TransactionEndpoint _ -derive newtype instance DecodeJson TransactionEndpoint - -newtype WithdrawalsEndpoint = WithdrawalsEndpoint - ( IndexEndpoint PostWithdrawalsRequest PostWithdrawalsResponseContent (WithdrawalEndpointRow + ()) GetWithdrawalsResponseContent - (WithdrawalEndpointRow + ()) - ) - -derive instance Eq WithdrawalsEndpoint -derive instance Newtype WithdrawalsEndpoint _ -derive newtype instance DecodeJson WithdrawalsEndpoint - -type GetWithdrawalsResponseContent = WithdrawalHeader - -type WithdrawalEndpointRow r = ("withdrawal" :: WithdrawalEndpoint | r) - -newtype PostWithdrawalsRequest = PostWithdrawalsRequest - { role :: String - , contractId :: TxOutRef - , minUTxODeposit :: V1.Ada - , changeAddress :: Bech32 - , addresses :: Array Bech32 - , collateralUTxOs :: Array TxOutRef - } - -instance EncodeJsonBody PostWithdrawalsRequest where - encodeJsonBody (PostWithdrawalsRequest r) = encodeJson - { role: r.role - , contractId: txOutRefToString r.contractId - , minUTxODeposit: r.minUTxODeposit - --- , collateralUTxOs: r.collateralUTxOs - } - -type PostWithdrawalsHeadersRow = - ( "X-Change-Address" :: String - , "X-Address" :: String - , "Accept" :: String - -- , "X-Collateral-UTxO" :: String - ) - -instance EncodeHeaders PostWithdrawalsRequest PostWithdrawalsHeadersRow where - encodeHeaders (PostWithdrawalsRequest { changeAddress, addresses }) = - { "X-Change-Address": bech32ToString changeAddress - , "X-Address": String.joinWith "," (map bech32ToString addresses) - , "Accept": "application/vendor.iog.marlowe-runtime.withdraw-tx-json" - } - -derive instance Eq PostWithdrawalsRequest -derive instance Newtype PostWithdrawalsRequest _ -derive newtype instance DecodeJson PostWithdrawalsRequest - -newtype PostWithdrawalsResponseContent = PostWithdrawalsResponseContent - { withdrawalId :: String - , tx :: TextEnvelope TransactionObject - } - -derive instance Newtype PostWithdrawalsResponseContent _ - -instance DecodeJson PostWithdrawalsResponseContent where - decodeJson = decodeNewtypedRecord - { tx: map decodeTransactionObjectTextEnvelope :: Maybe _ -> Maybe _ } - -newtype PutWithdrawalRequest = PutWithdrawalRequest (TextEnvelope TransactionWitnessSetObject) - -instance EncodeHeaders PutWithdrawalRequest () where - encodeHeaders (PutWithdrawalRequest _) = {} - -instance EncodeJsonBody PutWithdrawalRequest where - encodeJsonBody (PutWithdrawalRequest textEnvelope) = encodeJson textEnvelope - -type GetWithdrawalResponse = WithdrawalState - -newtype WithdrawalEndpoint = WithdrawalEndpoint - (ResourceEndpoint PutWithdrawalRequest GetWithdrawalResponse ()) - -derive instance Eq WithdrawalEndpoint -derive instance Newtype WithdrawalEndpoint _ -derive newtype instance DecodeJson WithdrawalEndpoint - -type WithdrawalStateRow = WithdrawalHeadersRowBase - ( withdrawalId :: String - , txBody :: Maybe (TextEnvelope TransactionObject) - ) - -newtype WithdrawalState = WithdrawalState { | WithdrawalStateRow } - -derive instance Generic WithdrawalState _ -derive instance Newtype WithdrawalState _ -derive instance Eq WithdrawalState - --- Entry point -api :: ContractsEndpoint -api = ContractsEndpoint (IndexEndpoint (ResourceLink "contracts")) - -withdrawalsApi :: WithdrawalsEndpoint -withdrawalsApi = WithdrawalsEndpoint (IndexEndpoint (ResourceLink "withdrawals")) - -newtype Runtime = Runtime - { root :: ContractsEndpoint - , withdrawalsEndpoint :: WithdrawalsEndpoint - , serverURL :: ServerURL - } - -runtime :: ServerURL -> Runtime -runtime serverURL = Runtime { root: api, withdrawalsEndpoint: withdrawalsApi, serverURL } - From 4e411d6f6f7d3b797931a552115e3c12ab67cb13 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Fri, 8 Sep 2023 12:12:33 +0200 Subject: [PATCH 02/10] PLT-7412: removed unused modules --- spago.dhall | 28 +--------------------------- 1 file changed, 1 insertion(+), 27 deletions(-) diff --git a/spago.dhall b/spago.dhall index 787ee067..e783d5fd 100644 --- a/spago.dhall +++ b/spago.dhall @@ -1,16 +1,11 @@ -{ name = "my-project" +{ name = "marlowe-runner" , dependencies = [ "aff" , "aff-promise" , "argonaut" , "argonaut-codecs" - , "argonaut-core" - , "argonaut-generic" - , "array-builder" - , "arraybuffer-types" , "arrays" , "atleast" - , "avar" , "bifunctors" , "bigints" , "cardano-multiplatform-lib" @@ -24,12 +19,7 @@ , "effect" , "either" , "enums" - , "errors" , "exceptions" - , "fetch" - , "fetch-argonaut" - , "fetch-core" - , "filterable" , "foldable-traversable" , "foreign" , "foreign-generic" @@ -39,9 +29,7 @@ , "functors" , "halogen-subscriptions" , "heterogeneous" - , "http-methods" , "identity" - , "indexed-monad" , "integers" , "js-date" , "js-object" @@ -49,12 +37,10 @@ , "js-promise-aff" , "js-timers" , "js-unsafe-stringify" - , "lazy" , "lists" , "marlowe" , "marlowe-runtime-client" , "maybe" - , "monad-loops" , "newtype" , "node-buffer" , "node-fs-aff" @@ -62,9 +48,7 @@ , "nonempty" , "now" , "nullable" - , "numbers" , "ordered-collections" - , "orders" , "parallel" , "parsing" , "partial" @@ -74,38 +58,28 @@ , "prelude" , "profunctor" , "profunctor-lenses" - , "qualified-do" , "quickcheck" , "random" , "react-basic" , "react-basic-dom" , "react-basic-hooks" , "react-bootstrap" - , "react-halo" , "record" - , "refined" , "refs" - , "row-joins" , "safe-coerce" , "spec" , "strings" - , "stringutils" , "tailrec" , "transformers" , "tuples" - , "typelevel" - , "typelevel-eval" , "typelevel-prelude" , "undefined-is-not-a-problem" - , "unfoldable" , "unsafe-coerce" , "validation" , "variant" , "web-dom" - , "web-encoding" , "web-file" , "web-html" - , "web-streams" ] , packages = ./packages.dhall , sources = [ "src/**/*.purs", "test/**/*.purs" ] From c745396db55a484b81eaa481f7123edb94054eb4 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Fri, 8 Sep 2023 14:50:04 +0200 Subject: [PATCH 03/10] PLT-7414: repo split --- packages.dhall | 31 ++ spago.dhall | 7 +- src/Component/App.purs | 5 +- src/Component/ApplyInputs/Machine.purs | 4 +- src/Component/ContractList.purs | 7 +- src/Component/CreateContract.purs | 2 +- src/Component/CreateContract/Machine.purs | 4 +- src/Component/Withdrawals.purs | 2 +- src/Wallet.purs | 472 ---------------------- src/WalletContext.purs | 84 ---- 10 files changed, 45 insertions(+), 573 deletions(-) delete mode 100644 src/Wallet.purs delete mode 100644 src/WalletContext.purs diff --git a/packages.dhall b/packages.dhall index 8bca70f2..2472a940 100644 --- a/packages.dhall +++ b/packages.dhall @@ -300,6 +300,37 @@ in upstream "https://github.com/input-output-hk/purescript-cardano-multiplatform-lib.git" "main" + with cardano-wallet-client = + mkPackage + [ "argonaut" + , "arraybuffer-types" + , "arrays" + , "debug" + , "effect" + , "either" + , "exceptions" + , "foldable-traversable" + , "js-object" + , "js-promise-aff" + , "lists" + , "marlowe" + , "maybe" + , "newtype" + , "nullable" + , "ordered-collections" + , "partial" + , "prelude" + , "refs" + , "strings" + , "transformers" + , "tuples" + , "typelevel-prelude" + , "undefined-is-not-a-problem" + , "web-encoding" + ] + "https://github.com/input-output-hk/purescript-cardano-wallet-client.git" + "main" + with marlowe-runtime-client = mkPackage [ "aff" diff --git a/spago.dhall b/spago.dhall index e783d5fd..600a76b7 100644 --- a/spago.dhall +++ b/spago.dhall @@ -9,6 +9,7 @@ , "bifunctors" , "bigints" , "cardano-multiplatform-lib" + , "cardano-wallet-client" , "console" , "control" , "convertable-options" @@ -21,8 +22,6 @@ , "enums" , "exceptions" , "foldable-traversable" - , "foreign" - , "foreign-generic" , "foreign-object" , "formatters" , "functions" @@ -32,9 +31,6 @@ , "identity" , "integers" , "js-date" - , "js-object" - , "js-promise" - , "js-promise-aff" , "js-timers" , "js-unsafe-stringify" , "lists" @@ -45,7 +41,6 @@ , "node-buffer" , "node-fs-aff" , "node-process" - , "nonempty" , "now" , "nullable" , "ordered-collections" diff --git a/src/Component/App.purs b/src/Component/App.purs index 7742428f..05e8118d 100644 --- a/src/Component/App.purs +++ b/src/Component/App.purs @@ -16,6 +16,7 @@ import Component.Modal (Size(..), mkModal) import Component.Types (ContractInfo(..), MessageContent(Success, Info), MessageHub(MessageHub), MkComponentMBase, WalletInfo(..)) import Component.Types.ContractInfo (MarloweInfo(..)) import Component.Widgets (link, linkWithIcon) +import Contrib.Cardano as Cardano import Contrib.Data.Map (New(..), Old(..), additions, deletions) as Map import Contrib.Halogen.Subscription (MinInterval(..)) import Contrib.Halogen.Subscription (bindEffect, foldMapThrottle) as Subscription @@ -172,7 +173,7 @@ mkApp = do let action = do walletContext <- WalletContext.walletContext cardanoMultiplatformLib walletInfo.wallet - liftEffect $ setWalletContext $ Just walletContext + liftEffect $ setWalletContext walletContext action `catchError` \_ -> do -- FIXME: Report back (to the reporting backend) a wallet problem? traceM "ERROR during wallet context construction" @@ -350,7 +351,7 @@ updateAppContractInfoMap (AppContractInfoMap { map: prev }) walletContext update let walletCtx = un WalletContext <$> walletContext (usedAddresses :: Array String) = map bech32ToString $ fromMaybe [] $ _.usedAddresses <$> walletCtx - (tokens :: Array String) = fromMaybe [] $ Array.fromFoldable <<< Map.keys <<< _.balance <$> walletCtx + (tokens :: Array String) = map Cardano.assetIdToString $ fromMaybe [] $ Array.fromFoldable <<< Map.keys <<< un Cardano.Value <<< _.balance <$> walletCtx map = Map.catMaybes $ updates <#> \{ contract: { resource: contractHeader@(Runtime.ContractHeader { contractId, roleTokenMintingPolicyId, tags }), links: endpoints }, contractState, transactions } -> do let diff --git a/src/Component/ApplyInputs/Machine.purs b/src/Component/ApplyInputs/Machine.purs index 0aac32f7..13438714 100644 --- a/src/Component/ApplyInputs/Machine.purs +++ b/src/Component/ApplyInputs/Machine.purs @@ -334,7 +334,8 @@ requestToAffAction = case _ of possibleWalletAddresses <- (Right <$> walletContext cardanoMultiplatformLib wallet) `catchError` (pure <<< Left) case possibleWalletAddresses of Left err -> pure $ FetchRequiredWalletContextFailed $ show err - Right (WalletContext { changeAddress: Just changeAddress, usedAddresses }) -> liftEffect $ do + Right Nothing -> pure $ FetchRequiredWalletContextFailed "Wallet does not have a change address" + Right (Just (WalletContext { changeAddress, usedAddresses })) -> liftEffect $ do invalidBefore <- millisecondsFromNow (Milliseconds (Int.toNumber $ (-10) * 60 * 1000)) invalidHereafter <- millisecondsFromNow (Milliseconds (Int.toNumber $ 5 * 60 * 1000)) let @@ -354,7 +355,6 @@ requestToAffAction = case _ of { requiredWalletContext: { changeAddress, usedAddresses } , allInputsChoices } - Right (WalletContext { changeAddress: Nothing }) -> pure $ FetchRequiredWalletContextFailed "Wallet does not have a change address" SignTxRequest { walletInfo, tx } -> do let WalletInfo { wallet } = walletInfo diff --git a/src/Component/ContractList.purs b/src/Component/ContractList.purs index 331e748b..e40b7d8a 100644 --- a/src/Component/ContractList.purs +++ b/src/Component/ContractList.purs @@ -19,6 +19,7 @@ import Component.Types.ContractInfo as ContractInfo import Component.Widget.Table (orderingHeader) as Table import Component.Widgets (buttonWithIcon, linkWithIcon) import Component.Withdrawals as Withdrawals +import Contrib.Cardano as Cardano import Contrib.Data.JSDate (toLocaleDateString, toLocaleTimeString) as JSDate import Contrib.Fetch (FetchError) import Contrib.Polyform.FormSpecBuilder (evalBuilder') @@ -451,10 +452,10 @@ mkContractList = do } _, _ -> mempty , case marloweInfo, possibleWalletContext of - Just (MarloweInfo { currencySymbol: Just currencySymbol, state: _, unclaimedPayouts }), Just { balance } -> do + Just (MarloweInfo { currencySymbol: Just currencySymbol, state: _, unclaimedPayouts }), Just { balance: Cardano.Value balance } -> do let - balance' = Map.filterKeys (eq currencySymbol) balance - roleTokens = List.toUnfoldable <<< concat <<< map Set.toUnfoldable <<< map Map.keys <<< Map.values $ balance' + balance' = Map.filterKeys (\assetId -> Cardano.assetIdToString assetId `eq` currencySymbol) balance + roleTokens = map Cardano.assetIdToString <<< List.toUnfoldable <<< Set.toUnfoldable <<< Map.keys $ balance' case Array.uncons (Array.intersect roleTokens (map (\(Payout { role }) -> role) unclaimedPayouts)) of Just { head, tail } -> linkWithIcon diff --git a/src/Component/CreateContract.purs b/src/Component/CreateContract.purs index 92c77441..a267d347 100644 --- a/src/Component/CreateContract.purs +++ b/src/Component/CreateContract.purs @@ -306,7 +306,7 @@ mkComponent = do possibleWalletInfo <- React.useContext walletInfoCtx React.useEffect (_.changeAddress <<< un WalletContext <<< snd <$> possibleWalletInfo) $ do case possibleWalletInfo of - Just (_ /\ (WalletContext { changeAddress: Just changeAddress })) -> do + Just (_ /\ (WalletContext { changeAddress })) -> do { multiChoiceTest: initialContract } <- liftEffect $ mkInitialContracts changeAddress case Map.lookup contractFieldId formState.fields of Just { touched, onChange } -> do diff --git a/src/Component/CreateContract/Machine.purs b/src/Component/CreateContract/Machine.purs index 274e991d..7998b92f 100644 --- a/src/Component/CreateContract/Machine.purs +++ b/src/Component/CreateContract/Machine.purs @@ -227,9 +227,9 @@ requestToAffAction = case _ of possibleWalletAddresses <- liftAff $ (Right <$> walletContext cardanoMultiplatformLib wallet) `catchError` (pure <<< Left) case possibleWalletAddresses of Left err -> pure $ FetchRequiredWalletContextFailed $ show err - Right (WalletContext { changeAddress: Just changeAddress, usedAddresses }) -> do + Right Nothing -> pure $ FetchRequiredWalletContextFailed "Wallet does not have a change address" + Right (Just (WalletContext { changeAddress, usedAddresses })) -> do pure $ FetchRequiredWalletContextSucceeded { changeAddress, usedAddresses } - Right (WalletContext { changeAddress: Nothing }) -> pure $ FetchRequiredWalletContextFailed "Wallet does not have a change address" SignTxRequest { walletInfo, tx } -> do let WalletInfo { wallet } = walletInfo diff --git a/src/Component/Withdrawals.purs b/src/Component/Withdrawals.purs index 1c7863b5..30d2bd52 100644 --- a/src/Component/Withdrawals.purs +++ b/src/Component/Withdrawals.purs @@ -82,7 +82,7 @@ mkComponent = do onSubmit :: { result :: _, payload :: _ } -> Effect Unit onSubmit = _.result >>> case _, possibleWalletContext of - Just (V (Right { role }) /\ _), Just { changeAddress: Just changeAddress, usedAddresses } -> do + Just (V (Right { role }) /\ _), Just { changeAddress, usedAddresses } -> do let withdrawalContext = WithdrawalContext { wallet: { changeAddress, usedAddresses } diff --git a/src/Wallet.purs b/src/Wallet.purs deleted file mode 100644 index 4b02bb0c..00000000 --- a/src/Wallet.purs +++ /dev/null @@ -1,472 +0,0 @@ -module Wallet - ( Api - , ApiError - , ApiForeignErrors - , Bytes(..) - , Cbor(..) - , Coin - , DataSignError - , HashObject32(..) - , SomeAddress(..) - , SignTxError - , Transaction(..) - , TxSignError - , TransactionUnspentOutput - , UnknownError - , Wallet - , apiVersion - , cardano - , enable - , enable_ - , eternl - , fromSomeAddress - , gerowallet - , getBalance - , getChangeAddress - , getCollateral - , getNetworkId - , getRewardAddresses - , getUnusedAddresses - , getUsedAddresses - , getUtxos - , icon - , isEnabled - , isEnabled_ - , lace - , name - , nami - , signData - , signTx - , submitTx - , yoroi - ) where - -import Prelude - -import CardanoMultiplatformLib (AddressObject, Bech32, CborHex, bech32FromCborHex, bech32FromString, runGarbageCollector) -import CardanoMultiplatformLib as CardanoMultiplatformLib -import CardanoMultiplatformLib.Transaction (TransactionHashObject, TransactionObject, TransactionUnspentOutputObject, TransactionWitnessSetObject, ValueObject) -import CardanoMultiplatformLib.Types (unsafeCborHex) -import Control.Alt ((<|>)) -import Control.Monad.Except (runExcept, runExceptT) -import Control.Monad.Except.Trans (except) -import Data.Either (Either(..), either, hush, note) -import Data.Foldable (fold) -import Data.List.NonEmpty (NonEmptyList(..)) -import Data.Maybe (Maybe(..), fromMaybe') -import Data.NonEmpty (singleton) -import Data.Nullable (Nullable) -import Data.Nullable as Nullable -import Data.Traversable (for) -import Data.Tuple.Nested (type (/\), (/\)) -import Data.Undefined.NoProblem (undefined) -import Data.Variant (Variant) -import Data.Variant as Variant -import Effect (Effect) -import Effect.Aff (Aff, makeAff) -import Effect.Class (liftEffect) -import Effect.Exception (throw) -import Foreign (Foreign, ForeignError(..)) -import Foreign as Foreign -import Foreign.Generic.Internal as Foreign.Generic -import Foreign.Index as Foreign.Index -import Foreign.Object (Object, lookup) -import HexString as HexString -import JS.Object (EffectMth0, EffectMth1, EffectMth2, EffectProp, JSObject) -import JS.Object.Generic (mkFFI) -import Prim.TypeError (class Warn, Text) -import Promise (Rejection, resolve, thenOrCatch) as Promise -import Promise.Aff (Promise) -import Promise.Aff (Promise, toAffE) as Promise -import Type.Prelude (Proxy(..)) -import Type.Row (type (+)) -import Unsafe.Coerce (unsafeCoerce) -import Web.HTML (Window) - -data TransactionUnspentOutput - -data Coin - -data Transaction - -data HashObject32 - -type ApiError r = - ( invalidRequest :: String - , internalError :: String - , refused :: String - , accountChange :: String - | r - ) - -type DataSignError r = - ( proofGeneration :: String - , addressNotPK :: String - , userDeclined :: String - | r - ) - -type TxSendError r = - ( refused :: String - , failure :: String - | r - ) - -type TxSignError r = - ( proofGeneration :: String - , userDeclined :: String - | r - ) - -type ApiForeignErrors r = - ( foreignErrors :: NonEmptyList ForeignError - | r - ) - -type UnknownError r = - ( unknownError :: Foreign - | r - ) - -_invalidRequest :: Proxy "invalidRequest" -_invalidRequest = Proxy - -_internalError :: Proxy "internalError" -_internalError = Proxy - -_refused :: Proxy "refused" -_refused = Proxy - -_failure :: Proxy "failure" -_failure = Proxy - -_accountChange :: Proxy "accountChange" -_accountChange = Proxy - -_proofGeneration :: Proxy "proofGeneration" -_proofGeneration = Proxy - -_addressNotPK :: Proxy "addressNotPK" -_addressNotPK = Proxy - -_userDeclined :: Proxy "userDeclined" -_userDeclined = Proxy - -toApiError :: forall e r. { info :: String, code :: Int | e } -> Maybe (Variant (| ApiError + r)) -toApiError = case _ of - { info, code: -1 } -> Just $ Variant.inj _invalidRequest info - { info, code: -2 } -> Just $ Variant.inj _internalError info - { info, code: -3 } -> Just $ Variant.inj _refused info - { info, code: -4 } -> Just $ Variant.inj _accountChange info - _ -> Nothing - -toDataSignError :: forall e r. { info :: String, code :: Int | e } -> Maybe (Variant (| DataSignError + r)) -toDataSignError = case _ of - { info, code: 1 } -> Just $ Variant.inj _proofGeneration info - { info, code: 2 } -> Just $ Variant.inj _addressNotPK info - { info, code: 3 } -> Just $ Variant.inj _userDeclined info - _ -> Nothing - -toTxSendError :: forall e r. { info :: String, code :: Int | e } -> Maybe (Variant (| TxSendError + r)) -toTxSendError = case _ of - { info, code: 1 } -> Just $ Variant.inj _refused info - { info, code: 2 } -> Just $ Variant.inj _failure info - _ -> Nothing - -toTxSignError :: forall e r. { info :: String, code :: Int | e } -> Maybe (Variant (| TxSignError + r)) -toTxSignError = case _ of - { info, code: 1 } -> Just $ Variant.inj _proofGeneration info - { info, code: 2 } -> Just $ Variant.inj _userDeclined info - _ -> Nothing - -unknownError :: forall r. Foreign -> Variant (| UnknownError + r) -unknownError = Variant.inj (Proxy :: Proxy "unknownError") - -foreignErrors :: forall r. NonEmptyList ForeignError -> Variant (| ApiForeignErrors + r) -foreignErrors = Variant.inj (Proxy :: Proxy "foreignErrors") - -lookupForeign :: forall a. String -> Object a -> Either (NonEmptyList ForeignError) a -lookupForeign str obj = note (NonEmptyList (singleton $ ForeignError $ "Missing " <> str)) $ lookup str obj - -readWalletError :: Foreign -> Either (NonEmptyList ForeignError) { info :: String, code :: Int } -readWalletError rejection = runExcept do - obj <- Foreign.Generic.readObject rejection - info' <- except $ lookupForeign "info" obj - code' <- except $ lookupForeign "code" obj - - info <- Foreign.readString info' - code <- Foreign.readInt code' - pure { info, code } - -newtype Cbor :: forall k. k -> Type -newtype Cbor a = Cbor String - -instance Show (Cbor a) where - show (Cbor s) = "(Cbor " <> show s <> ")" - -newtype Bytes = Bytes String - -type Api = JSObject - ( getNetworkId :: EffectMth0 (Promise Int) - , getUtxos :: EffectMth0 (Promise (Nullable (Array (CborHex TransactionUnspentOutputObject)))) - , getCollateral :: EffectMth1 (Cbor Coin) (Promise (Nullable (Array (Cbor TransactionUnspentOutput)))) - , getBalance :: EffectMth0 (Promise (CborHex ValueObject)) - , getUsedAddresses :: EffectMth0 (Promise (Array SomeAddress)) - , getUnusedAddresses :: EffectMth0 (Promise (Array (CborHex AddressObject))) - , getChangeAddress :: EffectMth0 (Promise SomeAddress) - , getRewardAddresses :: EffectMth0 (Promise (Array (CborHex AddressObject))) - , signTx :: EffectMth2 (CborHex TransactionObject) Boolean (Promise (CborHex TransactionWitnessSetObject)) - , signData :: EffectMth2 (CborHex AddressObject) Bytes (Promise Bytes) - , submitTx :: EffectMth1 (CborHex TransactionObject) (Promise (CborHex TransactionHashObject)) - ) - -_Api - :: { getBalance :: Api -> Effect (Promise (CborHex ValueObject)) - , getChangeAddress :: Api -> Effect (Promise SomeAddress) - , getCollateral :: Api -> Cbor Coin -> Effect (Promise (Nullable (Array (Cbor TransactionUnspentOutput)))) - , getNetworkId :: Api -> Effect (Promise Int) - , getRewardAddresses :: Api -> Effect (Promise (Array (CborHex AddressObject))) - , getUnusedAddresses :: Api -> Effect (Promise (Array (CborHex AddressObject))) - , getUsedAddresses :: Api -> Effect (Promise (Array SomeAddress)) - , getUtxos :: Api -> Effect (Promise (Nullable (Array (CborHex TransactionUnspentOutputObject)))) - , signData :: Api -> CborHex AddressObject -> Bytes -> Effect (Promise Bytes) - , signTx :: Api -> CborHex TransactionObject -> Boolean -> Effect (Promise (CborHex TransactionWitnessSetObject)) - , submitTx :: Api -> CborHex TransactionObject -> Effect (Promise (CborHex TransactionHashObject)) - } -_Api = mkFFI (Proxy :: Proxy Api) - --- FIXME: newtype this -type Wallet = JSObject - ( enable :: EffectMth0 (Promise Api) - , isEnabled :: EffectMth0 (Promise Boolean) - , apiVersion :: EffectProp String - , name :: EffectProp String - , icon :: EffectProp String - ) - -_Wallet - :: { apiVersion :: Wallet -> Effect String - , enable :: Wallet -> Effect (Promise Api) - , icon :: Wallet -> Effect String - , isEnabled :: Wallet -> Effect (Promise Boolean) - , name :: Wallet -> Effect String - } -_Wallet = mkFFI (Proxy :: Proxy Wallet) - -type Cardano = JSObject - ( eternl :: EffectProp (Nullable Wallet) - , gerowallet :: EffectProp (Nullable Wallet) - , lace :: EffectProp (Nullable Wallet) - , nami :: EffectProp (Nullable Wallet) - , yoroi :: EffectProp (Nullable Wallet) - ) - -_Cardano - :: { eternl :: Cardano -> Effect (Nullable Wallet) - , gerowallet :: Cardano -> Effect (Nullable Wallet) - , lace :: Cardano -> Effect (Nullable Wallet) - , nami :: Cardano -> Effect (Nullable Wallet) - , yoroi :: Cardano -> Effect (Nullable Wallet) - } -_Cardano = mkFFI (Proxy :: Proxy Cardano) - --- | Manually tested and works with Nami (after a delay) --- | --- | The Nami and Yoroi browser extensions injects themselves into the --- | running website with --- | ```js --- | window.cardano = { ...window.cardano, nami = stuff } --- | ``` -cardano :: Window -> Effect (Maybe Cardano) -cardano w = do - eProp <- runExceptT $ Foreign.Index.readProp "cardano" $ Foreign.unsafeToForeign w - case eProp of - Left e -> throw $ show e - Right prop - | Foreign.isUndefined prop -> pure Nothing - | otherwise -> pure $ Just $ Foreign.unsafeFromForeign prop - -eternl :: Cardano -> Effect (Maybe Wallet) -eternl = map Nullable.toMaybe <<< _Cardano.eternl - -gerowallet :: Cardano -> Effect (Maybe Wallet) -gerowallet = map Nullable.toMaybe <<< _Cardano.gerowallet - --- | Not yet manually tested. -lace :: Cardano -> Effect (Maybe Wallet) -lace = map Nullable.toMaybe <<< _Cardano.lace - --- | Manually tested and works with Nami. --- | --- | Remember that the Nami browser extension injects itself with --- | ```js --- | window.cardano = { ...window.cardano, nami = stuff } --- | ``` --- | after a delay so if you want to wait for it with an artificial delay, --- | you have to preceed the delay before invoking `cardano` rather than --- | this procedure. -nami :: Cardano -> Effect (Maybe Wallet) -nami = map Nullable.toMaybe <<< _Cardano.nami - --- | Not yet manually tested. -yoroi :: Cardano -> Effect (Maybe Wallet) -yoroi = map Nullable.toMaybe <<< _Cardano.yoroi - --- | Manually tested and works with Nami. -apiVersion :: Wallet -> Effect String -apiVersion = _Wallet.apiVersion - --- | Manually tested and works with Nami. -enable_ :: Warn (Text "enable_ is deprecated, use enable instead") => Wallet -> Aff Api -enable_ = Promise.toAffE <<< _Wallet.enable - --- | Manually tested and works with Nami. -enable :: forall r. Wallet -> Aff (Either (Variant (| ApiError + ApiForeignErrors + UnknownError r)) Api) -enable = toAffEitherE rejectionAPIError <<< _Wallet.enable - --- | Manually tested and works with Nami. -icon :: Wallet -> Effect String -icon = _Wallet.icon - --- | Manually tested and works with Nami. -isEnabled_ :: Warn (Text "isEnabled_ is deprecated, use isEnabled instead") => Wallet -> Aff Boolean -isEnabled_ = Promise.toAffE <<< _Wallet.isEnabled - --- | Manually tested and works with Nami. -isEnabled :: forall r. Wallet -> Aff (Either (Variant (| ApiError + ApiForeignErrors + UnknownError r)) Boolean) -isEnabled = toAffEitherE rejectionAPIError <<< _Wallet.isEnabled - --- | Manually tested and works with Nami. -name :: Wallet -> Effect String -name = _Wallet.name - --- | Manually tested and works with Nami. -getNetworkId :: forall r. Api -> Aff (Either (Variant (| ApiError + ApiForeignErrors + UnknownError r)) Int) -getNetworkId = toAffEitherE rejectionAPIError <<< _Api.getNetworkId - --- | Manually tested and works with Nami. -getBalance :: forall r. Api -> Aff (Either (Variant (| ApiError + ApiForeignErrors + UnknownError r)) (CborHex ValueObject)) -getBalance = toAffEitherE rejectionAPIError <<< _Api.getBalance - --- | Manually tested and works with Nami. -getChangeAddress :: forall r. Api -> Aff (Either (Variant (| ApiError + ApiForeignErrors + UnknownError r)) SomeAddress) -getChangeAddress = toAffEitherE rejectionAPIError <<< _Api.getChangeAddress - --- | Manually tested and works with Nami. -getCollateral :: forall r. Api -> Cbor Coin -> Aff (Either (Variant (| ApiError + ApiForeignErrors + UnknownError r)) (Array (Cbor TransactionUnspentOutput))) -getCollateral api = map (map (fold <<< Nullable.toMaybe)) <<< toAffEitherE rejectionAPIError <<< _Api.getCollateral api - --- | Manually tested and works with Nami. -getRewardAddresses :: forall r. Api -> Aff (Either (Variant (| ApiError + ApiForeignErrors + UnknownError r)) (Array (CborHex AddressObject))) -getRewardAddresses = toAffEitherE rejectionAPIError <<< _Api.getRewardAddresses - --- | Manually tested and works with Nami. -getUnusedAddresses :: forall r. Api -> Aff (Either (Variant (| ApiError + ApiForeignErrors + UnknownError r)) (Array (CborHex AddressObject))) -getUnusedAddresses = toAffEitherE rejectionAPIError <<< _Api.getUnusedAddresses - --- Most wallets return cbor hex of an AddrssObject as an output even though it is --- against the spec which says that it should be a Bech32 string. -newtype SomeAddress = SomeAddress String - -fromSomeAddress :: CardanoMultiplatformLib.Lib -> SomeAddress -> Effect (Maybe Bech32) -fromSomeAddress lib (SomeAddress s) = do - let - parseString = bech32FromString lib s - parseCborHex = runGarbageCollector lib do - for (HexString.hex s) \hex -> do - let - cborHex = unsafeCborHex hex - bech32FromCborHex cborHex undefined - - (<|>) <$> parseString <*> parseCborHex - --- | Manually tested and works with Nami. -getUsedAddresses :: forall r. Api -> Aff (Either (Variant (| ApiError + ApiForeignErrors + UnknownError r)) (Array SomeAddress)) -getUsedAddresses api = toAffEitherE rejectionAPIError <<< _Api.getUsedAddresses $ api - --- | Manually tested and works with Nami. -getUtxos - :: forall r - . Api - -> Aff (Either (Maybe Number /\ (Variant (| ApiError + ApiForeignErrors + UnknownError r))) (Maybe (Array (CborHex TransactionUnspentOutputObject)))) -getUtxos = map (map Nullable.toMaybe) <<< toAffEitherE rejectionPaginateError <<< _Api.getUtxos - -signData :: forall r. Api -> CborHex AddressObject -> Bytes -> Aff (Either (Variant (| ApiError + DataSignError + ApiForeignErrors + UnknownError r)) Bytes) -signData api address = toAffEitherE rejectionDataSignError <<< _Api.signData api address - -rejectionToForeign :: Promise.Rejection -> Foreign -rejectionToForeign = unsafeCoerce - -rejectionAPIError :: forall r. Promise.Rejection -> Variant (| ApiError + ApiForeignErrors + UnknownError r) -rejectionAPIError rejection = - let - x :: Foreign - x = rejectionToForeign rejection - in - either foreignErrors (fromMaybe' (\_ -> unknownError x) <<< toApiError) $ readWalletError x - -rejectionDataSignError :: forall r. Promise.Rejection -> Variant (| ApiError + DataSignError + ApiForeignErrors + UnknownError r) -rejectionDataSignError rejection = - let - x :: Foreign - x = rejectionToForeign rejection - in - readWalletError x # either foreignErrors \e -> - fromMaybe' (\_ -> unknownError x) $ toApiError e <|> toDataSignError e - -rejectionTxSignError :: forall r. Promise.Rejection -> Variant (| ApiError + TxSignError + ApiForeignErrors + UnknownError r) -rejectionTxSignError rejection = - let - x :: Foreign - x = rejectionToForeign rejection - in - readWalletError x # either foreignErrors \e -> - fromMaybe' (\_ -> unknownError x) $ toApiError e <|> toTxSignError e - -rejectionTxSendError :: forall r. Promise.Rejection -> Variant (| ApiError + TxSendError + ApiForeignErrors + UnknownError r) -rejectionTxSendError rejection = - let - x :: Foreign - x = rejectionToForeign rejection - in - readWalletError x # either foreignErrors \e -> - fromMaybe' (\_ -> unknownError x) $ toApiError e <|> toTxSendError e - -rejectionPaginateError :: forall r. Promise.Rejection -> Maybe Number /\ (Variant (| ApiError + ApiForeignErrors + UnknownError r)) -rejectionPaginateError rejection = - let - x :: Foreign - x = rejectionToForeign rejection - - maxSize :: Maybe Number - maxSize = hush $ runExcept $ Foreign.readNumber x - in - maxSize /\ (either foreignErrors (fromMaybe' (\_ -> unknownError x) <<< toApiError) $ readWalletError x) - -toAffEither :: forall a err. (Promise.Rejection -> err) -> Promise.Promise a -> Aff (Either err a) -toAffEither customCoerce p = makeAff \cb -> - mempty <$ - Promise.thenOrCatch - (\a -> Promise.resolve <$> cb (Right (Right a))) - (\e -> Promise.resolve <$> cb (Right (Left (customCoerce e)))) - p - -toAffEitherE :: forall a err. (Promise.Rejection -> err) -> Effect (Promise a) -> Aff (Either err a) -toAffEitherE coerce f = liftEffect f >>= toAffEither coerce - -type SignTxError r = ApiError + TxSignError + ApiForeignErrors + UnknownError + r - -signTx - :: forall r - . Api - -> CborHex TransactionObject - -> Boolean - -> Aff (Either (Variant (SignTxError + r)) (CborHex TransactionWitnessSetObject)) -signTx api cbor = toAffEitherE rejectionTxSignError <<< _Api.signTx api cbor - -submitTx - :: forall r - . Api - -> CborHex TransactionObject - -> Aff (Either (Variant (| ApiError + TxSendError + ApiForeignErrors + UnknownError r)) (CborHex TransactionHashObject)) -submitTx api = toAffEitherE rejectionTxSendError <<< _Api.submitTx api diff --git a/src/WalletContext.purs b/src/WalletContext.purs deleted file mode 100644 index a3fcd727..00000000 --- a/src/WalletContext.purs +++ /dev/null @@ -1,84 +0,0 @@ -module WalletContext where - -import Prelude - -import CardanoMultiplatformLib (Bech32, CborHex, addressObject, allocate, asksLib, runGarbageCollector, valueFromCbor) -import CardanoMultiplatformLib as CardanoMultiplatformLib -import CardanoMultiplatformLib.Transaction (TransactionUnspentOutputObject, ValueObject, transactionOutputObject, transactionUnspentOutput, transactionUnspentOutputObject) -import CardanoMultiplatformLib.Types (Cbor, cborHexToCbor) -import Data.Array as Array -import Data.BigInt.Argonaut as BigInt.Argonaut -import Data.Either (Either(..), fromRight) -import Data.Foldable (fold) -import Data.Map as Map -import Data.Maybe (Maybe(..)) -import Data.Newtype (class Newtype) -import Data.Traversable (for) -import Data.Undefined.NoProblem as NoProblem -import Effect.Aff (Aff) -import Effect.Class (liftEffect) -import Wallet (fromSomeAddress) -import Wallet as Wallet - - -newtype WalletContext = WalletContext - { balance :: Map.Map String (Map.Map String BigInt.Argonaut.BigInt) - , changeAddress :: Maybe Bech32 - , usedAddresses :: Array Bech32 - } - -derive instance Newtype WalletContext _ -derive newtype instance Show WalletContext -derive newtype instance Eq WalletContext -derive newtype instance Ord WalletContext - -walletBalance :: CardanoMultiplatformLib.Lib -> Wallet.Api -> Aff (Map.Map String (Map.Map String BigInt.Argonaut.BigInt)) -walletBalance cardanoMultiplatformLib wallet = do - Wallet.getBalance wallet >>= case _ of - Right valueCborHex -> do - let - valueCbor :: Cbor ValueObject - valueCbor = cborHexToCbor valueCborHex - liftEffect $ runGarbageCollector cardanoMultiplatformLib $ valueFromCbor valueCbor - Left _ -> pure Map.empty - -changeAddress :: CardanoMultiplatformLib.Lib -> Wallet.Api -> Aff (Maybe Bech32) -changeAddress cardanoMultiplatformLib wallet = do - possibleChangeAddress <- Wallet.getChangeAddress wallet - case possibleChangeAddress of - Right someAddr -> liftEffect do - fromSomeAddress cardanoMultiplatformLib someAddr - _ -> pure Nothing - -walletAddresses :: CardanoMultiplatformLib.Lib -> Wallet.Api -> Aff (Array Bech32) -walletAddresses cardanoMultiplatformLib wallet = do - possibleUsedAddresses <- Wallet.getUsedAddresses wallet - possibleUTxOs <- Wallet.getUtxos wallet - - let - addresses = fromRight [] possibleUsedAddresses - utxos = fromRight [] (map fold possibleUTxOs) - utxoAddresses' <- liftEffect $ runGarbageCollector cardanoMultiplatformLib do - _TransactionUnspentOutput <- asksLib _."TransactionUnspentOutput" - for utxos \(utxo :: CborHex TransactionUnspentOutputObject) -> do - let - utxo' = cborHexToCbor utxo - unspentTxOutObj <- allocate $ transactionUnspentOutput.from_bytes _TransactionUnspentOutput utxo' - txOutObj <- allocate $ transactionUnspentOutputObject.output unspentTxOutObj - addressObj <- allocate $ transactionOutputObject.address txOutObj - liftEffect $ addressObject.to_bech32 addressObj NoProblem.undefined - addresses' <- liftEffect $ Array.catMaybes <$> for addresses \someAddress -> do - fromSomeAddress cardanoMultiplatformLib someAddress - pure $ Array.nub $ utxoAddresses' <> addresses' - -walletContext :: CardanoMultiplatformLib.Lib -> Wallet.Api -> Aff WalletContext -walletContext cardanoMultiplatformLib wallet = do - balance <- walletBalance cardanoMultiplatformLib wallet - usedAddresses <- walletAddresses cardanoMultiplatformLib wallet - chAddr <- changeAddress cardanoMultiplatformLib wallet - - pure $ WalletContext - { balance - , changeAddress: chAddr - , usedAddresses - } From ae75b209679ab9feb0668e2bb22338c252f6ace6 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Tue, 12 Sep 2023 13:20:26 +0200 Subject: [PATCH 04/10] PLT-7412: Filter contracts by address and role tokens --- spago.dhall | 1 + src/Component/App.purs | 214 ++++++++++++++++++++------------------- src/Component/Types.purs | 2 - src/Main.purs | 28 +---- 4 files changed, 116 insertions(+), 129 deletions(-) diff --git a/spago.dhall b/spago.dhall index 600a76b7..34a932ce 100644 --- a/spago.dhall +++ b/spago.dhall @@ -37,6 +37,7 @@ , "marlowe" , "marlowe-runtime-client" , "maybe" + , "monad-loops" , "newtype" , "node-buffer" , "node-fs-aff" diff --git a/src/Component/App.purs b/src/Component/App.purs index 05e8118d..9ebc8c4b 100644 --- a/src/Component/App.purs +++ b/src/Component/App.purs @@ -2,58 +2,52 @@ module Component.App where import Prelude -import CardanoMultiplatformLib (bech32ToString) +import CardanoMultiplatformLib.Types (Bech32) import Component.Assets.Svgs (marloweLogoUrl) import Component.ConnectWallet (mkConnectWallet, walletInfo) import Component.ConnectWallet as ConnectWallet import Component.ContractList (mkContractList) import Component.Footer (footer) import Component.Footer as Footer -import Component.InputHelper (addressesInContract, rolesInContract) import Component.LandingPage (mkLandingPage) import Component.MessageHub (mkMessageBox, mkMessagePreview) import Component.Modal (Size(..), mkModal) -import Component.Types (ContractInfo(..), MessageContent(Success, Info), MessageHub(MessageHub), MkComponentMBase, WalletInfo(..)) +import Component.Types (ContractInfo(..), MessageContent(Success), MessageHub(MessageHub), MkComponentMBase, WalletInfo(..)) import Component.Types.ContractInfo (MarloweInfo(..)) import Component.Widgets (link, linkWithIcon) +import Contrib.Cardano (AssetId) import Contrib.Cardano as Cardano -import Contrib.Data.Map (New(..), Old(..), additions, deletions) as Map -import Contrib.Halogen.Subscription (MinInterval(..)) -import Contrib.Halogen.Subscription (bindEffect, foldMapThrottle) as Subscription import Contrib.React.Svg (svgImg) import Control.Monad.Error.Class (catchError) +import Control.Monad.Loops (untilJust) import Control.Monad.Reader.Class (asks) import Data.Array as Array import Data.Either (Either(..)) -import Data.Foldable (length) -import Data.List (List) import Data.List as List import Data.Map (Map) -import Data.Map (catMaybes, empty, lookup, keys) as Map +import Data.Map (catMaybes, keys) as Map import Data.Maybe (Maybe(..), fromMaybe) import Data.Monoid as Monoid -import Data.Newtype (un) +import Data.Newtype (un, unwrap) import Data.Newtype as Newtype import Data.Time.Duration (Milliseconds(..)) import Data.Traversable (for, traverse) import Data.Tuple.Nested ((/\)) import Debug (traceM) import Effect (Effect) -import Effect.Aff (Aff, error, killFiber, launchAff, launchAff_) +import Effect.Aff (Aff, delay, forkAff, supervise) import Effect.Class (liftEffect) import Effect.Exception (throw) -import Effect.Now (now) -import Halogen.Subscription (Emitter) as Subscription -import Language.Marlowe.Core.V1.Semantics as V1 -import Language.Marlowe.Core.V1.Semantics.Types as V1 -import Marlowe.Runtime.Web.Streaming (ContractWithTransactionsEvent, ContractWithTransactionsMap, ContractWithTransactionsStream(..)) -import Marlowe.Runtime.Web.Types (PolicyId(..)) +import Language.Marlowe.Core.V1.Semantics (emptyState) as V1 +import Marlowe.Runtime.Web.Streaming (ContractWithTransactionsMap, ContractWithTransactionsStream(..), MaxPages(..), PollingInterval(..), RequestInterval(..)) +import Marlowe.Runtime.Web.Streaming as Streaming +import Marlowe.Runtime.Web.Types (BlockHeader(..), BlockNumber(..), ContractHeader(..), PolicyId(..), Runtime(..)) import Marlowe.Runtime.Web.Types as Runtime import React.Basic (JSX) import React.Basic as ReactContext import React.Basic.DOM (div, img, span_, text) as DOOM import React.Basic.DOM.Simplified.Generated as DOM -import React.Basic.Hooks (component, provider, readRef, useEffect, useEffectOnce, useState') +import React.Basic.Hooks (component, provider, readRef, useState') import React.Basic.Hooks as React import React.Basic.Hooks.Aff (useAff) import ReactBootstrap.Icons (unsafeIcon) @@ -62,7 +56,7 @@ import ReactBootstrap.Offcanvas (offcanvas) import ReactBootstrap.Offcanvas as Offcanvas import Record as Record import Type.Prelude (Proxy(..)) -import Utils.React.Basic.Hooks (useEmitter', useLoopAff, useStateRef, useStateRef') +import Utils.React.Basic.Hooks (useLoopAff, useStateRef, useStateRef') import Wallet as Wallet import WalletContext (WalletContext(..)) import WalletContext as WalletContext @@ -136,17 +130,11 @@ mkApp = do connectWallet <- mkConnectWallet pure { contractListComponent, connectWallet, messageBox } - (ContractWithTransactionsStream contractStream) <- asks _.contractStream - - throttledEmitter :: Subscription.Emitter (List ContractWithTransactionsEvent) <- liftEffect $ - Subscription.foldMapThrottle (List.singleton) (MinInterval $ Milliseconds 1_000.0) contractStream.emitter - - initialVersion <- liftEffect now - walletInfoCtx <- asks _.walletInfoCtx msgHub@(MessageHub msgHubProps) <- asks _.msgHub about <- asks _.aboutMarkdown + Runtime runtime <- asks _.runtime liftEffect $ component "App" \_ -> React.do possibleWalletInfo /\ setWalletInfo <- useState' Nothing @@ -157,10 +145,35 @@ mkApp = do possibleWalletContext /\ setWalletContext <- useState' Nothing possibleWalletContextRef <- useStateRef' possibleWalletContext - useEffectOnce do - -- FIXME: We should restart fetchers on exception - fiber <- launchAff $ contractStream.start - pure $ launchAff_ $ killFiber (error "Unmounting component") fiber + possibleContractMap /\ setContractMap <- useState' Nothing + + -- TODO: use changeAddress as well + useAff (map (_.usedAddresses <<< unwrap) possibleWalletContext) $ do + let + walletCtx = un WalletContext <$> possibleWalletContext + (usedAddresses :: Array Bech32) = fromMaybe [] $ _.usedAddresses <$> walletCtx + (tokens :: Array AssetId) = fromMaybe [] $ Array.fromFoldable <<< Map.keys <<< un Cardano.Value <<< _.balance <$> walletCtx + + reqInterval = RequestInterval (Milliseconds 50.0) + pollInterval = PollingInterval (Milliseconds 60_000.0) + filterContracts getContractResponse = case un ContractHeader getContractResponse.resource of + { block: Nothing } -> true + { block: Just (BlockHeader { blockNo: BlockNumber blockNo }) } -> blockNo > 909000 -- 904279 + maxPages = Just (MaxPages 1) + params = { partyAddresses: usedAddresses, partyRoles: tokens, tags: [] } + + ContractWithTransactionsStream contractStream <- Streaming.mkContractsWithTransactions pollInterval reqInterval params filterContracts maxPages runtime.serverURL + supervise do + void $ forkAff do + untilJust do + updates <- liftEffect $ contractStream.getLiveState + let + new = mkAppContractInfoMap possibleWalletContext updates + liftEffect $ setContractMap $ Just new + delay (Milliseconds 1_000.0) + pure Nothing + + contractStream.start useLoopAff walletInfoName (Milliseconds 20_000.0) do pwi <- liftEffect $ readRef possibleWalletInfoRef @@ -183,39 +196,40 @@ mkApp = do checkingNotifications /\ setCheckingNotifications <- useState' false displayOption /\ setDisplayOption <- useState' Default + -- TODO: re-introduce notifications -- We are ignoring contract events for now and we update the whole contractInfo set. - upstreamVersion <- useEmitter' initialVersion (Subscription.bindEffect (const now) throttledEmitter) - upstreamVersionRef <- useStateRef' upstreamVersion - - -- Let's use versioning so we avoid large comparison. - (version /\ contractMap) /\ setContractMap <- useState' (upstreamVersion /\ AppContractInfoMap { walletContext: possibleWalletContext, map: Map.empty }) - idRef <- useStateRef version contractMap - - useEffect (upstreamVersion /\ possibleWalletContext) do - updates <- contractStream.getLiveState - old <- readRef idRef - newVersion <- readRef upstreamVersionRef - let - new = updateAppContractInfoMap old possibleWalletContext updates - _map (AppContractInfoMap { map }) = map - - old' = _map old - new' = _map new - - (additionsNumber :: Int) = length $ Map.additions (Map.Old old') (Map.New new') - (deletionsNumber :: Int) = length $ Map.deletions (Map.Old old') (Map.New new') - - when (deletionsNumber > 0 || additionsNumber > 0) do - msgHubProps.add $ Info $ DOOM.text $ - "Update: " - <> (if deletionsNumber == 0 then "" else show deletionsNumber <> " contracts removed") - <> (if deletionsNumber > 0 && additionsNumber > 0 then ", " else "") - <> (if additionsNumber == 0 then "" else show additionsNumber <> " contracts discovered") - <> "." - - - setContractMap (newVersion /\ new) - pure $ pure unit + -- upstreamVersion <- useEmitter' initialVersion (Subscription.bindEffect (const now) emitter) + -- upstreamVersionRef <- useStateRef' upstreamVersion + -- + -- -- Let's use versioning so we avoid large comparison. + -- (version /\ contractMap) /\ setContractMap <- useState' (upstreamVersion /\ AppContractInfoMap { walletContext: possibleWalletContext, map: Map.empty }) + -- idRef <- useStateRef version contractMap + -- + -- useEffect (upstreamVersion /\ possibleWalletContext) do + -- updates <- contractStream.getLiveState + -- old <- readRef idRef + -- newVersion <- readRef upstreamVersionRef + -- let + -- new = updateAppContractInfoMap old possibleWalletContext updates + -- _map (AppContractInfoMap { map }) = map + -- + -- old' = _map old + -- new' = _map new + -- + -- (additionsNumber :: Int) = length $ Map.additions (Map.Old old') (Map.New new') + -- (deletionsNumber :: Int) = length $ Map.deletions (Map.Old old') (Map.New new') + -- + -- when (deletionsNumber > 0 || additionsNumber > 0) do + -- msgHubProps.add $ Info $ DOOM.text $ + -- "Update: " + -- <> (if deletionsNumber == 0 then "" else show deletionsNumber <> " contracts removed") + -- <> (if deletionsNumber > 0 && additionsNumber > 0 then ", " else "") + -- <> (if additionsNumber == 0 then "" else show additionsNumber <> " contracts discovered") + -- <> "." + -- + -- + -- setContractMap (newVersion /\ new) + -- pure $ pure unit -- -- This causes a lot of re renders - we avoid it for now by -- -- enforcing manual offcanvas toggling. @@ -232,7 +246,9 @@ mkApp = do liftEffect $ setWalletInfo $ Just walletInfo let - AppContractInfoMap { map: contracts } = contractMap + possibleContracts = do + AppContractInfoMap { map: contracts } <- possibleContractMap + pure contracts pure $ case possibleWalletInfo of Nothing -> landingPage { setWalletInfo: setWalletInfo <<< Just } @@ -272,9 +288,10 @@ mkApp = do ] ] ] - , DOM.div { className: "position-fixed mt-2 position-left-50 transform-translate-x--50 z-index-popover" } $ - DOM.div { className: "container-xl" } - $ DOM.div { className: "row" } $ messagePreview msgHub + , DOM.div { className: "position-fixed mt-2 position-left-50 transform-translate-x--50 z-index-popover" } + $ DOM.div { className: "container-xl" } + $ DOM.div { className: "row" } + $ messagePreview msgHub , ReactContext.consumer msgHubProps.ctx \_ -> pure $ offcanvas { onHide: setCheckingNotifications false @@ -312,11 +329,11 @@ mkApp = do jsx , do let - contractArray = Array.fromFoldable contracts + contractArray = Array.fromFoldable <$> possibleContracts subcomponents.contractListComponent - { possibleContracts: do - if version == initialVersion then Nothing - else Just contractArray + { possibleContracts: contractArray + -- if version == initialVersion then Nothing + -- else Just contractArray , connectedWallet: possibleWalletInfo } -- renderTab props children = tab props $ DOM.div { className: "row pt-4" } children @@ -346,12 +363,12 @@ mkApp = do , footer (Footer.Fixed true) ] -updateAppContractInfoMap :: AppContractInfoMap -> Maybe WalletContext -> ContractWithTransactionsMap -> AppContractInfoMap -updateAppContractInfoMap (AppContractInfoMap { map: prev }) walletContext updates = do +mkAppContractInfoMap :: Maybe WalletContext -> ContractWithTransactionsMap -> AppContractInfoMap +mkAppContractInfoMap walletContext updates = do let - walletCtx = un WalletContext <$> walletContext - (usedAddresses :: Array String) = map bech32ToString $ fromMaybe [] $ _.usedAddresses <$> walletCtx - (tokens :: Array String) = map Cardano.assetIdToString $ fromMaybe [] $ Array.fromFoldable <<< Map.keys <<< un Cardano.Value <<< _.balance <$> walletCtx + -- walletCtx = un WalletContext <$> walletContext + -- (usedAddresses :: Array String) = map bech32ToString $ fromMaybe [] $ _.usedAddresses <$> walletCtx + -- (tokens :: Array String) = map Cardano.assetIdToString $ fromMaybe [] $ Array.fromFoldable <<< Map.keys <<< un Cardano.Value <<< _.balance <$> walletCtx map = Map.catMaybes $ updates <#> \{ contract: { resource: contractHeader@(Runtime.ContractHeader { contractId, roleTokenMintingPolicyId, tags }), links: endpoints }, contractState, transactions } -> do let @@ -368,32 +385,23 @@ updateAppContractInfoMap (AppContractInfoMap { map: prev }) walletContext update , unclaimedPayouts: contractState'.unclaimedPayouts } - let - keepContract = - case marloweInfo of - Just (MarloweInfo { initialContract }) - | (not $ Array.null $ Array.intersect usedAddresses (addressesInContract initialContract)) - || (not $ Array.null $ Array.intersect tokens (rolesInContract initialContract)) -> Just true - Just _ -> Just false - _ -> Nothing - - case contractId `Map.lookup` prev, keepContract of - Just (ContractInfo contractInfo), Just true -> do - pure $ ContractInfo $ contractInfo - { marloweInfo = marloweInfo - , _runtime - { contractHeader = contractHeader - , transactions = transactions - } - } - Nothing, Just true -> do - let Runtime.ContractHeader { contractId } = contractHeader - pure $ ContractInfo $ - { contractId - , endpoints - , marloweInfo - , tags - , _runtime: { contractHeader, transactions } - } - _, _ -> Nothing + -- let + -- keepContract = + -- case marloweInfo of + -- Just (MarloweInfo { initialContract }) + -- | (not $ Array.null $ Array.intersect usedAddresses (addressesInContract initialContract)) + -- || (not $ Array.null $ Array.intersect tokens (rolesInContract initialContract)) -> Just true + -- Just _ -> Just false + -- _ -> Nothing + + let Runtime.ContractHeader { contractId } = contractHeader + + pure $ ContractInfo $ + { contractId + , endpoints + , marloweInfo + , tags + , _runtime: { contractHeader, transactions } + } + AppContractInfoMap { walletContext, map } diff --git a/src/Component/Types.purs b/src/Component/Types.purs index d9f2822a..6588ada8 100644 --- a/src/Component/Types.purs +++ b/src/Component/Types.purs @@ -67,8 +67,6 @@ type MkContextBase r = , walletInfoCtx :: ReactContext (Maybe (WalletInfo Wallet.Api /\ WalletContext)) -- FIXME: use more advanced logger so we use levels and setup app verbosity. , logger :: String -> Effect Unit - , contractStream :: ContractWithTransactionsStream - -- , transactionStream :: ContractTransactionsStream , runtime :: Runtime , msgHub :: MessageHub , aboutMarkdown :: String diff --git a/src/Main.purs b/src/Main.purs index 553c764c..a86ed8a6 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -8,28 +8,19 @@ import Component.MessageHub (mkMessageHub) import Component.Types (Slotting(..)) import Contrib.Data.Argonaut (JsonParser) import Contrib.Effect as Effect -import Contrib.JsonBigInt (fromJson) import Contrib.JsonBigInt as JsonBigInt import Control.Monad.Reader (runReaderT) -import Data.Argonaut (Json, decodeJson, fromString, (.:)) +import Data.Argonaut (Json, decodeJson, (.:)) import Data.BigInt.Argonaut as BigInt -import Data.Map as Map -import Data.Maybe (Maybe(..), fromJust, isJust, maybe) -import Data.Newtype (un) +import Data.Maybe (Maybe(..), fromJust, maybe) import Data.Tuple.Nested ((/\)) -import Debug (traceM) import Effect (Effect) -import Effect.Aff (Milliseconds(..), delay, launchAff_) +import Effect.Aff (launchAff_) import Effect.Class (liftEffect) import Effect.Class.Console as Console import Effect.Exception (throw) -import Foreign.Object (Object) -import JS.Unsafe.Stringify (unsafeStringify) import Marlowe.Runtime.Web as Marlowe.Runtime.Web -import Marlowe.Runtime.Web.Streaming (MaxPages(..), PollingInterval(..), RequestInterval(..)) -import Marlowe.Runtime.Web.Streaming as Streaming -import Marlowe.Runtime.Web.Types (BlockHeader(..), BlockNumber(..), ContractHeader(..), ServerURL(..)) -import Marlowe.Runtime.Web.Types as Runtime +import Marlowe.Runtime.Web.Types (ServerURL(..)) import Partial.Unsafe (unsafePartial) import React.Basic (createContext) import React.Basic.DOM.Client (createRoot, renderRoot) @@ -84,16 +75,6 @@ main configJson = do (getElementById "app-root" $ toNonElementParentNode doc) reactRoot <- createRoot container launchAff_ do - contractStream <- do - let - reqInterval = RequestInterval (Milliseconds 50.0) - pollInterval = PollingInterval (Milliseconds 60_000.0) - filterContracts getContractResponse = case un ContractHeader getContractResponse.resource of - { block: Nothing } -> true - { block: Just (BlockHeader { blockNo: BlockNumber blockNo }) } -> blockNo > 909000 -- 904279 - maxPages = Just (MaxPages 1) - params = { partyAddresses: [], tags: [], partyRoles: [] } - Streaming.mkContractsWithTransactions pollInterval reqInterval params filterContracts maxPages config.marloweWebServerUrl CardanoMultiplatformLib.importLib >>= case _ of Nothing -> liftEffect $ logger "Cardano serialization lib loading failed" @@ -105,7 +86,6 @@ main configJson = do { cardanoMultiplatformLib , walletInfoCtx , logger - , contractStream , msgHub , runtime , aboutMarkdown: config.aboutMarkdown From 800a29bcf8b857ecc5c0e55b80f58db6252238c4 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Wed, 13 Sep 2023 09:10:25 +0200 Subject: [PATCH 05/10] PLT-7412: Include changeAddress to detect changes of wallet --- src/Component/App.purs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Component/App.purs b/src/Component/App.purs index 9ebc8c4b..b304ff59 100644 --- a/src/Component/App.purs +++ b/src/Component/App.purs @@ -28,7 +28,7 @@ import Data.Map (Map) import Data.Map (catMaybes, keys) as Map import Data.Maybe (Maybe(..), fromMaybe) import Data.Monoid as Monoid -import Data.Newtype (un, unwrap) +import Data.Newtype (un) import Data.Newtype as Newtype import Data.Time.Duration (Milliseconds(..)) import Data.Traversable (for, traverse) @@ -147,10 +147,11 @@ mkApp = do possibleContractMap /\ setContractMap <- useState' Nothing - -- TODO: use changeAddress as well - useAff (map (_.usedAddresses <<< unwrap) possibleWalletContext) $ do + let + walletCtx = un WalletContext <$> possibleWalletContext + + useAff ((\w -> w.usedAddresses /\ w.changeAddress) <$> walletCtx) do let - walletCtx = un WalletContext <$> possibleWalletContext (usedAddresses :: Array Bech32) = fromMaybe [] $ _.usedAddresses <$> walletCtx (tokens :: Array AssetId) = fromMaybe [] $ Array.fromFoldable <<< Map.keys <<< un Cardano.Value <<< _.balance <$> walletCtx From 5f35da852ad9f79b1369e344acc5d6cd856eee61 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Wed, 13 Sep 2023 12:05:46 +0200 Subject: [PATCH 06/10] PLT-7412: Explicitly exclude Ada as role token --- src/Component/App.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Component/App.purs b/src/Component/App.purs index b304ff59..b885b786 100644 --- a/src/Component/App.purs +++ b/src/Component/App.purs @@ -15,8 +15,7 @@ import Component.Modal (Size(..), mkModal) import Component.Types (ContractInfo(..), MessageContent(Success), MessageHub(MessageHub), MkComponentMBase, WalletInfo(..)) import Component.Types.ContractInfo (MarloweInfo(..)) import Component.Widgets (link, linkWithIcon) -import Contrib.Cardano (AssetId) -import Contrib.Cardano as Cardano +import Contrib.Cardano (AssetId(..), NonAdaAssets(..), nonAdaAssets) import Contrib.React.Svg (svgImg) import Control.Monad.Error.Class (catchError) import Control.Monad.Loops (untilJust) @@ -32,6 +31,7 @@ import Data.Newtype (un) import Data.Newtype as Newtype import Data.Time.Duration (Milliseconds(..)) import Data.Traversable (for, traverse) +import Data.Tuple (uncurry) import Data.Tuple.Nested ((/\)) import Debug (traceM) import Effect (Effect) @@ -153,7 +153,7 @@ mkApp = do useAff ((\w -> w.usedAddresses /\ w.changeAddress) <$> walletCtx) do let (usedAddresses :: Array Bech32) = fromMaybe [] $ _.usedAddresses <$> walletCtx - (tokens :: Array AssetId) = fromMaybe [] $ Array.fromFoldable <<< Map.keys <<< un Cardano.Value <<< _.balance <$> walletCtx + (tokens :: Array AssetId) = map (uncurry AssetId) <<< fromMaybe [] $ Array.fromFoldable <<< Map.keys <<< un NonAdaAssets <<< nonAdaAssets <<< _.balance <$> walletCtx reqInterval = RequestInterval (Milliseconds 50.0) pollInterval = PollingInterval (Milliseconds 60_000.0) From c04313b93f57d5df8234ec7647ae99aefbc533cf Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 14 Sep 2023 10:14:37 +0200 Subject: [PATCH 07/10] update node-version --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index b0a8d240..271b3745 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -23,7 +23,7 @@ jobs: - uses: actions/setup-node@v2 with: - node-version: "18.x" + node-version: "20.x" - name: Install dependencies run: npm install From 0b8d4b8e02988b60e9a4985dac92637bcc48e59a Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 14 Sep 2023 10:17:53 +0200 Subject: [PATCH 08/10] Use v2 --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 271b3745..2ee3ba84 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -12,7 +12,7 @@ jobs: steps: - uses: actions/checkout@v2 - - uses: actions/setup-node@v1 + - uses: actions/setup-node@v2 - uses: purescript-contrib/setup-purescript@main with: From ff5083b772cb58ab0f988fa7dcd0e1f9b6341055 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 14 Sep 2023 10:21:17 +0200 Subject: [PATCH 09/10] formatting --- src/Component/ContractDetails.purs | 2 +- src/Component/ContractList.purs | 38 ++-- src/Component/Footer.purs | 2 +- src/Component/InputHelper.purs | 2 +- src/Component/MarloweYaml.purs | 1 - src/Component/Types.purs | 4 +- src/Component/Withdrawals.purs | 26 +-- src/Contrib/JsonBigInt.purs | 26 +-- test/Main.purs | 2 +- test/Marlowe/Runtime/Web.purs | 3 +- test/Marlowe/Runtime/Web/Client.purs | 283 +++++++++++++-------------- test/Marlowe/Runtime/Web/Types.purs | 8 +- 12 files changed, 197 insertions(+), 200 deletions(-) diff --git a/src/Component/ContractDetails.purs b/src/Component/ContractDetails.purs index cf6ec2e0..4eafa497 100644 --- a/src/Component/ContractDetails.purs +++ b/src/Component/ContractDetails.purs @@ -91,7 +91,7 @@ mkComponent = do React.fragment [ tabs { fill: true, justify: true, defaultActiveKey, variant: Tabs.variant.pills } do let - renderTab props children = tab props $ DOM.div { className: "pt-4 w-100 h-vh50 overflow-auto"} children + renderTab props children = tab props $ DOM.div { className: "pt-4 w-100 h-vh50 overflow-auto" } children [ case contract of Nothing -> mempty Just contract' -> renderTab diff --git a/src/Component/ContractList.purs b/src/Component/ContractList.purs index e40b7d8a..cdd8623b 100644 --- a/src/Component/ContractList.purs +++ b/src/Component/ContractList.purs @@ -130,12 +130,12 @@ derive instance Eq ContractTemplate data ModalAction = NewContract | ContractDetails - { contract :: Maybe V1.Contract - , state :: Maybe V1.State - , initialContract :: V1.Contract - , initialState :: V1.State - , transactionEndpoints :: Array Runtime.TransactionEndpoint - } + { contract :: Maybe V1.Contract + , state :: Maybe V1.State + , initialContract :: V1.Contract + , initialState :: V1.State + , transactionEndpoints :: Array Runtime.TransactionEndpoint + } | ApplyInputs TransactionsEndpoint ApplyInputs.Machine.MarloweContext | Withdrawal WithdrawalsEndpoint (NonEmptyArray.NonEmptyArray String) TxOutRef | ContractTemplate ContractTemplate @@ -164,7 +164,8 @@ actionIconSizing = " h4" runLiteTags :: Tags -> Array String runLiteTags (Tags metadata) = case Map.lookup runLiteTag metadata >>= decodeJson >>> hush of Just arr -> - Array.filter ((_ > 2) <<< length) -- ignoring short tags + Array.filter ((_ > 2) <<< length) -- ignoring short tags + $ arr Nothing -> [] @@ -221,15 +222,15 @@ mkContractList = do contains pattern (txOutRefToString contractId) || or (map (contains pattern) tagList) filtered <|> possibleContracts' - -- pure $ if ordering.orderAsc - -- then sortedContracts - -- else Array.reverse sortedContracts + -- pure $ if ordering.orderAsc + -- then sortedContracts + -- else Array.reverse sortedContracts - -- isLoadingContracts :: Boolean - -- isLoadingContracts = case possibleContracts'' of - -- Nothing -> true - -- Just [] -> true - -- Just contracts -> any (\(ContractInfo { marloweInfo }) -> isNothing marloweInfo) contracts + -- isLoadingContracts :: Boolean + -- isLoadingContracts = case possibleContracts'' of + -- Nothing -> true + -- Just [] -> true + -- Just contracts -> any (\(ContractInfo { marloweInfo }) -> isNothing marloweInfo) contracts pure $ case possibleModalAction, connectedWallet of @@ -271,7 +272,7 @@ mkContractList = do , onSuccess , onDismiss: resetModalAction } - Just (ContractDetails { contract, state, initialContract, initialState, transactionEndpoints}), _ -> do + Just (ContractDetails { contract, state, initialContract, initialState, transactionEndpoints }), _ -> do let onClose = resetModalAction contractDetails { contract, onClose, state, transactionEndpoints, initialContract, initialState } @@ -421,8 +422,9 @@ mkContractList = do -- , disabled } [ text $ txOutRefToString contractId ] - , DOM.a { href: "#", className: "cursor-pointer text-decoration-none text-decoration-underline-hover text-reset" } $ - Icons.toJSX $ unsafeIcon "clipboard-plus ms-1 d-inline-block" + , DOM.a { href: "#", className: "cursor-pointer text-decoration-none text-decoration-underline-hover text-reset" } + $ Icons.toJSX + $ unsafeIcon "clipboard-plus ms-1 d-inline-block" ] , tdCentered [ do diff --git a/src/Component/Footer.purs b/src/Component/Footer.purs index 70ac4cc5..7bf31c80 100644 --- a/src/Component/Footer.purs +++ b/src/Component/Footer.purs @@ -11,7 +11,7 @@ footer :: Fixed -> JSX footer (Fixed fixed) = do let possibleFixedClass = - if fixed then "footer " else "" + if fixed then "footer " else "" DOM.footer { className: possibleFixedClass <> "mt-auto py-2 bg-light shadow-top z-index-sticky" , children: diff --git a/src/Component/InputHelper.purs b/src/Component/InputHelper.purs index 1747c267..9a996bdd 100644 --- a/src/Component/InputHelper.purs +++ b/src/Component/InputHelper.purs @@ -264,7 +264,7 @@ type ExecutionPath = List ((Maybe V1.InputContent /\ V1.TimeInterval) /\ InputEx executionPath :: Array ((Maybe V1.InputContent) /\ V1.TimeInterval) -> V1.Contract -> V1.State -> Either String ExecutionPath executionPath inputs contract state = do let - initialAcc :: { contract :: V1.Contract, state:: V1.State, executionPath :: ExecutionPath } + initialAcc :: { contract :: V1.Contract, state :: V1.State, executionPath :: ExecutionPath } initialAcc = { contract, state, executionPath: List.Nil } step acc input = do diff --git a/src/Component/MarloweYaml.purs b/src/Component/MarloweYaml.purs index 7410111b..78e2899a 100644 --- a/src/Component/MarloweYaml.purs +++ b/src/Component/MarloweYaml.purs @@ -18,7 +18,6 @@ marloweYaml contract = DOM.div { className: "child-pre-m-0 child-pre-px-2 child-pre-y-0 child-pre-bg-transparent" } [ yamlSyntaxHighlighter contract { sortKeys: mkFn2 sortMarloweKeys } ] - -- Alphabetical order of keys sortStateKeys :: String -> String -> JsYaml.JsOrdering sortStateKeys a b = JsYaml.toJsOrdering $ a `compare` b diff --git a/src/Component/Types.purs b/src/Component/Types.purs index 6588ada8..9c896cf7 100644 --- a/src/Component/Types.purs +++ b/src/Component/Types.purs @@ -58,8 +58,8 @@ newtype MessageHub = MessageHub } newtype Slotting = Slotting - { slotLength :: BigInt, - slotZeroTime :: BigInt + { slotLength :: BigInt + , slotZeroTime :: BigInt } type MkContextBase r = diff --git a/src/Component/Withdrawals.purs b/src/Component/Withdrawals.purs index 30d2bd52..4a1f55c4 100644 --- a/src/Component/Withdrawals.purs +++ b/src/Component/Withdrawals.purs @@ -120,7 +120,7 @@ mkComponent = do -- Rather improbable path because we disable submit button if the form is invalid traceM "withdrawal error" pure unit - + { formState, onSubmit: onSubmit', result } <- useStatelessFormSpec { spec: formSpec , onSubmit @@ -132,18 +132,18 @@ mkComponent = do fields = StatelessFormSpec.renderFormSpec formSpec formState formBody = DOM.div { className: "form-group" } fields actions = fragment - [ DOM.button - do - let - disabled = case result of - Just (V (Right _) /\ _) -> false - _ -> true - { className: "btn btn-primary" - , onClick: onSubmit' - , disabled - } - [ R.text "Submit" ] - ] + [ DOM.button + do + let + disabled = case result of + Just (V (Right _) /\ _) -> false + _ -> true + { className: "btn btn-primary" + , onClick: onSubmit' + , disabled + } + [ R.text "Submit" ] + ] { title: R.text "Withdrawal" , onDismiss diff --git a/src/Contrib/JsonBigInt.purs b/src/Contrib/JsonBigInt.purs index 4174905b..6e76ed08 100644 --- a/src/Contrib/JsonBigInt.purs +++ b/src/Contrib/JsonBigInt.purs @@ -21,23 +21,23 @@ unsafeToJson :: BigIntJson -> Json unsafeToJson = unsafeCoerce toBigInt :: BigIntJson -> Maybe BigInt -toBigInt json = if isBigInt json - then Just <<< unsafeCoerce $ json +toBigInt json = + if isBigInt json then Just <<< unsafeCoerce $ json else Nothing -type ParseResultHandlers a = { failure :: String -> a, success :: BigIntJson -> a} +type ParseResultHandlers a = { failure :: String -> a, success :: BigIntJson -> a } -foreign import patchersImpl :: - { patchStringify :: Effect Unit - , patchParse :: Effect Unit - , parseImpl :: forall a. Fn3 (ParseResultHandlers a) Reviver JsonString a - } +foreign import patchersImpl + :: { patchStringify :: Effect Unit + , patchParse :: Effect Unit + , parseImpl :: forall a. Fn3 (ParseResultHandlers a) Reviver JsonString a + } -patchers :: - { patchStringify :: Effect Unit - , patchParse :: Effect Unit - , parse :: Reviver -> JsonString -> Either String BigIntJson - } +patchers + :: { patchStringify :: Effect Unit + , patchParse :: Effect Unit + , parse :: Reviver -> JsonString -> Either String BigIntJson + } patchers = do let eitherHandlers = { failure: Left, success: Right } diff --git a/test/Main.purs b/test/Main.purs index c7e84084..027c6bc1 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -27,4 +27,4 @@ main = do runSpec' config [ consoleReporter, specReporter ] $ do Spec.parallel do Web.spec serverUrlStr - --Test.Contrib.Data.Map.spec +--Test.Contrib.Data.Map.spec diff --git a/test/Marlowe/Runtime/Web.purs b/test/Marlowe/Runtime/Web.purs index c36cb34c..f1abd08a 100644 --- a/test/Marlowe/Runtime/Web.purs +++ b/test/Marlowe/Runtime/Web.purs @@ -21,6 +21,5 @@ spec possibleServerURL = do Just serverURL -> Client.spec serverURL Nothing -> it ("Skipping client tests as " <> _MARLOWE_WEB_SERVER_URL <> " env var is not set") do - pure unit - + pure unit diff --git a/test/Marlowe/Runtime/Web/Client.purs b/test/Marlowe/Runtime/Web/Client.purs index 4fabb7f2..971481f2 100644 --- a/test/Marlowe/Runtime/Web/Client.purs +++ b/test/Marlowe/Runtime/Web/Client.purs @@ -18,146 +18,143 @@ spec serverUrl@(ServerURL serverUrlStr) = do traceM $ "mnemonic: " <> mnemonicStr traceM $ "mnemonic length: " <> show (Array.length (String.split (String.Pattern " ") mnemonicStr)) - -- it "POST contract correctly" do - -- let - -- -- addr = Address "addr_xvk12wjl5zcq8dd4q7he36667aqvcwm9sjhqpk3vyu625g3tcfex5sckf35hyu3vnhveyqrqvtrvff6m0jqu6xfus5lx5att4h2g7pteqrgu04hjs" - -- -- addr = Address "00bf05a62e0a25a1cde8b6f3b5b0d33ea60fde9a9ec8f615169493c7a90f1e33e7772682a03adde020ba989d97339c9b3f32a516aa056a9c7c" - -- -- addr = Address "addr1w94f8ywk4fg672xasahtk4t9k6w3aql943uxz5rt62d4dvq8evxaf" - -- addr = unsafeBech32 "addr_test1qz4y0hs2kwmlpvwc6xtyq6m27xcd3rx5v95vf89q24a57ux5hr7g3tkp68p0g099tpuf3kyd5g80wwtyhr8klrcgmhasu26qcn" - -- req = PostContractsRequest - -- { metadata: mempty - -- -- , version :: MarloweVersion - -- -- , roles :: Maybe RolesConfig - -- , contract: V1.Close - -- , minUTxODeposit: Lovelace (BigInt.fromInt 2_000_000) - -- , changeAddress: addr - -- , addresses: [addr] - -- , collateralUTxOs: [] - -- } - -- post' serverUrl api req >>= case _ of - -- Right _ -> do - -- pure unit - -- Left (FetchError (InvalidStatusCode res)) -> do - -- traceM "STATUS CODE ERROR" - -- traceM $ res.status - -- traceM $ res.statusText - -- body <- res.text - -- traceM "BODY:" - -- traceM body - - -- Left err -> do - -- traceM "Other error" - -- traceM err - -- pure unit - -- -- fail $ "Error: " <> show err - - -- it "POST contract with metadata" do - -- jsonStr <- readTextFile UTF8 "./test/Marlowe/Actus/ex_pam1.json" - -- json <- either (throwError <<< error) pure $ jsonParser jsonStr - - -- let - -- (terms :: Either JsonDecodeError ContractTerms) = decodeJson json - -- -- addr1 = V1.Address "addr1w94f8ywk4fg672xasahtk4t9k6w3aql943uxz5rt62d4dvq8evxaf" - -- -- addr2 = V1.Address "addr1w94f8ywk4fg672xasahtk4t9k6w3aql943uxz5rt62d4dvq8evxaf" - -- -- nami preview - -- -- addr1 = V1.Address "addr_test1qz4y0hs2kwmlpvwc6xtyq6m27xcd3rx5v95vf89q24a57ux5hr7g3tkp68p0g099tpuf3kyd5g80wwtyhr8klrcgmhasu26qcn" - -- -- yoroi preprod - -- addr1 = V1.Address "addr_test1qqe94c7z039ceta3xevcagwwh0l8ahmy90883nqm5edknmyhwefmaav7gfzuuck7c27y6fdp4vzgezrmmts3x3jp989s5f6lqr" - -- addr2 = V1.Address "addr_test1qrwl8cukwn7tazx5aee4ynzgj0edp6un878htr5fpgmjk3yhwefmaav7gfzuuck7c27y6fdp4vzgezrmmts3x3jp989se3tc7f" - - -- case terms of - -- Left err -> fail ("Parsing error: " <> show err) - -- Right contract -> do - -- let - -- metadataJson = encodeJson $ Metadata { contractTerms: contract, party: addr1, counterParty: addr2 } - -- addr = unsafeBech32 "addr_test1qz4y0hs2kwmlpvwc6xtyq6m27xcd3rx5v95vf89q24a57ux5hr7g3tkp68p0g099tpuf3kyd5g80wwtyhr8klrcgmhasu26qcn" - -- cashflows = genProjectedCashflows (addr1 /\ addr2) (defaultRiskFactors contract) contract - -- marloweContract = genContract contract cashflows - -- req = PostContractsRequest - -- { metadata: RT.Metadata $ Map.singleton actusMetadataKey metadataJson - -- -- , version :: MarloweVersion - -- -- , roles :: Maybe RolesConfig - -- , contract: marloweContract - -- , minUTxODeposit: Lovelace (BigInt.fromInt 2_000_000) - -- , changeAddress: addr - -- , addresses: [ addr ] - -- , collateralUTxOs: [] - -- } - -- post' serverUrl api req >>= case _ of - -- Right ({ resource: PostContractsResponseContent res }) -> do - -- traceM res - -- pure unit - -- Left (FetchError (InvalidStatusCode res)) -> do - -- traceM "STATUS CODE ERROR" - -- traceM $ res.status - -- traceM $ res.statusText - -- body <- res.text - -- traceM "BODY:" - -- traceM body - -- Left _ -> do - -- traceM "OTHER error" - -- pure unit - - -- it "GET contracts" do - -- contracts <- getItems' serverUrl api Nothing `catchError` \err -> do - -- log "Get contracts error: " - -- log $ unsafeStringify err - -- throwError err - - -- (hush contracts >>= Array.head) # case _ of - -- Just getContractsResponse -> do - -- traceM getContractsResponse - -- pure unit - -- -- contract <- fetchContract serverUrl contractHeader.links.contract - -- -- transactionHeaders <- fetchTransactionHeaders serverUrl contract.links.transactions - -- -- case head transactionHeaders of - -- -- Just transactionHeader -> do - -- -- transaction <- fetchTransaction serverUrl transactionHeader.links.transaction - -- -- let (Tx tx) = transaction.resource - -- -- case tx.block of - -- -- Just _ -> pure unit - -- -- _ -> fail "Expected block" - -- -- _ -> fail "Expected transaction" - -- _ -> fail "Expected contract" - - - -- it "GET transactions" do - -- (contracts :: Array GetContractsResponse) <- getItems' serverUrl api Nothing >>= Effect.liftEither - - -- let - -- contracts' = Array.catMaybes $ contracts <#> \c@{ resource, links } -> do - -- transactions <- links.transactions - -- pure $ c { links { transactions = transactions } } - - -- void $ for contracts' \{ links } -> do - -- txs <- getItems' serverUrl links.transactions Nothing - -- case txs of - -- Right txs' -> do - -- traceM $ "Transactions: " <> show (Array.length txs') - -- pure unit - -- Left (FetchError (InvalidStatusCode res)) -> do - -- traceM $ "Invalid status code: " <> show res.status - -- body <- res.text - -- traceM $ "error body" <> body - -- pure unit - -- _ -> pure unit - -- traceM txs - -- traceM "transactions fetched correctly" - - - - -- (hush contracts >>= List.head) # case _ of - -- Just getContractsResponse -> do - -- traceM getContractsResponse - -- pure unit - -- -- contract <- fetchContract serverUrl contractHeader.links.contract - -- -- transactionHeaders <- fetchTransactionHeaders serverUrl contract.links.transactions - -- -- case head transactionHeaders of - -- -- Just transactionHeader -> do - -- -- transaction <- fetchTransaction serverUrl transactionHeader.links.transaction - -- -- let (Tx tx) = transaction.resource - -- -- case tx.block of - -- -- Just _ -> pure unit - -- -- _ -> fail "Expected block" - -- -- _ -> fail "Expected transaction" - -- _ -> fail "Expected contract" +-- it "POST contract correctly" do +-- let +-- -- addr = Address "addr_xvk12wjl5zcq8dd4q7he36667aqvcwm9sjhqpk3vyu625g3tcfex5sckf35hyu3vnhveyqrqvtrvff6m0jqu6xfus5lx5att4h2g7pteqrgu04hjs" +-- -- addr = Address "00bf05a62e0a25a1cde8b6f3b5b0d33ea60fde9a9ec8f615169493c7a90f1e33e7772682a03adde020ba989d97339c9b3f32a516aa056a9c7c" +-- -- addr = Address "addr1w94f8ywk4fg672xasahtk4t9k6w3aql943uxz5rt62d4dvq8evxaf" +-- addr = unsafeBech32 "addr_test1qz4y0hs2kwmlpvwc6xtyq6m27xcd3rx5v95vf89q24a57ux5hr7g3tkp68p0g099tpuf3kyd5g80wwtyhr8klrcgmhasu26qcn" +-- req = PostContractsRequest +-- { metadata: mempty +-- -- , version :: MarloweVersion +-- -- , roles :: Maybe RolesConfig +-- , contract: V1.Close +-- , minUTxODeposit: Lovelace (BigInt.fromInt 2_000_000) +-- , changeAddress: addr +-- , addresses: [addr] +-- , collateralUTxOs: [] +-- } +-- post' serverUrl api req >>= case _ of +-- Right _ -> do +-- pure unit +-- Left (FetchError (InvalidStatusCode res)) -> do +-- traceM "STATUS CODE ERROR" +-- traceM $ res.status +-- traceM $ res.statusText +-- body <- res.text +-- traceM "BODY:" +-- traceM body + +-- Left err -> do +-- traceM "Other error" +-- traceM err +-- pure unit +-- -- fail $ "Error: " <> show err + +-- it "POST contract with metadata" do +-- jsonStr <- readTextFile UTF8 "./test/Marlowe/Actus/ex_pam1.json" +-- json <- either (throwError <<< error) pure $ jsonParser jsonStr + +-- let +-- (terms :: Either JsonDecodeError ContractTerms) = decodeJson json +-- -- addr1 = V1.Address "addr1w94f8ywk4fg672xasahtk4t9k6w3aql943uxz5rt62d4dvq8evxaf" +-- -- addr2 = V1.Address "addr1w94f8ywk4fg672xasahtk4t9k6w3aql943uxz5rt62d4dvq8evxaf" +-- -- nami preview +-- -- addr1 = V1.Address "addr_test1qz4y0hs2kwmlpvwc6xtyq6m27xcd3rx5v95vf89q24a57ux5hr7g3tkp68p0g099tpuf3kyd5g80wwtyhr8klrcgmhasu26qcn" +-- -- yoroi preprod +-- addr1 = V1.Address "addr_test1qqe94c7z039ceta3xevcagwwh0l8ahmy90883nqm5edknmyhwefmaav7gfzuuck7c27y6fdp4vzgezrmmts3x3jp989s5f6lqr" +-- addr2 = V1.Address "addr_test1qrwl8cukwn7tazx5aee4ynzgj0edp6un878htr5fpgmjk3yhwefmaav7gfzuuck7c27y6fdp4vzgezrmmts3x3jp989se3tc7f" + +-- case terms of +-- Left err -> fail ("Parsing error: " <> show err) +-- Right contract -> do +-- let +-- metadataJson = encodeJson $ Metadata { contractTerms: contract, party: addr1, counterParty: addr2 } +-- addr = unsafeBech32 "addr_test1qz4y0hs2kwmlpvwc6xtyq6m27xcd3rx5v95vf89q24a57ux5hr7g3tkp68p0g099tpuf3kyd5g80wwtyhr8klrcgmhasu26qcn" +-- cashflows = genProjectedCashflows (addr1 /\ addr2) (defaultRiskFactors contract) contract +-- marloweContract = genContract contract cashflows +-- req = PostContractsRequest +-- { metadata: RT.Metadata $ Map.singleton actusMetadataKey metadataJson +-- -- , version :: MarloweVersion +-- -- , roles :: Maybe RolesConfig +-- , contract: marloweContract +-- , minUTxODeposit: Lovelace (BigInt.fromInt 2_000_000) +-- , changeAddress: addr +-- , addresses: [ addr ] +-- , collateralUTxOs: [] +-- } +-- post' serverUrl api req >>= case _ of +-- Right ({ resource: PostContractsResponseContent res }) -> do +-- traceM res +-- pure unit +-- Left (FetchError (InvalidStatusCode res)) -> do +-- traceM "STATUS CODE ERROR" +-- traceM $ res.status +-- traceM $ res.statusText +-- body <- res.text +-- traceM "BODY:" +-- traceM body +-- Left _ -> do +-- traceM "OTHER error" +-- pure unit + +-- it "GET contracts" do +-- contracts <- getItems' serverUrl api Nothing `catchError` \err -> do +-- log "Get contracts error: " +-- log $ unsafeStringify err +-- throwError err + +-- (hush contracts >>= Array.head) # case _ of +-- Just getContractsResponse -> do +-- traceM getContractsResponse +-- pure unit +-- -- contract <- fetchContract serverUrl contractHeader.links.contract +-- -- transactionHeaders <- fetchTransactionHeaders serverUrl contract.links.transactions +-- -- case head transactionHeaders of +-- -- Just transactionHeader -> do +-- -- transaction <- fetchTransaction serverUrl transactionHeader.links.transaction +-- -- let (Tx tx) = transaction.resource +-- -- case tx.block of +-- -- Just _ -> pure unit +-- -- _ -> fail "Expected block" +-- -- _ -> fail "Expected transaction" +-- _ -> fail "Expected contract" + +-- it "GET transactions" do +-- (contracts :: Array GetContractsResponse) <- getItems' serverUrl api Nothing >>= Effect.liftEither + +-- let +-- contracts' = Array.catMaybes $ contracts <#> \c@{ resource, links } -> do +-- transactions <- links.transactions +-- pure $ c { links { transactions = transactions } } + +-- void $ for contracts' \{ links } -> do +-- txs <- getItems' serverUrl links.transactions Nothing +-- case txs of +-- Right txs' -> do +-- traceM $ "Transactions: " <> show (Array.length txs') +-- pure unit +-- Left (FetchError (InvalidStatusCode res)) -> do +-- traceM $ "Invalid status code: " <> show res.status +-- body <- res.text +-- traceM $ "error body" <> body +-- pure unit +-- _ -> pure unit +-- traceM txs +-- traceM "transactions fetched correctly" + +-- (hush contracts >>= List.head) # case _ of +-- Just getContractsResponse -> do +-- traceM getContractsResponse +-- pure unit +-- -- contract <- fetchContract serverUrl contractHeader.links.contract +-- -- transactionHeaders <- fetchTransactionHeaders serverUrl contract.links.transactions +-- -- case head transactionHeaders of +-- -- Just transactionHeader -> do +-- -- transaction <- fetchTransaction serverUrl transactionHeader.links.transaction +-- -- let (Tx tx) = transaction.resource +-- -- case tx.block of +-- -- Just _ -> pure unit +-- -- _ -> fail "Expected block" +-- -- _ -> fail "Expected transaction" +-- _ -> fail "Expected contract" diff --git a/test/Marlowe/Runtime/Web/Types.purs b/test/Marlowe/Runtime/Web/Types.purs index bda5591e..5947e140 100644 --- a/test/Marlowe/Runtime/Web/Types.purs +++ b/test/Marlowe/Runtime/Web/Types.purs @@ -24,8 +24,8 @@ spec = do json <- either (throwError <<< error) pure $ jsonParser jsonStr (contractsWithLinksJson :: Array Json) <- either (throwError <<< error <<< show) pure do - obj <- decodeJson json - obj .: "results" + obj <- decodeJson json + obj .: "results" for_ contractsWithLinksJson \contractWithLinksJson -> do let @@ -56,8 +56,8 @@ spec = do jsonStr <- readTextFile UTF8 "./test/Marlowe/Runtime/Web/tx-headers.json" json <- either (throwError <<< error) pure $ jsonParser jsonStr (txHeadersJsonArr :: Array Json) <- either (throwError <<< error <<< show) pure do - obj <- decodeJson json - obj .: "results" + obj <- decodeJson json + obj .: "results" for_ txHeadersJsonArr \txHeaderJson -> do let From 0bec17eb6f4ad5f9b07637a5712bcc8d0d924211 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Thu, 14 Sep 2023 10:27:54 +0200 Subject: [PATCH 10/10] formatting --- src/Component/ApplyInputs/Machine.purs | 1 - src/Component/CreateContract/Machine.purs | 2 +- src/Component/Types/ContractInfo.purs | 6 +-- src/Component/Widgets/Form.purs | 3 +- src/Component/Widgets/Modal.purs | 4 +- src/Contrib/Data/DateTime/Instant.purs | 4 +- .../Polyform/FormSpecs/StatefulFormSpec.purs | 3 -- .../React/Basic/Hooks/UseMealyMachine.purs | 3 +- .../React/Basic/Hooks/UseMooreMachine.purs | 16 +++---- .../Basic/Hooks/UseStatefulFormSpec.purs | 2 +- src/Contrib/React/MarloweGraph.purs | 1 - .../ReactBootstrap/DropdownButton.purs | 36 +++++++-------- src/Contrib/ReactBootstrap/DropdownItem.purs | 3 +- .../StatefulFormSpecBuilders.purs | 2 - .../StatlessFormSpecBuilders.purs | 46 +++++++++---------- src/Contrib/ReactBootstrap/Types.purs | 1 - src/Main.purs | 4 +- 17 files changed, 65 insertions(+), 72 deletions(-) diff --git a/src/Component/ApplyInputs/Machine.purs b/src/Component/ApplyInputs/Machine.purs index 13438714..b13044ed 100644 --- a/src/Component/ApplyInputs/Machine.purs +++ b/src/Component/ApplyInputs/Machine.purs @@ -67,7 +67,6 @@ data InputChoices | SpecificNotifyInput NotifyInput | AdvanceContract V1.Contract - newtype AutoRun = AutoRun Boolean data State diff --git a/src/Component/CreateContract/Machine.purs b/src/Component/CreateContract/Machine.purs index 7998b92f..7a25deaf 100644 --- a/src/Component/CreateContract/Machine.purs +++ b/src/Component/CreateContract/Machine.purs @@ -133,7 +133,7 @@ step state action = do DefineRoleTokensSucceeded rolesConfig -> FetchingRequiredWalletContext { contract, tags, rolesConfig: Just rolesConfig, errors: Nothing } _ -> state FetchingRequiredWalletContext r@{ errors: Just _ } -> case action of - FetchRequiredWalletContext -> FetchingRequiredWalletContext $ r{ errors = Nothing } + FetchRequiredWalletContext -> FetchingRequiredWalletContext $ r { errors = Nothing } _ -> state FetchingRequiredWalletContext r -> case action of FetchRequiredWalletContextFailed error -> FetchingRequiredWalletContext $ r { errors = Just error } diff --git a/src/Component/Types/ContractInfo.purs b/src/Component/Types/ContractInfo.purs index 38394a7e..d1beb390 100644 --- a/src/Component/Types/ContractInfo.purs +++ b/src/Component/Types/ContractInfo.purs @@ -83,8 +83,8 @@ fetchAppliedInputs serverURL transactionEndpoints = do Runtime.getResource' serverURL transactionEndpoint {} {} pure $ results `foldMapFlipped` case _ of - Left err -> V (Left [err]) - Right ({ payload: { resource: Runtime.Tx { inputs, invalidBefore, invalidHereafter }}}) -> do + Left err -> V (Left [ err ]) + Right ({ payload: { resource: Runtime.Tx { inputs, invalidBefore, invalidHereafter } } }) -> do let -- = NormalInput InputContent -- | MerkleizedInput InputContent String Contract @@ -94,5 +94,5 @@ fetchAppliedInputs serverURL transactionEndpoints = do timeInterval = V1.TimeInterval (Instant.fromDateTime invalidBefore) (Instant.fromDateTime invalidHereafter) V $ Right $ case Array.uncons inputs of Just _ -> inputs <#> \input -> Just (inputToInputContent input) /\ timeInterval - Nothing -> [Nothing /\ timeInterval] + Nothing -> [ Nothing /\ timeInterval ] diff --git a/src/Component/Widgets/Form.purs b/src/Component/Widgets/Form.purs index 84395d5b..3677407b 100644 --- a/src/Component/Widgets/Form.purs +++ b/src/Component/Widgets/Form.purs @@ -212,7 +212,7 @@ addressInput . Monad builderM => MonadEffect validatorM => Row.Lacks "validator" props - => Row.Cons "validator" (AddressInputValidator validatorM) props ( validator :: AddressInputValidator validatorM | props) + => Row.Cons "validator" (AddressInputValidator validatorM) props (validator :: AddressInputValidator validatorM | props) => Defaults TextInputOptionalProps { validator :: AddressInputValidator validatorM | props } (TextInputProps validatorM (Maybe Bech32)) => CardanoMultiplatformLib.Lib -> { | props } @@ -224,6 +224,7 @@ addressInput cardanoMultiplatformLib props = do Just value -> liftEffect $ bech32FromString cardanoMultiplatformLib value >>= case _ of Nothing -> pure $ Left [ "Invalid bech32 address" ] Just bech32 -> pure $ Right $ Just bech32 + props' :: { validator :: AddressInputValidator validatorM | props } props' = Record.insert (Proxy :: Proxy "validator") validator props textInput props' diff --git a/src/Component/Widgets/Modal.purs b/src/Component/Widgets/Modal.purs index e22b1ca4..7ea2b8a8 100644 --- a/src/Component/Widgets/Modal.purs +++ b/src/Component/Widgets/Modal.purs @@ -95,8 +95,8 @@ mkModal = do -- other handler. onModalDialogClicked = handler stopPropagation (const $ pure unit) - modalClassName = "modal-dialog" <> if fullscreen - then " modal-fullscreen" + modalClassName = "modal-dialog" <> + if fullscreen then " modal-fullscreen" else case size of Small -> " modal-sm" Medium -> " modal-md" diff --git a/src/Contrib/Data/DateTime/Instant.purs b/src/Contrib/Data/DateTime/Instant.purs index 387ca09f..1a426e3d 100644 --- a/src/Contrib/Data/DateTime/Instant.purs +++ b/src/Contrib/Data/DateTime/Instant.purs @@ -15,8 +15,8 @@ import Partial.Unsafe (unsafeCrashWith) unsafeInstant :: Milliseconds -> Instant unsafeInstant t = case instant t of - Just i -> i - Nothing -> unsafeCrashWith $ "Contrib.Data.DateTime.Instant.unsafeInstant: invalid instant value:" <> unsafeStringify t + Just i -> i + Nothing -> unsafeCrashWith $ "Contrib.Data.DateTime.Instant.unsafeInstant: invalid instant value:" <> unsafeStringify t unsafeInstantFromInt :: Int -> Instant unsafeInstantFromInt = unsafeInstant <<< Milliseconds <<< Int.toNumber diff --git a/src/Contrib/Polyform/FormSpecs/StatefulFormSpec.purs b/src/Contrib/Polyform/FormSpecs/StatefulFormSpec.purs index 9cd25e64..1a1f43e2 100644 --- a/src/Contrib/Polyform/FormSpecs/StatefulFormSpec.purs +++ b/src/Contrib/Polyform/FormSpecs/StatefulFormSpec.purs @@ -45,7 +45,6 @@ type FormState st err = | st } - type FieldInitialsRow r = ( name :: FieldId , initial :: Array String @@ -147,7 +146,6 @@ toFormValidator name fieldValidator = do Array.head value UrlEncoded.fromValidator name validator' - input :: forall a doc err m st . Monad m @@ -202,4 +200,3 @@ multiSelect name initial err render touched validator = StatefulFormSpec , render } - diff --git a/src/Contrib/React/Basic/Hooks/UseMealyMachine.purs b/src/Contrib/React/Basic/Hooks/UseMealyMachine.purs index fb2ecf74..1acb4c98 100644 --- a/src/Contrib/React/Basic/Hooks/UseMealyMachine.purs +++ b/src/Contrib/React/Basic/Hooks/UseMealyMachine.purs @@ -40,7 +40,8 @@ useMealyMachine :: forall output state action . MealyMachineSpec state action output -> React.Hook - (UseMealyMachine state action output) (state /\ Maybe output /\ (action -> Effect Unit)) + (UseMealyMachine state action output) + (state /\ Maybe output /\ (action -> Effect Unit)) useMealyMachine { driver, initialState, step } = React.coerceHook React.do { state: { state, output }, version } /\ setState <- useVersionedState' { state: initialState, output: Nothing } stateRef <- useStateRef version state diff --git a/src/Contrib/React/Basic/Hooks/UseMooreMachine.purs b/src/Contrib/React/Basic/Hooks/UseMooreMachine.purs index 32cf5203..ea56bf58 100644 --- a/src/Contrib/React/Basic/Hooks/UseMooreMachine.purs +++ b/src/Contrib/React/Basic/Hooks/UseMooreMachine.purs @@ -46,14 +46,14 @@ useMooreMachine :: forall output state action . MooreMachineSpec state action output -> React.Hook - (UseMooreMachine state action output) - { state :: state - , output :: output - , applyAction :: action -> Effect Unit - -- If just after the reset in the handler you have to use `applyAction` then - -- you can use the returned value to do it. - , reset :: Maybe (MooreMachineSpec state action output) -> Effect (action -> Effect Unit) - } + (UseMooreMachine state action output) + { state :: state + , output :: output + , applyAction :: action -> Effect Unit + -- If just after the reset in the handler you have to use `applyAction` then + -- you can use the returned value to do it. + , reset :: Maybe (MooreMachineSpec state action output) -> Effect (action -> Effect Unit) + } useMooreMachine initialSpec = React.coerceHook React.do { state: spec, version: specVersion } /\ setSpec <- useVersionedState' initialSpec specRef <- useStateRef specVersion spec diff --git a/src/Contrib/React/Basic/Hooks/UseStatefulFormSpec.purs b/src/Contrib/React/Basic/Hooks/UseStatefulFormSpec.purs index 630a6a0f..f5e47962 100644 --- a/src/Contrib/React/Basic/Hooks/UseStatefulFormSpec.purs +++ b/src/Contrib/React/Basic/Hooks/UseStatefulFormSpec.purs @@ -113,7 +113,7 @@ useStatefulFormSpec ({ spec: StatefulFormSpec { fields, validator }, onSubmit, v useEffect debouncedQuery do when (not <<< null $ touched) do - result /\ state' <- flip runStateT state $ (runValidator validator) debouncedQuery + result /\ state' <- flip runStateT state $ (runValidator validator) debouncedQuery setInternalStatefulFormState state' setValidationResult $ Just (result /\ debouncedQuery) pure $ pure unit diff --git a/src/Contrib/React/MarloweGraph.purs b/src/Contrib/React/MarloweGraph.purs index a6bdbe69..7f86506f 100644 --- a/src/Contrib/React/MarloweGraph.purs +++ b/src/Contrib/React/MarloweGraph.purs @@ -38,7 +38,6 @@ executionPathIndicies = foldMap \(_ /\ path) -> do arr = Array.NonEmpty.toArray path <#> fst map branchIndex arr - type Props = { contract :: V1.Contract, executionPath :: Opt ExecutionPath } -- { contract :: V1.Contract, path :: ExecutionPath } diff --git a/src/Contrib/ReactBootstrap/DropdownButton.purs b/src/Contrib/ReactBootstrap/DropdownButton.purs index 2895ee2a..3df2b186 100644 --- a/src/Contrib/ReactBootstrap/DropdownButton.purs +++ b/src/Contrib/ReactBootstrap/DropdownButton.purs @@ -25,44 +25,45 @@ import Unsafe.Coerce (unsafeCoerce) -- flip?: boolean; -- } - -- Some not implemented placeholders type PropsFromToggle :: forall k. k -> k -type PropsFromToggle r = ( | r) +type PropsFromToggle r = (| r) foreign import data DropdownMenuVariant :: Type foreign import data RootCloseEvent :: Type -rootCloseEvent :: - { click :: RootCloseEvent - , mousedown :: RootCloseEvent - } +rootCloseEvent + :: { click :: RootCloseEvent + , mousedown :: RootCloseEvent + } rootCloseEvent = { click: unsafeCoerce "click" , mousedown: unsafeCoerce "mousedown" } type DropdownButtonProps r = - DropdownProps + - PropsFromToggle + - ( title :: JSX -- ReactNode - , menuRole :: Opt String - , renderMenuOnMount :: Opt Boolean - , rootCloseEvent :: Opt RootCloseEvent - , menuVariant :: Opt DropdownMenuVariant - , flip :: Opt Boolean - | r - ) + DropdownProps + + PropsFromToggle + + + ( title :: JSX -- ReactNode + , menuRole :: Opt String + , renderMenuOnMount :: Opt Boolean + , rootCloseEvent :: Opt RootCloseEvent + , menuVariant :: Opt DropdownMenuVariant + , flip :: Opt Boolean + | r + ) foreign import _DropdownButton :: ReactComponent { | DropdownButtonProps () } _internalDropdownButton :: forall props . NoProblem.Coerce { | props } { | DropdownButtonProps () } - => { | props } -> JSX + => { | props } + -> JSX _internalDropdownButton props = do let props' = NoProblem.coerce props @@ -84,4 +85,3 @@ dropdownButton props children = do props' = Record.insert (Proxy :: Proxy "children") (toJSX children) props _internalDropdownButton props' - diff --git a/src/Contrib/ReactBootstrap/DropdownItem.purs b/src/Contrib/ReactBootstrap/DropdownItem.purs index c1b20cd1..57655a30 100644 --- a/src/Contrib/ReactBootstrap/DropdownItem.purs +++ b/src/Contrib/ReactBootstrap/DropdownItem.purs @@ -55,7 +55,8 @@ foreign import _DropdownItem :: ReactComponent { | DropdownItemProps () } _internalDropdownItem :: forall props . NoProblem.Coerce { | props } { | DropdownItemProps () } - => { | props } -> JSX + => { | props } + -> JSX _internalDropdownItem props = do let props' = NoProblem.coerce props diff --git a/src/Contrib/ReactBootstrap/FormSpecBuilders/StatefulFormSpecBuilders.purs b/src/Contrib/ReactBootstrap/FormSpecBuilders/StatefulFormSpecBuilders.purs index 7d4c3eea..ebe3623d 100644 --- a/src/Contrib/ReactBootstrap/FormSpecBuilders/StatefulFormSpecBuilders.purs +++ b/src/Contrib/ReactBootstrap/FormSpecBuilders/StatefulFormSpecBuilders.purs @@ -73,7 +73,6 @@ import ReactBootstrap.Form.Control as Form.Control import Record as Record import Type.Prelude (Proxy(..)) - type StatefulBootstrapFormSpec validatorM st = StatefulFormSpec validatorM st (Array JSX) String fromStatlessFormSpec = FormSpecBuilder.hoistFormSpec liftStatelessFormSpec @@ -121,7 +120,6 @@ dateTimeField dateTimeField possibleLabel possibleHelpText dateTimeValidator = do FormSpecBuilder.hoistFormSpec liftStatelessFormSpec $ StatelessFormSpecBuilders.dateTimeField possibleLabel possibleHelpText dateTimeValidator - type MultiFieldIds = { multi :: FieldId, sub :: Array FieldId } -- multiField diff --git a/src/Contrib/ReactBootstrap/FormSpecBuilders/StatlessFormSpecBuilders.purs b/src/Contrib/ReactBootstrap/FormSpecBuilders/StatlessFormSpecBuilders.purs index f267c428..b5557e76 100644 --- a/src/Contrib/ReactBootstrap/FormSpecBuilders/StatlessFormSpecBuilders.purs +++ b/src/Contrib/ReactBootstrap/FormSpecBuilders/StatlessFormSpecBuilders.purs @@ -102,7 +102,6 @@ fieldValidity touched value errors = do isValid = Just [] == map fst errors { errors: errors', isInvalid, isValid } - data FormControlSizing = FormControlSm | FormControlLg data LabelSpacing @@ -336,7 +335,6 @@ textInput props = formSpecBuilderT do props'.validator pure form - _validator = (Proxy :: Proxy "validator") _type = (Proxy :: Proxy "type") @@ -667,7 +665,7 @@ textArea textArea props = formSpecBuilderT do name <- _genFieldId props' let - form ::StatelessBootstrapFormSpec validatorM Query a + form :: StatelessBootstrapFormSpec validatorM Query a form = StatelessFormSpec.input name props'.initial @@ -966,8 +964,8 @@ booleanField props = do validator = liftFnEither case _ of "on" -> Right true _ -> Right false - booleanAsValue = if _ - then "on" + booleanAsValue = + if _ then "on" else "off" initial = fromOpt false props'.initial @@ -1012,10 +1010,10 @@ renderBooleanField { disabled, label: possibleLabel, layout, possibleHelpText, n MultiColumn spacing -> labelSpacingsToClasses spacing Inline -> { labelColClass: "", inputColClass: "" } label' = case NoProblem.toMaybe possibleLabel of - Nothing -> mempty - Just label -> if isInline layout - then DOM.label {} [ label ] - else DOM.label { className: "col-form-label-sm " <> labelColClass, htmlFor: nameStr } [ label ] + Nothing -> mempty + Just label -> + if isInline layout then DOM.label {} [ label ] + else DOM.label { className: "col-form-label-sm " <> labelColClass, htmlFor: nameStr } [ label ] body = do let @@ -1027,21 +1025,21 @@ renderBooleanField { disabled, label: possibleLabel, layout, possibleHelpText, n DOM.div { className } $ [ Form.check - { className: "min-h-1_2rem" - , disabled - , id: nameStr - , isValid - , isInvalid - , name: nameStr - , "type": - if switch then Check.checkType.switch - else Check.checkType.radio - , value: "on" - , checked - , onChange: handler_ do - onChange $ if checked then "off" else "on" - } - -- We should probably render this as `feedback` above when in `inline` + { className: "min-h-1_2rem" + , disabled + , id: nameStr + , isValid + , isInvalid + , name: nameStr + , "type": + if switch then Check.checkType.switch + else Check.checkType.radio + , value: "on" + , checked + , onChange: handler_ do + onChange $ if checked then "off" else "on" + } + -- We should probably render this as `feedback` above when in `inline` , helpText ] diff --git a/src/Contrib/ReactBootstrap/Types.purs b/src/Contrib/ReactBootstrap/Types.purs index bdcf4e4a..b11d3ce7 100644 --- a/src/Contrib/ReactBootstrap/Types.purs +++ b/src/Contrib/ReactBootstrap/Types.purs @@ -29,7 +29,6 @@ dropDirection = , "down": unsafeCoerce "down" } - -- export type AlignDirection = 'start' | 'end'; -- export type ResponsiveAlignProp = { -- sm: AlignDirection; diff --git a/src/Main.purs b/src/Main.purs index a86ed8a6..318bc541 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -67,8 +67,8 @@ main configJson = do -- FIXME: Slotting numbers have to be provided by Marlowe Runtime slotting = case config.network of - "mainnet" -> Slotting { slotLength: BigInt.fromInt 1000 , slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1591566291000" } - _ -> Slotting { slotLength: BigInt.fromInt 1000 , slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1666656000000" } + "mainnet" -> Slotting { slotLength: BigInt.fromInt 1000, slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1591566291000" } + _ -> Slotting { slotLength: BigInt.fromInt 1000, slotZeroTime: unsafePartial $ fromJust $ BigInt.fromString "1666656000000" } doc :: HTMLDocument <- document =<< window container :: Element <- maybe (throw "Could not find element with id 'app-root'") pure =<<