Add Web.ContractHeader decoders

spago.dhall

@@ -3,11 +3,13 @@
   [ "aff"
   , "argonaut"
   , "argonaut-codecs"
+  , "argonaut-generic"
   , "arrays"
   , "bifunctors"
   , "console"
   , "control"
   , "datetime"
+  , "debug"
   , "decimals"
   , "effect"
   , "either"

src/Contrib/Data/Argonaut.purs

@@ -8,7 +8,10 @@ import Data.Either (Either(..), note)
 import Data.Enum (class BoundedEnum)
 import Data.Maybe (Maybe)
 
-decodeFromString :: forall a. (String -> Maybe a) -> Json -> Either JsonDecodeError a
+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
@@ -20,7 +23,7 @@ decodeFromString decode json = do
     decode'
     json
 
-decodeJsonEnumWith :: forall a. Show a => BoundedEnum a => (String -> String) -> Json -> Either JsonDecodeError a
+decodeJsonEnumWith :: forall a. Show a => BoundedEnum a => (String -> String) -> JsonParser a
 decodeJsonEnumWith adaptConstructorName = do
   decodeFromString (S.decodeEnumWith adaptConstructorName)
 

src/Contrib/Data/Argonaut/Generic/Record.purs

@@ -67,6 +67,34 @@ else instance
         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 }
 
@@ -85,6 +113,22 @@ instance
       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
 

src/Marlowe/Runtime/Web.purs

@@ -0,0 +1,132 @@
+module Marlowe.Runtime.Web where
+
+import Prelude
+
+import Contrib.Data.Argonaut (JsonParser, JsonParserResult, decodeFromString)
+import Contrib.Data.Argonaut.Generic.Record (decodeNewtypedRecord)
+import Data.Argonaut (class DecodeJson, Json, JsonDecodeError(..), decodeJson)
+import Data.Argonaut.Decode.Generic (genericDecodeJson)
+import Data.Either (note)
+import Data.Generic.Rep (class Generic)
+import Data.Int as Int
+import Data.Map (Map)
+import Data.Map as Map
+import Data.Maybe (Maybe(..))
+import Data.Newtype (class Newtype)
+import Data.String as String
+import Data.Traversable (for)
+import Data.Tuple.Nested (type (/\), (/\))
+import Foreign.Object (Object)
+import Foreign.Object as Object
+
+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 = genericDecodeJson
+
+newtype TxOutRef = TxOutRef
+  { txId :: TxId
+  , txIx :: Int
+  }
+derive instance Generic TxOutRef _
+derive instance Eq 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
+
+newtype PolicyId = PolicyId String
+derive instance Generic PolicyId _
+derive instance Newtype PolicyId _
+derive instance Eq PolicyId
+derive instance Ord PolicyId
+instance DecodeJson PolicyId where
+  decodeJson = map PolicyId <$> decodeJson
+
+data MarloweVersion = V1
+derive instance Generic MarloweVersion _
+derive instance Eq MarloweVersion
+derive instance Ord MarloweVersion
+instance DecodeJson MarloweVersion where
+  decodeJson = decodeFromString case _ of
+    "v1" -> Just V1
+    _ -> Nothing
+
+data TxStatus
+  = Unsigned
+  | Submitted
+  | Confirmed
+derive instance Eq TxStatus
+derive instance Ord TxStatus
+
+--  deriving (Show, Eq, Ord)
+
+instance DecodeJson TxStatus where
+  decodeJson = decodeFromString case _ of
+    "unsigned" -> Just Unsigned
+    "submitted" -> Just Submitted
+    "confirmed" -> Just Confirmed
+    _ -> Nothing
+
+
+newtype BlockHeader = BlockHeader
+  { slotNo :: Int
+  , blockNo :: Int
+  , 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
+
+-- FIXME: We want to make it more concrete soon ;-)
+type Metadata = Map Int (Object Json)
+
+newtype ContractHeader = ContractHeader
+  { contractId :: TxOutRef
+  , roleTokenMintingPolicyId :: PolicyId
+  , version :: MarloweVersion
+  , metadata :: Metadata
+  , status :: TxStatus
+  , block :: Maybe BlockHeader
+  }
+derive instance Generic ContractHeader _
+derive instance Newtype ContractHeader _
+derive instance Eq ContractHeader
+
+instance DecodeJson ContractHeader where
+  decodeJson = do
+    let
+      decodeMetadata :: JsonParser Metadata
+      decodeMetadata json = do
+        (obj :: Object (Object Json)) <- decodeJson json
+
+        (arr :: Array (Int /\ Object 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 $ Map.fromFoldable arr
+    decodeNewtypedRecord { metadata: map decodeMetadata :: Maybe Json -> Maybe (JsonParserResult Metadata) }
+
+

src/Marlowe/Runtime/Web/Types.purs

@@ -0,0 +1,35 @@
+module Marlowe.Runtime.Web.Types where
+
+import Prelude
+
+import Contrib.Data.Argonaut.Generic.Record (class DecodeRecord, DecodeJsonFieldFn, decodeRecord)
+import Data.Argonaut (class DecodeJson, Json, JsonDecodeError, decodeJson)
+import Data.Argonaut.Decode.Generic (genericDecodeJson)
+import Data.Either (Either)
+import Data.Generic.Rep (class Generic)
+import Data.Newtype (class Newtype)
+import Type.Row.Homogeneous (class Homogeneous)
+
+newtype ResourceLink = ResourceLink String
+derive instance Generic ResourceLink _
+derive instance Newtype ResourceLink _
+derive instance Eq ResourceLink
+derive instance Ord ResourceLink
+instance DecodeJson ResourceLink where
+  decodeJson json= ResourceLink <$> decodeJson json
+
+type ResourceWithLinksRow resource linksRow =
+  ( links :: { | linksRow }
+  , resource :: resource
+  )
+
+type ResourceWithLinks resource linksRow = { | ResourceWithLinksRow resource linksRow }
+
+decodeResourceWithLink
+  :: forall a linksRow
+   . Homogeneous linksRow ResourceLink
+  => DecodeRecord (resource :: DecodeJsonFieldFn a) (ResourceWithLinksRow a linksRow)
+  => DecodeJsonFieldFn a
+  -> Json
+  -> Either JsonDecodeError (ResourceWithLinks a linksRow)
+decodeResourceWithLink decodeResource = decodeRecord { resource: decodeResource }

test/Actus/Domain/actus-tests-lam.json

@@ -12,7 +12,7 @@
             "cycleAnchorDateOfPrincipalRedemption": "2013-02-01T00:00:00",
             "nextPrincipalRedemptionPayment": " 500",
             "dayCountConvention": "A365",
-            "nominalInterestRate": " 0.08",
+            "nominalInterestRate": "0.08",
             "currency": "USD",
             "cycleOfPrincipalRedemption": "P1ML0",
             "cycleAnchorDateOfRateReset": "2013-04-01T00:00:00",
@@ -60,7 +60,7 @@
                 "payoff": -5000,
                 "currency": "USD",
                 "notionalPrincipal": 5000,
-                "nominalInterestRate": 0.08,
+                "nominalInterestRate": "0.08",
                 "accruedInterest": 0
             },
             {

test/Main.purs

@@ -2,21 +2,17 @@ module Test.Main where
 
 import Prelude
 
-import Data.Maybe (Maybe(..))
-import Data.Time.Duration (Milliseconds(..))
 import Effect (Effect)
-import Effect.Aff (launchAff_, delay)
-import Effect.Class.Console (log)
+import Effect.Aff (launchAff_)
 import Test.Actus.Domain.ContractTerms as ContractTerms
-import Test.Spec (pending, describe, it)
+import Test.Marlowe.Runtime.Web as Web
 import Test.Spec as Spec
-import Test.Spec.Assertions (shouldEqual)
 import Test.Spec.Reporter.Console (consoleReporter)
-import Test.Spec.Runner (defaultConfig, runSpec, runSpec')
-
+import Test.Spec.Runner (runSpec)
 
 main :: Effect Unit
 main = launchAff_ $ runSpec [ consoleReporter ]
   do
     Spec.parallel do
       ContractTerms.spec
+      Web.spec

test/Marlowe/Runtime/Web.purs

@@ -0,0 +1,12 @@
+module Test.Marlowe.Runtime.Web where
+
+import Prelude
+
+import Test.Marlowe.Web.ContractHeader as ContractHeader
+import Test.Spec (Spec, describe)
+import Test.Spec as Spec
+
+spec :: Spec Unit
+spec = do
+  describe "Marlowe.Web" $ Spec.parallel do
+   ContractHeader.spec

test/Marlowe/Runtime/Web/ContractHeader.purs

@@ -0,0 +1,43 @@
+module Test.Marlowe.Web.ContractHeader where
+
+import Prelude
+
+import Control.Monad.Error.Class (throwError)
+import Data.Argonaut (Json, JsonDecodeError, decodeJson, fromObject, fromString, jsonParser, stringify)
+import Data.Argonaut.Decode ((.:))
+import Data.Either (Either(..), either)
+import Data.Foldable (for_)
+import Effect.Exception (error)
+import Foreign.Object as Object
+import Marlowe.Runtime.Web (ContractHeader)
+import Marlowe.Runtime.Web.Types (ResourceLink, ResourceWithLinks, decodeResourceWithLink)
+import Node.Encoding (Encoding(..))
+import Node.FS.Aff (readTextFile)
+import Test.Spec (Spec, describe, it, pending)
+import Test.Spec.Assertions (fail)
+
+spec :: Spec Unit
+spec = do
+  describe "ContractHeader" do
+    describe "decodeJson" do
+      it "contracts.json" do
+        jsonStr <- readTextFile UTF8 "./test/Marlowe/Runtime/Web/contracts.json"
+        json <- either (throwError <<< error) pure $ jsonParser jsonStr
+
+        (contractsWithLinksJson :: Array Json) <- either (throwError <<< error <<< show) pure do
+            obj <- decodeJson json
+            obj .: "results"
+
+        for_ contractsWithLinksJson \contractWithLinksJson -> do
+          let
+            contracts :: Either JsonDecodeError (ResourceWithLinks ContractHeader (contract :: ResourceLink))
+            contracts = decodeResourceWithLink (map decodeJson) contractWithLinksJson
+          case contracts of
+            Left err -> do
+              let
+                errJson = fromObject $ Object.fromHomogeneous { json: contractWithLinksJson, err: fromString $ show err }
+              fail $ stringify errJson
+            Right result -> do
+              pure unit
+
+      pending "feature complete"