From 4058b3a42b872afcd23572311816e7663e556132 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 8 Sep 2023 21:18:39 +0200 Subject: [PATCH] WIP: Use typed-protocols-0.2.0.0 --- cabal.project | 26 +++- ekg-forward.cabal | 5 +- flake.lock | 165 ++++++++++++++++------- flake.nix | 1 - src/System/Metrics/Protocol/Acceptor.hs | 12 +- src/System/Metrics/Protocol/Codec.hs | 36 ++--- src/System/Metrics/Protocol/Forwarder.hs | 12 +- src/System/Metrics/Protocol/Type.hs | 51 +++---- 8 files changed, 198 insertions(+), 110 deletions(-) diff --git a/cabal.project b/cabal.project index 01337d6..277a7cb 100644 --- a/cabal.project +++ b/cabal.project @@ -17,7 +17,7 @@ repository cardano-haskell-packages index-state: , hackage.haskell.org 2023-08-02T14:18:01Z - , cardano-haskell-packages 2023-08-24T12:17:17Z + , cardano-haskell-packages 2023-09-05T08:50:43Z packages: ./. @@ -31,3 +31,27 @@ if impl(ghc >= 9.6) , *:base , ekg-core:* , protolude:* + +source-repository-package + type: git + location: https://github.com/input-output-hk/typed-protocols + tag: fdfc6c580b964458e53776ea48417b67c7494d71 + --sha256: sha256-LoPuQIlMu1QNEzb/p2Gnb/SqMxJpBQLUQVGz0TlyIho= + subdir: + typed-protocols + typed-protocols-cborg + typed-protocols-examples + typed-protocols-stateful + typed-protocols-stateful-cborg + +source-repository-package + type: git + location: https://github.com/input-output-hk/ouroboros-network + tag: f1bb5e5fce3e704c9f252df9f36e687bd3d4f1cc + --sha256: sha256-n9aom5Jw23pNNCLeVBczSyAomBqHOByJ7htVo36csh0= + subdir: network-mux + ouroboros-network + ouroboros-network-api + ouroboros-network-framework + ouroboros-network-protocols + ouroboros-network-testing diff --git a/ekg-forward.cabal b/ekg-forward.cabal index c1bca41..7c4bf3a 100644 --- a/ekg-forward.cabal +++ b/ekg-forward.cabal @@ -62,15 +62,16 @@ library , cborg , contra-tracer , ekg-core - , io-classes >= 0.3 + , io-classes >= 1.2 , network , ouroboros-network-api , ouroboros-network-framework >= 0.8 && < 0.10 + , singletons >= 3.0.0 , serialise , stm , text , time - , typed-protocols ^>= 0.1 + , typed-protocols ^>= 0.2 , typed-protocols-cborg , unordered-containers diff --git a/flake.lock b/flake.lock index 7d2c99d..4dda000 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1689851177, - "narHash": "sha256-ZSJyqKQAN+AXQ1xE9hgDmtqoKUf6mtB0Ukd9f+8Zabs=", + "lastModified": 1695701948, + "narHash": "sha256-YUrtWWa+DponzzFg46oDCEMMnF2tQG/+WwK+auHeCsE=", "owner": "input-output-hk", "repo": "cardano-haskell-packages", - "rev": "a557e8b56e150e9d51e57a48b0c5de94c96f085c", + "rev": "4c55186c53103fee3e3973d70a9ce8a3a55a8486", "type": "github" }, "original": { @@ -255,22 +255,6 @@ } }, "flake-utils_2": { - "locked": { - "lastModified": 1679360468, - "narHash": "sha256-LGnza3cfXF10Biw3ZTg0u9o9t7s680Ww200t5KkHTh8=", - "owner": "hamishmack", - "repo": "flake-utils", - "rev": "e1ea268ff47ad475443dbabcd54744b4e5b9d4f5", - "type": "github" - }, - "original": { - "owner": "hamishmack", - "ref": "hkm/nested-hydraJobs", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_3": { "locked": { "lastModified": 1653893745, "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", @@ -285,7 +269,7 @@ "type": "github" } }, - "flake-utils_4": { + "flake-utils_3": { "locked": { "lastModified": 1659877975, "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", @@ -317,6 +301,43 @@ "type": "github" } }, + "ghc980": { + "flake": false, + "locked": { + "lastModified": 1692910316, + "narHash": "sha256-Qv8I3GzzIIN32RTEKI38BW5nO1f7j6Xm+dDeDUyYZWo=", + "ref": "ghc-9.8", + "rev": "249aa8193e4c5c1ee46ce29b39d2fffa57de7904", + "revCount": 61566, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "ref": "ghc-9.8", + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, + "ghc99": { + "flake": false, + "locked": { + "lastModified": 1695427505, + "narHash": "sha256-j0hXl6uEI+Uwf37z3WLuQZN4S0XqGtiepELv2Gl2aHU=", + "ref": "refs/heads/master", + "rev": "b8e4fe2318798185228fb5f8214ba2384ac95b4f", + "revCount": 61951, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, "gomod2nix": { "inputs": { "nixpkgs": "nixpkgs_3", @@ -339,11 +360,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1685406313, - "narHash": "sha256-y+ZD6dlq/G4kmM0WsTJUOCwmpLnCJOVT7MrP5GaOX6s=", + "lastModified": 1695774158, + "narHash": "sha256-P9zifDVeDpv94NbwxVd6IQD2oggMa47CaBTjKAMPXqY=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "0ad8858dba2e9a93738dff55062b572aa69271c1", + "rev": "ad01b49b5be1112aed7ad135bf667b7b92169ce1", "type": "github" }, "original": { @@ -360,10 +381,13 @@ "cabal-36": "cabal-36", "cardano-shell": "cardano-shell", "flake-compat": "flake-compat_2", - "flake-utils": "flake-utils_2", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "ghc980": "ghc980", + "ghc99": "ghc99", "hackage": "hackage", "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", + "hls-2.2": "hls-2.2", "hpc-coveralls": "hpc-coveralls", "hydra": "hydra", "iserv-proxy": "iserv-proxy", @@ -376,16 +400,17 @@ "nixpkgs-2111": "nixpkgs-2111", "nixpkgs-2205": "nixpkgs-2205", "nixpkgs-2211": "nixpkgs-2211", + "nixpkgs-2305": "nixpkgs-2305", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, "locked": { - "lastModified": 1685421421, - "narHash": "sha256-/C1aN9T/e4mOF/Caso/Ha0q7n2oGA4Gxehd3si0LdA4=", + "lastModified": 1695775825, + "narHash": "sha256-fOt7qY3Qm69AZljpYcyPP+8mpfRcFoqaV1ps/vi6X5Y=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "e59e94e40b19c814aec7e7a2c409de6cbad30c38", + "rev": "9be017fdfbd2b290f1df4385ccd0fc22f549c1f2", "type": "github" }, "original": { @@ -411,6 +436,40 @@ "type": "github" } }, + "hls-2.0": { + "flake": false, + "locked": { + "lastModified": 1687698105, + "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "783905f211ac63edf982dd1889c671653327e441", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.0.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.2": { + "flake": false, + "locked": { + "lastModified": 1693064058, + "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.2.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hpc-coveralls": { "flake": false, "locked": { @@ -496,11 +555,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1670983692, - "narHash": "sha256-avLo34JnI9HNyOuauK5R69usJm+GfW3MlyGlYxZhTgY=", + "lastModified": 1691634696, + "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=", "ref": "hkm/remote-iserv", - "rev": "50d0abb3317ac439a4e7495b185a64af9b7b9300", - "revCount": 10, + "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73", + "revCount": 14, "type": "git", "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" }, @@ -608,7 +667,7 @@ }, "nix2container": { "inputs": { - "flake-utils": "flake-utils_3", + "flake-utils": "flake-utils_2", "nixpkgs": "nixpkgs_4" }, "locked": { @@ -723,11 +782,11 @@ }, "nixpkgs-2205": { "locked": { - "lastModified": 1682600000, - "narHash": "sha256-ha4BehR1dh8EnXSoE1m/wyyYVvHI9txjW4w5/oxsW5Y=", + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "50fc86b75d2744e1ab3837ef74b53f103a9b55a0", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", "type": "github" }, "original": { @@ -739,11 +798,11 @@ }, "nixpkgs-2211": { "locked": { - "lastModified": 1682682915, - "narHash": "sha256-haR0u/j/nUvlMloYlaOYq1FMXTvkNHw+wGxc+0qXisM=", + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "09f1b33fcc0f59263137e23e935c1bb03ec920e4", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", "type": "github" }, "original": { @@ -753,6 +812,22 @@ "type": "github" } }, + "nixpkgs-2305": { + "locked": { + "lastModified": 1695416179, + "narHash": "sha256-610o1+pwbSu+QuF3GE0NU5xQdTHM3t9wyYhB9l94Cd8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "715d72e967ec1dd5ecc71290ee072bcaf5181ed6", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-regression": { "locked": { "lastModified": 1643052045, @@ -771,11 +846,11 @@ }, "nixpkgs-unstable": { "locked": { - "lastModified": 1682656005, - "narHash": "sha256-fYplYo7so1O+rSQ2/aS+SbTPwLTeoUXk4ekKNtSl4P8=", + "lastModified": 1695318763, + "narHash": "sha256-FHVPDRP2AfvsxAdc+AsgFJevMz5VBmnZglFUMlxBkcY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "6806b63e824f84b0f0e60b6d660d4ae753de0477", + "rev": "e12483116b3b51a185a33a272bf351e357ba9a99", "type": "github" }, "original": { @@ -1001,11 +1076,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1685405385, - "narHash": "sha256-41gOy8zlN00MbHQPeFL9ZCHr3mf+h/8iqpVmBZE6F2M=", + "lastModified": 1695773356, + "narHash": "sha256-pNc857f4JgtrS4TZR2/GLu0N4VESNGAOSYK6lZVyUM4=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "10fcdfbe504a4dfb766e6372e1eaa998de496305", + "rev": "bb18dc10e65c84525d17ac7f3985f47c6517e694", "type": "github" }, "original": { @@ -1024,7 +1099,7 @@ "blank": "blank", "devshell": "devshell", "dmerge": "dmerge", - "flake-utils": "flake-utils_4", + "flake-utils": "flake-utils_3", "incl": "incl", "makes": [ "tullia", diff --git a/flake.nix b/flake.nix index 3232c5f..426fdf6 100644 --- a/flake.nix +++ b/flake.nix @@ -3,7 +3,6 @@ inputs = { haskellNix.url = "github:input-output-hk/haskell.nix"; - haskellNix.inputs.tullia.follows = "tullia"; nixpkgs.follows = "haskellNix/nixpkgs-unstable"; iohkNix.url = "github:input-output-hk/iohk-nix"; flake-utils.url = "github:hamishmack/flake-utils/hkm/nested-hydraJobs"; diff --git a/src/System/Metrics/Protocol/Acceptor.hs b/src/System/Metrics/Protocol/Acceptor.hs index efb5868..e931c39 100644 --- a/src/System/Metrics/Protocol/Acceptor.hs +++ b/src/System/Metrics/Protocol/Acceptor.hs @@ -12,8 +12,8 @@ module System.Metrics.Protocol.Acceptor ( , ekgAcceptorPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), - PeerRole (..)) +import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer.Client import System.Metrics.Protocol.Type @@ -36,14 +36,14 @@ data EKGAcceptor req resp m a where ekgAcceptorPeer :: Monad m => EKGAcceptor req resp m a - -> Peer (EKGForward req resp) 'AsClient 'StIdle m a + -> Client (EKGForward req resp) 'NonPipelined 'Empty 'StIdle m stm a ekgAcceptorPeer = \case SendMsgReq req next -> -- Send our message (request for the new metrics from the forwarder). - Yield (ClientAgency TokIdle) (MsgReq req) $ + Yield (MsgReq req) $ -- We're now into the 'StBusy' state, and now we'll wait for a reply -- from the forwarder. - Await (ServerAgency TokBusy) $ \(MsgResp resp) -> + Await $ \(MsgResp resp) -> Effect $ ekgAcceptorPeer <$> next resp @@ -53,4 +53,4 @@ ekgAcceptorPeer = \case -- 'done', with a return value. Effect $ do r <- getResult - return $ Yield (ClientAgency TokIdle) MsgDone (Done TokDone r) + return $ Yield MsgDone (Done r) diff --git a/src/System/Metrics/Protocol/Codec.hs b/src/System/Metrics/Protocol/Codec.hs index d22dd42..43af878 100644 --- a/src/System/Metrics/Protocol/Codec.hs +++ b/src/System/Metrics/Protocol/Codec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -14,9 +15,9 @@ import Codec.CBOR.Read (DeserialiseFailure) import Control.Monad.Class.MonadST (MonadST) import qualified Data.ByteString.Lazy as LBS import Text.Printf (printf) -import Network.TypedProtocol.Codec.CBOR (Codec, PeerHasAgency (..), - PeerRole (..), SomeMessage (..), - mkCodecCborLazyBS) +import Network.TypedProtocol.Core +import Network.TypedProtocol.Codec (Codec, SomeMessage (..)) +import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS) import System.Metrics.Protocol.Type @@ -34,47 +35,46 @@ codecEKGForward encodeReq decodeReq mkCodecCborLazyBS encode decode where -- Encode messages. - encode :: forall (pr :: PeerRole) - (st :: EKGForward req resp) + encode :: forall (st :: EKGForward req resp) (st' :: EKGForward req resp). - PeerHasAgency pr st - -> Message (EKGForward req resp) st st' + Message (EKGForward req resp) st st' -> CBOR.Encoding - encode (ClientAgency TokIdle) (MsgReq req) = + encode (MsgReq req) = CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> encodeReq req - encode (ClientAgency TokIdle) MsgDone = + encode MsgDone = CBOR.encodeListLen 1 <> CBOR.encodeWord 1 - encode (ServerAgency TokBusy) (MsgResp resp) = + encode (MsgResp resp) = CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> encodeResp resp -- Decode messages - decode :: forall (pr :: PeerRole) - (st :: EKGForward req resp) s. - PeerHasAgency pr st + decode :: forall (st :: EKGForward req resp) s. + ActiveState st + => StateToken st -> CBOR.Decoder s (SomeMessage st) decode stok = do len <- CBOR.decodeListLen key <- CBOR.decodeWord case (key, len, stok) of - (0, 2, ClientAgency TokIdle) -> + (0, 2, SingIdle) -> SomeMessage . MsgReq <$> decodeReq - (1, 1, ClientAgency TokIdle) -> + (1, 1, SingIdle) -> return $ SomeMessage MsgDone - (1, 2, ServerAgency TokBusy) -> + (1, 2, SingBusy) -> SomeMessage . MsgResp <$> decodeResp -- Failures per protocol state - (_, _, ClientAgency TokIdle) -> + (_, _, SingIdle) -> fail (printf "codecEKGForward (%s) unexpected key (%d, %d)" (show stok) key len) - (_, _, ServerAgency TokBusy) -> + (_, _, SingBusy) -> fail (printf "codecEKGForward (%s) unexpected key (%d, %d)" (show stok) key len) + (_, _, SingDone) -> notActiveState stok diff --git a/src/System/Metrics/Protocol/Forwarder.hs b/src/System/Metrics/Protocol/Forwarder.hs index 38572c3..d94bd53 100644 --- a/src/System/Metrics/Protocol/Forwarder.hs +++ b/src/System/Metrics/Protocol/Forwarder.hs @@ -8,8 +8,8 @@ module System.Metrics.Protocol.Forwarder ( , ekgForwarderPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), - PeerRole (..)) +import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer.Server import System.Metrics.Protocol.Type @@ -34,18 +34,18 @@ data EKGForwarder req resp m a = EKGForwarder { ekgForwarderPeer :: Monad m => EKGForwarder req resp m a - -> Peer (EKGForward req resp) 'AsServer 'StIdle m a + -> Server (EKGForward req resp) 'NonPipelined 'Empty 'StIdle m stm a ekgForwarderPeer EKGForwarder{..} = -- In the 'StIdle' state the forwarder is awaiting a request message -- from the acceptor. - Await (ClientAgency TokIdle) $ \case + Await $ \case -- The acceptor sent us a request for new metrics, so now we're -- in the 'StBusy' state which means it's the forwarder's turn to send -- a reply. MsgReq req -> Effect $ do (resp, next) <- recvMsgReq req - return $ Yield (ServerAgency TokBusy) (MsgResp resp) (ekgForwarderPeer next) + return $ Yield (MsgResp resp) (ekgForwarderPeer next) -- The acceptor sent the done transition, so we're in the 'StDone' state -- so all we can do is stop using 'done', with a return value. - MsgDone -> Effect $ Done TokDone <$> recvMsgDone + MsgDone -> Effect $ Done <$> recvMsgDone diff --git a/src/System/Metrics/Protocol/Type.hs b/src/System/Metrics/Protocol/Type.hs index 5cc26b0..869bb69 100644 --- a/src/System/Metrics/Protocol/Type.hs +++ b/src/System/Metrics/Protocol/Type.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -- | The type of the EKG forwarding/accepting protocol. @@ -13,14 +14,12 @@ module System.Metrics.Protocol.Type ( EKGForward (..) + , SingEKGForward (..) , Message (..) - , ClientHasAgency (..) - , ServerHasAgency (..) - , NobodyHasAgency (..) ) where -import Data.Proxy (Proxy(..)) -import Network.TypedProtocol.Core (Protocol (..)) +import Data.Singletons +import Network.TypedProtocol.Core import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) -- | A kind to identify our protocol, and the types of the states in the state @@ -69,6 +68,16 @@ instance (ShowProxy req, ShowProxy resp) , ")" ] +data SingEKGForward (st :: EKGForward req resp) where + SingIdle :: SingEKGForward 'StIdle + SingBusy :: SingEKGForward 'StBusy + SingDone :: SingEKGForward 'StDone + +deriving instance Show (SingEKGForward st) +instance StateTokenI 'StIdle where stateToken = SingIdle +instance StateTokenI 'StBusy where stateToken = SingBusy +instance StateTokenI 'StDone where stateToken = SingDone + instance Protocol (EKGForward req resp) where -- | The messages in the EKG forwarding/accepting protocol. @@ -91,32 +100,12 @@ instance Protocol (EKGForward req resp) where -- 2. When both peers are in Busy state, the forwarder is expected to send -- a reply to the acceptor (list of new metrics). -- - -- So we assume that, from __interaction__ point of view: - -- 1. ClientHasAgency (from 'Network.TypedProtocol.Core') corresponds to acceptor's agency. - -- 3. ServerHasAgency (from 'Network.TypedProtocol.Core') corresponds to forwarder's agency. - -- - data ClientHasAgency st where - TokIdle :: ClientHasAgency 'StIdle - - data ServerHasAgency st where - TokBusy :: ServerHasAgency 'StBusy - - data NobodyHasAgency st where - TokDone :: NobodyHasAgency 'StDone - - -- | Impossible cases. - exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {} - exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {} - exclusionLemma_NobodyAndServerHaveAgency TokDone tok = case tok of {} + type StateAgency 'StIdle = 'ClientAgency + type StateAgency 'StBusy = 'ServerAgency + type StateAgency 'StDone = 'NobodyAgency -instance (Show req, Show resp) - => Show (Message (EKGForward req resp) from to) where - show MsgReq{} = "MsgReq" - show MsgResp{} = "MsgResp" - show MsgDone{} = "MsgDone" + type StateToken = SingEKGForward -instance Show (ClientHasAgency (st :: EKGForward req resp)) where - show TokIdle = "TokIdle" -instance Show (ServerHasAgency (st :: EKGForward req resp)) where - show TokBusy = "TokBusy" +deriving instance (Show req, Show resp) + => Show (Message (EKGForward req resp) from to)