basis/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 make assocs arrays random
   6 sequences channels match concurrency.messaging
   7 concurrency.distributed threads accessors ;
   8 IN: channels.remote
   9
  10 <PRIVATE
  11
  12 : remote-channels ( -- hash )
  13     \ remote-channels get-global ;
  14 PRIVATE>
  15
  16 : publish ( channel -- id )
  17     256 random-bits dup [ remote-channels set-at ] dip ;
  18
  19 : get-channel ( id -- channel )
  20     remote-channels at ;
  21
  22 : unpublish ( id -- )
  23     remote-channels delete-at ;
  24
  25 <PRIVATE
  26
  27 MATCH-VARS: ?from ?tag ?id ?value ;
  28
  29 SYMBOL: no-channel
  30
  31 : channel-process ( -- )
  32     [
  33         {
  34             { { to ?id ?value  }
  35             [ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
  36             { { from ?id }
  37             [ ?id get-channel [ from ] [ no-channel ] if* ] }
  38         } match-cond
  39     ] handle-synchronous ;
  40
  41 PRIVATE>
  42
  43 : start-channel-node ( -- )
  44     "remote-channels" get-process [
  45         "remote-channels"
  46         [ channel-process t ] "Remote channels" spawn-server
  47         register-process
  48     ] unless ;
  49
  50 TUPLE: remote-channel node id ;
  51
  52 C: <remote-channel> remote-channel
  53
  54 M: remote-channel to ( value remote-channel -- )
  55     [ [ \ to , id>> , , ] { } make ] keep
  56     node>> "remote-channels" <remote-process>
  57     send-synchronous no-channel = [ no-channel throw ] when ;
  58
  59 M: remote-channel from ( remote-channel -- value )
  60     [ [ \ from , id>> , ] { } make ] keep
  61     node>> "remote-channels" <remote-process>
  62     send-synchronous dup no-channel = [ no-channel throw ] when* ;
  63
  64 [
  65     H{ } clone \ remote-channels set-global
  66     start-channel-node
  67 ] "channel-registry" add-init-hook