X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;ds=sidebyside;f=8sync%2Fsystems%2Factors.scm;h=c08916ea5d39a9b1465d7c28e2895f4523e436fa;hb=c5d1445fa4cecb4eea22d73bf0e9535e3490f6d4;hp=39cd4528338233dcca73cf1b1342c1e88665e42a;hpb=9271382a4eda5d90e33ebe9a3f28316a9dd7f423;p=8sync.git
diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm
index 39cd452..c08916e 100644
--- a/8sync/systems/actors.scm
+++ b/8sync/systems/actors.scm
@@ -24,6 +24,7 @@
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
#:use-module (8sync agenda)
#:use-module (8sync repl)
#:export (;; utilities... ought to go in their own module
@@ -37,7 +38,9 @@
actor-hive
actor-message-handler
-
+ ;;; Commenting out the type for now;
+ ;;; it may be back when we have better serializers
+ ;;
make-address address?
address-actor-id address-hive-id
@@ -67,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-mesage
+ read-message read-message-from-string))
;; For ids
(define %random-state
@@ -107,7 +114,7 @@
;;; =========================
(define-class ()
- ;; An object
+ ;; An address object
(id #:init-thunk (require-slot "id")
#:init-keyword #:id
#:getter actor-id)
@@ -123,16 +130,31 @@
(define-method (actor-message-handler (actor ))
(slot-ref actor 'message-handler))
-(define-record-type
- (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
+;; (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!
;;
;; (lambda (record port)
-;; (format port "< ~s>" (address->string record))))
+;; (format port ""
+;; (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))
+
+(define (address-hive-id address)
+ (cdr address))
(define (address->string address)
(string-append (address-actor-id address) "@"
@@ -443,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-body-lacks-key
+ "Message body does not contain key and no default provided"
+ #:key key
+ #:message message)
+ dflt))))
(define (kwarg-list-to-alist args)
@@ -540,3 +571,64 @@ an integer."
(define (hive-bootstrap-message hive to-id action . message-body-args)
(wrap
(apply send-message hive to-id action message-body-args)))
+
+
+
+;;; Convenience procedures
+;;; ======================
+
+(define (serialize-message message)
+ "Serialize a message for read/write"
+ (list
+ (message-id message)
+ (address->string (message-to message))
+ (address->string (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 #: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
+Guile's `read' procedure knows how to read, this doesn't do anything
+to improve that. You'll need a better serializer for that.."
+ (write (serialize-message message) port))
+
+(define (serialize-message-pretty message)
+ "Serialize a message in a way that's easy for humans to read."
+ `(*message*
+ (id ,(message-id message))
+ (to ,(message-to message))
+ (from ,(message-from message))
+ (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)))))