X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Factors.scm;h=8bff1d4365795b11c4980178cb342ef5f6a3b1a2;hp=2d42897a03740c3be374473d192d9b463e289a71;hb=cd2611c04e1bf009d2bf6d57ec9eef5ecf0214cc;hpb=55bf40bbd2d7cd5f0f14f0e2de28f71dfe1a127e

diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm
index 2d42897..8bff1d4 100644
--- a/8sync/systems/actors.scm
+++ b/8sync/systems/actors.scm
@@ -38,7 +38,9 @@
             actor-hive
             actor-message-handler
 
-            <address>
+            ;;; Commenting out the <address> type for now;
+            ;;; it may be back when we have better serializers
+            ;; <address>
             make-address address?
             address-actor-id address-hive-id
 
@@ -68,7 +70,11 @@
             reply-message reply-message-wait
 
             ez-run-hive
-            hive-bootstrap-message))
+            hive-bootstrap-message
+
+            serialize-message write-message
+            serialize-message-pretty pprint-message
+            read-message read-message-from-string))
 
 ;; For ids
 (define %random-state
@@ -108,7 +114,7 @@
 ;;; =========================
 
 (define-class <actor> ()
-  ;; An <address> object
+  ;; An address object
   (id #:init-thunk (require-slot "id")
       #:init-keyword #:id
       #:getter actor-id)
@@ -124,17 +130,31 @@
 (define-method (actor-message-handler (actor <actor>))
   (slot-ref actor 'message-handler))
 
-(define-record-type <address>
-  (make-address actor-id hive-id)  ; @@: Do we want the trailing -id?
-  address?
-  (actor-id address-actor-id)
-  (hive-id address-hive-id))
+;;; So these are the nicer representations of addresses.
+;;; However, they don't serialize so easily with scheme read/write, so we're
+;;; using the simpler cons cell version below for now.
+
+;; (define-record-type <address>
+;;   (make-address actor-id hive-id)  ; @@: Do we want the trailing -id?
+;;   address?
+;;   (actor-id address-actor-id)
+;;   (hive-id address-hive-id))
+;;
+;; (set-record-type-printer!
+;;  <address>
+;;  (lambda (record port)
+;;    (format port "<address: ~s@~s>"
+;;            (address-actor-id record) (address-hive-id record))))
+;;
+
+(define (make-address actor-id hive-id)
+  (cons actor-id hive-id))
+
+(define (address-actor-id address)
+  (car address))
 
-(set-record-type-printer!
- <address>
- (lambda (record port)
-   (format port "<address: ~s@~s>"
-           (address-actor-id record) (address-hive-id record))))
+(define (address-hive-id address)
+  (cdr address))
 
 (define (address->string address)
   (string-append (address-actor-id address) "@"
@@ -445,13 +465,22 @@ Instead, actors should call create-actor."
 ;;   change), and using existing tooling (though adding new tooling
 ;;   would be negligible in implementation effort.)
 
-(define* (message-ref message key #:optional dflt)
+;; This cons cell is immutable and unique (for eq? tests)
+(define %nothing-provided (cons 'nothing 'provided))
+
+(define* (message-ref message key #:optional (dflt %nothing-provided))
   "Extract KEY from body of MESSAGE.
 
-Optionally set default with [DFLT]"
+Optionally set default with [DFLT]
+If key not found and DFLT not provided, throw an error."
   (let ((result (assoc key (message-body message))))
     (if result (cdr result)
-        dflt)))
+        (if (eq? dflt %nothing-provided)
+            (throw 'message-missing-key
+                   "Message body does not contain key and no default provided"
+                   #:key key
+                   #:message message)
+            dflt))))
 
 
 (define (kwarg-list-to-alist args)
@@ -552,15 +581,16 @@ an integer."
   "Serialize a message for read/write"
   (list
    (message-id message)
-   (address->string (message-to message))
-   (address->string (message-from message))
+   (message-to message)
+   (message-from message)
    (message-action message)
    (message-body message)
    (message-in-reply-to message)
+   (message-wants-reply message)
    (message-replied message)
    (message-deferred-reply message)))
 
-(define (write-message message port)
+(define* (write-message message #:optional (port (current-output-port)))
   "Write out a message to a port for easy reading later.
 
 Note that if a sub-value can't be easily written to something
@@ -577,9 +607,28 @@ to improve that.  You'll need a better serializer for that.."
     (action ,(message-action message))
     (body ,(message-body message))
     (in-reply-to ,(message-in-reply-to message))
+    (wants-reply ,(message-wants-reply message))
     (replied ,(message-replied message))
     (deferred-reply ,(message-deferred-reply message))))
 
 (define (pprint-message message)
   "Pretty print a message."
   (pretty-print (serialize-message-pretty message)))
+
+(define* (read-message #:optional (port (current-input-port)))
+  "Read a message serialized via serialize-message from PORT"
+  (match (read port)
+    ((id to from action body in-reply-to wants-reply replied deferred-reply)
+     (make-message-intern
+      id to from action body
+      in-reply-to wants-reply replied deferred-reply))
+    (anything-else
+     (throw 'message-read-bad-structure
+            "Could not read message from structure"
+            anything-else))))
+
+(define (read-message-from-string message-str)
+  "Read message from MESSAGE-STR"
+  (with-input-from-string message-str
+    (lambda ()
+      (read-message (current-input-port)))))