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-thread ( -- )
  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-remote-thread [
  45         [ channel-thread t ] "Remote channels" spawn-server
  46         "remote-channels" register-remote-thread
  47     ] unless ;
  48
  49 TUPLE: remote-channel node id ;
  50
  51 C: <remote-channel> remote-channel
  52
  53 M: remote-channel to ( value remote-channel -- )
  54     [ [ \ to , id>> , , ] { } make ] keep
  55     node>> "remote-channels" <remote-thread>
  56     send-synchronous no-channel = [ no-channel throw ] when ;
  57
  58 M: remote-channel from ( remote-channel -- value )
  59     [ [ \ from , id>> , ] { } make ] keep
  60     node>> "remote-channels" <remote-thread>
  61     send-synchronous dup no-channel = [ no-channel throw ] when* ;
  62
  63 [
  64     H{ } clone \ remote-channels set-global
  65     start-channel-node
  66 ] "channel-registry" add-init-hook