X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Factors.scm;h=8477a2899e41bc93b04180fcd78d7b01072dc7e4;hp=8f15feb8b9046258968039eb338d8a79953f3e1a;hb=60e3b7a7ea55450ccf69a04d7c64789833c4369b;hpb=70b92d795a14d1328b90dd06f8c618b2ea09332d diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm index 8f15feb..8477a28 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-message + 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) "@" @@ -423,7 +445,7 @@ Instead, actors should call create-actor." ;; Requiring mutation on message objects is clearly not great, ;; but it may be worth it...? Investigate! (replied message-replied set-message-replied!) - (deferred-reply deferred-reply set-message-deferred-reply!)) + (deferred-reply message-deferred-reply set-message-deferred-reply!)) (define* (make-message id to from action body @@ -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-missing-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)))))