Minor fix to send-network-message.

[sam.git] / sam.scm

diff --git a/sam.scm b/sam.scm
index 656338d..511b953 100644 (file)
--- a/sam.scm
+++ b/sam.scm
@@ -5,47 +5,49 @@
 
 (import (chicken io)
         (chicken string)
+        (chicken port)
         matchable
         srfi-18 ; threads
         srfi-69 ; hash-table
+        uuid ; ids for actors
+        uri-generic
         udp
         fifo)
 
 ;; Actors
 
-(define (make-machine host port)
-  (cons host port))
-(define (machine-host m) (car m))
-(define (machine-port m) (cdr m))
-
-(define this-machine (make-machine "localhost" 1234))
-
-(define next-actor-id
-  (let ((mutex (make-mutex "actor id mutex"))
-        (next-id 1))
-    (lambda ()
-      (let ((res #f))
-        (mutex-lock! mutex)
-        (set! res next-id)
-        (set! next-id (+ next-id 1))
-        (mutex-unlock! mutex)
-        res))))
-
-(define (address-id address) (car address))
-(define (address-machine address) (cdr address))
-(define (make-address id machine)
-  (cons id machine))
+(define this-host "localhost")
+(define this-port 8000)
+
+(define (make-address host port id)
+  (make-uri #:scheme "actor"
+            #:host host
+            #:port port
+            #:path (list '/ id)))
+
+(define address->string uri->string)
+(define string->address uri-reference)
+
+(define (make-local-address . args)
+  (make-address this-host
+                this-port
+                (if (null? args)
+                    (uuid)
+                    (car args))))
+                
+(define (address-id address) (cadr (uri-path address)))
 
 (define (address-local? address)
-  (equal? (address-machine address)
-          this-machine))
+  (and (equal? (uri-host address) this-host)
+       (equal? (uri-port address) this-port)))
 
 (define actor-table (make-hash-table))
 
 (define (make-actor beh)
-  (let* ((id (next-actor-id)))
+  (let* ((address (make-local-address))
+         (id (address-id address)))
     (hash-table-set! actor-table id beh)
-    (make-address id this-machine)))
+    address))
   
 (define (deliver-message address . message)
   (let ((id (address-id address)))
@@ -78,12 +80,15 @@
 
 (define (send-network-message address . message)
   (let ((s (udp-open-socket))
-        (machine (address-machine address)))
+        (machine (address-machine address))
+        (packet (with-output-to-string)
+               (lambda ()
+                 (print (cons (address->string address) message)))))
     (udp-bind! s #f 0)
     (udp-connect! s
                   (machine-host machine)
                   (machine-port machine))
-    (udp-send s message)
+    (udp-send s packet)
     (udp-close-socket s)))
 
 (define (next-local-message)
@@ -137,6 +142,23 @@
     (loop)))
 
 
+;; Network
+
+(define (start-network-listener)
+  (thread-start!
+   (lambda ()
+     (let ((s (udp-open-socket*)))
+       (udp-bind! s #f this-port)
+       (let loop ()
+         (let-values (((n str) (udp-recv s 1024)))
+           (print "Received " n " bytes over network: " str)
+           (match (with-input-from-string str read)
+             ((addr-str message ...)
+              (apply send-message (cons (string->address addr-str) message)))
+             (else
+              (print "Warning: received badly formatted message string '" str "'"))))
+         (loop))))))
+
 ;; System interface
 
 (define system
@@ -163,10 +185,30 @@
 
 (thread-start!
  (lambda ()
-   (thread-sleep! 10)
+   (thread-sleep! 120)
    (send-message system 'shutdown)))
 
+(print (uri->string system))
+
 (start-scheduler)
+(start-network-listener)
 (start-console)
 
+(define (boot-sam host port)
+  (start-scheduler))
+
 ;; (thread-join! scheduler-thread)
+
+(define (main)
+  (let loop ((args (cdr (argv)))
+             (host "localhost")
+             (port 8000))
+    (match args
+      ((or "-h" "--help")
+       (print-usage))
+      (((or "-p" "--port") pstr rest ...)
+       (loop rest host (string->number pstr)))
+      (("--hostname" hstr rest ...)
+       (loop rest hstr port))
+      (()
+       (boot-sam host port)))))