@@ -1,3 +1,5 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+
13-- | Types used throughout the Cloud Haskell framework
24--
35-- We collect all types used internally in a single module because
@@ -29,6 +31,7 @@ module Control.Distributed.Process.Internal.Types
2931 , ReceivePort(..)
3032 -- * Messages
3133 , Message(..)
34+ , isEncoded
3235 , createMessage
3336 , createUnencodedMessage
3437 , unsafeCreateUnencodedMessage
@@ -77,7 +80,7 @@ module Control.Distributed.Process.Internal.Types
7780import System.Mem.Weak (Weak)
7881import Data.Map (Map)
7982import Data.Int (Int32)
80−import Data.Typeable (Typeable)
83+import Data.Typeable (Typeable, typeOf)
8184import Data.Binary (Binary(put, get), putWord8, getWord8, encode)
8285import qualified Data.ByteString as BSS (ByteString, concat, copy)
8386import qualified Data.ByteString.Lazy as BSL
@@ -90,6 +93,7 @@ import qualified Data.ByteString.Lazy as BSL
9093import qualified Data.ByteString.Lazy.Internal as BSL (ByteString(..))
9194import Data.Accessor (Accessor, accessor)
9295import Control.Category ((>>>))
96+import Control.DeepSeq (NFData(..))
9397import Control.Exception (Exception)
9498import Control.Concurrent (ThreadId)
9599import Control.Concurrent.Chan (Chan)
@@ -113,14 +117,19 @@ import Control.Distributed.Process.Internal.WeakTQueue (TQueue)
113117import Control.Distributed.Static (RemoteTable, Closure)
114118import qualified Control.Distributed.Process.Internal.StrictContainerAccessors as DAC (mapMaybe)
115119
120+import Data.Hashable
121+import GHC.Generics
122+
116123--------------------------------------------------------------------------------
117124-- Node and process identifiers --
118125--------------------------------------------------------------------------------
119126
120127-- | Node identifier
121128newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }
122− deriving (Eq, Ord, Binary, Typeable)
123−
129+ deriving (Eq, Ord, Typeable, Generic)
130+instance Binary NodeId where
131+instance NFData NodeId
132+instance Hashable NodeId where
124133instance Show NodeId where
125134 show (NodeId addr) = "nid://" ++ show addr
126135
@@ -130,7 +139,9 @@ data LocalProcessId = LocalProcessId
130139 { lpidUnique :: {-# UNPACK #-} !Int32
131140 , lpidCounter :: {-# UNPACK #-} !Int32
132141 }
133− deriving (Eq, Ord, Typeable, Show)
142+ deriving (Eq, Ord, Typeable, Generic, Show)
143+
144+instance Hashable LocalProcessId where
134145
135146-- | Process identifier
136147data ProcessId = ProcessId
@@ -139,7 +150,11 @@ data ProcessId = ProcessId
139150 -- | Node-local identifier for the process
140151 , processLocalId :: {-# UNPACK #-} !LocalProcessId
141152 }
142− deriving (Eq, Ord, Typeable)
153+ deriving (Eq, Ord, Typeable, Generic)
154+
155+instance Binary ProcessId where
156+instance NFData ProcessId where
157+instance Hashable ProcessId where
143158
144159instance Show ProcessId where
145160 show (ProcessId (NodeId addr) (LocalProcessId _ lid))
@@ -150,7 +165,9 @@ data Identifier =
150165 NodeIdentifier !NodeId
151166 | ProcessIdentifier !ProcessId
152167 | SendPortIdentifier !SendPortId
153− deriving (Eq, Ord)
168+ deriving (Eq, Ord, Generic)
169+
170+instance Hashable Identifier where
154171
155172instance Show Identifier where
156173 show (NodeIdentifier nid) = show nid
@@ -276,8 +293,9 @@ data SendPortId = SendPortId {
276293 -- | Process-local ID of the channel
277294 , sendPortLocalId :: {-# UNPACK #-} !LocalSendPortId
278295 }
279− deriving (Eq, Ord)
296+ deriving (Eq, Ord, Typeable, Generic)
280297
298+instance Hashable SendPortId where
281299instance Show SendPortId where
282300 show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)
283301 = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid
@@ -289,7 +307,11 @@ newtype SendPort a = SendPort {
289307 -- | The (unique) ID of this send port
290308 sendPortId :: SendPortId
291309 }
292− deriving (Typeable, Binary, Show, Eq, Ord)
310+ deriving (Typeable, Generic, Show, Eq, Ord)
311+
312+instance (Serializable a) => Binary (SendPort a) where
313+instance (Hashable a) => Hashable (SendPort a) where
314+instance (NFData a) => NFData (SendPort a) where
293315
294316-- | The receive end of a typed channel (not serializable)
295317--
@@ -329,7 +351,19 @@ data Message =
329351
330352instance Show Message where
331353 show (EncodedMessage fp enc) = show enc ++ " :: " ++ showFingerprint fp []
332− show (UnencodedMessage fp _) = "[unencoded message] :: " ++ (showFingerprint fp [])
354+ show (UnencodedMessage _ uenc) = "[unencoded message] :: " ++ (show $ typeOf uenc)
355+
356+-- | /internal use only/.
357+isEncoded :: Message -> Bool
358+isEncoded (EncodedMessage _ _) = True
359+isEncoded _ = False
360+-- [note] isEncoded:
361+-- This is just as internal as it looks and yes, it does feel a bit odd that
362+-- we're exporting it for use, however DPP does a /lot/ of work with low
363+-- level APIs such as unwrapMessage and handleMessage, and in the process
364+-- tries very hard to avoid copying (and re-serialisation) where possible.
365+-- Being able to determine that a message is encoded (or otherwise) makes
366+-- that a lot more manageable.
333367
334368-- | Turn any serialiable term into a message
335369createMessage :: Serializable a => a -> Message
@@ -377,7 +411,8 @@ data MonitorRef = MonitorRef
377411 -- | Unique to distinguish multiple monitor requests by the same process
378412 , monitorRefCounter :: !Int32
379413 }
380− deriving (Eq, Ord, Show)
414+ deriving (Eq, Ord, Show, Generic)
415+instance Hashable MonitorRef where
381416
382417-- | Message sent by process monitors
383418data ProcessMonitorNotification =
@@ -531,10 +566,6 @@ instance Binary LocalProcessId where
531566 put lpid = put (lpidUnique lpid) >> put (lpidCounter lpid)
532567 get = LocalProcessId <$> get <*> get
533568
534−instance Binary ProcessId where
535− put pid = put (processNodeId pid) >> put (processLocalId pid)
536− get = ProcessId <$> get <*> get
537−
538569instance Binary ProcessMonitorNotification where
539570 put (ProcessMonitorNotification ref pid reason) = put ref >> put pid >> put reason
540571 get = ProcessMonitorNotification <$> get <*> get <*> get
@@ -567,7 +598,7 @@ instance Binary ProcessSignal where
567598 put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)
568599 put (Kill pid reason) = putWord8 9 >> put pid >> put reason
569600 put (Exit pid reason) = putWord8 10 >> put pid >> put (messageToPayload reason)
570− put (LocalSend to msg) = putWord8 11 >> put to >> put (messageToPayload msg)
601+ put (LocalSend to' msg) = putWord8 11 >> put to' >> put (messageToPayload msg)
571602 put (LocalPortSend sid msg) = putWord8 12 >> put sid >> put (messageToPayload msg)
572603 put (GetInfo about) = putWord8 30 >> put about
573604 put (SigShutdown) = putWord8 31
@@ -615,6 +646,9 @@ instance Binary SendPortId where
615646 put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid)
616647 get = SendPortId <$> get <*> get
617648
649+instance NFData SendPortId where
650+ rnf cid = (sendPortProcessId cid) `seq` (sendPortLocalId cid) `seq` ()
651+
618652instance Binary Identifier where
619653 put (ProcessIdentifier pid) = putWord8 0 >> put pid
620654 put (NodeIdentifier nid) = putWord8 1 >> put nid
@@ -667,7 +701,7 @@ localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProc
667701localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid
668702
669703localConnectionBetween :: Identifier -> Identifier -> Accessor LocalNodeState (Maybe (NT.Connection, ImplicitReconnect))
670−localConnectionBetween from to = localConnections >>> DAC.mapMaybe (from, to)
704+localConnectionBetween from' to' = localConnections >>> DAC.mapMaybe (from', to')
671705
672706monitorCounter :: Accessor LocalProcessState Int32
673707monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })