diff --git a/distributed-process-extras.cabal b/distributed-process-extras.cabal --- a/distributed-process-extras.cabal +++ b/distributed-process-extras.cabal @@ -1,5 +1,5 @@ name: distributed-process-extras -version: 0.1.0 +version: 0.1.1 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -29,6 +29,7 @@ library build-depends: base >= 4.4 && < 5, + data-accessor >= 0.2.2.3, distributed-process >= 0.5.2 && < 0.6, binary >= 0.6.3.0 && < 0.8, deepseq >= 1.3.0.1 && < 1.4, @@ -51,6 +52,7 @@ exposed-modules: Control.Distributed.Process.Extras, Control.Distributed.Process.Extras.Call, + Control.Distributed.Process.Extras.SystemLog, Control.Distributed.Process.Extras.Time, Control.Distributed.Process.Extras.Timer, Control.Distributed.Process.Extras.UnsafePrimitives, @@ -85,6 +87,34 @@ main-is: TestQueues.hs cpp-options: -DTESTING +test-suite PrimitivesTests + type: exitcode-stdio-1.0 + x-uses-tf: true + build-depends: + base >= 4.4 && < 5, + ansi-terminal >= 0.5 && < 0.6, + distributed-process >= 0.5.2 && < 0.6, + distributed-process-extras, + distributed-process-tests >= 0.4.1 && < 0.5, + network-transport >= 0.4 && < 0.5, + mtl, + containers >= 0.4 && < 0.6, + network-transport-tcp >= 0.4 && < 0.5, + binary >= 0.6.3.0 && < 0.8, + deepseq >= 1.3.0.1 && < 1.4, + network >= 2.3 && < 2.6, + HUnit >= 1.2 && < 2, + stm >= 2.3 && < 2.5, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + rematch >= 0.2.0.0, + transformers + hs-source-dirs: + tests + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + extensions: CPP + main-is: TestPrimitives.hs + test-suite TimerTests type: exitcode-stdio-1.0 x-uses-tf: true @@ -110,3 +140,39 @@ extensions: CPP main-is: TestTimer.hs cpp-options: -DTESTING + +test-suite LoggerTests + type: exitcode-stdio-1.0 +-- x-uses-tf: true + build-depends: + base >= 4.4 && < 5, + ansi-terminal >= 0.5 && < 0.6, + containers, + hashable, + unordered-containers >= 0.2.3.0 && < 0.3, + distributed-process >= 0.5.2 && < 0.6, + distributed-process-extras, + distributed-process-tests >= 0.4.1 && < 0.5, + distributed-static, + bytestring, + data-accessor, + fingertree < 0.2, + network-transport >= 0.4 && < 0.5, + deepseq >= 1.3.0.1 && < 1.4, + mtl, + network-transport-tcp >= 0.4 && < 0.5, + binary >= 0.6.3.0 && < 0.8, + network >= 2.3 && < 2.6, + HUnit >= 1.2 && < 2, + stm >= 2.3 && < 2.5, + time > 1.4 && < 1.5, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + transformers, + rematch >= 0.2.0.0, + ghc-prim + hs-source-dirs: + tests + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog + extensions: CPP + main-is: TestLog.hs diff --git a/src/Control/Distributed/Process/Extras/SystemLog.hs b/src/Control/Distributed/Process/Extras/SystemLog.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Extras/SystemLog.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Extras.SystemLog +-- Copyright : (c) Tim Watson 2013 - 2014 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides a general purpose logging facility, implemented as a +-- distributed-process /Management Agent/. To start the logging agent on a +-- running node, evaluate 'systemLog' with the relevant expressions to handle +-- logging textual messages, a cleanup operation (if required), initial log +-- level and a formatting expression. +-- +-- We export a working example in the form of 'systemLogFile', which logs +-- to a text file using buffered I/O. Its implementation is very simple, and +-- should serve as a demonstration of how to use the API: +-- +-- > systemLogFile :: FilePath -> LogLevel -> LogFormat -> Process ProcessId +-- > systemLogFile path lvl fmt = do +-- > h <- liftIO $ openFile path AppendMode +-- > liftIO $ hSetBuffering h LineBuffering +-- > systemLog (liftIO . hPutStrLn h) (liftIO (hClose h)) lvl fmt +-- +----------------------------------------------------------------------------- + +-- TODO - REWRITE THIS WITHOUT USING THE MX API, SINCE THAT's POINTLESS>>>>>>>. + +module Control.Distributed.Process.Extras.SystemLog + ( -- * Types exposed by this module + LogLevel(..) + , LogFormat + , LogClient + , LogChan + , LogText(..) + , ToLog(..) + , Logger(..) + -- * Mx Agent Configuration / Startup + , mxLogId + , systemLog + , client + , logChannel + , addFormatter + -- * systemLogFile + , systemLogFile + -- * Logging Messages + , report + , debug + , info + , notice + , warning + , error + , critical + , alert + , emergency + , sendLog + ) where + +import Control.DeepSeq (NFData) +import Control.Distributed.Process +import Control.Distributed.Process.Management + ( MxEvent(MxConnected, MxDisconnected, MxLog, MxUser) + , MxAgentId(..) + , mxAgentWithFinalize + , mxSink + , mxReady + , mxReceive + , liftMX + , mxGetLocal + , mxSetLocal + , mxUpdateLocal + , mxNotify + ) +import Control.Distributed.Process.Extras + ( Resolvable(..) + , Routable(..) + ) +import Control.Distributed.Process.Serializable +import Control.Exception (SomeException) +import Data.Accessor + ( Accessor + , accessor + , (^:) + , (^=) + , (^.) + ) +import Data.Binary +import Data.Typeable (Typeable) +import GHC.Generics + +#if ! MIN_VERSION_base(4,6,0) +import Prelude hiding (catch, error, Read) +#else +import Prelude hiding (error, Read) +#endif + +import System.IO + ( IOMode(AppendMode) + , BufferMode(..) + , openFile + , hClose + , hPutStrLn + , hSetBuffering + ) +import Text.Read (Read) + +data LogLevel = + Debug + | Info + | Notice + | Warning + | Error + | Critical + | Alert + | Emergency + deriving (Typeable, Generic, Eq, + Read, Show, Ord, Enum) +instance Binary LogLevel where + +data SetLevel = SetLevel !LogLevel + deriving (Typeable, Generic) +instance Binary SetLevel where +instance NFData SetLevel where + +data AddFormatter = AddFormatter !(Closure (Message -> Process (Maybe String))) + deriving (Typeable, Generic) +instance Binary AddFormatter where +instance NFData AddFormatter where + +data LogState = + LogState { output :: !(String -> Process ()) + , cleanup :: !(Process ()) + , _level :: !LogLevel + , _format :: !(String -> Process String) + , _formatters :: ![Message -> Process (Maybe String)] + } + +data LogMessage = + LogMessage !String !LogLevel + | LogData !Message !LogLevel + deriving (Typeable, Generic, Show) +instance Binary LogMessage where +instance NFData LogMessage where + +type LogFormat = String -> Process String + +type LogChan = () +instance Routable LogChan where + sendTo _ = mxNotify + unsafeSendTo _ = mxNotify + +data LogText = LogText { txt :: !String } + +newtype LogClient = LogClient { agent :: ProcessId } +instance Resolvable LogClient where + resolve = return . Just . agent + +class ToLog m where + toLog :: m -> Process (LogLevel -> LogMessage) + +instance ToLog LogText where + toLog = return . LogMessage . txt + +instance (Serializable a) => ToLog a where + toLog = return . LogData . unsafeWrapMessage + +instance ToLog Message where + toLog = return . LogData + +class Logger a where + logMessage :: a -> LogMessage -> Process () + +instance Logger LogClient where + logMessage = sendTo + +instance Logger LogChan where + logMessage _ = mxNotify + +logProcessName :: String +logProcessName = "service.systemlog" + +mxLogId :: MxAgentId +mxLogId = MxAgentId logProcessName + +logChannel :: LogChan +logChannel = () + +report :: (Logger l) + => (l -> LogText -> Process ()) + -> l + -> String + -> Process () +report f l = f l . LogText + +client :: Process (Maybe LogClient) +client = resolve logProcessName >>= return . maybe Nothing (Just . LogClient) + +debug :: (Logger l, ToLog m) => l -> m -> Process () +debug l m = sendLog l m Debug + +info :: (Logger l, ToLog m) => l -> m -> Process () +info l m = sendLog l m Info + +notice :: (Logger l, ToLog m) => l -> m -> Process () +notice l m = sendLog l m Notice + +warning :: (Logger l, ToLog m) => l -> m -> Process () +warning l m = sendLog l m Warning + +error :: (Logger l, ToLog m) => l -> m -> Process () +error l m = sendLog l m Error + +critical :: (Logger l, ToLog m) => l -> m -> Process () +critical l m = sendLog l m Critical + +alert :: (Logger l, ToLog m) => l -> m -> Process () +alert l m = sendLog l m Alert + +emergency :: (Logger l, ToLog m) => l -> m -> Process () +emergency l m = sendLog l m Emergency + +sendLog :: (Logger l, ToLog m) => l -> m -> LogLevel -> Process () +sendLog a m lv = toLog m >>= \m' -> logMessage a $ m' lv + +addFormatter :: (Routable r) + => r + -> Closure (Message -> Process (Maybe String)) + -> Process () +addFormatter r clj = sendTo r $ AddFormatter clj + +-- | Start a system logger that writes to a file. +-- +-- This is a /very basic/ file logging facility, that uses /regular/ buffered +-- file I/O (i.e., @System.IO.hPutStrLn@ et al) under the covers. The handle +-- is closed appropriately if/when the logging process terminates. +-- +-- See @Control.Distributed.Process.Management.mxAgentWithFinalize@ for futher +-- details about management agents that use finalizers. +-- +systemLogFile :: FilePath -> LogLevel -> LogFormat -> Process ProcessId +systemLogFile path lvl fmt = do + h <- liftIO $ openFile path AppendMode + liftIO $ hSetBuffering h LineBuffering + systemLog (liftIO . hPutStrLn h) (liftIO (hClose h)) lvl fmt + +-- | Start a /system logger/ process as a management agent. +-- +systemLog :: (String -> Process ()) -- ^ This expression does the actual logging + -> (Process ()) -- ^ An expression used to clean up any residual state + -> LogLevel -- ^ The initial 'LogLevel' to use + -> LogFormat -- ^ An expression used to format logging messages/text + -> Process ProcessId +systemLog o c l f = go $ LogState o c l f defaultFormatters + where + go :: LogState -> Process ProcessId + go st = do + mxAgentWithFinalize mxLogId st [ + -- these are the messages we're /really/ interested in + (mxSink $ \(m :: LogMessage) -> do + case m of + (LogMessage msg lvl) -> do + mxGetLocal >>= outputMin lvl msg >> mxReceive + (LogData dat lvl) -> handleRawMsg dat lvl) + + -- complex messages rely on properly registered formatters + , (mxSink $ \(ev :: MxEvent) -> do + case ev of + (MxUser msg) -> handleRawMsg msg Debug + -- we treat trace/log events like regular log events at + -- a Debug level (only) + (MxLog str) -> mxGetLocal >>= outputMin Debug str >> mxReceive + _ -> handleEvent ev >> mxReceive) + + -- command message handling + , (mxSink $ \(SetLevel lvl) -> + mxGetLocal >>= mxSetLocal . (level ^= lvl) >> mxReceive) + , (mxSink $ \(AddFormatter f') -> do + fmt <- liftMX $ catch (unClosure f' >>= return . Just) + (\(_ :: SomeException) -> return Nothing) + case fmt of + Nothing -> mxReady + Just mf -> do + mxUpdateLocal (formatters ^: (mf:)) + mxReceive) + ] runCleanup + + runCleanup = liftMX . cleanup =<< mxGetLocal + + handleRawMsg dat' lvl' = do + st <- mxGetLocal + msg <- formatMsg dat' st + case msg of + Just str -> outputMin lvl' str st >> mxReceive + Nothing -> mxReceive -- we cannot format a Message, so we ignore it + + handleEvent (MxConnected _ ep) = do + mxGetLocal >>= outputMin Notice + ("Endpoint: " ++ (show ep) ++ " Disconnected") + handleEvent (MxDisconnected _ ep) = do + mxGetLocal >>= outputMin Notice + ("Endpoint " ++ (show ep) ++ " Connected") + handleEvent _ = return () + + formatMsg m st = let fms = st ^. formatters in formatMsg' m fms + + formatMsg' _ [] = return Nothing + formatMsg' m (f':fs) = do + res <- liftMX $ f' m + case res of + ok@(Just _) -> return ok + Nothing -> formatMsg' m fs + + outputMin minLvl msgData st = + case minLvl >= (st ^. level) of + True -> liftMX $ ((st ^. format) msgData >>= (output st)) + False -> return () + + defaultFormatters = [basicDataFormat] + +basicDataFormat :: Message -> Process (Maybe String) +basicDataFormat = unwrapMessage + +level :: Accessor LogState LogLevel +level = accessor _level (\l s -> s { _level = l }) + +format :: Accessor LogState LogFormat +format = accessor _format (\f s -> s { _format = f }) + +formatters :: Accessor LogState [Message -> Process (Maybe String)] +formatters = accessor _formatters (\n' st -> st { _formatters = n' }) + diff --git a/tests/TestLog.hs b/tests/TestLog.hs new file mode 100644 --- /dev/null +++ b/tests/TestLog.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +-- import Control.Exception (SomeException) +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, newEmptyMVar) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan +import Control.Distributed.Process hiding (monitor) +import Control.Distributed.Process.Closure (remotable, mkStaticClosure) +import Control.Distributed.Process.Node +import Control.Distributed.Process.Extras hiding (__remoteTable) +import qualified Control.Distributed.Process.Extras.SystemLog as Log (Logger, error) +import Control.Distributed.Process.Extras.SystemLog hiding (Logger, error) +import Control.Distributed.Process.Tests.Internal.Utils +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer +import Control.Monad (void) +import Data.List (delete) + +#if ! MIN_VERSION_base(4,6,0) +import Prelude hiding (catch, drop, Read) +#else +import Prelude hiding (drop, read, Read) +#endif + +import Test.Framework (Test, testGroup, defaultMain) +import Test.Framework.Providers.HUnit (testCase) +import Network.Transport.TCP +import qualified Network.Transport as NT + +import GHC.Read +import Text.ParserCombinators.ReadP as P +import Text.ParserCombinators.ReadPrec + +import qualified Network.Transport as NT + +logLevelFormatter :: Message -> Process (Maybe String) +logLevelFormatter m = handleMessage m showLevel + where + showLevel :: LogLevel -> Process String + showLevel = return . show + +$(remotable ['logLevelFormatter]) + +logFormat :: Closure (Message -> Process (Maybe String)) +logFormat = $(mkStaticClosure 'logLevelFormatter) + +testLoggingProcess :: Process (ProcessId, TChan String) +testLoggingProcess = do + chan <- liftIO $ newTChanIO + let cleanup = return () + let format = return + pid <- systemLog (writeLog chan) cleanup Debug format + addFormatter pid logFormat + sleep $ seconds 1 + return (pid, chan) + where + writeLog chan = liftIO . atomically . writeTChan chan + +testLogLevels :: (Log.Logger logger, ToLog tL) + => MVar () + -> TChan String + -> logger + -> LogLevel + -> LogLevel + -> (LogLevel -> tL) + -> TestResult Bool + -> Process () +testLogLevels lck chan logger from to fn result = do + void $ liftIO $ takeMVar lck + let lvls = enumFromTo from to + logIt logger fn lvls + testHarness lvls chan result + liftIO $ putMVar lck () + where + logIt _ _ [] = return () + logIt lc f (l:ls) = sendLog lc (f l) l >> logIt lc f ls + +testHarness :: [LogLevel] + -> TChan String + -> TestResult Bool + -> Process () +testHarness [] chan result = do + liftIO (atomically (isEmptyTChan chan)) >>= stash result +testHarness levels chan result = do + msg <- liftIO $ atomically $ readTChan chan + -- liftIO $ putStrLn $ "testHarness handling " ++ msg + let item = readEither msg + case item of + Right i -> testHarness (delete i levels) chan result + Left _ -> testHarness levels chan result + where + readEither :: String -> Either String LogLevel + readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + _ -> Left "read: ambiguous parse" + + read' = + do x <- readPrec + lift P.skipSpaces + return x + +tests :: NT.Transport -> IO [Test] +tests transport = do + let ch = logChannel + localNode <- newLocalNode transport $ __remoteTable initRemoteTable + lock <- newMVar () + ex <- newEmptyMVar + void $ forkProcess localNode $ do (_, chan) <- testLoggingProcess + liftIO $ putMVar ex chan + chan <- takeMVar ex + return [ + testGroup "Log Reports / LogText" + (map (mkTestCase lock chan ch simpleShowToLog localNode) (enumFromTo Debug Emergency)) + , testGroup "Logging Raw Messages" + (map (mkTestCase lock chan ch messageToLog localNode) (enumFromTo Debug Emergency)) + , testGroup "Custom Formatters" + (map (mkTestCase lock chan ch messageRaw localNode) (enumFromTo Debug Emergency)) + ] + where + mkTestCase lck chan ch' rdr ln lvl = do + let l = show lvl + testCase l (delayedAssertion ("Expected up to " ++ l) + ln True $ testLogLevels lck chan ch' Debug lvl rdr) + + simpleShowToLog = (LogText . show) + messageToLog = unsafeWrapMessage . show + messageRaw = unsafeWrapMessage + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals + "127.0.0.1" "10501" defaultTCPParameters + testData <- builder transport + defaultMain testData + +main :: IO () +main = testMain $ tests + diff --git a/tests/TestPrimitives.hs b/tests/TestPrimitives.hs new file mode 100644 --- /dev/null +++ b/tests/TestPrimitives.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import Control.Distributed.Process +import Control.Distributed.Process.Node +import Control.Distributed.Process.Serializable() + +import Control.Distributed.Process.Extras hiding (__remoteTable, monitor, send) +import qualified Control.Distributed.Process.Extras (__remoteTable) +import Control.Distributed.Process.Extras.Call +-- import Control.Distributed.Process.Extras.Service.Monitoring +import Control.Distributed.Process.Extras.Time +import Control.Monad (void) +import Control.Rematch hiding (match) +import qualified Network.Transport as NT (Transport) +import Network.Transport.TCP() +#if ! MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif + +import Test.HUnit (Assertion) +import Test.Framework (Test, testGroup, defaultMain) +import Test.Framework.Providers.HUnit (testCase) +import Network.Transport.TCP +import qualified Network.Transport as NT +import Control.Distributed.Process.Tests.Internal.Utils + +testLinkingWithNormalExits :: TestResult DiedReason -> Process () +testLinkingWithNormalExits result = do + testPid <- getSelfPid + pid <- spawnLocal $ do + worker <- spawnLocal $ do + "finish" <- expect + return () + linkOnFailure worker + send testPid worker + () <- expect + return () + + workerPid <- expect :: Process ProcessId + ref <- monitor workerPid + + send workerPid "finish" + receiveWait [ + matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref') + (\_ -> return ()) + ] + + -- by now, the worker is gone, so we can check that the + -- insulator is still alive and well and that it exits normally + -- when asked to do so + ref2 <- monitor pid + send pid () + + r <- receiveWait [ + matchIf (\(ProcessMonitorNotification ref2' _ _) -> ref2 == ref2') + (\(ProcessMonitorNotification _ _ reason) -> return reason) + ] + stash result r + +testLinkingWithAbnormalExits :: TestResult (Maybe Bool) -> Process () +testLinkingWithAbnormalExits result = do + testPid <- getSelfPid + pid <- spawnLocal $ do + worker <- spawnLocal $ do + "finish" <- expect + return () + + linkOnFailure worker + send testPid worker + () <- expect + return () + + workerPid <- expect :: Process ProcessId + + ref <- monitor pid + kill workerPid "finish" -- note the use of 'kill' instead of send + r <- receiveTimeout (asTimeout $ seconds 20) [ + matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref') + (\(ProcessMonitorNotification _ _ reason) -> return reason) + ] + case r of + Just (DiedException _) -> stash result $ Just True + (Just _) -> stash result $ Just False + Nothing -> stash result Nothing + +myRemoteTable :: RemoteTable +myRemoteTable = Control.Distributed.Process.Extras.__remoteTable initRemoteTable + +multicallTest :: NT.Transport -> Assertion +multicallTest transport = + do node1 <- newLocalNode transport myRemoteTable + tryRunProcess node1 $ + do pid1 <- whereisOrStart "server1" server1 + _ <- whereisOrStart "server2" server2 + pid2 <- whereisOrStart "server2" server2 + tag <- newTagPool + + -- First test: expect positives answers from both processes + tag1 <- getTag tag + result1 <- multicall [pid1,pid2] mystr tag1 infiniteWait + case result1 of + [Just reversed, Just doubled] | + reversed == reverse mystr && doubled == mystr ++ mystr -> return () + _ -> error "Unmatched" + + -- Second test: First process works, second thread throws an exception + tag2 <- getTag tag + [Just 10, Nothing] <- multicall [pid1,pid2] (5::Int) tag2 infiniteWait :: Process [Maybe Int] + + -- Third test: First process exceeds time limit, second process is still dead + tag3 <- getTag tag + [Nothing, Nothing] <- multicall [pid1,pid2] (23::Int) tag3 (Just 1000000) :: Process [Maybe Int] + return () + where server1 = receiveWait [callResponse (\str -> mention (str::String) (return (reverse str,())))] >> + receiveWait [callResponse (\i -> mention (i::Int) (return (i*2,())))] >> + receiveWait [callResponse (\i -> liftIO (threadDelay 2000000) >> mention (i::Int) (return (i*10,())))] + server2 = receiveWait [callResponse (\str -> mention (str::String) (return (str++str,())))] >> + receiveWait [callResponse (\i -> error "barf" >> mention (i::Int) (return (i :: Int,())))] + mystr = "hello" + mention :: a -> b -> b + mention _a b = b + + + +-------------------------------------------------------------------------------- +-- Utilities and Plumbing -- +-------------------------------------------------------------------------------- + +tests :: NT.Transport -> LocalNode -> [Test] +tests transport localNode = [ + testGroup "Linking Tests" [ + testCase "testLinkingWithNormalExits" + (delayedAssertion + "normal exit should not terminate the caller" + localNode DiedNormal testLinkingWithNormalExits) + , testCase "testLinkingWithAbnormalExits" + (delayedAssertion + "abnormal exit should terminate the caller" + localNode (Just True) testLinkingWithAbnormalExits) + ], + testGroup "Call/RPC" [ + testCase "multicallTest" (multicallTest transport) + ] + ] + +primitivesTests :: NT.Transport -> IO [Test] +primitivesTests transport = do + localNode <- newLocalNode transport initRemoteTable + let testData = tests transport localNode + return testData + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals + "127.0.0.1" "10501" defaultTCPParameters + testData <- builder transport + defaultMain testData + +main :: IO () +main = testMain $ primitivesTests