extra/channels/remote/remote.factor

   1 ! Copyright (C) 2007 Chris Double. All Rights Reserved.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 ! Remote Channels
   5 USING: kernel init namespaces assocs arrays
   6 sequences channels match concurrency concurrency.distributed ;
   7 IN: channels.remote
   8
   9 <PRIVATE
  10
  11 : remote-channels ( -- hash )
  12     \ remote-channels get-global ;
  13 PRIVATE>
  14
  15 : publish ( channel -- id )
  16     random-64 dup >r remote-channels set-at r> ;
  17
  18 : get-channel ( id -- channel )
  19     remote-channels at ;
  20
  21 : unpublish ( id -- )
  22     remote-channels delete-at ;
  23
  24 <PRIVATE
  25
  26 MATCH-VARS: ?id ?value ;
  27
  28 SYMBOL: no-channel
  29
  30 : channel-process ( -- )
  31     receive
  32     {
  33         { { ?from ?tag { to ?id ?value  } }
  34           [ ?value ?id get-channel [ to f ] [ no-channel ] if* ?tag swap 2array ?from send ] }
  35         { { ?from ?tag { from ?id  } }
  36           [ ?id get-channel [ from ] [ no-channel ] if* ?tag swap 2array ?from send ] }
  37     } match-cond
  38     channel-process ;
  39
  40 PRIVATE>
  41
  42 : start-channel-node ( -- )
  43     "remote-channels" get-process [
  44       [ channel-process ] spawn "remote-channels" swap register-process
  45     ] unless ;
  46
  47 TUPLE: remote-channel node id ;
  48
  49 C: <remote-channel> remote-channel
  50
  51 M: remote-channel to ( value remote-channel -- )
  52     dup >r [ \ to , remote-channel-id , , ] { } make r>
  53     remote-channel-node "remote-channels" <remote-process>
  54     send-synchronous no-channel = [ no-channel throw ] when ;
  55
  56 M: remote-channel from ( remote-channel -- value )
  57     dup >r [ \ from , remote-channel-id , ] { } make r>
  58     remote-channel-node "remote-channels" <remote-process>
  59     send-synchronous dup no-channel = [ no-channel throw ] when* ;
  60
  61 [
  62     H{ } clone \ remote-channels set-global
  63     start-channel-node
  64 ] "channel-registry" add-init-hook