Make HydraHeadPeer type extendable

Author: errfrom

example/minimal/src/Config.purs

@@ -6,7 +6,7 @@ module HydraSdk.Example.Minimal.Config
 import Prelude
 
 import Cardano.Types (TransactionInput)
-import Data.Codec.Argonaut (JsonCodec, object, printJsonDecodeError, string) as CA
+import Data.Codec.Argonaut (JsonCodec, object, printJsonDecodeError, record, string) as CA
 import Data.Codec.Argonaut.Compat (maybe) as CA
 import Data.Codec.Argonaut.Record (record) as CAR
 import Data.Either (either)
@@ -20,7 +20,7 @@ import Node.Path (FilePath)
 import Node.Process (argv)
 
 type DelegateServerConfig =
-  { hydraNodeStartupParams :: HydraNodeStartupParams
+  { hydraNodeStartupParams :: HydraNodeStartupParams ()
   , blockfrostApiKeyFile :: FilePath
   , logLevel :: LogLevel
   , ctlLogLevel :: LogLevel
@@ -30,7 +30,7 @@ type DelegateServerConfig =
 delegateServerConfigCodec :: CA.JsonCodec DelegateServerConfig
 delegateServerConfigCodec =
   CA.object "DelegateServerConfig" $ CAR.record
-    { hydraNodeStartupParams: hydraNodeStartupParamsCodec
+    { hydraNodeStartupParams: hydraNodeStartupParamsCodec CA.record
     , blockfrostApiKeyFile: CA.string
     , logLevel: logLevelCodec
     , ctlLogLevel: logLevelCodec

spago-packages.nix

@@ -1181,6 +1181,18 @@ let
         installPhase = "ln -s $src $out";
       };
 
+    "record-extra" = pkgs.stdenv.mkDerivation {
+        name = "record-extra";
+        version = "v5.0.1";
+        src = pkgs.fetchgit {
+          url = "https://github.com/justinwoo/purescript-record-extra.git";
+          rev = "a9a4b8201d154513017048fc41efa0eefa48fba2";
+          sha256 = "0190igayc2ghzjg1ggwl0dv0b2b7sg16n5dm9fyi39ygp48fvshp";
+        };
+        phases = "installPhase";
+        installPhase = "ln -s $src $out";
+      };
+
     "refs" = pkgs.stdenv.mkDerivation {
         name = "refs";
         version = "v6.0.0";

spago.dhall

@@ -44,6 +44,7 @@
   , "profunctor"
   , "quickcheck"
   , "record"
+  , "record-extra"
   , "safely"
   , "spec"
   , "strings"

src/Internal/Lib/Codec.purs

@@ -25,6 +25,7 @@ module HydraSdk.Internal.Lib.Codec
   , toCaJsonDecodeError
   , txCodec
   , txHashCodec
+  , unionRecordCodecs
   ) where
 
 import Prelude
@@ -67,7 +68,9 @@ import Data.Argonaut
 import Data.Bifunctor (lmap)
 import Data.ByteArray (ByteArray, byteArrayToHex, hexToByteArray)
 import Data.Codec.Argonaut
-  ( JsonCodec
+  ( Codec(Codec)
+  , JPropCodec
+  , JsonCodec
   , JsonDecodeError(TypeMismatch, UnexpectedValue, AtIndex, AtKey, Named, MissingValue)
   , codec'
   , decode
@@ -86,13 +89,44 @@ import Data.Newtype (wrap)
 import Data.Profunctor (wrapIso)
 import Data.String (Pattern(Pattern))
 import Data.String (split, stripSuffix, take) as String
+import Data.Tuple.Nested ((/\))
 import Data.UInt (fromString, toString) as UInt
 import Effect (Effect)
 import HydraSdk.Internal.Lib.Misc (cborBytesToHex)
 import Node.Encoding (Encoding(UTF8)) as Encoding
 import Node.FS.Sync (readTextFile) as FSSync
 import Node.Path (FilePath)
 import Partial.Unsafe (unsafePartial)
+import Prim.Row (class Union) as Row
+import Prim.RowList (class RowToList) as RowList
+import Record (union) as Record
+import Record.Extra (class Keys, pick) as Record.Extra
+
+unionRecordCodecs
+  :: forall r r0 r' rl r0l
+   . Row.Union r r0 r'
+  => RowList.RowToList r rl
+  => Record.Extra.Keys rl
+  => Row.Union r0 r r'
+  => RowList.RowToList r0 r0l
+  => Record.Extra.Keys r0l
+  => CA.JPropCodec (Record r)
+  -> CA.JPropCodec (Record r0)
+  -> CA.JPropCodec (Record r')
+unionRecordCodecs
+  (CA.Codec rDecode rEncode)
+  (CA.Codec r0Decode r0Encode) = CA.Codec decode encode
+  where
+  decode obj = do
+    r0Rec <- r0Decode obj
+    rRec <- rDecode obj
+    pure $ Record.union r0Rec rRec
+  encode rec =
+    let
+      rList /\ rRec = rEncode (Record.Extra.pick rec :: Record r)
+      r0List /\ r0Rec = r0Encode (Record.Extra.pick rec :: Record r0)
+    in
+      (rList <> r0List) /\ Record.union rRec r0Rec
 
 fromCaJsonDecodeError :: CA.JsonDecodeError -> A.JsonDecodeError
 fromCaJsonDecodeError = case _ of

src/Internal/Process/HydraNode.purs

@@ -16,7 +16,7 @@ import Cardano.AsCbor (encodeCbor)
 import Cardano.Types (TransactionHash)
 import Control.Error.Util (bool)
 import Data.Array (concat, singleton) as Array
-import Data.Codec.Argonaut (JsonCodec, array, int, object, string) as CA
+import Data.Codec.Argonaut (JsonCodec, JPropCodec, array, int, object, string) as CA
 import Data.Codec.Argonaut.Compat (maybe) as CA
 import Data.Codec.Argonaut.Record (record) as CAR
 import Data.Foldable (foldMap)
@@ -28,7 +28,7 @@ import Data.Traversable (for_, traverse_)
 import Effect (Effect)
 import Effect.AVar (empty, tryPut) as AVar
 import Effect.Class (class MonadEffect, liftEffect)
-import HydraSdk.Internal.Lib.Codec (txHashCodec)
+import HydraSdk.Internal.Lib.Codec (txHashCodec, unionRecordCodecs)
 import HydraSdk.Internal.Lib.Misc (cborBytesToHex)
 import HydraSdk.Internal.Types.HostPort
   ( HostPort
@@ -46,9 +46,13 @@ import Node.ChildProcess (ChildProcess, defaultSpawnOptions, spawn, stderr, stdo
 import Node.Encoding (Encoding(UTF8)) as Encoding
 import Node.Path (FilePath)
 import Node.Stream (onDataString)
+import Prim.Row (class Union) as Row
+import Prim.RowList (RowList)
+import Prim.RowList (class RowToList) as RowList
+import Record.Extra (class Keys) as Record.Extra
 
 -- | Parameters to be passed to the hydra-node child process on startup.
-type HydraNodeStartupParams =
+type HydraNodeStartupParams (peerExtra :: Row Type) =
   { nodeId :: String
   , hydraNodeAddress :: HostPort
   , hydraNodeAdvertisedAddress :: Maybe HostPort
@@ -60,12 +64,18 @@ type HydraNodeStartupParams =
   , pparams :: FilePath
   , hydraScripts :: Array TransactionHash
   , contestPeriodSec :: Int
-  , peers :: Array HydraHeadPeer
+  , peers :: Array (Record (HydraHeadPeer peerExtra))
   }
 
 -- | Bidirectional JSON codec for `HydraNodeStartupParams`.
-hydraNodeStartupParamsCodec :: CA.JsonCodec HydraNodeStartupParams
-hydraNodeStartupParamsCodec =
+hydraNodeStartupParamsCodec
+  :: forall (peerExtra :: Row Type) (rl :: RowList Type)
+   . Row.Union peerExtra (HydraHeadPeer ()) (HydraHeadPeer peerExtra)
+  => RowList.RowToList peerExtra rl
+  => Record.Extra.Keys rl
+  => CA.JPropCodec (Record peerExtra)
+  -> CA.JsonCodec (HydraNodeStartupParams peerExtra)
+hydraNodeStartupParamsCodec peerExtraCodec =
   CA.object "HydraNodeStartupParams" $ CAR.record
     { nodeId: CA.string
     , hydraNodeAddress: hostPortStringCodec
@@ -78,22 +88,29 @@ hydraNodeStartupParamsCodec =
     , pparams: CA.string
     , hydraScripts: CA.array txHashCodec
     , contestPeriodSec: CA.int
-    , peers: CA.array hydraHeadPeerCodec
+    , peers: CA.array $ hydraHeadPeerCodec peerExtraCodec
     }
 
 -- | Configuration parameters for a single Hydra Head peer. When setting up a
 -- | Hydra Head, each node must specify the network addresses and public key
 -- | information of its respective peers.
-type HydraHeadPeer =
-  { hydraNodeAddress :: HostPort
+type HydraHeadPeer (extra :: Row Type) =
+  ( hydraNodeAddress :: HostPort
   , hydraVerificationKey :: FilePath
   , cardanoVerificationKey :: FilePath
-  }
+  | extra
+  )
 
 -- | Bi-directional JSON codec for `HydraHeadPeer`.
-hydraHeadPeerCodec :: CA.JsonCodec HydraHeadPeer
-hydraHeadPeerCodec =
-  CA.object "HydraHeadPeer" $ CAR.record
+hydraHeadPeerCodec
+  :: forall (extra :: Row Type) (rl :: RowList Type)
+   . Row.Union extra (HydraHeadPeer ()) (HydraHeadPeer extra)
+  => RowList.RowToList extra rl
+  => Record.Extra.Keys rl
+  => CA.JPropCodec (Record extra)
+  -> CA.JsonCodec (Record (HydraHeadPeer extra))
+hydraHeadPeerCodec extraCodec =
+  CA.object "HydraHeadPeer" $ unionRecordCodecs extraCodec $ CAR.record
     { hydraNodeAddress: hostPortStringCodec
     , hydraVerificationKey: CA.string
     , cardanoVerificationKey: CA.string
@@ -126,9 +143,9 @@ noopHydraNodeHandlers =
 -- |
 -- | NOTE: The hydra-node executable must be available in the PATH.
 spawnHydraNode
-  :: forall m
+  :: forall (m :: Type -> Type) (peerExtra :: Row Type)
    . MonadEffect m
-  => HydraNodeStartupParams
+  => HydraNodeStartupParams peerExtra
   -> HydraNodeHandlers
   -> m ChildProcess
 spawnHydraNode params handlers = liftEffect do