-- | Cloud Haskell primitives---- We define these in a separate module so that we don't have to rely on -- the closure combinatorsmoduleControl.Distributed.Process.Internal.Primitives(-- * Basic messagingsend,expect-- * Channels,newChan,sendChan,receiveChan,mergePortsBiased,mergePortsRR-- * Advanced messaging,Match,receiveWait,receiveTimeout,match,matchIf,matchUnknown,AbstractMessage(..),matchAny-- * Process management,terminate,ProcessTerminationException(..),getSelfPid,getSelfNode-- * Monitoring and linking,link,unlink,monitor,unmonitor-- * Logging,say-- * Registry,register,reregister,unregister,whereis,nsend,registerRemoteAsync,reregisterRemoteAsync,unregisterRemoteAsync,whereisRemoteAsync,nsendRemote-- * Closures,unClosure,unStatic-- * Exception handling,catch,mask,onException,bracket,bracket_,finally-- * Auxiliary API,expectTimeout,receiveChanTimeout,spawnAsync,linkNode,linkPort,unlinkNode,unlinkPort,monitorNode,monitorPort-- * Reconnecting,reconnect,reconnectPort)where#if ! MIN_VERSION_base(4,6,0)importPreludehiding(catch)#endifimportData.Binary(decode)importData.Time.Clock(getCurrentTime)importData.Time.Format(formatTime)importSystem.Locale(defaultTimeLocale)importSystem.Timeout(timeout)importControl.Monad(when)importControl.Monad.Reader(ask)importControl.Monad.IO.Class(MonadIO,liftIO)importControl.Applicative((<$>))importControl.Exception(Exception,throwIO,SomeException)importqualifiedControl.ExceptionasEx(catch,mask)importControl.Distributed.Process.Internal.StrictMVar(StrictMVar,modifyMVar,modifyMVar_)importControl.Concurrent.Chan(writeChan)importControl.Concurrent.STM(STM,TVar,atomically,orElse,newTVar,readTVar,writeTVar)importControl.Distributed.Process.Internal.CQueue(dequeue,BlockSpec(..))importControl.Distributed.Process.Serializable(Serializable,fingerprint)importData.Accessor((^.),(^:),(^=))importControl.Distributed.Static(Closure,Static)importData.Rank1Typeable(Typeable)importqualifiedControl.Distributed.StaticasStatic(unstatic,unclosure)importControl.Distributed.Process.Internal.Types(NodeId(..),ProcessId(..),LocalNode(..),LocalProcess(..),Process(..),Message(..),MonitorRef(..),SpawnRef(..),NCMsg(..),ProcessSignal(..),monitorCounter,spawnCounter,SendPort(..),ReceivePort(..),channelCounter,typedChannelWithId,TypedChannel(..),SendPortId(..),Identifier(..),DidUnmonitor(..),DidUnlinkProcess(..),DidUnlinkNode(..),DidUnlinkPort(..),WhereIsReply(..),RegisterReply(..),ProcessRegistrationException(..),createMessage,runLocalProcess,ImplicitReconnect(WithImplicitReconnect,NoImplicitReconnect),LocalProcessState,LocalSendPortId,messageToPayload)importControl.Distributed.Process.Internal.Messaging(sendMessage,sendBinary,sendPayload,disconnect)importControl.Distributed.Process.Internal.WeakTQueue(newTQueueIO,readTQueue,mkWeakTQueue)---------------------------------------------------------------------------------- Basic messaging ------------------------------------------------------------------------------------ | Send a messagesend::Serializablea=>ProcessId->a->Process()-- This requires a lookup on every send. If we want to avoid that we need to-- modify serializable to allow for stateful (IO) deserializationsendthemmsg=doproc<-askliftIO$sendMessage(processNodeproc)(ProcessIdentifier(processIdproc))(ProcessIdentifierthem)NoImplicitReconnectmsg-- | Wait for a message of a specific typeexpect::foralla.Serializablea=>Processaexpect=receiveWait[matchreturn]---------------------------------------------------------------------------------- Channels ------------------------------------------------------------------------------------ | Create a new typed channelnewChan::Serializablea=>Process(SendPorta,ReceivePorta)newChan=doproc<-askliftIO.modifyMVar(processStateproc)$\st->doletlcid=st^.channelCounterletcid=SendPortId{sendPortProcessId=processIdproc,sendPortLocalId=lcid}letsport=SendPortcidchan<-liftIOnewTQueueIOchan'<-mkWeakTQueuechan$finalizer(processStateproc)lcidletrport=ReceivePort$readTQueuechanlettch=TypedChannelchan'return((channelCounter^:(+1)).(typedChannelWithIdlcid^=Justtch)$st,(sport,rport))wherefinalizer::StrictMVarLocalProcessState->LocalSendPortId->IO()finalizerstlcid=modifyMVar_st$return.(typedChannelWithIdlcid^=Nothing)-- | Send a message on a typed channelsendChan::Serializablea=>SendPorta->a->Process()sendChan(SendPortcid)msg=doproc<-askliftIO$sendBinary(processNodeproc)(ProcessIdentifier(processIdproc))(SendPortIdentifiercid)NoImplicitReconnectmsg-- | Wait for a message on a typed channelreceiveChan::Serializablea=>ReceivePorta->ProcessareceiveChan=liftIO.atomically.receiveSTM-- | Like 'receiveChan' but with a timeout. If the timeout is 0, do a -- non-blocking check for a message.receiveChanTimeout::Serializablea=>Int->ReceivePorta->Process(Maybea)receiveChanTimeout0ch=liftIO.atomically$(Just<$>receiveSTMch)`orElse`returnNothingreceiveChanTimeoutnch=liftIO.timeoutn.atomically$receiveSTMch-- | Merge a list of typed channels.-- -- The result port is left-biased: if there are messages available on more-- than one port, the first available message is returned.mergePortsBiased::Serializablea=>[ReceivePorta]->Process(ReceivePorta)mergePortsBiased=return.ReceivePort.foldr1orElse.mapreceiveSTM-- | Like 'mergePortsBiased', but with a round-robin scheduler (rather than-- left-biased)mergePortsRR::Serializablea=>[ReceivePorta]->Process(ReceivePorta)mergePortsRR=\ps->dopsVar<-liftIO.atomically$newTVar(mapreceiveSTMps)return$ReceivePort(rrpsVar)whererotate::[a]->[a]rotate[]=[]rotate(x:xs)=xs++[x]rr::TVar[STMa]->STMarrpsVar=dops<-readTVarpsVara<-foldr1orElsepswriteTVarpsVar(rotateps)returna---------------------------------------------------------------------------------- Advanced messaging -- ---------------------------------------------------------------------------------- | Opaque type used in 'receiveWait' and 'receiveTimeout'newtypeMatchb=Match{unMatch::Message->Maybe(Processb)}-- | Test the matches in order against each message in the queuereceiveWait::[Matchb]->ProcessbreceiveWaitms=doqueue<-processQueue<$>askJustproc<-liftIO$dequeuequeueBlocking(mapunMatchms)proc-- | Like 'receiveWait' but with a timeout.-- -- If the timeout is zero do a non-blocking check for matching messages. A-- non-zero timeout is applied only when waiting for incoming messages (that is,-- /after/ we have checked the messages that are already in the mailbox).receiveTimeout::Int->[Matchb]->Process(Maybeb)receiveTimeouttms=doqueue<-processQueue<$>askletblockSpec=ift==0thenNonBlockingelseTimeouttmProc<-liftIO$dequeuequeueblockSpec(mapunMatchms)casemProcofNothing->returnNothingJustproc->Just<$>proc-- | Match against any message of the right typematch::forallab.Serializablea=>(a->Processb)->Matchbmatch=matchIf(constTrue)-- | Match against any message of the right type that satisfies a predicatematchIf::forallab.Serializablea=>(a->Bool)->(a->Processb)->MatchbmatchIfcp=Match$\msg->casemessageFingerprintmsg==fingerprint(undefined::a)ofTrue|cdecoded->Just(pdecoded)wheredecoded::a-- Make sure the value is fully decoded so that we don't hang to -- bytestrings when the process calling 'matchIf' doesn't process-- the values immediately!decoded=decode(messageEncodingmsg)_->NothingdataAbstractMessage=AbstractMessage{forward::ProcessId->Process()}-- | Match against an arbitrary messagematchAny::forallb.(AbstractMessage->Processb)->MatchbmatchAnyp=Match$Just.p.abstractwhereabstract::Message->AbstractMessageabstractmsg=AbstractMessage{forward=\them->doproc<-askliftIO$sendPayload(processNodeproc)(ProcessIdentifier(processIdproc))(ProcessIdentifierthem)NoImplicitReconnect(messageToPayloadmsg)}-- | Remove any message from the queuematchUnknown::Processb->MatchbmatchUnknown=Match.const.Just---------------------------------------------------------------------------------- Process management ------------------------------------------------------------------------------------ | Thrown by 'terminate'dataProcessTerminationException=ProcessTerminationExceptionderiving(Show,Typeable)instanceExceptionProcessTerminationException-- | Terminate (throws a ProcessTerminationException)terminate::Processaterminate=liftIO$throwIOProcessTerminationException-- | Our own process IDgetSelfPid::ProcessProcessIdgetSelfPid=processId<$>ask-- | Get the node ID of our local nodegetSelfNode::ProcessNodeIdgetSelfNode=localNodeId.processNode<$>ask---------------------------------------------------------------------------------- Monitoring and linking ------------------------------------------------------------------------------------ | Link to a remote process (asynchronous)---- When process A links to process B (that is, process A calls-- @link pidB@) then an asynchronous exception will be thrown to process A-- when process B terminates (normally or abnormally), or when process A gets-- disconnected from process B. Although it is /technically/ possible to catch-- these exceptions, chances are if you find yourself trying to do so you should-- probably be using 'monitor' rather than 'link'. In particular, code such as---- > link pidB -- Link to process B-- > expect -- Wait for a message from process B-- > unlink pidB -- Unlink again---- doesn't quite do what one might expect: if process B sends a message to-- process A, and /subsequently terminates/, then process A might or might not -- be terminated too, depending on whether the exception is thrown before or-- after the 'unlink' (i.e., this code has a race condition).---- Linking is all-or-nothing: A is either linked to B, or it's not. A second-- call to 'link' has no effect.---- Note that 'link' provides unidirectional linking (see 'spawnSupervised').-- Linking makes no distinction between normal and abnormal termination of-- the remote process.link::ProcessId->Process()link=sendCtrlMsgNothing.Link.ProcessIdentifier-- | Monitor another process (asynchronous)---- When process A monitors process B (that is, process A calls -- @monitor pidB@) then process A will receive a 'ProcessMonitorNotification'-- when process B terminates (normally or abnormally), or when process A gets-- disconnected from process B. You receive this message like any other (using-- 'expect'); the notification includes a reason ('DiedNormal', 'DiedException',-- 'DiedDisconnect', etc.).---- Every call to 'monitor' returns a new monitor reference 'MonitorRef'; if-- multiple monitors are set up, multiple notifications will be delivered -- and monitors can be disabled individually using 'unmonitor'.monitor::ProcessId->ProcessMonitorRefmonitor=monitor'.ProcessIdentifier-- | Remove a link ---- This is synchronous in the sense that once it returns you are guaranteed-- that no exception will be raised if the remote process dies. However, it is-- asynchronous in the sense that we do not wait for a response from the remote -- node.unlink::ProcessId->Process()unlinkpid=dounlinkAsyncpidreceiveWait[matchIf(\(DidUnlinkProcesspid')->pid'==pid)(\_->return())]-- | Remove a node link ---- This has the same synchronous/asynchronous nature as 'unlink'. unlinkNode::NodeId->Process()unlinkNodenid=dounlinkNodeAsyncnidreceiveWait[matchIf(\(DidUnlinkNodenid')->nid'==nid)(\_->return())]-- | Remove a channel (send port) link---- This has the same synchronous/asynchronous nature as 'unlink'. unlinkPort::SendPorta->Process()unlinkPortsport=dounlinkPortAsyncsportreceiveWait[matchIf(\(DidUnlinkPortcid)->cid==sendPortIdsport)(\_->return())]-- | Remove a monitor ---- This has the same synchronous/asynchronous nature as 'unlink'. unmonitor::MonitorRef->Process()unmonitorref=dounmonitorAsyncrefreceiveWait[matchIf(\(DidUnmonitorref')->ref'==ref)(\_->return())]---------------------------------------------------------------------------------- Exception handling ------------------------------------------------------------------------------------ | Lift 'Control.Exception.catch'catch::Exceptione=>Processa->(e->Processa)->Processacatchph=dolproc<-askliftIO$Ex.catch(runLocalProcesslprocp)(runLocalProcesslproc.h)-- | Lift 'Control.Exception.mask' mask::((foralla.Processa->Processa)->Processb)->Processbmaskp=dolproc<-askliftIO$Ex.mask$\restore->runLocalProcesslproc(p(liftRestorelprocrestore))whereliftRestore::LocalProcess->(foralla.IOa->IOa)->(foralla.Processa->Processa)liftRestorelprocrestoreIO=liftIO.restoreIO.runLocalProcesslproc-- | Lift 'Control.Exception.onException'onException::Processa->Processb->ProcessaonExceptionpwhat=p`catch`\e->do_<-whatliftIO$throwIO(e::SomeException)-- | Lift 'Control.Exception.bracket'bracket::Processa->(a->Processb)->(a->Processc)->Processcbracketbeforeafterthing=mask$\restore->doa<-beforer<-restore(thinga)`onException`aftera_<-afterareturnr-- | Lift 'Control.Exception.bracket_'bracket_::Processa->Processb->Processc->Processcbracket_beforeafterthing=bracketbefore(constafter)(constthing)-- | Lift 'Control.Exception.finally'finally::Processa->Processb->Processafinallyasequel=bracket_(return())sequela---------------------------------------------------------------------------------- Auxiliary API ------------------------------------------------------------------------------------ | Like 'expect' but with a timeoutexpectTimeout::foralla.Serializablea=>Int->Process(Maybea)expectTimeoutn=receiveTimeoutn[matchreturn]-- | Asynchronous version of 'spawn'-- -- ('spawn' is defined in terms of 'spawnAsync' and 'expect')spawnAsync::NodeId->Closure(Process())->ProcessSpawnRefspawnAsyncnidproc=dospawnRef<-getSpawnRefsendCtrlMsg(Justnid)$SpawnprocspawnRefreturnspawnRef-- | Monitor a node (asynchronous)monitorNode::NodeId->ProcessMonitorRefmonitorNode=monitor'.NodeIdentifier-- | Monitor a typed channel (asynchronous)monitorPort::foralla.Serializablea=>SendPorta->ProcessMonitorRefmonitorPort(SendPortcid)=monitor'(SendPortIdentifiercid)-- | Remove a monitor (asynchronous)unmonitorAsync::MonitorRef->Process()unmonitorAsync=sendCtrlMsgNothing.Unmonitor-- | Link to a node (asynchronous)linkNode::NodeId->Process()linkNode=link'.NodeIdentifier-- | Link to a channel (asynchronous)linkPort::SendPorta->Process()linkPort(SendPortcid)=link'(SendPortIdentifiercid)-- | Remove a process link (asynchronous)unlinkAsync::ProcessId->Process()unlinkAsync=sendCtrlMsgNothing.Unlink.ProcessIdentifier-- | Remove a node link (asynchronous)unlinkNodeAsync::NodeId->Process()unlinkNodeAsync=sendCtrlMsgNothing.Unlink.NodeIdentifier-- | Remove a channel (send port) link (asynchronous)unlinkPortAsync::SendPorta->Process()unlinkPortAsync(SendPortcid)=sendCtrlMsgNothing.Unlink$SendPortIdentifiercid---------------------------------------------------------------------------------- Logging ------------------------------------------------------------------------------------ | Log a string---- @say message@ sends a message (time, pid of the current process, message)-- to the process registered as 'logger'. By default, this process simply-- sends the string to 'stderr'. Individual Cloud Haskell backends might-- replace this with a different logger process, however.say::String->Process()saystring=donow<-liftIOgetCurrentTimeus<-getSelfPidnsend"logger"(formatTimedefaultTimeLocale"%c"now,us,string)---------------------------------------------------------------------------------- Registry ------------------------------------------------------------------------------------ | Register a process with the local registry (asynchronous).-- This version will wait until a response is gotten from the-- management process. The name must not already be registered.-- The process need not be on this node.-- A bad registration will result in a 'ProcessRegistrationException'---- The process to be registered does not have to be local itself.register::String->ProcessId->Process()register=registerImplFalse-- | Like 'register', but will replace an existing registration.-- The name must already be registered.reregister::String->ProcessId->Process()reregister=registerImplTrueregisterImpl::Bool->String->ProcessId->Process()registerImplforcelabelpid=domynid<-getSelfNodesendCtrlMsgNothing(Registerlabelmynid(Justpid)force)receiveWait[matchIf(\(RegisterReplylabel'_)->label==label')(\(RegisterReply_ok)->handleRegistrationReplylabelok)]-- | Register a process with a remote registry (asynchronous).---- The process to be registered does not have to live on the same remote node.-- Reply wil come in the form of a 'RegisterReply' message---- See comments in 'whereisRemoteAsync'registerRemoteAsync::NodeId->String->ProcessId->Process()registerRemoteAsyncnidlabelpid=sendCtrlMsg(Justnid)(Registerlabelnid(Justpid)False)reregisterRemoteAsync::NodeId->String->ProcessId->Process()reregisterRemoteAsyncnidlabelpid=sendCtrlMsg(Justnid)(Registerlabelnid(Justpid)True)-- | Remove a process from the local registry (asynchronous).-- This version will wait until a response is gotten from the-- management process. The name must already be registered.unregister::String->Process()unregisterlabel=domynid<-getSelfNodesendCtrlMsgNothing(RegisterlabelmynidNothingFalse)receiveWait[matchIf(\(RegisterReplylabel'_)->label==label')(\(RegisterReply_ok)->handleRegistrationReplylabelok)]-- | Deal with the result from an attempted registration or unregistration-- by throwing an exception if necessaryhandleRegistrationReply::String->Bool->Process()handleRegistrationReplylabelok=when(notok)$liftIO$throwIO$ProcessRegistrationExceptionlabel-- | Remove a process from a remote registry (asynchronous).-- -- Reply wil come in the form of a 'RegisterReply' message---- See comments in 'whereisRemoteAsync'unregisterRemoteAsync::NodeId->String->Process()unregisterRemoteAsyncnidlabel=sendCtrlMsg(Justnid)(RegisterlabelnidNothingFalse)-- | Query the local process registrywhereis::String->Process(MaybeProcessId)whereislabel=dosendCtrlMsgNothing(WhereIslabel)receiveWait[matchIf(\(WhereIsReplylabel'_)->label==label')(\(WhereIsReply_mPid)->returnmPid)]-- | Query a remote process registry (asynchronous)---- Reply will come in the form of a 'WhereIsReply' message. ---- There is currently no synchronous version of 'whereisRemoteAsync': if-- you implement one yourself, be sure to take into account that the remote-- node might die or get disconnect before it can respond (i.e. you should-- use 'monitorNode' and take appropriate action when you receive a -- 'NodeMonitorNotification').whereisRemoteAsync::NodeId->String->Process()whereisRemoteAsyncnidlabel=sendCtrlMsg(Justnid)(WhereIslabel)-- | Named send to a process in the local registry (asynchronous) nsend::Serializablea=>String->a->Process()nsendlabelmsg=sendCtrlMsgNothing(NamedSendlabel(createMessagemsg))-- | Named send to a process in a remote registry (asynchronous)nsendRemote::Serializablea=>NodeId->String->a->Process()nsendRemotenidlabelmsg=sendCtrlMsg(Justnid)(NamedSendlabel(createMessagemsg))---------------------------------------------------------------------------------- Closures ------------------------------------------------------------------------------------ | Resolve a static valueunStatic::Typeablea=>Statica->ProcessaunStaticstatic=dortable<-remoteTable.processNode<$>askcaseStatic.unstaticrtablestaticofLefterr->fail$"Could not resolve static value: "++errRightx->returnx-- | Resolve a closureunClosure::Typeablea=>Closurea->ProcessaunClosureclosure=dortable<-remoteTable.processNode<$>askcaseStatic.unclosurertableclosureofLefterr->fail$"Could not resolve closure: "++errRightx->returnx---------------------------------------------------------------------------------- Reconnecting ------------------------------------------------------------------------------------ | Cloud Haskell provides the illusion of connection-less, reliable, ordered-- message passing. However, when network connections get disrupted this-- illusion cannot always be maintained. Once a network connection breaks (even-- temporarily) no further communication on that connection will be possible.-- For example, if process A sends a message to process B, and A is then -- notified (by monitor notification) that it got disconnected from B, A will-- not be able to send any further messages to B, /unless/ A explicitly -- indicates that it is acceptable to attempt to reconnect to B using the-- Cloud Haskell 'reconnect' primitive. ---- Importantly, when A calls 'reconnect' it acknowledges that some messages to-- B might have been lost. For instance, if A sends messages m1 and m2 to B,-- then receives a monitor notification that its connection to B has been lost,-- calls 'reconnect' and then sends m3, it is possible that B will receive m1-- and m3 but not m2.---- Note that 'reconnect' does not mean /reconnect now/ but rather /it is okay-- to attempt to reconnect on the next send/. In particular, if no further-- communication attempts are made to B then A can use reconnect to clean up-- its connection to B.reconnect::ProcessId->Process()reconnectthem=dous<-getSelfPidnode<-processNode<$>askliftIO$disconnectnode(ProcessIdentifierus)(ProcessIdentifierthem)-- | Reconnect to a sendport. See 'reconnect' for more information.reconnectPort::SendPorta->Process()reconnectPortthem=dous<-getSelfPidnode<-processNode<$>askliftIO$disconnectnode(ProcessIdentifierus)(SendPortIdentifier(sendPortIdthem))---------------------------------------------------------------------------------- Auxiliary functions ----------------------------------------------------------------------------------getMonitorRefFor::Identifier->ProcessMonitorRefgetMonitorRefForident=doproc<-askliftIO$modifyMVar(processStateproc)$\st->doletcounter=st^.monitorCounterreturn(monitorCounter^:(+1)$st,MonitorRefidentcounter)getSpawnRef::ProcessSpawnRefgetSpawnRef=doproc<-askliftIO$modifyMVar(processStateproc)$\st->doletcounter=st^.spawnCounterreturn(spawnCounter^:(+1)$st,SpawnRefcounter)-- | Monitor a process/node/channelmonitor'::Identifier->ProcessMonitorRefmonitor'ident=domonitorRef<-getMonitorRefForidentsendCtrlMsgNothing$MonitormonitorRefreturnmonitorRef-- | Link to a process/node/channellink'::Identifier->Process()link'=sendCtrlMsgNothing.Link-- Send a control messagesendCtrlMsg::MaybeNodeId-- ^ Nothing for the local node->ProcessSignal-- ^ Message to send ->Process()sendCtrlMsgmNidsignal=doproc<-askletmsg=NCMsg{ctrlMsgSender=ProcessIdentifier(processIdproc),ctrlMsgSignal=signal}casemNidofNothing->doctrlChan<-localCtrlChan.processNode<$>askliftIO$writeChanctrlChanmsgJustnid->liftIO$sendBinary(processNodeproc)(ProcessIdentifier(processIdproc))(NodeIdentifiernid)WithImplicitReconnectmsg