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: accessors assocs channels concurrency.distributed
   6 concurrency.messaging init kernel match namespaces random
   7 threads ;
   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 TUPLE: to-message id value ;
  31 TUPLE: from-message id ;
  32
  33 : channel-thread ( -- )
  34     [
  35         {
  36             { T{ to-message f ?id ?value  }
  37             [ ?value ?id get-channel [ to f ] [ drop no-channel ] if* ] }
  38             { T{ from-message f ?id }
  39             [ ?id get-channel [ from ] [ no-channel ] if* ] }
  40         } match-cond
  41     ] handle-synchronous ;
  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 PRIVATE>
  50
  51 TUPLE: remote-channel node id ;
  52
  53 C: <remote-channel> remote-channel
  54
  55 <PRIVATE
  56
  57 : send-message ( message remote-channel -- value )
  58     node>> "remote-channels" <remote-thread>
  59     send-synchronous dup no-channel = [ no-channel throw ] when* ;
  60
  61 PRIVATE>
  62
  63 M: remote-channel to
  64     [ id>> swap to-message boa ] keep send-message drop ;
  65
  66 M: remote-channel from
  67     [ id>> from-message boa ] keep send-message ;
  68
  69 [
  70     H{ } clone \ remote-channels set-global
  71     start-channel-node
  72 ] "channel-registry" add-startup-hook