diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2017-02-05 Tim Watson 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 + 2016-02-16 Facundo Domínguez 0.2.1.2 * Update dependency bounds. @@ -8,12 +14,3 @@ * Add compatibility with ghc-7.10. * Fix dependency bounds. * Add missing NFData instances. - -# HEAD - -* Added initial GenServer module -* Added Timer Module -* Moved time functions into Time.hs -* Added Async API -* Added GenProcess API (subsumes lower level GenServer API) - diff --git a/distributed-process-extras.cabal b/distributed-process-extras.cabal --- a/distributed-process-extras.cabal +++ b/distributed-process-extras.cabal @@ -1,21 +1,21 @@ name: distributed-process-extras -version: 0.2.1.2 +version: 0.3.0 cabal-version: >=1.8 build-type: Simple license: BSD3 license-file: LICENCE stability: experimental -Copyright: Tim Watson 2012 - 2013 +Copyright: Tim Watson 2012 - 2017 Author: Tim Watson -Maintainer: Facundo Domínguez +Maintainer: Tim Watson Stability: experimental Homepage: http://github.com/haskell-distributed/distributed-process-extras -Bug-Reports: https://cloud-haskell.atlassian.net +Bug-Reports: http://github.com/haskell-distributed/distributed-process-extras/issues synopsis: Cloud Haskell Extras description: Supporting library, providing common types and utilities used by the - various components that make up the distributed-process-platform package. + various libraries built on top of distributed-process category: Control -tested-with: GHC == 7.4.2 GHC == 7.6.2 +Tested-With: GHC==7.10.3 GHC==8.0.1 GHC==8.0.2 data-dir: "" extra-source-files: ChangeLog @@ -23,29 +23,34 @@ type: git location: https://github.com/haskell-distributed/distributed-process-extras +flag old-locale + description: If false then depend on time >= 1.5. + . + If true then depend on time < 1.5 together with old-locale. + default: False + library - build-depends: - base >= 4.4 && < 5, + build-depends: base >= 4.6 && < 5, data-accessor >= 0.2.2.3, - distributed-process >= 0.5.3 && < 0.7, - binary >= 0.6.3.0 && < 0.8, + distributed-process >= 0.6.6 && < 0.7, + binary >= 0.6.3.0 && < 0.9, deepseq >= 1.3.0.1 && < 1.6, - mtl, + mtl >= 2.0 && < 2.4, containers >= 0.4 && < 0.6, + exceptions >= 0.5, hashable >= 1.2.0.5 && < 1.3, unordered-containers >= 0.2.3.0 && < 0.3, fingertree < 0.2, stm >= 2.4 && < 2.5, - time > 1.4 && < 1.6, - transformers - if impl(ghc <= 7.5) - Build-Depends: template-haskell == 2.7.0.0, - derive == 2.5.5, - uniplate == 1.6.12, - ghc-prim + transformers >= 0.2 && < 0.6 + if flag(old-locale) + Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1 + else + Build-Depends: time >= 1.5 extensions: CPP - hs-source-dirs: src + other-extensions: ExistentialQuantification ghc-options: -Wall + HS-Source-Dirs: src exposed-modules: Control.Distributed.Process.Extras, Control.Distributed.Process.Extras.Call, @@ -66,11 +71,11 @@ type: exitcode-stdio-1.0 x-uses-tf: true build-depends: - base >= 4.4 && < 5, + base >= 4.6 && < 5, ansi-terminal >= 0.5 && < 0.7, - distributed-process >= 0.5.3 && < 0.7, + distributed-process >= 0.6.6 && < 0.7, distributed-process-extras, - distributed-process-tests >= 0.4.2 && < 0.5, + distributed-process-systest >= 0.1.0 && < 0.2.0, HUnit >= 1.2 && < 2, test-framework >= 0.6 && < 0.9, test-framework-hunit, @@ -89,16 +94,16 @@ type: exitcode-stdio-1.0 x-uses-tf: true build-depends: - base >= 4.4 && < 5, + base >= 4.6 && < 5, ansi-terminal >= 0.5 && < 0.7, - distributed-process >= 0.5.3 && < 0.7, + distributed-process >= 0.6.6 && < 0.7, distributed-process-extras, - distributed-process-tests >= 0.4.2 && < 0.5, + distributed-process-systest >= 0.1.0 && < 0.2.0, network-transport >= 0.4 && < 0.5, mtl, containers >= 0.4 && < 0.6, network-transport-tcp >= 0.4 && < 0.6, - binary >= 0.6.3.0 && < 0.8, + binary >= 0.6.3.0 && < 0.9, deepseq >= 1.3.0.1 && < 1.6, network >= 2.3 && < 2.7, HUnit >= 1.2 && < 2, @@ -117,12 +122,12 @@ type: exitcode-stdio-1.0 x-uses-tf: true build-depends: - base >= 4.4 && < 5, + base >= 4.6 && < 5, ansi-terminal >= 0.5 && < 0.7, deepseq >= 1.3.0.1 && < 1.6, - distributed-process >= 0.5.3 && < 0.7, + distributed-process >= 0.6.6 && < 0.7, distributed-process-extras, - distributed-process-tests >= 0.4.2 && < 0.5, + distributed-process-systest >= 0.1.0 && < 0.2.0, network-transport >= 0.4 && < 0.5, network-transport-tcp >= 0.4 && < 0.6, HUnit >= 1.2 && < 2, @@ -143,14 +148,14 @@ type: exitcode-stdio-1.0 -- x-uses-tf: true build-depends: - base >= 4.4 && < 5, + base >= 4.6 && < 5, ansi-terminal >= 0.5 && < 0.7, containers, hashable, unordered-containers >= 0.2.3.0 && < 0.3, - distributed-process >= 0.5.3 && < 0.7, + distributed-process >= 0.6.6 && < 0.7, distributed-process-extras, - distributed-process-tests >= 0.4.2 && < 0.5, + distributed-process-systest >= 0.1.0 && < 0.2.0, distributed-static, bytestring, data-accessor, @@ -159,11 +164,11 @@ deepseq >= 1.3.0.1 && < 1.6, mtl, network-transport-tcp >= 0.4 && < 0.6, - binary >= 0.6.3.0 && < 0.8, + binary >= 0.6.3.0 && < 0.9, network >= 2.3 && < 2.7, HUnit >= 1.2 && < 2, stm >= 2.3 && < 2.5, - time > 1.4 && < 1.6, + time > 1.4 && < 1.8, test-framework >= 0.6 && < 0.9, test-framework-hunit, transformers, @@ -171,6 +176,6 @@ ghc-prim hs-source-dirs: tests - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind extensions: CPP main-is: TestLog.hs diff --git a/src/Control/Concurrent/Utils.hs b/src/Control/Concurrent/Utils.hs --- a/src/Control/Concurrent/Utils.hs +++ b/src/Control/Concurrent/Utils.hs @@ -1,65 +1,42 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE ExistentialQuantification #-} module Control.Concurrent.Utils ( Lock() - , Exclusive(..) - , Synchronised(..) + , mkExclusiveLock + , mkQLock , withLock ) where -import Control.Distributed.Process - ( Process - ) -import qualified Control.Distributed.Process as Process (catch) -import Control.Exception (SomeException, throw) -import qualified Control.Exception as Exception (catch) +import Control.Monad.Catch (MonadMask) +import qualified Control.Monad.Catch as Catch import Control.Concurrent.MVar - ( MVar - , tryPutMVar - , newMVar + ( newMVar , takeMVar + , putMVar ) +import Control.Concurrent.QSem import Control.Monad.IO.Class (MonadIO, liftIO) -newtype Lock = Lock { mvar :: MVar () } - -class Exclusive a where - new :: IO a - acquire :: (MonadIO m) => a -> m () - release :: (MonadIO m) => a -> m () - -instance Exclusive Lock where - new = return . Lock =<< newMVar () - acquire = liftIO . takeMVar . mvar - release l = liftIO (tryPutMVar (mvar l) ()) >> return () - -class Synchronised e m where - synchronised :: (Exclusive e, Monad m) => e -> m b -> m b +-- | Opaque lock. +data Lock = forall l . Lock l (l -> IO ()) (l -> IO ()) - synchronized :: (Exclusive e, Monad m) => e -> m b -> m b - synchronized = synchronised +-- | Take a lock. +acquire :: MonadIO m => Lock -> m () +acquire (Lock l acq _) = liftIO $ acq l -instance Synchronised Lock IO where - synchronised = withLock +-- | Release lock. +release :: MonadIO m => Lock -> m () +release (Lock l _ rel) = liftIO $ rel l -instance Synchronised Lock Process where - synchronised = withLockP +-- | Create exclusive lock. Only one process could take such lock. +mkExclusiveLock :: IO Lock +mkExclusiveLock = Lock <$> newMVar () <*> pure takeMVar <*> pure (flip putMVar ()) -withLockP :: (Exclusive e) => e -> Process a -> Process a -withLockP excl act = do - Process.catch (do { liftIO $ acquire excl - ; result <- act - ; liftIO $ release excl - ; return result - }) - (\(e :: SomeException) -> (liftIO $ release excl) >> throw e) +-- | Create quantity lock. A fixed number of processes can take this lock simultaniously. +mkQLock :: Int -> IO Lock +mkQLock n = Lock <$> newQSem n <*> pure waitQSem <*> pure signalQSem -withLock :: (Exclusive e) => e -> IO a -> IO a -withLock excl act = do - Exception.catch (do { acquire excl - ; result <- act - ; release excl - ; return result - }) - (\(e :: SomeException) -> release excl >> throw e) +-- | Run action under a held lock. +withLock :: (MonadMask m, MonadIO m) => Lock -> m a -> m a +withLock excl = + Catch.bracket_ (acquire excl) + (release excl) diff --git a/src/Control/Distributed/Process/Extras.hs b/src/Control/Distributed/Process/Extras.hs --- a/src/Control/Distributed/Process/Extras.hs +++ b/src/Control/Distributed/Process/Extras.hs @@ -51,7 +51,6 @@ ( -- * Exported Types Addressable - , sendToRecipient , Resolvable(..) , Routable(..) , Linkable(..) @@ -97,8 +96,6 @@ import Control.Distributed.Process (RemoteTable) import Control.Distributed.Process.Extras.Internal.Types ( NFSerializable - , sendToRecipient - , NFSerializable , Recipient(..) , Shutdown(..) , ExitReason(..) diff --git a/src/Control/Distributed/Process/Extras/Internal/Types.hs b/src/Control/Distributed/Process/Extras/Internal/Types.hs --- a/src/Control/Distributed/Process/Extras/Internal/Types.hs +++ b/src/Control/Distributed/Process/Extras/Internal/Types.hs @@ -3,10 +3,9 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Types used throughout the Extras package -- @@ -22,7 +21,6 @@ , Resolvable(..) , Routable(..) , Addressable - , sendToRecipient , Recipient(..) , RegisterSelf(..) -- * Interactions @@ -58,6 +56,7 @@ import Control.Distributed.Process.Serializable import Data.Binary +import Data.Foldable (traverse_) import Data.Typeable (Typeable) import GHC.Generics @@ -74,8 +73,11 @@ -- 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. type Tag = Int @@ -96,6 +98,15 @@ 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. +whereisRemote :: NodeId -> String -> Process (Maybe ProcessId) +whereisRemote node name = + call $(functionTDict 'whereis) node ($(mkClosure 'whereis) name) + + -- | Wait cancellation message. data CancelWait = CancelWait deriving (Eq, Show, Typeable, Generic) @@ -128,154 +139,137 @@ instance Binary ExitReason where instance NFData ExitReason where --- | A simple means of mapping to a receiver. -data Recipient = - Pid !ProcessId - | Registered !String - | RemoteRegistered !String !NodeId --- | ProcReg !ProcessId !String --- | RemoteProcReg NodeId String --- | GlobalReg String - deriving (Typeable, Generic, Show, Eq) -instance Binary Recipient where -instance NFData Recipient where - rnf (Pid p) = rnf p `seq` () - rnf (Registered s) = rnf s `seq` () - rnf (RemoteRegistered s n) = rnf s `seq` rnf n `seq` () - --- useful exit reasons - --- | Given when a server is unobtainable. -data ServerDisconnected = ServerDisconnected !DiedReason - deriving (Typeable, Generic) -instance Binary ServerDisconnected where -instance NFData ServerDisconnected where - -$(remotable ['whereis]) - --- | A synchronous version of 'whereis', this relies on 'call' --- to perform the relevant monitoring of the remote node. -whereisRemote :: NodeId -> String -> Process (Maybe ProcessId) -whereisRemote node name = - call $(functionTDict 'whereis) node ($(mkClosure 'whereis) name) - -sendToRecipient :: (Serializable m) => Recipient -> m -> Process () -sendToRecipient (Pid p) m = P.send p m -sendToRecipient (Registered s) m = nsend s m -sendToRecipient (RemoteRegistered s n) m = nsendRemote n s m - -unsafeSendToRecipient :: (NFSerializable m) => Recipient -> m -> Process () -unsafeSendToRecipient (Pid p) m = P.unsafeSend p $!! m -unsafeSendToRecipient (Registered s) m = P.unsafeNSend s $!! m -unsafeSendToRecipient (RemoteRegistered s n) m = nsendRemote n s m - -baseAddressableErrorMessage :: (Routable a) => a -> String +baseAddressableErrorMessage :: (Resolvable a) => a -> String baseAddressableErrorMessage _ = "CannotResolveAddressable" -- | Class of things to which a @Process@ can /link/ itself. class Linkable a where -- | Create a /link/ with the supplied object. - linkTo :: a -> Process () + linkTo :: (Resolvable a) => a -> Process () + linkTo r = resolve r >>= traverse_ link +-- | Class of things that can be killed (or instructed to exit). +class Killable p where + -- | Kill (instruct to exit) generic process, using 'kill' primitive. + killProc :: Resolvable p => p -> String -> Process () + killProc r s = resolve r >>= traverse_ (flip kill $ s) + + -- | Kill (instruct to exit) generic process, using 'exit' primitive. + exitProc :: (Resolvable p, Serializable m) => p -> m -> Process () + exitProc r m = resolve r >>= traverse_ (flip exit $ m) + +-- | 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 + result <- resolve resolvable + case result of + Nothing -> die $ failureMsg ++ " " ++ unresolvableMessage resolvable + Just pid -> return pid + -- | Class of things that can be resolved to a 'ProcessId'. -- class Resolvable a where -- | Resolve the reference to a process id, or @Nothing@ if resolution fails resolve :: a -> Process (Maybe ProcessId) --- | Class of things that can be killed (or instructed to exit). -class Killable a where - killProc :: a -> String -> Process () - exitProc :: (Serializable m) => a -> m -> Process () + -- | Unresolvable @Addressable@ Message + unresolvableMessage :: (Resolvable a) => a -> String + unresolvableMessage = baseAddressableErrorMessage -instance Killable ProcessId where - killProc = kill - exitProc = exit +instance Resolvable ProcessId where + resolve p = return (Just p) + unresolvableMessage p = "CannotResolvePid[" ++ (show p) ++ "]" -instance Resolvable r => Killable r where - killProc r s = resolve r >>= maybe (return ()) (flip kill $ s) - exitProc r m = resolve r >>= maybe (return ()) (flip exit $ m) +instance Resolvable String where + resolve = whereis + unresolvableMessage s = "CannotResolveRegisteredName[" ++ s ++ "]" --- | Provides a unified API for addressing processes. --- -class Routable a where - -- | Send a message to the target asynchronously - sendTo :: (Serializable m) => a -> m -> Process () +instance Resolvable (NodeId, String) where + resolve (nid, pname) = whereisRemote nid pname + unresolvableMessage (n, s) = + "CannotResolveRemoteRegisteredName[name: " ++ s ++ ", node: " ++ (show n) ++ "]" - -- | Send some @NFData@ message to the target asynchronously, - -- forcing evaluation (i.e., @deepseq@) beforehand. - unsafeSendTo :: (NFSerializable m) => a -> m -> Process () +-- Provide a unified API for addressing processes. - -- | Unresolvable @Addressable@ Message - unresolvableMessage :: a -> String - unresolvableMessage = baseAddressableErrorMessage +-- | Class of things that you can route/send serializable message to +class Routable a where -instance (Resolvable a) => Routable a where + -- | Send a message to the target asynchronously + sendTo :: (Serializable m, Resolvable a) => a -> m -> Process () sendTo a m = do mPid <- resolve a maybe (die (unresolvableMessage a)) (\p -> P.send p m) mPid + -- | Send some @NFData@ message to the target asynchronously, + -- forcing evaluation (i.e., @deepseq@) beforehand. + unsafeSendTo :: (NFSerializable m, Resolvable a) => a -> m -> Process () unsafeSendTo a m = do mPid <- resolve a maybe (die (unresolvableMessage a)) (\p -> P.unsafeSend p $!! m) mPid - -- | Unresolvable Addressable Message - unresolvableMessage = baseAddressableErrorMessage - -instance Resolvable Recipient where - resolve (Pid p) = return (Just p) - resolve (Registered n) = whereis n - resolve (RemoteRegistered s n) = whereisRemote n s - -instance Routable Recipient where - sendTo = sendToRecipient - unsafeSendTo = unsafeSendToRecipient - - unresolvableMessage (Pid p) = unresolvableMessage p - unresolvableMessage (Registered n) = unresolvableMessage n - unresolvableMessage (RemoteRegistered s n) = unresolvableMessage (n, s) - -instance Resolvable ProcessId where - resolve p = return (Just p) - instance Routable ProcessId where sendTo = P.send unsafeSendTo pid msg = P.unsafeSend pid $!! msg - unresolvableMessage p = "CannotResolvePid[" ++ (show p) ++ "]" -instance Resolvable String where - resolve = whereis - instance Routable String where sendTo = nsend unsafeSendTo name msg = P.unsafeNSend name $!! msg - unresolvableMessage s = "CannotResolveRegisteredName[" ++ s ++ "]" -instance Resolvable (NodeId, String) where - resolve (nid, pname) = whereisRemote nid pname - instance Routable (NodeId, String) where sendTo (nid, pname) msg = nsendRemote nid pname msg unsafeSendTo = sendTo -- because serialisation *must* take place - unresolvableMessage (n, s) = - "CannotResolveRemoteRegisteredName[name: " ++ s ++ ", node: " ++ (show n) ++ "]" instance Routable (Message -> Process ()) where sendTo f = f . wrapMessage unsafeSendTo f = f . unsafeWrapMessage class (Resolvable a, Routable a) => Addressable a -instance (Resolvable a, Routable a) => Addressable a +instance Addressable ProcessId --- TODO: this probably belongs somewhere other than in ..Types. --- | resolve the Resolvable or die with specified msg plus details of what didn't resolve -resolveOrDie :: (Routable a, Resolvable a) => a -> String -> Process ProcessId -resolveOrDie resolvable failureMsg = do - result <- resolve resolvable - case result of - Nothing -> die $ failureMsg ++ " " ++ unresolvableMessage resolvable - Just pid -> return pid +-- | A simple means of mapping to a receiver. +data Recipient = + Pid !ProcessId + | Registered !String + | RemoteRegistered !String !NodeId +-- | ProcReg !ProcessId !String +-- | RemoteProcReg NodeId String +-- | GlobalReg String + deriving (Typeable, Generic, Show, Eq) +instance Binary Recipient where +instance NFData Recipient where + rnf (Pid p) = rnf p `seq` () + rnf (Registered s) = rnf s `seq` () + rnf (RemoteRegistered s n) = rnf s `seq` rnf n `seq` () + +instance Resolvable Recipient where + resolve (Pid p) = return (Just p) + resolve (Registered n) = whereis n + resolve (RemoteRegistered s n) = whereisRemote n s + + unresolvableMessage (Pid p) = unresolvableMessage p + unresolvableMessage (Registered n) = unresolvableMessage n + unresolvableMessage (RemoteRegistered s n) = unresolvableMessage (n, s) + +-- although we have an instance of Routable for Resolvable, it really +-- makes no sense to do remote lookups on a pid, only to then send to it! +instance Routable Recipient where + + sendTo (Pid p) m = P.send p m + sendTo (Registered s) m = nsend s m + sendTo (RemoteRegistered s n) m = nsendRemote n s m + + unsafeSendTo (Pid p) m = P.unsafeSend p $!! m + unsafeSendTo (Registered s) m = P.unsafeNSend s $!! m + unsafeSendTo (RemoteRegistered s n) m = nsendRemote n s m + +-- useful exit reasons + +-- | Given when a server is unobtainable. +data ServerDisconnected = ServerDisconnected !DiedReason + deriving (Typeable, Generic) +instance Binary ServerDisconnected where +instance NFData ServerDisconnected where diff --git a/src/Control/Distributed/Process/Extras/SystemLog.hs b/src/Control/Distributed/Process/Extras/SystemLog.hs --- a/src/Control/Distributed/Process/Extras/SystemLog.hs +++ b/src/Control/Distributed/Process/Extras/SystemLog.hs @@ -4,9 +4,8 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstrainedClassMethods #-} ----------------------------------------------------------------------------- -- | @@ -44,7 +43,7 @@ , LogFormat , LogClient , LogChan - , LogText(..) + , LogText , ToLog(..) , Logger(..) -- * Mx Agent Configuration / Startup @@ -69,7 +68,7 @@ ) where import Control.DeepSeq (NFData(..)) -import Control.Distributed.Process +import Control.Distributed.Process hiding (catch) import Control.Distributed.Process.Management ( MxEvent(MxConnected, MxDisconnected, MxLog, MxUser) , MxAgentId(..) @@ -86,9 +85,12 @@ import Control.Distributed.Process.Extras ( Resolvable(..) , Routable(..) + , Addressable + , NFSerializable ) import Control.Distributed.Process.Serializable import Control.Exception (SomeException) +import Control.Monad.Catch (catch) import Data.Accessor ( Accessor , accessor @@ -156,25 +158,27 @@ type LogFormat = String -> Process String -type LogChan = () +type LogChanT = () + +newtype LogChan = LogChan LogChanT instance Routable LogChan where sendTo _ = mxNotify unsafeSendTo _ = mxNotify -data LogText = LogText { txt :: !String } +type LogText = String +instance NFSerializable LogText newtype LogClient = LogClient { agent :: ProcessId } instance Resolvable LogClient where resolve = return . Just . agent +instance Routable LogClient class ToLog m where - toLog :: m -> Process (LogLevel -> LogMessage) + toLog :: (Serializable m) => m -> Process (LogLevel -> LogMessage) + toLog = return . LogData . unsafeWrapMessage instance ToLog LogText where - toLog = return . LogMessage . txt - -instance (Serializable a) => ToLog a where - toLog = return . LogData . unsafeWrapMessage + toLog = return . LogMessage instance ToLog Message where toLog = return . LogData @@ -195,46 +199,46 @@ mxLogId = MxAgentId logProcessName logChannel :: LogChan -logChannel = () +logChannel = LogChan () report :: (Logger l) => (l -> LogText -> Process ()) -> l -> String -> Process () -report f l = f l . LogText +report f l = f l client :: Process (Maybe LogClient) client = resolve logProcessName >>= return . maybe Nothing (Just . LogClient) -debug :: (Logger l, ToLog m) => l -> m -> Process () +debug :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () debug l m = sendLog l m Debug -info :: (Logger l, ToLog m) => l -> m -> Process () +info :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () info l m = sendLog l m Info -notice :: (Logger l, ToLog m) => l -> m -> Process () +notice :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () notice l m = sendLog l m Notice -warning :: (Logger l, ToLog m) => l -> m -> Process () +warning :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () warning l m = sendLog l m Warning -error :: (Logger l, ToLog m) => l -> m -> Process () +error :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () error l m = sendLog l m Error -critical :: (Logger l, ToLog m) => l -> m -> Process () +critical :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () critical l m = sendLog l m Critical -alert :: (Logger l, ToLog m) => l -> m -> Process () +alert :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () alert l m = sendLog l m Alert -emergency :: (Logger l, ToLog m) => l -> m -> Process () +emergency :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () emergency l m = sendLog l m Emergency -sendLog :: (Logger l, ToLog m) => l -> m -> LogLevel -> Process () +sendLog :: (Logger l, Serializable m, ToLog m) => l -> m -> LogLevel -> Process () sendLog a m lv = toLog m >>= \m' -> logMessage a $ m' lv -addFormatter :: (Routable r) +addFormatter :: (Addressable r) => r -> Closure (Message -> Process (Maybe String)) -> Process () diff --git a/src/Control/Distributed/Process/Extras/Time.hs b/src/Control/Distributed/Process/Extras/Time.hs --- a/src/Control/Distributed/Process/Extras/Time.hs +++ b/src/Control/Distributed/Process/Extras/Time.hs @@ -155,7 +155,7 @@ {-# INLINE hoursPerDay #-} hoursPerDay :: Int -hoursPerDay = 60 +hoursPerDay = 24 {-# INLINE minutesPerHour #-} minutesPerHour :: Int diff --git a/src/Control/Distributed/Process/Extras/Timer.hs b/src/Control/Distributed/Process/Extras/Timer.hs --- a/src/Control/Distributed/Process/Extras/Timer.hs +++ b/src/Control/Distributed/Process/Extras/Timer.hs @@ -36,7 +36,7 @@ , flushTimer ) where -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData(..)) import Control.Distributed.Process hiding (send) import Control.Distributed.Process.Serializable import Control.Distributed.Process.Extras.UnsafePrimitives (send) @@ -56,12 +56,16 @@ deriving (Typeable, Generic, Eq, Show) 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 deriving (Typeable, Generic, Eq, Show) instance Binary Tick where instance NFData Tick where + rnf t = t `seq` () +instance NFSerializable Tick data SleepingPill = SleepingPill deriving (Typeable, Generic, Eq, Show) diff --git a/tests/TestLog.hs b/tests/TestLog.hs --- a/tests/TestLog.hs +++ b/tests/TestLog.hs @@ -13,7 +13,7 @@ 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.SysTest.Utils import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Extras.Timer import Control.Monad (void) @@ -59,7 +59,7 @@ where writeLog chan = liftIO . atomically . writeTChan chan -testLogLevels :: (Log.Logger logger, ToLog tL) +testLogLevels :: (Log.Logger logger, NFSerializable tL, ToLog tL) => MVar () -> TChan String -> logger @@ -126,7 +126,7 @@ testCase l (delayedAssertion ("Expected up to " ++ l) ln True $ testLogLevels lck chan ch' Debug lvl rdr) - simpleShowToLog = (LogText . show) + simpleShowToLog = show messageToLog = unsafeWrapMessage . show messageRaw = unsafeWrapMessage diff --git a/tests/TestPrimitives.hs b/tests/TestPrimitives.hs --- a/tests/TestPrimitives.hs +++ b/tests/TestPrimitives.hs @@ -27,7 +27,7 @@ import Test.Framework.Providers.HUnit (testCase) import Network.Transport.TCP import qualified Network.Transport as NT -import Control.Distributed.Process.Tests.Internal.Utils +import Control.Distributed.Process.SysTest.Utils testLinkingWithNormalExits :: TestResult DiedReason -> Process () testLinkingWithNormalExits result = do diff --git a/tests/TestQueues.hs b/tests/TestQueues.hs --- a/tests/TestQueues.hs +++ b/tests/TestQueues.hs @@ -47,8 +47,8 @@ Just (a', q2) = FIFO.dequeue q1 Just (b', q3) = FIFO.dequeue q2 Just (c', q4) = FIFO.dequeue q3 - Nothing = FIFO.dequeue q4 - in q4 `seq` [a',b',c'] == [a,b,c] -- why seq here? to shut the compiler up. + d = FIFO.dequeue q4 + in (d == Nothing) && (q4 `seq` [a',b',c'] == [a,b,c]) -- why seq here? to shut the compiler up. prop_enqueue_empty :: String -> Bool prop_enqueue_empty s = diff --git a/tests/TestTimer.hs b/tests/TestTimer.hs --- a/tests/TestTimer.hs +++ b/tests/TestTimer.hs @@ -16,9 +16,10 @@ 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.Tests.Internal.Utils +import Control.Distributed.Process.SysTest.Utils import Test.Framework (Test, testGroup, defaultMain) import Test.Framework.Providers.HUnit (testCase) @@ -29,6 +30,7 @@ -- orphan instance instance NFData Ping where +instance NFSerializable Ping testSendAfter :: TestResult Bool -> Process () testSendAfter result = @@ -63,8 +65,8 @@ let delay = milliSeconds 50 pid <- periodically delay noop ref <- monitor pid - - sleep $ seconds 1 + _ <- getProcessInfo pid + cancelTimer pid _ <- receiveWait [