distributed-process-extras 0.1.0 → 0.1.1

raw patch · 4 files changed

+718/−1 lines, 4 filesdep +bytestringdep +data-accessordep +distributed-staticdep ~containersdep ~hashabledep ~stmPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, data-accessor, distributed-static, network

Dependency ranges changed: containers, hashable, stm

API changes (from Hackage documentation)

Files

• distributed-process-extras.cabal +67/−1
• src/Control/Distributed/Process/Extras/SystemLog.hs +342/−0
• tests/TestLog.hs +143/−0
• tests/TestPrimitives.hs +166/−0

@@ -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

@@ -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 <watson.timothy@gmail.com>+-- 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' })+

@@ -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+

@@ -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