distributed-process-extras 0.3.0 → 0.3.1
raw patch · 12 files changed
+111/−137 lines, 12 filesdep ~data-accessordep ~timePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: data-accessor, time
API changes (from Hackage documentation)
- Control.Distributed.Process.Extras: data ServerDisconnected
- Control.Distributed.Process.Extras.Internal.Types: __remoteTable :: RemoteTable -> RemoteTable
- Control.Distributed.Process.Extras.Internal.Types: data ServerDisconnected
- Control.Distributed.Process.Extras.Internal.Types: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Internal.Types.Message
- Control.Distributed.Process.Extras.Internal.Types: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Internal.Types.ProcessId
- Control.Distributed.Process.Extras.SystemLog: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Extras.SystemLog.LogText
- Control.Distributed.Process.Extras.Timer: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Extras.Timer.Tick
- Control.Distributed.Process.Extras.Timer: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Extras.Timer.TimerConfig
+ Control.Distributed.Process.Extras: newtype ServerDisconnected
+ Control.Distributed.Process.Extras.Internal.Types: instance (Control.DeepSeq.NFData a, Control.Distributed.Process.Serializable.Serializable a) => Control.Distributed.Process.Extras.Internal.Types.NFSerializable a
+ Control.Distributed.Process.Extras.Internal.Types: instance Control.Distributed.Process.Extras.Internal.Types.Resolvable p => Control.Distributed.Process.Extras.Internal.Types.Killable p
+ Control.Distributed.Process.Extras.Internal.Types: newtype ServerDisconnected
- Control.Distributed.Process.Extras: ServerDisconnected :: !DiedReason -> ServerDisconnected
+ Control.Distributed.Process.Extras: ServerDisconnected :: DiedReason -> ServerDisconnected
- Control.Distributed.Process.Extras.Internal.Types: ServerDisconnected :: !DiedReason -> ServerDisconnected
+ Control.Distributed.Process.Extras.Internal.Types: ServerDisconnected :: DiedReason -> ServerDisconnected
Files
- ChangeLog +10/−0
- distributed-process-extras.cabal +2/−3
- src/Control/Distributed/Process/Extras.hs +8/−4
- src/Control/Distributed/Process/Extras/Internal/Primitives.hs +21/−29
- src/Control/Distributed/Process/Extras/Internal/Queue/SeqQ.hs +2/−13
- src/Control/Distributed/Process/Extras/Internal/Types.hs +25/−25
- src/Control/Distributed/Process/Extras/Internal/Unsafe.hs +10/−2
- src/Control/Distributed/Process/Extras/Monitoring.hs +1/−2
- src/Control/Distributed/Process/Extras/SystemLog.hs +22/−41
- src/Control/Distributed/Process/Extras/Timer.hs +8/−12
- src/Control/Distributed/Process/Extras/UnsafePrimitives.hs +1/−2
- tests/TestTimer.hs +1/−4
ChangeLog view
@@ -1,5 +1,15 @@ 2017-02-05 Tim Watson <watson.timothy @ google mail service dot com> 0.3.0 +* re-implement whereIsRemote in terms of whereIsRemoteAsync+* re-implement whereisOrStart to avoid leaking zombie processes+* implement general NFSerializable instances+* make Resolvable instance of (NodeId, String) exception safe+* remove dependency on data-accessor+* Relax upper bound on time for testing+* documentation fixes and improvements++2017-02-05 Tim Watson <watson.timothy @ google mail service dot com> 0.3.0+ * Update dependency bounds - drop support for distributed-process < 0.6.6 * Drop support for GHC < 7.10 * Fixes for testing with latest stack and CI changes
distributed-process-extras.cabal view
@@ -1,5 +1,5 @@ name: distributed-process-extras-version: 0.3.0+version: 0.3.1 cabal-version: >=1.8 build-type: Simple license: BSD3@@ -31,7 +31,6 @@ library build-depends: base >= 4.6 && < 5,- data-accessor >= 0.2.2.3, distributed-process >= 0.6.6 && < 0.7, binary >= 0.6.3.0 && < 0.9, deepseq >= 1.3.0.1 && < 1.6,@@ -168,7 +167,7 @@ network >= 2.3 && < 2.7, HUnit >= 1.2 && < 2, stm >= 2.3 && < 2.5,- time > 1.4 && < 1.8,+ time > 1.4 && < 1.9, test-framework >= 0.6 && < 0.9, test-framework-hunit, transformers,
src/Control/Distributed/Process/Extras.hs view
@@ -33,6 +33,13 @@ semantics of these operations, and therefore the /unsafe/ moniker will remain in place, in one form or another, for all functions and modules that use them. +[Addressing/Interaction Tools]++The various type classes exposed here, along with some common data types (such+as @Shutdown@, @ServerDisconnected@, etc.) are intended to simplify your CH+programs, and facilitate easily plugging code into higher level libraries such+as distributed-process-client-server and distributed-process-supervisor.+ [Error/Exception Handling] It is /important/ not to be too general when catching exceptions in@@ -110,12 +117,9 @@ import Control.Distributed.Process.Extras.UnsafePrimitives import Control.Distributed.Process.Extras.Internal.Primitives hiding (__remoteTable) import qualified Control.Distributed.Process.Extras.Internal.Primitives (__remoteTable)-import qualified Control.Distributed.Process.Extras.Internal.Types (__remoteTable) -- remote table __remoteTable :: RemoteTable -> RemoteTable __remoteTable =- Control.Distributed.Process.Extras.Internal.Primitives.__remoteTable .- Control.Distributed.Process.Extras.Internal.Types.__remoteTable-+ Control.Distributed.Process.Extras.Internal.Primitives.__remoteTable
src/Control/Distributed/Process/Extras/Internal/Primitives.hs view
@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Distributed.Process.Extras.Internal.Primitives--- Copyright : (c) Tim Watson 2013, Parallel Scientific (Jeff Epstein) 2012+-- Copyright : (c) Tim Watson 2013 - 2017, Parallel Scientific (Jeff Epstein) 2012 -- License : BSD3 (see the file LICENSE) -- -- Maintainers : Jeff Epstein, Tim Watson@@ -56,7 +56,7 @@ ) where import Control.Concurrent (myThreadId, throwTo)-import Control.Distributed.Process hiding (monitor)+import Control.Distributed.Process hiding (monitor, finally, catch) import qualified Control.Distributed.Process as P (monitor) import Control.Distributed.Process.Closure (seqCP, remotable, mkClosure) import Control.Distributed.Process.Serializable (Serializable)@@ -71,6 +71,7 @@ , whereisRemote ) import Control.Monad (void)+import Control.Monad.Catch (finally, catchIf) import Data.Maybe (isJust, fromJust) -- utility@@ -96,9 +97,12 @@ (\_ -> return ()) ] +-- | deliver = flip sendTo deliver :: (Addressable a, Serializable m) => m -> a -> Process () deliver = flip sendTo +-- | True if getProcessInfo /= Nothing+-- NB: only works for local processes. isProcessAlive :: ProcessId -> Process Bool isProcessAlive pid = getProcessInfo pid >>= \info -> return $ info /= Nothing @@ -133,7 +137,7 @@ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef) (\(ProcessMonitorNotification _ _ dr) -> die $ ExitOther (show dr)) , matchChan recvStart (\() -> return pid)- ]+ ] `finally` (unmonitor mRef) -- | Node local version of 'Control.Distributed.Process.spawnLink'. -- Note that this is just the sequential composition of 'spawn' and 'link'.@@ -182,31 +186,20 @@ -- is started. This is a handy way to start per-node named servers. -- whereisOrStart :: String -> Process () -> Process ProcessId-whereisOrStart name proc =- do mpid <- whereis name- case mpid of- Just pid -> return pid- Nothing ->- do caller <- getSelfPid- pid <- spawnLocal $- do self <- getSelfPid- register name self- send caller (RegisterSelf,self)- () <- expect- proc- ref <- P.monitor pid- ret <- receiveWait- [ matchIf (\(ProcessMonitorNotification aref _ _) -> ref == aref)- (\(ProcessMonitorNotification _ _ _) -> return Nothing),- matchIf (\(RegisterSelf,apid) -> apid == pid)- (\(RegisterSelf,_) -> return $ Just pid)- ]- case ret of- Nothing -> whereisOrStart name proc- Just somepid ->- do unmonitor ref- send somepid ()- return somepid+whereisOrStart name proc = do+ (sigStart, recvStart) <- newChan+ (_, mRef) <- spawnMonitorLocal $ do+ us <- getSelfPid+ catchIf (\(ProcessRegistrationException _ r) -> isJust r)+ (register name us >> sendChan sigStart us)+ (\(ProcessRegistrationException _ rPid) ->+ sendChan sigStart $ fromJust rPid)+ proc+ receiveWait [+ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)+ (\(ProcessMonitorNotification _ _ dr) -> die $ ExitOther (show dr))+ , matchChan recvStart return+ ] `finally` (unmonitor mRef) registerSelf :: (String, ProcessId) -> Process () registerSelf (name,target) =@@ -287,4 +280,3 @@ matchRef r = matchIf (\(ProcessMonitorNotification r' _ _) -> r == r') (\(ProcessMonitorNotification _ _ d) -> do return (Left (ExitOther (show d))))-
src/Control/Distributed/Process/Extras/Internal/Queue/SeqQ.hs view
@@ -1,15 +1,3 @@--------------------------------------------------------------------------------- |--- Module : Control.Distributed.Process.Extras.Internal.Queue.SeqQ--- Copyright : (c) Tim Watson 2012 - 2013--- License : BSD3 (see the file LICENSE)------ Maintainer : Tim Watson <watson.timothy@gmail.com>--- Stability : experimental------ A simple FIFO queue implementation backed by @Data.Sequence@.------------------------------------------------------------------------------- module Control.Distributed.Process.Extras.Internal.Queue.SeqQ ( SeqQ , empty@@ -21,6 +9,8 @@ ) where +-- A simple FIFO queue implementation backed by @Data.Sequence@.+ import Data.Sequence ( Seq , ViewR(..)@@ -63,4 +53,3 @@ case (viewr (q s)) of EmptyR -> Nothing a -> Just a-
src/Control/Distributed/Process/Extras/Internal/Types.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} -- | Types used throughout the Extras package --@@ -32,8 +30,6 @@ , ExitReason(..) , ServerDisconnected(..) , NFSerializable- -- remote table- , __remoteTable ) where import Control.Concurrent.MVar@@ -42,19 +38,15 @@ , modifyMVar ) import Control.DeepSeq (NFData(..), ($!!))-import Control.Distributed.Process hiding (send)+import Control.Distributed.Process hiding (send, catch) import qualified Control.Distributed.Process as P ( send , unsafeSend , unsafeNSend )-import Control.Distributed.Process.Closure- ( remotable- , mkClosure- , functionTDict- ) import Control.Distributed.Process.Serializable-+import Control.Exception (SomeException)+import Control.Monad.Catch (catch) import Data.Binary import Data.Foldable (traverse_) import Data.Typeable (Typeable)@@ -73,10 +65,9 @@ -- behaviour by using /unsafe/ primitives in this way. -- class (NFData a, Serializable a) => NFSerializable a+instance (NFData a, Serializable a) => NFSerializable a -instance NFSerializable ProcessId instance (NFSerializable a) => NFSerializable (SendPort a)-instance NFSerializable Message -- | Tags provide uniqueness for messages, so that they can be -- matched with their response.@@ -98,14 +89,20 @@ getTag :: TagPool -> Process Tag getTag tp = liftIO $ modifyMVar tp (\tag -> return (tag+1,tag)) -$(remotable ['whereis])---- | A synchronous version of 'whereis', this relies on 'call'--- to perform the relevant monitoring of the remote node.+-- | A synchronous version of 'whereis', this monitors the remote node+-- and returns @Nothing@ if the node goes down (since a remote node failing+-- or being non-contactible has the same effect as a process not being+-- registered from the caller's point of view). whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)-whereisRemote node name =- call $(functionTDict 'whereis) node ($(mkClosure 'whereis) name)-+whereisRemote node name = do+ mRef <- monitorNode node+ whereisRemoteAsync node name+ receiveWait [ matchIf (\(NodeMonitorNotification ref nid _) -> ref == mRef &&+ nid == node)+ (\NodeMonitorNotification{} -> return Nothing)+ , matchIf (\(WhereIsReply n _) -> n == name)+ (\(WhereIsReply _ mPid) -> return mPid)+ ] -- | Wait cancellation message. data CancelWait = CancelWait@@ -158,6 +155,8 @@ exitProc :: (Resolvable p, Serializable m) => p -> m -> Process () exitProc r m = resolve r >>= traverse_ (flip exit $ m) +instance Resolvable p => Killable p+ -- | resolve the Resolvable or die with specified msg plus details of what didn't resolve resolveOrDie :: (Resolvable a) => a -> String -> Process ProcessId resolveOrDie resolvable failureMsg = do@@ -185,7 +184,8 @@ unresolvableMessage s = "CannotResolveRegisteredName[" ++ s ++ "]" instance Resolvable (NodeId, String) where- resolve (nid, pname) = whereisRemote nid pname+ resolve (nid, pname) =+ whereisRemote nid pname `catch` (\(_ :: SomeException) -> return Nothing) unresolvableMessage (n, s) = "CannotResolveRemoteRegisteredName[name: " ++ s ++ ", node: " ++ (show n) ++ "]" @@ -220,8 +220,8 @@ unsafeSendTo name msg = P.unsafeNSend name $!! msg instance Routable (NodeId, String) where- sendTo (nid, pname) msg = nsendRemote nid pname msg- unsafeSendTo = sendTo -- because serialisation *must* take place+ sendTo (nid, pname) = nsendRemote nid pname+ unsafeSendTo = sendTo -- because serialisation *must* take place instance Routable (Message -> Process ()) where sendTo f = f . wrapMessage@@ -269,7 +269,7 @@ -- useful exit reasons -- | Given when a server is unobtainable.-data ServerDisconnected = ServerDisconnected !DiedReason+newtype ServerDisconnected = ServerDisconnected DiedReason deriving (Typeable, Generic) instance Binary ServerDisconnected where instance NFData ServerDisconnected where
src/Control/Distributed/Process/Extras/Internal/Unsafe.hs view
@@ -1,11 +1,20 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} -- | If you don't know exactly what this module is for and precisely -- how to use the types within, you should move on, quickly! --+-- [Implementation Notes]+-- This module provides facilities for forcibly sending non-serializable+-- data via cloud haskell's messaging primitives, such as @send@ et al.+-- Of course, if you attmept to do this when interacting with a remote process,+-- your application will break.+--+-- NB: this module will be deprecated in the next dot release, pending rewrite+-- of the libraries that currently rely on it, to use the new supporting APIs+-- for STM interactions in distributed-process-client-server.+-- module Control.Distributed.Process.Extras.Internal.Unsafe ( -- * Copying non-serializable data PCopy()@@ -125,4 +134,3 @@ matchInputStream (ReadSTM stm) = matchSTM stm return matchInputStream Null = match (\NullInputStream -> do error "NullInputStream")-
src/Control/Distributed/Process/Extras/Monitoring.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Distributed.Process.Extras.Monitoring--- Copyright : (c) Tim Watson 2013 - 2014+-- Copyright : (c) Tim Watson 2013 - 2017 -- License : BSD3 (see the file LICENSE) -- -- Maintainer : Tim Watson <watson.timothy@gmail.com>@@ -136,4 +136,3 @@ nodeUp = NodeUp . NodeId nodeDown = NodeDown . NodeId-
src/Control/Distributed/Process/Extras/SystemLog.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Distributed.Process.Extras.SystemLog--- Copyright : (c) Tim Watson 2013 - 2014+-- Copyright : (c) Tim Watson 2013 - 2017 -- License : BSD3 (see the file LICENSE) -- -- Maintainer : Tim Watson <watson.timothy@gmail.com>@@ -86,18 +86,10 @@ ( Resolvable(..) , Routable(..) , Addressable- , NFSerializable ) import Control.Distributed.Process.Serializable import Control.Exception (SomeException) import Control.Monad.Catch (catch)-import Data.Accessor- ( Accessor- , accessor- , (^:)- , (^=)- , (^.)- ) import Data.Binary import Data.Typeable (Typeable) import GHC.Generics@@ -142,11 +134,11 @@ instance Binary AddFormatter data LogState =- LogState { output :: !(String -> Process ())- , cleanup :: !(Process ())- , _level :: !LogLevel- , _format :: !(String -> Process String)- , _formatters :: ![Message -> Process (Maybe String)]+ LogState { output :: !(String -> Process ())+ , cleanup :: !(Process ())+ , level :: !LogLevel+ , format :: !(String -> Process String)+ , formatters :: ![Message -> Process (Maybe String)] } data LogMessage =@@ -166,7 +158,6 @@ unsafeSendTo _ = mxNotify type LogText = String-instance NFSerializable LogText newtype LogClient = LogClient { agent :: ProcessId } instance Resolvable LogClient where@@ -206,7 +197,7 @@ -> l -> String -> Process ()-report f l = f l +report f l = f l client :: Process (Maybe LogClient) client = resolve logProcessName >>= return . maybe Nothing (Just . LogClient)@@ -269,17 +260,17 @@ systemLog o c l f = go $ LogState o c l f defaultFormatters where go :: LogState -> Process ProcessId- go st = do+ go st = mxAgentWithFinalize mxLogId st [ -- these are the messages we're /really/ interested in- (mxSink $ \(m :: LogMessage) -> do+ (mxSink $ \(m :: LogMessage) -> case m of- (LogMessage msg lvl) -> do+ (LogMessage msg lvl) -> mxGetLocal >>= outputMin lvl msg >> mxReceive (LogData dat lvl) -> handleRawMsg dat lvl) -- complex messages rely on properly registered formatters- , (mxSink $ \(ev :: MxEvent) -> do+ , (mxSink $ \(ev :: MxEvent) -> case ev of (MxUser msg) -> handleRawMsg msg Debug -- we treat trace/log events like regular log events at@@ -289,14 +280,14 @@ -- command message handling , (mxSink $ \(SetLevel lvl) ->- mxGetLocal >>= mxSetLocal . (level ^= lvl) >> mxReceive)+ mxGetLocal >>= \st' -> mxSetLocal st' { 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:))+ mxUpdateLocal (\s -> s { formatters = mf:formatters s }) mxReceive) ] runCleanup @@ -309,15 +300,15 @@ Just str -> outputMin lvl' str st >> mxReceive Nothing -> mxReceive -- we cannot format a Message, so we ignore it - handleEvent (MxConnected _ ep) = do+ handleEvent (MxConnected _ ep) = mxGetLocal >>= outputMin Notice- ("Endpoint: " ++ (show ep) ++ " Disconnected")- handleEvent (MxDisconnected _ ep) = do+ ("Endpoint: " ++ show ep ++ " Disconnected")+ handleEvent (MxDisconnected _ ep) = mxGetLocal >>= outputMin Notice- ("Endpoint " ++ (show ep) ++ " Connected")+ ("Endpoint " ++ show ep ++ " Connected") handleEvent _ = return () - formatMsg m st = let fms = st ^. formatters in formatMsg' m fms+ formatMsg m LogState{..} = let fms = formatters in formatMsg' m fms formatMsg' _ [] = return Nothing formatMsg' m (f':fs) = do@@ -326,22 +317,12 @@ ok@(Just _) -> return ok Nothing -> formatMsg' m fs - outputMin minLvl msgData st =- case minLvl >= (st ^. level) of- True -> liftMX $ ((st ^. format) msgData >>= (output st))+ outputMin minLvl msgData LogState{..} =+ case minLvl >= level of+ True -> liftMX (format msgData >>= output) 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' })-
src/Control/Distributed/Process/Extras/Timer.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Distributed.Process.Extras.Timer--- Copyright : (c) Tim Watson 2012+-- Copyright : (c) Tim Watson 2012 - 2017 -- License : BSD3 (see the file LICENSE) -- -- Maintainer : Tim Watson <watson.timothy@gmail.com>@@ -42,6 +40,7 @@ import Control.Distributed.Process.Extras.UnsafePrimitives (send) import Control.Distributed.Process.Extras.Internal.Types (NFSerializable) import Control.Distributed.Process.Extras.Time+import Control.Monad (unless, void) import Data.Binary import Data.Typeable (Typeable) import Prelude hiding (init)@@ -57,7 +56,6 @@ instance Binary TimerConfig where instance NFData TimerConfig where rnf tc = tc `seq` ()-instance NFSerializable TimerConfig -- | represents a 'tick' event that timers can generate data Tick = Tick@@ -65,7 +63,6 @@ instance Binary Tick where instance NFData Tick where rnf t = t `seq` ()-instance NFSerializable Tick data SleepingPill = SleepingPill deriving (Typeable, Generic, Eq, Show)@@ -99,7 +96,7 @@ -> a -> Process TimerRef sendAfter t pid msg = runAfter t proc- where proc = do { send pid msg }+ where proc = send pid msg -- | runs the supplied process action(s) after @t@ has elapsed runAfter :: TimeInterval -> Process () -> Process TimerRef@@ -138,11 +135,11 @@ -- out, after which the timer will continue running. To stop a long-running -- timer permanently, you should use 'cancelTimer' instead. resetTimer :: TimerRef -> Process ()-resetTimer = (flip send) Reset+resetTimer = flip send Reset -- | permanently cancels a timer cancelTimer :: TimerRef -> Process ()-cancelTimer = (flip send) Cancel+cancelTimer = flip send Cancel -- | cancels a running timer and flushes any viable timer messages from the -- process' message queue. This function should only be called by the process@@ -155,9 +152,9 @@ return () where performFlush mRef Infinity = receiveWait $ filters mRef performFlush mRef NoDelay = performFlush mRef (Delay $ microSeconds 0)- performFlush mRef (Delay i) = receiveTimeout (asTimeout i) (filters mRef) >> return ()+ performFlush mRef (Delay i) = void (receiveTimeout (asTimeout i) (filters mRef)) filters mRef = [- matchIf (\x -> x == ignore)+ matchIf (== ignore) (\_ -> return ()) , matchIf (\(ProcessMonitorNotification mRef' _ _) -> mRef == mRef') (\_ -> return ()) ]@@ -178,7 +175,6 @@ case cancel of Nothing -> runProc cancelOnReset Just Cancel -> return ()- Just Reset -> if cancelOnReset then return ()- else runTimer t proc cancelOnReset+ Just Reset -> unless cancelOnReset $ runTimer t proc cancelOnReset where runProc True = proc runProc False = proc >> runTimer t proc cancelOnReset
src/Control/Distributed/Process/Extras/UnsafePrimitives.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Distributed.Process.Extras.UnsafePrimitives--- Copyright : (c) Tim Watson 2013+-- Copyright : (c) Tim Watson 2013 - 2017 -- License : BSD3 (see the file LICENSE) -- -- Maintainer : Tim Watson <watson.timothy@gmail.com>@@ -60,4 +60,3 @@ -- | Create an unencoded @Message@ for any @Serializable@ type. wrapMessage :: NFSerializable a => a -> Message wrapMessage msg = Unsafe.wrapMessage $!! msg-
tests/TestTimer.hs view
@@ -16,7 +16,6 @@ import Control.Distributed.Process import Control.Distributed.Process.Node import Control.Distributed.Process.Serializable()-import Control.Distributed.Process.Extras (NFSerializable) import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Extras.Timer import Control.Distributed.Process.SysTest.Utils@@ -28,9 +27,7 @@ import GHC.Generics --- orphan instance instance NFData Ping where-instance NFSerializable Ping testSendAfter :: TestResult Bool -> Process () testSendAfter result =@@ -66,7 +63,7 @@ pid <- periodically delay noop ref <- monitor pid _ <- getProcessInfo pid- + cancelTimer pid _ <- receiveWait [