cardano-api: 10.6

cabal.project

@@ -12,8 +12,8 @@ repository cardano-haskell-packages
 
 -- See CONTRIBUTING.md for information about when and how to update these.
 index-state:
-  , hackage.haskell.org 2024-11-22T14:59:16Z
-  , cardano-haskell-packages 2024-12-20T15:52:56Z
+  , hackage.haskell.org 2025-01-15T13:32:16Z
+  , cardano-haskell-packages 2025-01-15T09:59:24Z
 
 packages:
   hydra-prelude
@@ -41,7 +41,3 @@ test-show-details: direct
 
 program-options
   ghc-options: -fwrite-ide-info
-
-constraints:
-  quickcheck-instances==0.3.31,
-  data-default==0.7.1.3

hydra-cardano-api/hydra-cardano-api.cabal

@@ -77,7 +77,7 @@ library
     , aeson                      >=2
     , base                       >=4.16
     , bytestring
-    , cardano-api                ^>=10.5
+    , cardano-api                ^>=10.6
     , cardano-api:gen
     , cardano-binary
     , cardano-crypto-class

hydra-cardano-api/src/Hydra/Cardano/Api/Prelude.hs

@@ -38,9 +38,9 @@ import Cardano.Api.Shelley hiding (
 import Cardano.Api.UTxO (UTxO, UTxO' (..))
 import Cardano.Crypto.Hash.Class qualified as CC
 import Cardano.Ledger.Binary qualified as Ledger
+import Cardano.Ledger.Core (EraCrypto)
 import Cardano.Ledger.Core qualified as Ledger
 import Cardano.Ledger.Crypto (StandardCrypto)
-import Cardano.Ledger.Era (EraCrypto)
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy (fromStrict, toStrict)

hydra-cardano-api/src/Hydra/Cardano/Api/ScriptData.hs

@@ -4,7 +4,7 @@ module Hydra.Cardano.Api.ScriptData where
 
 import Hydra.Cardano.Api.Prelude hiding (left)
 
-import Cardano.Ledger.Era qualified as Ledger
+import Cardano.Ledger.Core qualified as Ledger
 import Cardano.Ledger.Plutus.Data qualified as Ledger
 import PlutusLedgerApi.V3 qualified as Plutus
 

hydra-node/src/Hydra/Ledger/Cardano.hs

@@ -96,6 +96,7 @@ newLedgerEnv protocolParams =
       Ledger.ledgerAccount = Ledger.AccountState mempty mempty
     , Ledger.ledgerPp = protocolParams
     , Ledger.ledgerMempool = False
+    , Ledger.ledgerEpochNo = Nothing
     }
 
 -- * Conversions and utilities

hydra-node/src/Hydra/Network.hs

@@ -31,7 +31,6 @@ import Cardano.Ledger.Orphans ()
 import Data.IP (IP, toIPv4w)
 import Data.Text (pack, unpack)
 import Network.Socket (PortNumber, close)
-import Network.TypedProtocol.Pipelined ()
 import Test.QuickCheck (elements, listOf, suchThat)
 import Text.Read (Read (readsPrec))
 import Text.Show (Show (show))

hydra-node/src/Hydra/Network/Ouroboros.hs

@@ -58,9 +58,6 @@ import Hydra.Network.Ouroboros.Type (
   Message (..),
   codecFireForget,
  )
-import Network.Mux.Compat (
-  WithMuxBearer (..),
- )
 import Network.Socket (
   AddrInfo (addrAddress),
   NameInfoFlag (..),
@@ -72,9 +69,10 @@ import Network.Socket (
   getPeerName,
  )
 import Network.TypedProtocol.Codec (
-  AnyMessageAndAgency (..),
+  AnyMessage (..),
  )
-import Network.TypedProtocol.Pipelined ()
+
+import Network.Mux (Mode (..), WithBearer (..))
 import Ouroboros.Network.Driver.Simple (
   TraceSendRecv (..),
  )
@@ -94,7 +92,6 @@ import Ouroboros.Network.Mux (
   MiniProtocolCb,
   MiniProtocolLimits (..),
   MiniProtocolNum (MiniProtocolNum),
-  MuxMode (..),
   OuroborosApplication (..),
   OuroborosApplicationWithMinimalCtx,
   RunMiniProtocol (..),
@@ -107,6 +104,7 @@ import Ouroboros.Network.Server.Socket (AcceptedConnectionsLimit (AcceptedConnec
 import Ouroboros.Network.Snocket (makeSocketBearer, socketSnocket)
 import Ouroboros.Network.Socket (
   AcceptConnectionsPolicyTrace,
+  ConnectToArgs (..),
   ConnectionId (..),
   HandshakeCallbacks (..),
   NetworkConnectTracers (..),
@@ -236,15 +234,18 @@ withOuroborosNetwork
       IO ()
     actualConnect iomgr newBroadcastChannel app sn = do
       chan <- newBroadcastChannel
-      connectToNodeSocket
-        iomgr
-        (codecHandshake hydraVersionedProtocolCodec)
-        noTimeLimitsHandshake
-        hydraVersionedProtocolDataCodec
-        networkConnectTracers
-        (HandshakeCallbacks acceptableVersion queryVersion)
-        (simpleSingletonVersions protocolVersion MkHydraVersionedProtocolData (app chan))
-        sn
+      void $
+        connectToNodeSocket
+          iomgr
+          ConnectToArgs
+            { ctaHandshakeCodec = codecHandshake hydraVersionedProtocolCodec
+            , ctaHandshakeTimeLimits = noTimeLimitsHandshake
+            , ctaVersionDataCodec = hydraVersionedProtocolDataCodec
+            , ctaConnectTracers = networkConnectTracers
+            , ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion
+            }
+          (simpleSingletonVersions protocolVersion MkHydraVersionedProtocolData (app chan))
+          sn
      where
       networkConnectTracers :: NetworkConnectTracers SockAddr HydraVersionedProtocolNumber
       networkConnectTracers =
@@ -376,7 +377,7 @@ data TraceOuroborosNetwork msg
   = TraceSubscriptions (WithIPList (SubscriptionTrace SockAddr))
   | TraceErrorPolicy (WithAddr SockAddr ErrorPolicyTrace)
   | TraceAcceptPolicy AcceptConnectionsPolicyTrace
-  | TraceHandshake (WithMuxBearer (ConnectionId SockAddr) (TraceSendRecv (Handshake HydraVersionedProtocolNumber CBOR.Term)))
+  | TraceHandshake (WithBearer (ConnectionId SockAddr) (TraceSendRecv (Handshake HydraVersionedProtocolNumber CBOR.Term)))
   | TraceSendRecv (TraceSendRecv (FireForget msg))
 
 -- NOTE: cardano-node would have orphan ToObject instances for most of these
@@ -415,16 +416,16 @@ encodeWithAddr (WithAddr addr ev) =
     ]
 
 encodeTraceSendRecvHandshake ::
-  WithMuxBearer (ConnectionId SockAddr) (TraceSendRecv (Handshake HydraVersionedProtocolNumber CBOR.Term)) ->
+  WithBearer (ConnectionId SockAddr) (TraceSendRecv (Handshake HydraVersionedProtocolNumber CBOR.Term)) ->
   [Aeson.Pair]
 encodeTraceSendRecvHandshake = \case
-  WithMuxBearer peerId (TraceSendMsg (AnyMessageAndAgency agency msg)) ->
+  WithBearer peerId (TraceSendMsg (AnyMessageAndAgency agency msg)) ->
     [ "event" .= ("send" :: String)
     , "agency" .= (show agency :: Text)
     , "peer" .= (show peerId :: Text)
     ]
       ++ encodeMsg msg
-  WithMuxBearer peerId (TraceRecvMsg (AnyMessageAndAgency agency msg)) ->
+  WithBearer peerId (TraceRecvMsg (AnyMessageAndAgency agency msg)) ->
     [ "event" .= ("receive" :: Text)
     , "agency" .= (show agency :: Text)
     , "peer" .= (show peerId :: Text)

hydra-node/src/Hydra/Network/Ouroboros/Client.hs

@@ -3,15 +3,16 @@ module Hydra.Network.Ouroboros.Client where
 import Hydra.Prelude
 
 import Hydra.Network.Ouroboros.Type (
-  ClientHasAgency (TokIdle),
   FireForget (..),
   Message (MsgDone, MsgSend),
-  NobodyHasAgency (TokDone),
  )
 import Network.TypedProtocol.Core (
-  Peer (..),
-  PeerHasAgency (..),
+  IsPipelined (..),
   PeerRole (..),
+  ReflRelativeAgency (..),
+ )
+import Network.TypedProtocol.Peer (
+  Peer (..),
  )
 
 data FireForgetClient msg m a where
@@ -22,13 +23,13 @@ data FireForgetClient msg m a where
 fireForgetClientPeer ::
   Monad m =>
   FireForgetClient msg m a ->
-  Peer (FireForget msg) 'AsClient 'StIdle m a
+  Peer (FireForget msg) 'AsClient 'NonPipelined 'StIdle m a
 fireForgetClientPeer = \case
   Idle next ->
     Effect $ fireForgetClientPeer <$> next
   SendMsg msg next ->
-    Yield (ClientAgency TokIdle) (MsgSend msg) $
+    Yield ReflClientAgency (MsgSend msg) $
       Effect $
         fireForgetClientPeer <$> next
   SendDone action ->
-    Effect $ Yield (ClientAgency TokIdle) MsgDone . Done TokDone <$> action
+    Effect $ Yield ReflClientAgency MsgDone . Done ReflNobodyAgency <$> action

hydra-node/src/Hydra/Network/Ouroboros/Server.hs

@@ -3,15 +3,17 @@ module Hydra.Network.Ouroboros.Server where
 import Hydra.Prelude
 
 import Hydra.Network.Ouroboros.Type (
-  ClientHasAgency (TokIdle),
   FireForget (StIdle),
   Message (MsgDone, MsgSend),
-  NobodyHasAgency (TokDone),
  )
 import Network.TypedProtocol (
-  Peer (Await, Done, Effect),
-  PeerHasAgency (ClientAgency),
+  IsPipelined (..),
   PeerRole (AsServer),
+  ReflRelativeAgency (..),
+ )
+
+import Network.TypedProtocol.Peer (
+  Peer (Await, Done, Effect),
  )
 
 data FireForgetServer msg m a = FireForgetServer
@@ -26,11 +28,11 @@ data FireForgetServer msg m a = FireForgetServer
 fireForgetServerPeer ::
   Monad m =>
   FireForgetServer msg m a ->
-  Peer (FireForget msg) 'AsServer 'StIdle m a
+  Peer (FireForget msg) 'AsServer 'NonPipelined 'StIdle m a
 fireForgetServerPeer FireForgetServer{recvMsg, recvMsgDone} =
   -- In the 'StIdle' the server is awaiting a request message
-  Await (ClientAgency TokIdle) $ \case
+  Await ReflClientAgency $ \case
     -- The client got to choose between two messages and we have to handle
     -- either of them
     MsgSend payload -> Effect $ fireForgetServerPeer <$> recvMsg payload
-    MsgDone -> Effect $ Done TokDone <$> recvMsgDone
+    MsgDone -> Effect $ Done ReflNobodyAgency <$> recvMsgDone

hydra-node/src/Hydra/Network/Ouroboros/Type.hs

@@ -2,14 +2,8 @@ module Hydra.Network.Ouroboros.Type where
 
 import Hydra.Prelude
 
-import Cardano.Binary qualified as CBOR
-import Codec.CBOR.Read qualified as CBOR
-import GHC.Show (Show (show))
-import Network.TypedProtocol (PeerHasAgency (ClientAgency), Protocol (..))
-import Network.TypedProtocol.Codec (Codec)
-import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS)
-import Network.TypedProtocol.Core (PeerRole)
-import Network.TypedProtocol.Driver (SomeMessage (SomeMessage))
+import Network.TypedProtocol.Codec
+import Network.TypedProtocol.Core
 import Ouroboros.Consensus.Util (ShowProxy (..))
 
 -- | TODO explain Protocol
@@ -21,6 +15,17 @@ data FireForget msg where
   StIdle :: FireForget msg
   StDone :: FireForget msg
 
+data SFireForget (st :: FireForget msg) where
+  SingIdle :: SFireForget StIdle
+  SingDone :: SFireForget StDone
+
+deriving instance Show (SFireForget st)
+
+instance StateTokenI StIdle where
+  stateToken = SingIdle
+instance StateTokenI StDone where
+  stateToken = SingDone
+
 instance ShowProxy (FireForget msg) where
   showProxy _ = "FireForget"
 
@@ -34,62 +39,62 @@ instance Protocol (FireForget msg) where
     MsgSend :: msg -> Message (FireForget msg) 'StIdle 'StIdle
     MsgDone :: Message (FireForget msg) 'StIdle 'StDone
 
-  -- We have to explain to the framework what our states mean, in terms of
-  -- who is expected to send and receive in the different states.
-  --
-  -- Idle states are where it is for the client to send a message.
-  data ClientHasAgency st where
-    TokIdle :: ClientHasAgency 'StIdle
-
-  -- In our protocol the server is always receiving, thus in no state the server
-  -- has agency.
-  data ServerHasAgency st
+  type StateAgency StIdle = ClientAgency
+  type StateAgency StDone = NobodyAgency
 
-  -- In the done state neither client nor server can send messages.
-  data NobodyHasAgency st where
-    TokDone :: NobodyHasAgency 'StDone
-
-  exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {}
-  exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {}
-  exclusionLemma_NobodyAndServerHaveAgency TokDone tok = case tok of {}
+  type StateToken = SFireForget
 
 deriving stock instance Show msg => Show (Message (FireForget msg) from to)
 
 deriving stock instance Eq msg => Eq (Message (FireForget msg) from to)
 
-instance Show (ClientHasAgency (st :: FireForget msg)) where
-  show TokIdle = "TokIdle"
-
-instance Show (ServerHasAgency (st :: FireForget msg)) where
-  show _ = error "absurd"
-
 codecFireForget ::
-  forall a m.
-  ( MonadST m
-  , ToCBOR a
-  , FromCBOR a
-  ) =>
-  Codec (FireForget a) CBOR.DeserialiseFailure m LByteString
-codecFireForget = mkCodecCborLazyBS encodeMsg decodeMsg
+  forall m msg.
+  (Monad m, Show msg, Read msg) =>
+  Codec (FireForget msg) CodecFailure m String
+codecFireForget =
+  Codec{encode, decode}
  where
-  encodeMsg ::
-    forall (pr :: PeerRole) st st'.
-    PeerHasAgency pr st ->
-    Message (FireForget a) st st' ->
-    CBOR.Encoding
-  encodeMsg (ClientAgency TokIdle) MsgDone = CBOR.encodeWord 0
-  encodeMsg (ClientAgency TokIdle) (MsgSend msg) = CBOR.encodeWord 1 <> toCBOR msg
+  encode ::
+    forall msg' (st :: FireForget msg') (st' :: FireForget msg').
+    Show (Message (FireForget msg') st st') =>
+    Message (FireForget msg') st st' ->
+    String
+  encode msg = show msg ++ "\n"
 
-  decodeMsg ::
-    forall (pr :: PeerRole) s (st :: FireForget a).
-    PeerHasAgency pr st ->
-    CBOR.Decoder s (SomeMessage st)
-  decodeMsg stok = do
-    key <- CBOR.decodeWord
-    case (stok, key) of
-      (ClientAgency TokIdle, 0) ->
-        return $ SomeMessage MsgDone
-      (ClientAgency TokIdle, 1) -> do
-        SomeMessage . MsgSend <$> fromCBOR
-      (ClientAgency TokIdle, _) ->
-        fail "codecFireForget.StIdle: unexpected key"
+  decode ::
+    forall msg' m' (st :: FireForget msg').
+    (Monad m', Read msg', ActiveState st) =>
+    StateToken st ->
+    m' (DecodeStep String CodecFailure m' (SomeMessage st))
+  decode stok =
+    decodeTerminatedFrame '\n' $ \str trailing ->
+      case (stok, break (== ' ') str) of
+        (SingIdle, ("MsgSend", str'))
+          | Just req <- readMaybe str' ->
+              DecodeDone (SomeMessage (MsgSend req)) trailing
+        (_, _) -> DecodeFail failure
+         where
+          failure = CodecFailure ("unexpected server message: " ++ str)
+
+decodeTerminatedFrame ::
+  forall m a.
+  Monad m =>
+  Char ->
+  (String -> Maybe String -> DecodeStep String CodecFailure m a) ->
+  m (DecodeStep String CodecFailure m a)
+decodeTerminatedFrame terminator k = go []
+ where
+  go :: [String] -> m (DecodeStep String CodecFailure m a)
+  go chunks =
+    return $ DecodePartial $ \mchunk ->
+      case mchunk of
+        Nothing -> return $ DecodeFail CodecFailureOutOfInput
+        Just chunk ->
+          case break (== terminator) chunk of
+            (c, _ : c') ->
+              return $
+                k
+                  (concat (reverse (c : chunks)))
+                  (if null c' then Nothing else Just c)
+            _ -> go (chunk : chunks)