-- | 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-- * Process management,terminate,ProcessTerminationException(..),getSelfPid,getSelfNode-- * Monitoring and linking,link,unlink,monitor,unmonitor-- * Logging,say-- * Registry,register,unregister,whereis,nsend,registerRemote,unregisterRemote,whereisRemote,whereisRemoteAsync,nsendRemote-- * Closures,unClosure-- * Auxiliary API,catch,expectTimeout,spawnAsync,linkNode,linkPort,unlinkNode,unlinkPort,monitorNode,monitorPort)where#if ! MIN_VERSION_base(4,6,0)importPreludehiding(catch)#endifimportData.Binary(decode)importData.Typeable(Typeable,typeOf)importData.Time.Clock(getCurrentTime)importData.Time.Format(formatTime)importSystem.Locale(defaultTimeLocale)importControl.Monad.Reader(ask)importControl.Monad.IO.Class(MonadIO,liftIO)importControl.Applicative((<$>))importControl.Exception(Exception,throw)importqualifiedControl.ExceptionasException(catch)importControl.Concurrent.MVar(modifyMVar)importControl.Concurrent.Chan(writeChan)importControl.Concurrent.STM(STM,atomically,orElse,newTChan,readTChan,newTVar,readTVar,writeTVar)importControl.Distributed.Process.Internal.CQueue(dequeue,BlockSpec(..))importControl.Distributed.Process.Serializable(Serializable,fingerprint)importData.Accessor((^.),(^:),(^=))importControl.Distributed.Process.Internal.Types(NodeId(..),ProcessId(..),LocalNode(..),LocalProcess(..),Process(..),Closure(..),Message(..),MonitorRef(..),SpawnRef(..),NCMsg(..),ProcessSignal(..),monitorCounter,spawnCounter,Closure(..),SendPort(..),ReceivePort(..),channelCounter,typedChannelWithId,TypedChannel(..),SendPortId(..),Identifier(..),procMsg,DidUnmonitor(..),DidUnlinkProcess(..),DidUnlinkNode(..),DidUnlinkPort(..),WhereIsReply(..),createMessage,Static(..))importControl.Distributed.Process.Internal.MessageT(sendMessage,sendBinary,getLocalNode)importControl.Distributed.Process.Internal.Node(runLocalProcess)importControl.Distributed.Process.Internal.Closure.Resolution(resolveClosure)importControl.Distributed.Process.Internal.Dynamic(fromDyn,dynTypeRep)---------------------------------------------------------------------------------- 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=procMsg$sendMessage(ProcessIdentifierthem)msg-- | 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->dochan<-liftIO.atomically$newTChanletlcid=st^.channelCountercid=SendPortId{sendPortProcessId=processIdproc,sendPortLocalId=lcid}sport=SendPortcidrport=ReceivePortSinglechantch=TypedChannelchanreturn((channelCounter^:(+1)).(typedChannelWithIdlcid^=Justtch)$st,(sport,rport))-- | Send a message on a typed channelsendChan::Serializablea=>SendPorta->a->Process()sendChan(SendPortcid)msg=procMsg$sendBinary(SendPortIdentifiercid)msg-- | Wait for a message on a typed channelreceiveChan::Serializablea=>ReceivePorta->ProcessareceiveChan=liftIO.atomically.receiveSTMwherereceiveSTM::ReceivePorta->STMareceiveSTM(ReceivePortSinglec)=readTChancreceiveSTM(ReceivePortBiasedps)=foldr1orElse(mapreceiveSTMps)receiveSTM(ReceivePortRRpsVar)=dops<-readTVarpsVara<-foldr1orElse(mapreceiveSTMps)writeTVarpsVar(rotateps)returnarotate::[a]->[a]rotate[]=[]rotate(x:xs)=xs++[x]-- | 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.ReceivePortBiased-- | Like 'mergePortsBiased', but with a round-robin scheduler (rather than-- left-biased)mergePortsRR::Serializablea=>[ReceivePorta]->Process(ReceivePorta)mergePortsRRps=liftIO.atomically$ReceivePortRR<$>newTVarps---------------------------------------------------------------------------------- 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->letdecoded::adecoded=decode.messageEncoding$msginifmessageFingerprintmsg==fingerprint(undefined::a)&&cdecodedthenJust$pdecodedelseNothing-- | 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$throwProcessTerminationException-- | Our own process IDgetSelfPid::ProcessProcessIdgetSelfPid=processId<$>ask-- | Get the node ID of our local nodegetSelfNode::ProcessNodeIdgetSelfNode=localNodeId<$>procMsggetLocalNode---------------------------------------------------------------------------------- Monitoring and linking ------------------------------------------------------------------------------------ | Link to a remote process (asynchronous)---- 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)monitor::ProcessId->ProcessMonitorRefmonitor=monitor'.ProcessIdentifier-- | Remove a link (synchronous)unlink::ProcessId->Process()unlinkpid=dounlinkAsyncpidreceiveWait[matchIf(\(DidUnlinkProcesspid')->pid'==pid)(\_->return())]-- | Remove a node link (synchronous)unlinkNode::NodeId->Process()unlinkNodenid=dounlinkNodeAsyncnidreceiveWait[matchIf(\(DidUnlinkNodenid')->nid'==nid)(\_->return())]-- | Remove a channel (send port) link (synchronous)unlinkPort::SendPorta->Process()unlinkPortsport=dounlinkPortAsyncsportreceiveWait[matchIf(\(DidUnlinkPortcid)->cid==sendPortIdsport)(\_->return())]-- | Remove a monitor (synchronous)unmonitor::MonitorRef->Process()unmonitorref=dounmonitorAsyncrefreceiveWait[matchIf(\(DidUnmonitorref')->ref'==ref)(\_->return())]---------------------------------------------------------------------------------- Auxiliary API ------------------------------------------------------------------------------------ | Catch exceptions within a processcatch::Exceptione=>Processa->(e->Processa)->Processacatchph=donode<-procMsggetLocalNodelproc<-askletrun::Processa->IOarunproc=runLocalProcessnodeproclprocliftIO$Exception.catch(runp)(run.h)-- | Like 'expect' but with a timeoutexpectTimeout::foralla.Serializablea=>Int->Process(Maybea)expectTimeouttimeout=receiveTimeouttimeout[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 nodemonitorNode::NodeId->ProcessMonitorRefmonitorNode=monitor'.NodeIdentifier-- | Monitor a typed channelmonitorPort::foralla.Serializablea=>SendPorta->ProcessMonitorRefmonitorPort(SendPortcid)=monitor'(SendPortIdentifiercid)-- | Remove a monitor (asynchronous)unmonitorAsync::MonitorRef->Process()unmonitorAsync=sendCtrlMsgNothing.Unmonitor-- | Link to a nodelinkNode::NodeId->Process()linkNode=link'.NodeIdentifier-- | Link to a channel (send port)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).---- The process to be registered does not have to be local itself.register::String->ProcessId->Process()registerlabelpid=sendCtrlMsgNothing(Registerlabel(Justpid))-- | Register a process with a remote registry (asynchronous).---- The process to be registered does not have to live on the same remote node.registerRemote::NodeId->String->ProcessId->Process()registerRemotenidlabelpid=sendCtrlMsg(Justnid)(Registerlabel(Justpid))-- | Remove a process from the local registry (asynchronous).unregister::String->Process()unregisterlabel=sendCtrlMsgNothing(RegisterlabelNothing)-- | Remove a process from a remote registry (asynchronous).unregisterRemote::NodeId->String->Process()unregisterRemotenidlabel=sendCtrlMsg(Justnid)(RegisterlabelNothing)-- | Query the local process registry (synchronous).whereis::String->Process(MaybeProcessId)whereislabel=dosendCtrlMsgNothing(WhereIslabel)receiveWait[matchIf(\(WhereIsReplylabel'_)->label==label')(\(WhereIsReply_mPid)->returnmPid)]-- | Query a remote process registry (synchronous)whereisRemote::NodeId->String->Process(MaybeProcessId)whereisRemotenidlabel=dowhereisRemoteAsyncnidlabelreceiveWait[matchIf(\(WhereIsReplylabel'_)->label==label')(\(WhereIsReply_mPid)->returnmPid)]-- | Query a remote process registry (asynchronous)---- Reply will come in the form of a 'WhereIsReply' messagewhereisRemoteAsync::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 ------------------------------------------------------------------------------------ | Deserialize a closureunClosure::foralla.Typeablea=>Closurea->ProcessaunClosure(Closure(Staticlabel)env)=dortable<-remoteTable<$>procMsggetLocalNodecaseresolveClosurertablelabelenvofNothing->throw.userError$"Unregistered closure "++showlabelJustdyn->return$fromDyndyn(throw(typeErrordyn))wheretypeErrordyn=userError$"lookupStatic type error: "++"cannot match "++show(dynTypeRepdyn)++" against "++show(typeOf(undefined::a))---------------------------------------------------------------------------------- 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=dous<-getSelfPidletmsg=NCMsg{ctrlMsgSender=ProcessIdentifierus,ctrlMsgSignal=signal}casemNidofNothing->doctrlChan<-localCtrlChan<$>procMsggetLocalNodeliftIO$writeChanctrlChanmsgJustnid->procMsg$sendBinary(NodeIdentifiernid)msg