diff --git a/CODEOWNERS b/CODEOWNERS index 22d381607a0..b391ea1fed6 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -23,6 +23,7 @@ bench/tx-generator @deepfire @MarcFon bench @deepfire @denisshevchenko @jutaro @MarcFontaine nix/workbench @deepfire @denisshevchenko @jutaro @MarcFontaine nix/supervisord-cluster @deepfire @denisshevchenko @jutaro @MarcFontaine +trace-forward @deepfire @denisshevchenko @jutaro Makefile @deepfire .buildkite @devops diff --git a/cabal.project b/cabal.project index aa2cd86ece4..1ed5017ea7e 100644 --- a/cabal.project +++ b/cabal.project @@ -12,6 +12,7 @@ packages: bench/cardano-topology bench/locli bench/tx-generator + trace-forward package cardano-api ghc-options: -Werror @@ -60,6 +61,9 @@ package cardano-node-chairman package cardano-testnet tests: True +package trace-forward + tests: True + -- The following is needed because Nix is doing something crazy. package byron-spec-ledger tests: False diff --git a/trace-forward/CHANGELOG.md b/trace-forward/CHANGELOG.md new file mode 100644 index 00000000000..27316fb6d97 --- /dev/null +++ b/trace-forward/CHANGELOG.md @@ -0,0 +1,3 @@ +# ChangeLog + +# 0.1.0 diff --git a/trace-forward/CODEOWNERS b/trace-forward/CODEOWNERS new file mode 100644 index 00000000000..6e6b1a89e87 --- /dev/null +++ b/trace-forward/CODEOWNERS @@ -0,0 +1,3 @@ +# General reviewers per PR +# Denis Serge Jürgen +* @denisshevchenko @deepfire @jutaro diff --git a/trace-forward/LICENSE b/trace-forward/LICENSE new file mode 100644 index 00000000000..f471221ad3a --- /dev/null +++ b/trace-forward/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2021 Input Output (Hong Kong) Ltd. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/trace-forward/NOTICE b/trace-forward/NOTICE new file mode 100644 index 00000000000..fb77bb84e9d --- /dev/null +++ b/trace-forward/NOTICE @@ -0,0 +1,14 @@ +Copyright 2021 Input Output (Hong Kong) Ltd. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/trace-forward/README.md b/trace-forward/README.md new file mode 100644 index 00000000000..435f147f835 --- /dev/null +++ b/trace-forward/README.md @@ -0,0 +1,9 @@ +# trace-forward + +`trace-forward` is a library allowing to forward tracing items from one process to another one. It is built upon [`typed-protocols`](https://github.com/input-output-hk/ouroboros-network/tree/master/typed-protocols). + +The `trace-dispatcher` is using `trace-forward` to forward `TraceObject`s from the node to exernal acceptors (for example, `cardano-tracer`). + +## Developers + +Benchmarking team is responsible for this library. The primary developer is [@denisshevchenko](https://github.com/denisshevchenko). diff --git a/trace-forward/src/Trace/Forward/Acceptor.hs b/trace-forward/src/Trace/Forward/Acceptor.hs new file mode 100644 index 00000000000..6743dd3e3bf --- /dev/null +++ b/trace-forward/src/Trace/Forward/Acceptor.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE LambdaCase #-} + +-- | This top-level module will be used by the acceptor application. +-- Acceptor application asks 'TraceObject's from the forwarder application. +module Trace.Forward.Acceptor + ( runTraceAcceptor + ) where + +import qualified Codec.Serialise as CBOR +import Control.Concurrent.STM.TBQueue (TBQueue) +import Control.Exception.Extra (try_) +import Data.Typeable (Typeable) +import System.Time.Extra (sleep) + +import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) + +import Trace.Forward.Network.Acceptor (listenToForwarder) +import Trace.Forward.Configuration (AcceptorConfiguration (..)) +import Trace.Forward.Protocol.Type (NodeInfoStore) + +runTraceAcceptor + :: (CBOR.Serialise lo, + ShowProxy lo, + Typeable lo) + => AcceptorConfiguration lo -- ^ Acceptor configuration. + -> TBQueue lo -- ^ All 'TraceObject's received from the node will be written in this queue. + -> NodeInfoStore -- ^ The node's basic info will be written in this store. + -> IO () +runTraceAcceptor config loQueue niStore = + try_ (listenToForwarder config loQueue niStore) >>= \case + Left e -> do + putStrLn $ "trace-forward, acceptor has a problem: " <> show e + sleep 1.0 + runTraceAcceptor config loQueue niStore + Right _ -> return () diff --git a/trace-forward/src/Trace/Forward/Configuration.hs b/trace-forward/src/Trace/Forward/Configuration.hs new file mode 100644 index 00000000000..de72ab50f56 --- /dev/null +++ b/trace-forward/src/Trace/Forward/Configuration.hs @@ -0,0 +1,55 @@ +module Trace.Forward.Configuration + ( AcceptorConfiguration (..) + , ForwarderConfiguration (..) + , HowToConnect (..) + , Host + , Port + ) where + +import Control.Tracer (Tracer) +import Data.IORef (IORef) +import Data.Text (Text) +import Data.Word (Word16) +import Ouroboros.Network.Driver (TraceSendRecv) + +import Trace.Forward.Protocol.Type (NodeInfo, Request, TraceForward) + +type Host = Text +type Port = Word16 + +-- | Specifies how to connect to the peer. +data HowToConnect + = LocalPipe !FilePath -- ^ Local pipe (UNIX or Windows). + | RemoteSocket !Host !Port -- ^ Remote socket (host and port). + +-- | Acceptor configuration, parameterized by trace item's type. +data AcceptorConfiguration lo = AcceptorConfiguration + { -- | The tracer that will be used by the acceptor in its network layer. + acceptorTracer :: !(Tracer IO (TraceSendRecv (TraceForward lo))) + -- | The endpoint that will be used to listen to the forwarder. + , forwarderEndpoint :: !HowToConnect + -- | The request specifies how many 'TraceObject's will be requested. + , whatToRequest :: !Request + -- | Additional action that will be performed every time the acceptor + -- receives a reply from the forwarder" + , actionOnReply :: !([lo] -> IO ()) + -- | 'IORef' that can be used as a brake: if an external thread sets + -- it to 'True', the acceptor will send 'MsgDone' message to the + -- forwarder and their session will be closed. + , shouldWeStop :: !(IORef Bool) + -- | An action that will be performed before sending 'MsgDone' message. + , actionOnDone :: !(IO ()) + } + +-- | Forwarder configuration, parameterized by trace item's type. +data ForwarderConfiguration lo = ForwarderConfiguration + { -- | The tracer that will be used by the forwarder in its network layer. + forwarderTracer :: !(Tracer IO (TraceSendRecv (TraceForward lo))) + -- | The endpoint that will be used to connect to the acceptor. + , acceptorEndpoint :: !HowToConnect + -- | An action that returns node's basic information. + , nodeBasicInfo :: !(IO NodeInfo) + -- | Additional action that will be performed every time the forwarder will + -- receive the request from the acceptor. + , actionOnRequest :: !(Request -> IO ()) + } diff --git a/trace-forward/src/Trace/Forward/Forwarder.hs b/trace-forward/src/Trace/Forward/Forwarder.hs new file mode 100644 index 00000000000..9cd6f7a010e --- /dev/null +++ b/trace-forward/src/Trace/Forward/Forwarder.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE LambdaCase #-} + +-- This top-level module will be used by the forwarder application. +-- Forwarder application collects 'TraceObject's and sends them to +-- the acceptor application. +module Trace.Forward.Forwarder + ( runTraceForwarder + ) where + +import qualified Codec.Serialise as CBOR +import Control.Concurrent.STM.TBQueue (TBQueue) +import Control.Exception.Extra (try_) +import Data.Typeable (Typeable) +import System.Time.Extra (sleep) + +import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) + +import Trace.Forward.Configuration (ForwarderConfiguration (..)) +import Trace.Forward.Network.Forwarder (connectToAcceptor) + +runTraceForwarder + :: (CBOR.Serialise lo, + ShowProxy lo, + Typeable lo) + => ForwarderConfiguration lo -- ^ Forwarder configuration. + -> TBQueue lo -- ^ The queue from which the forwarder will take 'TraceObject's. + -> IO () +runTraceForwarder config loQueue = + try_ (connectToAcceptor config loQueue) >>= \case + Left e -> do + putStrLn $ "trace-forward, forwarder has a problem: " <> show e + sleep 1.0 + runTraceForwarder config loQueue + Right _ -> return () diff --git a/trace-forward/src/Trace/Forward/Network/Acceptor.hs b/trace-forward/src/Trace/Forward/Network/Acceptor.hs new file mode 100644 index 00000000000..ad0abe5af38 --- /dev/null +++ b/trace-forward/src/Trace/Forward/Network/Acceptor.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Trace.Forward.Network.Acceptor + ( listenToForwarder + -- | Export this function for Mux purpose. + , acceptTraceObjects + , acceptTraceObjectsInit + ) where + +import Codec.CBOR.Term (Term) +import qualified Codec.Serialise as CBOR +import Control.Concurrent.Async (async, wait, waitAnyCancel) +import Control.Concurrent.STM.TBQueue (TBQueue) +import Control.Monad (void, unless) +import Control.Monad.Class.MonadSTM.Strict (StrictTVar, atomically, modifyTVar, + newEmptyTMVarIO, newTVarIO, putTMVar, + readTVar, retry) +import qualified Data.ByteString.Lazy as LBS +import Data.Functor ((<&>)) +import Data.IORef (atomicModifyIORef', readIORef) +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Data.Void (Void) +import qualified Network.Socket as Socket +import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (..), + MiniProtocolNum (..), MuxMode (..), + OuroborosApplication (..), MuxPeer (..), + RunMiniProtocol (..), + miniProtocolLimits, miniProtocolNum, miniProtocolRun) +import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits, runPeerWithLimits) +import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) +import Ouroboros.Network.IOManager (withIOManager) +import Ouroboros.Network.Snocket (Snocket, localAddressFromPath, localSnocket, socketSnocket) +import Ouroboros.Network.Socket (AcceptedConnectionsLimit (..), + SomeResponderApplication (..), + cleanNetworkMutableState, newNetworkMutableState, + nullNetworkServerTracers, withServerNode) +import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, + noTimeLimitsHandshake, + timeLimitsHandshake) +import Ouroboros.Network.Protocol.Handshake.Unversioned (UnversionedProtocol (..), + UnversionedProtocolData (..), + unversionedHandshakeCodec, + unversionedProtocolDataCodec) +import Ouroboros.Network.Protocol.Handshake.Type (Handshake) +import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, + simpleSingletonVersions) +import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) + +import qualified Trace.Forward.Protocol.Acceptor as Acceptor +import qualified Trace.Forward.Protocol.Codec as Acceptor +import Trace.Forward.Protocol.Limits (byteLimitsTraceForward, timeLimitsTraceForward) +import Trace.Forward.Protocol.Type +import Trace.Forward.Queue (logObjectsFromReply, writeTraceObjectsToQueue) +import Trace.Forward.Configuration (AcceptorConfiguration (..), HowToConnect (..)) + +listenToForwarder + :: (CBOR.Serialise lo, + ShowProxy lo, + Typeable lo) + => AcceptorConfiguration lo + -> TBQueue lo + -> NodeInfoStore + -> IO () +listenToForwarder config@AcceptorConfiguration{..} loQueue niStore = withIOManager $ \iocp -> + case forwarderEndpoint of + LocalPipe localPipe -> do + let snocket = localSnocket iocp localPipe + address = localAddressFromPath localPipe + doListenToForwarder snocket address noTimeLimitsHandshake app + RemoteSocket host port -> do + listenAddress:_ <- Socket.getAddrInfo Nothing (Just $ T.unpack host) (Just $ show port) + let snocket = socketSnocket iocp + address = Socket.addrAddress listenAddress + doListenToForwarder snocket address timeLimitsHandshake app + where + app = + OuroborosApplication $ \_connectionId _shouldStopSTM -> + [ MiniProtocol + { miniProtocolNum = MiniProtocolNum 1 + , miniProtocolLimits = MiniProtocolLimits { maximumIngressQueue = maxBound } + , miniProtocolRun = acceptTraceObjects config loQueue niStore + } + ] + +doListenToForwarder + :: Ord addr + => Snocket IO fd addr + -> addr + -> ProtocolTimeLimits (Handshake UnversionedProtocol Term) + -> OuroborosApplication 'ResponderMode addr LBS.ByteString IO Void () + -> IO () +doListenToForwarder snocket address timeLimits app = do + networkState <- newNetworkMutableState + nsAsync <- async $ cleanNetworkMutableState networkState + clAsync <- async . void $ + withServerNode + snocket + nullNetworkServerTracers + networkState + (AcceptedConnectionsLimit maxBound maxBound 0) + address + unversionedHandshakeCodec + timeLimits + (cborTermVersionDataCodec unversionedProtocolDataCodec) + acceptableVersion + (simpleSingletonVersions + UnversionedProtocol + UnversionedProtocolData + (SomeResponderApplication app)) + nullErrorPolicies + $ \_ serverAsync -> wait serverAsync -- Block until async exception. + void $ waitAnyCancel [nsAsync, clAsync] + +acceptTraceObjects + :: (CBOR.Serialise lo, + ShowProxy lo, + Typeable lo) + => AcceptorConfiguration lo + -> TBQueue lo + -> NodeInfoStore + -> RunMiniProtocol 'ResponderMode LBS.ByteString IO Void () +acceptTraceObjects config loQueue niStore = + ResponderProtocolOnly $ + MuxPeerRaw $ \channel -> do + sv <- newEmptyTMVarIO + siblingVar <- newTVarIO 2 + (r, trailing) <- + runPeerWithLimits + (acceptorTracer config) + (Acceptor.codecTraceForward CBOR.encode CBOR.decode + CBOR.encode CBOR.decode + CBOR.encode CBOR.decode) + (byteLimitsTraceForward (fromIntegral . LBS.length)) + timeLimitsTraceForward + channel + (Acceptor.traceAcceptorPeer $ + acceptorActions config loQueue niStore True False) + atomically $ putTMVar sv r + waitSibling siblingVar + return ((), trailing) + +acceptTraceObjectsInit + :: (CBOR.Serialise lo, + ShowProxy lo, + Typeable lo) + => AcceptorConfiguration lo + -> TBQueue lo + -> NodeInfoStore + -> RunMiniProtocol 'InitiatorMode LBS.ByteString IO () Void +acceptTraceObjectsInit config loQueue niStore = + InitiatorProtocolOnly $ + MuxPeerRaw $ \channel -> do + sv <- newEmptyTMVarIO + siblingVar <- newTVarIO 2 + (r, trailing) <- + runPeerWithLimits + (acceptorTracer config) + (Acceptor.codecTraceForward CBOR.encode CBOR.decode + CBOR.encode CBOR.decode + CBOR.encode CBOR.decode) + (byteLimitsTraceForward (fromIntegral . LBS.length)) + timeLimitsTraceForward + channel + (Acceptor.traceAcceptorPeer $ + acceptorActions config loQueue niStore True False) + atomically $ putTMVar sv r + waitSibling siblingVar + return ((), trailing) + +waitSibling :: StrictTVar IO Int -> IO () +waitSibling cntVar = do + atomically $ modifyTVar cntVar (\a -> a - 1) + atomically $ do + cnt <- readTVar cntVar + unless (cnt == 0) retry + +acceptorActions + :: (CBOR.Serialise lo, + ShowProxy lo, + Typeable lo) + => AcceptorConfiguration lo + -> TBQueue lo + -> NodeInfoStore + -> Bool + -> Bool + -> Acceptor.TraceAcceptor lo IO () +acceptorActions config@AcceptorConfiguration{..} loQueue niStore askForNI False = + -- We are able to send request for: + -- 1. node's basic info, + -- 2. new 'TraceObject's. + -- But request for node's info should be sent only once (in the beginning of session). + if askForNI + then + Acceptor.SendMsgNodeInfoRequest $ \reply -> + if niContainsAllWeNeed reply + then do + atomicModifyIORef' niStore $ const (reply, ()) + readIORef shouldWeStop <&> acceptorActions config loQueue niStore False + else + -- The node didn't provide us all the info we need, stop the session. + return $ acceptorActions config loQueue niStore False True + else + Acceptor.SendMsgRequest TokBlocking whatToRequest $ \reply -> do + writeTraceObjectsToQueue reply loQueue + actionOnReply $ logObjectsFromReply reply + readIORef shouldWeStop <&> acceptorActions config loQueue niStore False + where + niContainsAllWeNeed ni = length allWeNeed == length allWeHave + where + allWeNeed = + [ lookup "NodeName" ni + , lookup "NodeProtocol" ni + , lookup "NodeRelease" ni + , lookup "NodeCommit" ni + , lookup "NodeStartTime" ni + ] + allWeHave = catMaybes allWeNeed + +acceptorActions AcceptorConfiguration{..} _ _ _ True = + Acceptor.SendMsgDone + actionOnDone diff --git a/trace-forward/src/Trace/Forward/Network/Forwarder.hs b/trace-forward/src/Trace/Forward/Network/Forwarder.hs new file mode 100644 index 00000000000..a7c44cb16dc --- /dev/null +++ b/trace-forward/src/Trace/Forward/Network/Forwarder.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} + +module Trace.Forward.Network.Forwarder + ( connectToAcceptor + -- | Export this function for Mux purpose. + , forwardTraceObjects + , forwardTraceObjectsResp + ) where + +import Codec.CBOR.Term (Term) +import qualified Codec.Serialise as CBOR +import Control.Concurrent.STM.TBQueue (TBQueue) +import Control.Monad (unless) +import Control.Monad.Class.MonadSTM.Strict (StrictTVar, atomically, modifyTVar, + newEmptyTMVarIO, newTVarIO, putTMVar, + readTVar, retry) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import Data.Void (Void) +import qualified Network.Socket as Socket +import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits, runPeerWithLimits) +import Ouroboros.Network.IOManager (withIOManager) +import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (..), + MiniProtocolNum (..), MuxMode (..), + OuroborosApplication (..), MuxPeer (..), + RunMiniProtocol (..), + miniProtocolLimits, miniProtocolNum, miniProtocolRun) +import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, + noTimeLimitsHandshake, + timeLimitsHandshake) +import Ouroboros.Network.Protocol.Handshake.Unversioned (UnversionedProtocol (..), + UnversionedProtocolData (..), + unversionedHandshakeCodec, + unversionedProtocolDataCodec) +import Ouroboros.Network.Protocol.Handshake.Type (Handshake) +import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, simpleSingletonVersions) +import Ouroboros.Network.Snocket (Snocket, localAddressFromPath, localSnocket, socketSnocket) +import Ouroboros.Network.Socket (connectToNode, nullNetworkConnectTracers) +import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) + +import Trace.Forward.Configuration (ForwarderConfiguration (..), HowToConnect (..)) +import Trace.Forward.Queue (readItems) +import qualified Trace.Forward.Protocol.Forwarder as Forwarder +import qualified Trace.Forward.Protocol.Codec as Forwarder +import Trace.Forward.Protocol.Limits (byteLimitsTraceForward, timeLimitsTraceForward) + +connectToAcceptor + :: (CBOR.Serialise lo, + ShowProxy lo) + => ForwarderConfiguration lo + -> TBQueue lo + -> IO () +connectToAcceptor config@ForwarderConfiguration{..} loQueue = withIOManager $ \iocp -> + case acceptorEndpoint of + LocalPipe localPipe -> do + let snocket = localSnocket iocp localPipe + address = localAddressFromPath localPipe + doConnectToAcceptor snocket address noTimeLimitsHandshake app + RemoteSocket host port -> do + acceptorAddr:_ <- Socket.getAddrInfo Nothing (Just $ T.unpack host) (Just $ show port) + let snocket = socketSnocket iocp + address = Socket.addrAddress acceptorAddr + doConnectToAcceptor snocket address timeLimitsHandshake app + where + app = + OuroborosApplication $ \_connectionId _shouldStopSTM -> + [ MiniProtocol + { miniProtocolNum = MiniProtocolNum 1 + , miniProtocolLimits = MiniProtocolLimits { maximumIngressQueue = maxBound } + , miniProtocolRun = forwardTraceObjects config loQueue + } + ] + +doConnectToAcceptor + :: Snocket IO fd addr + -> addr + -> ProtocolTimeLimits (Handshake UnversionedProtocol Term) + -> OuroborosApplication 'InitiatorMode addr LBS.ByteString IO () Void + -> IO () +doConnectToAcceptor snocket address timeLimits app = + connectToNode + snocket + unversionedHandshakeCodec + timeLimits + (cborTermVersionDataCodec unversionedProtocolDataCodec) + nullNetworkConnectTracers + acceptableVersion + (simpleSingletonVersions + UnversionedProtocol + UnversionedProtocolData + app) + Nothing + address + +forwardTraceObjects + :: (CBOR.Serialise lo, + ShowProxy lo) + => ForwarderConfiguration lo + -> TBQueue lo + -> RunMiniProtocol 'InitiatorMode LBS.ByteString IO () Void +forwardTraceObjects config loQueue = + InitiatorProtocolOnly $ + MuxPeerRaw $ \channel -> do + cv <- newEmptyTMVarIO + siblingVar <- newTVarIO 2 + (r, trailing) <- + runPeerWithLimits + (forwarderTracer config) + (Forwarder.codecTraceForward CBOR.encode CBOR.decode + CBOR.encode CBOR.decode + CBOR.encode CBOR.decode) + (byteLimitsTraceForward (fromIntegral . LBS.length)) + timeLimitsTraceForward + channel + (Forwarder.traceForwarderPeer $ readItems config loQueue) + atomically $ putTMVar cv r + waitSibling siblingVar + return ((), trailing) + +forwardTraceObjectsResp + :: (CBOR.Serialise lo, + ShowProxy lo) + => ForwarderConfiguration lo + -> TBQueue lo + -> RunMiniProtocol 'ResponderMode LBS.ByteString IO Void () +forwardTraceObjectsResp config loQueue = + ResponderProtocolOnly $ + MuxPeerRaw $ \channel -> do + cv <- newEmptyTMVarIO + siblingVar <- newTVarIO 2 + (r, trailing) <- + runPeerWithLimits + (forwarderTracer config) + (Forwarder.codecTraceForward CBOR.encode CBOR.decode + CBOR.encode CBOR.decode + CBOR.encode CBOR.decode) + (byteLimitsTraceForward (fromIntegral . LBS.length)) + timeLimitsTraceForward + channel + (Forwarder.traceForwarderPeer $ readItems config loQueue) + atomically $ putTMVar cv r + waitSibling siblingVar + return ((), trailing) + +waitSibling :: StrictTVar IO Int -> IO () +waitSibling cntVar = do + atomically $ modifyTVar cntVar (\a -> a - 1) + atomically $ do + cnt <- readTVar cntVar + unless (cnt == 0) retry diff --git a/trace-forward/src/Trace/Forward/Protocol/Acceptor.hs b/trace-forward/src/Trace/Forward/Protocol/Acceptor.hs new file mode 100644 index 00000000000..3f01da266ab --- /dev/null +++ b/trace-forward/src/Trace/Forward/Protocol/Acceptor.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +-- | A view of the trace forwarding/accepting protocol +-- from the point of view of the client. +-- +-- For execution, a conversion into the typed protocol is provided. +-- +module Trace.Forward.Protocol.Acceptor + ( TraceAcceptor(..) + , traceAcceptorPeer + ) where + +import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), + PeerRole (..)) + +import Trace.Forward.Protocol.Type + +data TraceAcceptor lo m a where + SendMsgNodeInfoRequest + :: (NodeInfo -> m (TraceAcceptor lo m a)) + -> TraceAcceptor lo m a + + SendMsgRequest + :: TokBlockingStyle blocking + -> Request + -> (BlockingReplyList blocking lo -> m (TraceAcceptor lo m a)) + -> TraceAcceptor lo m a + + SendMsgDone + :: m a + -> TraceAcceptor lo m a + +-- | Interpret a particular action sequence into the client side of the protocol. +-- +traceAcceptorPeer + :: Monad m + => TraceAcceptor lo m a + -> Peer (TraceForward lo) 'AsClient 'StIdle m a +traceAcceptorPeer = \case + SendMsgNodeInfoRequest next -> + -- Send our message (request for node's basic info from the forwarder). + Yield (ClientAgency TokIdle) MsgNodeInfoRequest $ + -- We're now into the 'StNodeInfoBusy' state, and now we'll wait for + -- a reply from the forwarder. + Await (ServerAgency TokNodeInfoBusy) $ \(MsgNodeInfoReply reply) -> + Effect $ + traceAcceptorPeer <$> next reply + + SendMsgRequest TokBlocking request next -> + -- Send our message (request for new 'TraceObject's from the forwarder). + Yield (ClientAgency TokIdle) (MsgRequest TokBlocking request) $ + -- We're now into the 'StBusy' state, and now we'll wait for a reply + -- from the forwarder. + Await (ServerAgency (TokBusy TokBlocking)) $ \(MsgReply reply) -> + Effect $ + traceAcceptorPeer <$> next reply + + SendMsgRequest TokNonBlocking request next -> + -- Send our message (request for new 'TraceObject's from the forwarder). + Yield (ClientAgency TokIdle) (MsgRequest TokNonBlocking request) $ + -- We're now into the 'StBusy' state, and now we'll wait for a reply + -- from the forwarder. It is assuming that the forwarder will reply + -- immediately (even there are no 'TraceObject's). + Await (ServerAgency (TokBusy TokNonBlocking)) $ \(MsgReply reply) -> + Effect $ + traceAcceptorPeer <$> next reply + + SendMsgDone getResult -> + -- We do an actual transition using 'yield', to go from the 'StIdle' to + -- 'StDone' state. Once in the 'StDone' state we can actually stop using + -- 'done', with a return value. + Effect $ + Yield (ClientAgency TokIdle) MsgDone . Done TokDone + <$> getResult diff --git a/trace-forward/src/Trace/Forward/Protocol/Codec.hs b/trace-forward/src/Trace/Forward/Protocol/Codec.hs new file mode 100644 index 00000000000..8ac7b1483c1 --- /dev/null +++ b/trace-forward/src/Trace/Forward/Protocol/Codec.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Trace.Forward.Protocol.Codec ( + codecTraceForward + ) where + +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR +import Codec.CBOR.Read (DeserialiseFailure) +import Control.Monad.Class.MonadST (MonadST) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Text.Printf (printf) +import Ouroboros.Network.Codec (Codec, PeerHasAgency (..), + PeerRole (..), SomeMessage (..), + mkCodecCborLazyBS) + +import Trace.Forward.Protocol.Type + +codecTraceForward + :: forall lo m. + MonadST m + => (Request -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s Request) + -> ([(Text, Text)] -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s [(Text, Text)]) + -> ([lo] -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s [lo]) + -> Codec (TraceForward lo) + DeserialiseFailure m LBS.ByteString +codecTraceForward encodeRequest decodeRequest + encodeNIReply decodeNIReply + encodeReplyList decodeReplyList = + mkCodecCborLazyBS encode decode + where + -- Encode messages. + encode + :: forall (pr :: PeerRole) + (st :: TraceForward lo) + (st' :: TraceForward lo). + PeerHasAgency pr st + -> Message (TraceForward lo) st st' + -> CBOR.Encoding + + encode (ClientAgency TokIdle) MsgNodeInfoRequest = + CBOR.encodeListLen 1 + <> CBOR.encodeWord 0 + + encode (ClientAgency TokIdle) (MsgRequest blocking request) = + CBOR.encodeListLen 3 + <> CBOR.encodeWord 1 + <> CBOR.encodeBool (case blocking of + TokBlocking -> True + TokNonBlocking -> False) + <> encodeRequest request + + encode (ClientAgency TokIdle) MsgDone = + CBOR.encodeListLen 1 + <> CBOR.encodeWord 2 + + encode (ServerAgency TokNodeInfoBusy) (MsgNodeInfoReply reply) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 3 + <> encodeNIReply reply + + encode (ServerAgency (TokBusy _)) (MsgReply reply) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 4 + <> encodeReplyList replyList + where + replyList = + case reply of + BlockingReply los -> NE.toList los + NonBlockingReply los -> los + + -- Decode messages + decode + :: forall (pr :: PeerRole) + (st :: TraceForward lo) s. + PeerHasAgency pr st + -> CBOR.Decoder s (SomeMessage st) + decode stok = do + len <- CBOR.decodeListLen + key <- CBOR.decodeWord + case (key, len, stok) of + (0, 1, ClientAgency TokIdle) -> + return $ SomeMessage MsgNodeInfoRequest + + (1, 3, ClientAgency TokIdle) -> do + blocking <- CBOR.decodeBool + request <- decodeRequest + return $! + if blocking then + SomeMessage $ MsgRequest TokBlocking request + else + SomeMessage $ MsgRequest TokNonBlocking request + + (2, 1, ClientAgency TokIdle) -> + return $ SomeMessage MsgDone + + (3, 2, ServerAgency TokNodeInfoBusy) -> + SomeMessage . MsgNodeInfoReply <$> decodeNIReply + + (4, 2, ServerAgency (TokBusy blocking)) -> do + replyList <- decodeReplyList + case (blocking, replyList) of + (TokBlocking, x:xs) -> + return $ SomeMessage (MsgReply (BlockingReply (x NE.:| xs))) + + (TokNonBlocking, los) -> + return $ SomeMessage (MsgReply (NonBlockingReply los)) + + (TokBlocking, []) -> + fail "codecTraceForward: MsgReply: empty list not permitted" + + -- Failures per protocol state + (_, _, ClientAgency TokIdle) -> + fail (printf "codecTraceForward (%s) unexpected key (%d, %d)" (show stok) key len) + (_, _, ServerAgency TokNodeInfoBusy) -> + fail (printf "codecTraceForward (%s) unexpected key (%d, %d)" (show stok) key len) + (_, _, ServerAgency (TokBusy TokBlocking)) -> + fail (printf "codecTraceForward (%s) unexpected key (%d, %d)" (show stok) key len) + (_, _, ServerAgency (TokBusy TokNonBlocking)) -> + fail (printf "codecTraceForward (%s) unexpected key (%d, %d)" (show stok) key len) diff --git a/trace-forward/src/Trace/Forward/Protocol/Forwarder.hs b/trace-forward/src/Trace/Forward/Protocol/Forwarder.hs new file mode 100644 index 00000000000..aa31a824b7b --- /dev/null +++ b/trace-forward/src/Trace/Forward/Protocol/Forwarder.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Trace.Forward.Protocol.Forwarder + ( TraceForwarder (..) + , traceForwarderPeer + ) where + +import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), + PeerRole (..)) + +import Trace.Forward.Protocol.Type + +data TraceForwarder lo m a = TraceForwarder + { -- | The acceptor sent us a request for node's basic info. + recvMsgNodeInfoRequest + :: m (NodeInfo, TraceForwarder lo m a) + + -- | The acceptor sent us a request for new 'TraceObject's. + , recvMsgRequest + :: forall blocking. TokBlockingStyle blocking + -> Request + -> m (BlockingReplyList blocking lo, TraceForwarder lo m a) + + -- | The acceptor terminated. Here we have a pure return value, but we + -- could have done another action in 'm' if we wanted to. + , recvMsgDone :: m a + } + +-- | Interpret a particular action sequence into the server side of the protocol. +-- +traceForwarderPeer + :: Monad m + => TraceForwarder lo m a + -> Peer (TraceForward lo) 'AsServer 'StIdle m a +traceForwarderPeer TraceForwarder{..} = + -- In the 'StIdle' state the forwarder is awaiting a request message + -- from the acceptor. + Await (ClientAgency TokIdle) $ \case + -- The acceptor sent us a request for node's basic info, so now we're + -- in the 'StBusy' state which means it's the forwarder's turn to send + -- a reply. + MsgNodeInfoRequest -> Effect $ do + (reply, next) <- recvMsgNodeInfoRequest + return $ Yield (ServerAgency TokNodeInfoBusy) + (MsgNodeInfoReply reply) + (traceForwarderPeer next) + + -- The acceptor sent us a request for new 'TraceObject's, so now we're + -- in the 'StBusy' state which means it's the forwarder's turn to send + -- a reply. + MsgRequest blocking request -> Effect $ do + (reply, next) <- recvMsgRequest blocking request + return $ Yield (ServerAgency (TokBusy blocking)) + (MsgReply reply) + (traceForwarderPeer 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 diff --git a/trace-forward/src/Trace/Forward/Protocol/Limits.hs b/trace-forward/src/Trace/Forward/Protocol/Limits.hs new file mode 100644 index 00000000000..01fd8e86805 --- /dev/null +++ b/trace-forward/src/Trace/Forward/Protocol/Limits.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +module Trace.Forward.Protocol.Limits + ( byteLimitsTraceForward + , timeLimitsTraceForward + ) where + +import Data.Time.Clock (DiffTime) + +import Network.TypedProtocol.Core (PeerHasAgency (..), PeerRole (..)) +import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..), + ProtocolTimeLimits (..)) +import Ouroboros.Network.Protocol.Limits (largeByteLimit, shortWait, + smallByteLimit, waitForever) + +import Trace.Forward.Protocol.Type + +-- | Byte Limits. +byteLimitsTraceForward + :: forall bytes lo. + (bytes -> Word) + -> ProtocolSizeLimits (TraceForward lo) bytes +byteLimitsTraceForward = ProtocolSizeLimits stateToLimit + where + stateToLimit + :: forall lo + (pr :: PeerRole) + (st :: TraceForward lo). + PeerHasAgency pr st + -> Word + stateToLimit (ServerAgency TokNodeInfoBusy) = largeByteLimit + stateToLimit (ServerAgency (TokBusy TokBlocking)) = largeByteLimit + stateToLimit (ServerAgency (TokBusy TokNonBlocking)) = largeByteLimit + stateToLimit (ClientAgency TokIdle) = smallByteLimit + +-- | Time Limits. +timeLimitsTraceForward + :: forall lo. ProtocolTimeLimits (TraceForward lo) +timeLimitsTraceForward = ProtocolTimeLimits stateToLimit + where + stateToLimit + :: forall lo + (pr :: PeerRole) + (st :: TraceForward lo). + PeerHasAgency pr st + -> Maybe DiffTime + stateToLimit (ServerAgency TokNodeInfoBusy) = shortWait + stateToLimit (ServerAgency (TokBusy TokBlocking)) = waitForever + stateToLimit (ServerAgency (TokBusy TokNonBlocking)) = shortWait + stateToLimit (ClientAgency TokIdle) = waitForever diff --git a/trace-forward/src/Trace/Forward/Protocol/Type.hs b/trace-forward/src/Trace/Forward/Protocol/Type.hs new file mode 100644 index 00000000000..9d730c5c8d9 --- /dev/null +++ b/trace-forward/src/Trace/Forward/Protocol/Type.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The type of the trace forwarding/accepting protocol. +-- +-- Since we are using a typed protocol framework this is in some sense /the/ +-- definition of the protocol: what is allowed and what is not allowed. + +module Trace.Forward.Protocol.Type + ( TraceForward (..) + , TokBlockingStyle (..) + , Message (..) + , ClientHasAgency (..) + , ServerHasAgency (..) + , NobodyHasAgency (..) + , Request (..) + , BlockingReplyList (..) + , NodeInfo + , NodeInfoStore + ) where + +import Codec.Serialise (Serialise (..)) +import Data.IORef (IORef) +import Data.List.NonEmpty (NonEmpty) +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import Data.Word (Word16) +import GHC.Generics (Generic) +import Network.TypedProtocol.Core (Protocol (..)) +import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) + +-- | A kind to identify our protocol, and the types of the states in the state +-- transition diagram of the protocol. +-- +-- IMPORTANT NOTE: the following terminology is used: +-- +-- 1. From the protocol's point of view, two peers talk to each other: +-- the forwarder and the acceptor. +-- 2. The forwarder is an application that collects 'TraceObject's and sends +-- them to the acceptor by request. +-- 3. The acceptor is an application that receives 'TraceObject's from the +-- forwarder. +-- 4. You can think of the acceptor as a client, and the forwarder as a server. +-- After the connection is established, the acceptor asks for 'TraceObject's, +-- the forwarder replies to it. + +-- | The request for N 'TraceObject's. +-- The acceptor will send this request to the forwarder. +newtype Request = GetTraceObjects Word16 + deriving (Eq, Generic, Show) + +instance ShowProxy Request +instance Serialise Request + +data TraceForward lo where + + -- | Both acceptor and forwarder are in idle state. The acceptor can send a + -- request for node's basic info OR for a list of 'TraceObject's, the forwarder + -- is waiting for some request. + -- + -- Node's basic info is an important information about the node, such as + -- its protocol, version, start time, etc. It is assuming that the node + -- must provide this information. + StIdle :: TraceForward lo + + -- | The acceptor has sent a request for node's basic info. The acceptor is + -- now waiting for a reply, and the forwarder is busy getting ready to send a + -- reply with node's basic info. + StNodeInfoBusy :: TraceForward lo + + -- | The acceptor has sent a next request for 'TraceObject's. The acceptor is + -- now waiting for a reply, and the forwarder is busy getting ready to send a + -- reply with new list of 'TraceObject's. + -- + -- There are two sub-states for this, for blocking and non-blocking cases. + StBusy :: StBlockingStyle -> TraceForward lo + + -- | Both the acceptor and forwarder are in the terminal state. They're done. + StDone :: TraceForward lo + +instance (ShowProxy lo) + => ShowProxy (TraceForward lo) where + showProxy _ = concat + [ "TraceForward (" + , showProxy (Proxy :: Proxy lo) + , ")" + ] + +data StBlockingStyle where + -- | In this sub-state the reply need not be prompt. There is no timeout. + StBlocking :: StBlockingStyle + -- | In this sub-state the peer must reply. There is a timeout. + StNonBlocking :: StBlockingStyle + +-- | The value level equivalent of 'StBlockingStyle'. +-- +-- This is also used in 'MsgRequest' where it is interpreted (and can be encoded) +-- as a 'Bool' with 'True' for blocking, and 'False' for non-blocking. +data TokBlockingStyle (k :: StBlockingStyle) where + TokBlocking :: TokBlockingStyle 'StBlocking + TokNonBlocking :: TokBlockingStyle 'StNonBlocking + +deriving instance Eq (TokBlockingStyle b) +deriving instance Show (TokBlockingStyle b) + +-- | We have requests for lists of things. In the blocking case the +-- corresponding reply must be non-empty, whereas in the non-blocking case +-- an empty reply is fine. +-- +data BlockingReplyList (blocking :: StBlockingStyle) lo where + BlockingReply :: NonEmpty lo -> BlockingReplyList 'StBlocking lo + NonBlockingReply :: [lo] -> BlockingReplyList 'StNonBlocking lo + +deriving instance Eq lo => Eq (BlockingReplyList blocking lo) +deriving instance Show lo => Show (BlockingReplyList blocking lo) + +-- | The node provides its basic information, such as +-- protocol, version, start time, unique name, etc. +type NodeInfo = [(Text, Text)] + +-- | The store for 'NodeInfo', it will be used on the acceptor's side +-- to store received node's info. +type NodeInfoStore = IORef NodeInfo + +instance Protocol (TraceForward lo) where + + -- | The messages in the trace forwarding/accepting protocol. + -- + data Message (TraceForward lo) from to where + + -- | Request the node's basic info from the forwarder. + -- State: Idle -> NodeInfoBusy. + MsgNodeInfoRequest + :: Message (TraceForward lo) 'StIdle 'StNodeInfoBusy + + -- | Reply with the node's basic info, as a list of text pairs. + -- State: NodeInfoBusy -> Idle. + MsgNodeInfoReply + :: NodeInfo + -> Message (TraceForward lo) 'StNodeInfoBusy 'StIdle + + -- | Request the list of 'TraceObject's from the forwarder. + -- State: Idle -> Busy. + -- + -- With 'TokBlocking' this is a a blocking operation: the reply will + -- always have at least one 'TraceObject', and it does not expect a prompt + -- reply: there is no timeout. This covers the case when there + -- is nothing else to do but wait. + -- + -- With 'TokNonBlocking' this is a non-blocking operation: the reply + -- may be an empty list and this does expect a prompt reply. + MsgRequest + :: TokBlockingStyle blocking + -> Request + -> Message (TraceForward lo) 'StIdle ('StBusy blocking) + + -- | Reply with a list of 'TraceObject's for the acceptor. + -- State: Busy -> Idle. + MsgReply + :: BlockingReplyList blocking lo + -> Message (TraceForward lo) ('StBusy blocking) 'StIdle + + -- | Terminating message. State: Idle -> Done. + MsgDone + :: Message (TraceForward lo) 'StIdle 'StDone + + -- | This is an explanation of our states, in terms of which party has agency + -- in each state. + -- + -- 1. When both peers are in Idle state, the acceptor can send a message + -- to the forwarder (request for new 'TraceObject's), + -- 2. When both peers are in Busy state, the forwarder is expected to send + -- a reply to the acceptor (list of new 'TraceObject's). + -- + -- 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 + TokNodeInfoBusy :: ServerHasAgency 'StNodeInfoBusy + TokBusy :: TokBlockingStyle blocking -> ServerHasAgency ('StBusy blocking) + + 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 {} + +instance (Show lo) + => Show (Message (TraceForward lo) from to) where + show MsgNodeInfoRequest{} = "MsgNodeInfoRequest" + show MsgNodeInfoReply{} = "MsgNodeInfoReply" + show MsgRequest{} = "MsgRequest" + show MsgReply{} = "MsgReply" + show MsgDone{} = "MsgDone" + +instance Show (ClientHasAgency (st :: TraceForward lo)) where + show TokIdle = "TokIdle" + +instance Show (ServerHasAgency (st :: TraceForward lo)) where + show TokNodeInfoBusy = "TokNodeInfoBusy" + show TokBusy{} = "TokBusy" diff --git a/trace-forward/src/Trace/Forward/Queue.hs b/trace-forward/src/Trace/Forward/Queue.hs new file mode 100644 index 00000000000..131ba09af67 --- /dev/null +++ b/trace-forward/src/Trace/Forward/Queue.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Trace.Forward.Queue + ( readItems + , writeTraceObjectsToQueue + , logObjectsFromReply + ) where + +import Control.Concurrent.STM (STM, atomically, retry) +import Control.Concurrent.STM.TBQueue (TBQueue, isFullTBQueue, + tryReadTBQueue, writeTBQueue) +import Control.Monad (forM_) +import Control.Monad.Extra (unlessM) +import qualified Data.List.NonEmpty as NE +import Data.Word (Word16) + +import Trace.Forward.Configuration (ForwarderConfiguration (..)) +import qualified Trace.Forward.Protocol.Forwarder as Forwarder +import Trace.Forward.Protocol.Type + +readItems + :: ForwarderConfiguration lo -- ^ The forwarder configuration. + -> TBQueue lo -- ^ The queue we will read 'TraceObject's from. + -> Forwarder.TraceForwarder lo IO () +readItems config@ForwarderConfiguration{..} loQueue = + Forwarder.TraceForwarder + { Forwarder.recvMsgNodeInfoRequest = do + reply <- nodeBasicInfo + return (reply, readItems config loQueue) + , Forwarder.recvMsgRequest = \blocking request@(GetTraceObjects n) -> do + actionOnRequest request + replyList <- + case blocking of + TokBlocking -> do + objs <- atomically $ getNTraceObjects n loQueue >>= \case + [] -> retry -- No 'TraceObject's yet, just wait... + (x:xs) -> return $ x NE.:| xs + return $ BlockingReply objs + TokNonBlocking -> do + objs <- atomically $ getNTraceObjects n loQueue + return $ NonBlockingReply objs + return (replyList, readItems config loQueue) + , Forwarder.recvMsgDone = return () + } + +-- | Returns at most N 'TraceObject's from the queue. +getNTraceObjects + :: Word16 + -> TBQueue lo + -> STM [lo] +getNTraceObjects 0 _ = return [] +getNTraceObjects n loQueue = + tryReadTBQueue loQueue >>= \case + Just lo' -> (:) lo' <$> getNTraceObjects (n - 1) loQueue + Nothing -> getNTraceObjects 0 loQueue + +writeTraceObjectsToQueue + :: BlockingReplyList blocking lo -- ^ The reply with list of 'TraceObject's. + -> TBQueue lo -- ^ The queue we want to write in. + -> IO () +writeTraceObjectsToQueue reply loQueue = + writeListToQueue $ logObjectsFromReply reply + where + writeListToQueue [] = return () + writeListToQueue list = atomically $ + forM_ list $ \lo' -> + unlessM (isFullTBQueue loQueue) $ + writeTBQueue loQueue lo' + +logObjectsFromReply :: BlockingReplyList blocking lo -> [lo] +logObjectsFromReply (BlockingReply neList) = NE.toList neList +logObjectsFromReply (NonBlockingReply list) = list diff --git a/trace-forward/test/Main.hs b/trace-forward/test/Main.hs new file mode 100644 index 00000000000..72e2e6ef9e5 --- /dev/null +++ b/trace-forward/test/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import Test.Tasty + +import qualified Test.Trace.Forward.Protocol.Tests as Protocol +import qualified Test.Trace.Forward.Demo.Tests as Demo + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "trace-forward" + [ Protocol.tests + , Demo.tests + ] diff --git a/trace-forward/test/Test/Trace/Forward/Demo/Configs.hs b/trace-forward/test/Test/Trace/Forward/Demo/Configs.hs new file mode 100644 index 00000000000..1561d5a1a2e --- /dev/null +++ b/trace-forward/test/Test/Trace/Forward/Demo/Configs.hs @@ -0,0 +1,36 @@ +module Test.Trace.Forward.Demo.Configs + ( mkAcceptorConfig + , mkForwarderConfig + ) where + +import Control.Tracer (nullTracer) +import Data.IORef (IORef) + +import Trace.Forward.Configuration +import Trace.Forward.Protocol.Type + +import Test.Trace.Forward.Protocol.TraceItem + +mkAcceptorConfig + :: HowToConnect + -> IORef Bool + -> AcceptorConfiguration TraceItem +mkAcceptorConfig ep weAreDone = AcceptorConfiguration + { acceptorTracer = nullTracer + , forwarderEndpoint = ep + , whatToRequest = GetTraceObjects 10 + , actionOnReply = const $ pure () + , shouldWeStop = weAreDone + , actionOnDone = putStrLn "Acceptor: we are done!" + } + +mkForwarderConfig + :: HowToConnect + -> IO NodeInfo + -> ForwarderConfiguration TraceItem +mkForwarderConfig ep getNI = ForwarderConfiguration + { forwarderTracer = nullTracer + , acceptorEndpoint = ep + , nodeBasicInfo = getNI + , actionOnRequest = const $ pure () + } diff --git a/trace-forward/test/Test/Trace/Forward/Demo/Tests.hs b/trace-forward/test/Test/Trace/Forward/Demo/Tests.hs new file mode 100644 index 00000000000..932a6a40d06 --- /dev/null +++ b/trace-forward/test/Test/Trace/Forward/Demo/Tests.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Trace.Forward.Demo.Tests + ( tests + ) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, + tryReadTBQueue, writeTBQueue) +import Control.Monad (void) +import Data.Functor ((<&>)) +import Data.IORef (atomicModifyIORef', newIORef) +import System.Directory (getTemporaryDirectory) +#if defined(mingw32_HOST_OS) +import System.FilePath ((), dropDrive) +import qualified Data.Text as T +#else +import System.FilePath (()) +#endif +import Test.Tasty +import Test.Tasty.QuickCheck + +import Trace.Forward.Acceptor +import Trace.Forward.Configuration +import Trace.Forward.Forwarder +import Trace.Forward.Protocol.Type + +import Test.Trace.Forward.Demo.Configs +import Test.Trace.Forward.Protocol.Codec () +import Test.Trace.Forward.Protocol.TraceItem + +data Endpoint = Remote | Local + +tests :: TestTree +tests = localOption (QuickCheckTests 1) $ testGroup "Trace.Forward.Demo" + [ testProperty "RemoteSocket" $ prop_RemoteSocket 100 Remote + , testProperty "LocalPipe" $ prop_RemoteSocket 100 Local + ] + +prop_RemoteSocket :: Int -> Endpoint -> Property +prop_RemoteSocket n ep' = ioProperty $ do + ep <- case ep' of + Remote -> return $ RemoteSocket "127.0.0.1" 3030 + Local -> LocalPipe <$> mkLocalPipePath + + forwarderQueue <- newTBQueueIO $ fromIntegral n + acceptorQueue <- newTBQueueIO $ fromIntegral n + nodeInfoStore <- newIORef [] + weAreDone <- newIORef False + -- Run the forwarder. It will take 'TraceItem's from 'forwarderQueue'. + void . forkIO $ runTraceForwarder (mkForwarderConfig ep (return nodeInfo)) + forwarderQueue + threadDelay 3000000 + -- Run the acceptor. It will ask 'TraceItem's from the forwarder + -- and store them in 'acceptorQueue'. + void . forkIO $ runTraceAcceptor (mkAcceptorConfig ep weAreDone) + acceptorQueue + nodeInfoStore + -- Generate 'n' arbitrary 'TraceItem's and write them in 'forwarderQueue'. + itemsToForward <- generateNTraceItems n + atomically $ mapM_ (writeTBQueue forwarderQueue) itemsToForward + -- Just wait. We assume that, during this delay, the acceptor will ask + -- and receive all 'TraceItem's from the forwarder. + threadDelay 10000000 + -- Stop the acceptor, the forwarder will be stopped as well. + atomicModifyIORef' weAreDone $ const (True, ()) + threadDelay 1000000 + -- Read all 'TraceItem's from 'acceptorQueue' and compare them with 'itemsToForward'. + acceptedItems <- atomically $ getNTraceItems n acceptorQueue + return $ itemsToForward === acceptedItems + +generateNTraceItems :: Int -> IO [TraceItem] +generateNTraceItems n = generate (infiniteListOf arbitrary) <&> take n + +getNTraceItems :: Int -> TBQueue TraceItem -> STM [TraceItem] +getNTraceItems 0 _ = return [] +getNTraceItems n queue = + tryReadTBQueue queue >>= \case + Just ti -> (:) ti <$> getNTraceItems (n - 1) queue + Nothing -> getNTraceItems 0 queue + +nodeInfo :: NodeInfo +nodeInfo = [ ("NodeName" , "core-3") + , ("NodeProtocol" , "Shelley") + , ("NodeRelease" , "1.28.1") + , ("NodeCommit" , "cffa06c") + , ("NodeStartTime", "2021-08-25T13:01:10") + ] + +mkLocalPipePath :: IO FilePath +mkLocalPipePath = do + tmpDir <- getTemporaryDirectory +#if defined(mingw32_HOST_OS) + return $ "\\\\.\\pipe\\" <> (T.unpack . T.replace "\\" "-" . T.pack) (dropDrive tmpDir) + <> "_" "trace-forward-test" +#else + return $ tmpDir "trace-forward-test.sock" +#endif diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/Codec.hs b/trace-forward/test/Test/Trace/Forward/Protocol/Codec.hs new file mode 100644 index 00000000000..f224bf16030 --- /dev/null +++ b/trace-forward/test/Test/Trace/Forward/Protocol/Codec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Trace.Forward.Protocol.Codec () where + +import Test.QuickCheck + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Codec + +import Trace.Forward.Protocol.Type + +import Test.Trace.Forward.Protocol.TraceItem + +instance Arbitrary Request where + arbitrary = GetTraceObjects <$> arbitrary + +ni1, ni2 :: NodeInfo +ni1 = [ ("NodeName" , "core-1") + , ("NodeProtocol" , "Shelley") + , ("NodeRelease" , "1.28.0") + , ("NodeCommit" , "cffa06c") + , ("NodeStartTime", "2021-07-24T12:00:10") + ] +ni2 = [ ("NodeName" , "relay-1") + , ("NodeProtocol" , "Shelley") + , ("NodeRelease" , "1.27.0") + , ("NodeCommit" , "88d86ff") + , ("NodeStartTime", "2021-07-24T12:00:59") + ] + +instance Arbitrary (AnyMessageAndAgency (TraceForward TraceItem)) where + arbitrary = oneof + [ pure $ AnyMessageAndAgency (ClientAgency TokIdle) MsgNodeInfoRequest + , AnyMessageAndAgency (ClientAgency TokIdle) . MsgRequest TokBlocking <$> arbitrary + , AnyMessageAndAgency (ClientAgency TokIdle) . MsgRequest TokNonBlocking <$> arbitrary + , AnyMessageAndAgency (ServerAgency TokNodeInfoBusy) . MsgNodeInfoReply <$> oneof [pure ni1, pure ni2] + , AnyMessageAndAgency (ServerAgency (TokBusy TokBlocking)) . MsgReply . BlockingReply <$> arbitrary + , AnyMessageAndAgency (ServerAgency (TokBusy TokNonBlocking)) . MsgReply . NonBlockingReply <$> arbitrary + , pure $ AnyMessageAndAgency (ClientAgency TokIdle) MsgDone + ] + +instance Eq (AnyMessage (TraceForward TraceItem)) where + AnyMessage MsgNodeInfoRequest == AnyMessage MsgNodeInfoRequest = True + AnyMessage (MsgNodeInfoReply r1) == AnyMessage (MsgNodeInfoReply r2) = r1 == r2 + AnyMessage (MsgRequest TokBlocking r1) == AnyMessage (MsgRequest TokBlocking r2) = r1 == r2 + AnyMessage (MsgRequest TokNonBlocking r1) == AnyMessage (MsgRequest TokNonBlocking r2) = r1 == r2 + AnyMessage (MsgReply (BlockingReply r1)) == AnyMessage (MsgReply (BlockingReply r2)) = r1 == r2 + AnyMessage (MsgReply (NonBlockingReply r1)) == AnyMessage (MsgReply (NonBlockingReply r2)) = r1 == r2 + AnyMessage MsgDone == AnyMessage MsgDone = True + _ == _ = False diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/Tests.hs b/trace-forward/test/Test/Trace/Forward/Protocol/Tests.hs new file mode 100644 index 00000000000..9606805fd5d --- /dev/null +++ b/trace-forward/test/Test/Trace/Forward/Protocol/Tests.hs @@ -0,0 +1,29 @@ +module Test.Trace.Forward.Protocol.Tests + ( tests + ) where + +import qualified Codec.Serialise as CBOR +import Control.Monad.ST (runST) +import Test.Tasty +import Test.Tasty.QuickCheck + +import Network.TypedProtocol.Codec + +import Trace.Forward.Protocol.Codec +import Trace.Forward.Protocol.Type + +import Test.Trace.Forward.Protocol.Codec () +import Test.Trace.Forward.Protocol.TraceItem + +tests :: TestTree +tests = testGroup "Trace.Forward.Protocol" + [ testProperty "codec" prop_codec_TraceForward + ] + +prop_codec_TraceForward :: AnyMessageAndAgency (TraceForward TraceItem) -> Bool +prop_codec_TraceForward msg = + runST $ prop_codecM + (codecTraceForward CBOR.encode CBOR.decode + CBOR.encode CBOR.decode + CBOR.encode CBOR.decode) + msg diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/TraceItem.hs b/trace-forward/test/Test/Trace/Forward/Protocol/TraceItem.hs new file mode 100644 index 00000000000..cab48a48f99 --- /dev/null +++ b/trace-forward/test/Test/Trace/Forward/Protocol/TraceItem.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Trace.Forward.Protocol.TraceItem + ( TraceItem (..) + ) where + +import Codec.Serialise (Serialise (..)) +import Data.List.NonEmpty (NonEmpty, fromList) +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import GHC.Generics +import Test.QuickCheck + +import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) + +data Severity = Debug | Info | Notice + deriving (Show, Eq, Ord, Enum, Generic) + +instance Arbitrary Severity where + arbitrary = oneof + [ pure Debug + , pure Info + , pure Notice + ] + +instance Serialise Severity + +data DetailLevel = Brief | Regular + deriving (Show, Eq, Ord, Enum, Generic) + +instance Arbitrary DetailLevel where + arbitrary = oneof + [ pure Brief + , pure Regular + ] + +instance Serialise DetailLevel + +instance Arbitrary UTCTime where + arbitrary = oneof + [ pure $ UTCTime (fromGregorian 2021 7 24) ((22 * 3600) + (15 * 60) + 1) + , pure $ UTCTime (fromGregorian 2021 7 25) ((12 * 3600) + (4 * 60) + 37) + , pure $ UTCTime (fromGregorian 2021 7 26) ((23 * 3600) + (19 * 60) + 56) + ] + +-- | Trace items that will be used during testing. +-- This type is similar to the real 'TraceObject' that will be used by the node. +data TraceItem = TraceItem + { tiHuman :: Maybe String + , tiNamespace :: [String] + , tiSeverity :: Severity + , tiDetails :: DetailLevel + , tiTimestamp :: UTCTime + , tiHostname :: String + , tiThreadId :: Text + } deriving (Eq, Ord, Show, Generic) + +instance Serialise TraceItem +instance ShowProxy TraceItem + +instance Arbitrary TraceItem where + arbitrary = TraceItem + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> oneof [pure "1", pure "10"] + +instance Arbitrary (NonEmpty TraceItem) where + arbitrary = fromList <$> listOf1 arbitrary diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal new file mode 100644 index 00000000000..edb8f84137c --- /dev/null +++ b/trace-forward/trace-forward.cabal @@ -0,0 +1,90 @@ +cabal-version: 2.4 +name: trace-forward +version: 0.1.0 +synopsis: See README for more info +description: See README for more info +license: Apache-2.0 +license-file: LICENSE +copyright: 2021 Input Output (Hong Kong) Ltd. +author: IOHK +maintainer: operations@iohk.io +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md + +common base { build-depends: base >= 4.14 && < 4.15 } + +common project-config + default-language: Haskell2010 + + ghc-options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wno-unticked-promoted-constructors + -Wno-orphans + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + +library + import: base, project-config + hs-source-dirs: src + + exposed-modules: Trace.Forward.Acceptor + Trace.Forward.Configuration + Trace.Forward.Forwarder + Trace.Forward.Queue + + Trace.Forward.Network.Acceptor + Trace.Forward.Network.Forwarder + + Trace.Forward.Protocol.Acceptor + Trace.Forward.Protocol.Codec + Trace.Forward.Protocol.Forwarder + Trace.Forward.Protocol.Limits + Trace.Forward.Protocol.Type + + build-depends: async + , bytestring + , cborg + , contra-tracer + , extra + , io-classes + , network + , ouroboros-network-framework + , serialise + , stm + , text + , time + , typed-protocols + +test-suite test + import: base, project-config + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + + other-modules: Test.Trace.Forward.Protocol.Codec + Test.Trace.Forward.Protocol.Tests + Test.Trace.Forward.Protocol.TraceItem + Test.Trace.Forward.Demo.Configs + Test.Trace.Forward.Demo.Tests + + build-depends: contra-tracer + , directory + , filepath + , ouroboros-network-framework + , trace-forward + , QuickCheck + , serialise + , stm + , tasty + , tasty-quickcheck + , typed-protocols + , typed-protocols-examples + , text + , time + + ghc-options: -rtsopts + -threaded