redefine message as subclass of shape:record

core/core.lisp

@@ -4,6 +4,7 @@
   (:use :common-lisp)
   (:local-nicknames (:config :scopes/config)
                     (:message :scopes/core/message)
+                    (:shape :scopes/shape)
                     (:alx :alexandria))
   (:export #:*root* #:default-setup #:default-actions 
            #:find-service #:setup-services
@@ -20,7 +21,7 @@
    (handlers :accessor handlers :initarg :handlers)))
 
 (defun select (msg acts)
-  (let ((h (message:head msg))
+  (let ((h (shape:head msg))
         (hdlrs nil))
     (dolist (a acts)
       (if (match (pattern a) h)
@@ -107,9 +108,9 @@
 (defun echo (ctx msg)
   (let ((sndr (message:sender msg)))
     (if sndr
-      (let* ((h (message:head msg))
+      (let* ((h (shape:head msg))
              (new-msg (message:create `(:scopes :echo ,@(cddr h))
-                                      :data (message:data msg))))
+                                      :data (shape:data msg))))
         (send sndr new-msg))
       (log:warn "sender missing: ~s" msg))))
 

core/message.lisp

@@ -2,6 +2,7 @@
 
 (defpackage :scopes/core/message
   (:use :common-lisp)
+  (:local-nicknames (:shape :scopes/shape))
   (:export #:message #:create
            #:head #:data #:sender))
 
@@ -9,14 +10,14 @@
 
 ;;;; message
 
-(defclass message ()
-  ((head :reader head :initarg :head)
+(defclass message (shape:record)
+  ((shape:head-fields :initform '(:domain :action :class :item))
    (sender :reader sender :initarg :sender :initform nil)
-   (timestamp)
-   (data :accessor data :initarg :data :initform nil)))
+   (timestamp)))
 
 (defun create (head &key data sender)
   (make-instance 'message :head head :data data :sender sender))
 
 (defmethod print-object ((msg message) stream)
-  (format stream "<message ~s ~s <data ~s>>" (head msg) (sender msg) (data msg)))
+  (format stream "<message ~s ~s <data ~s>>" 
+          (shape:head msg) (sender msg) (shape:data msg)))

frontend/cs-hx.lisp

@@ -7,6 +7,7 @@
   (:local-nicknames (:dom :scopes/web/dom)
                     (:message :scopes/core/message)
                     (:response :scopes/web/response)
+                    (:shape :scopes/shape)
                     (:util :scopes/util))
   (:import-from :scopes/web/dom #:div #:label)
   (:export #:render-content #:response))
@@ -16,9 +17,9 @@
 (defclass response (response:html-response) ())
 
 (defmethod response:render-content ((resp response) msg)
-  ;(dom:render (dom:dlist nil (message:data msg))))
+  ;(dom:render (dom:dlist nil (shape:data msg))))
   (dom:render
-    (div nil (util:loop-plist (message:data msg) k v collect (view-field k v)))))
+    (div nil (util:loop-plist (shape:data msg) k v collect (view-field k v)))))
 
 (defun view-field (label value)
   (div nil (label nil label) ": " value))

shape/shape.lisp

@@ -10,8 +10,8 @@
 (defclass record ()
   ((head-fields :reader head-fields :initarg :head-fields 
                 :initform '(:taskid :username) :allocation :class)
-   (head :accessor head :initarg :head)
-   (data :accessor data :initform nil)))
+   (head :reader head :initarg :head)
+   (data :accessor data :initarg :data :initform nil)))
 
 (defun head-plist (track)
   (let (pl (hv (head track)))

test/test-core.lisp

@@ -7,6 +7,7 @@
                     (:core :scopes/core)
                     (:logging :scopes/logging)
                     (:message :scopes/core/message)
+                    (:shape :scopes/shape)
                     (:util :scopes/util)
                     (:t :scopes/testing))
   (:export #:run #:user #:password)
@@ -24,18 +25,18 @@
   (core:default-setup cfg 'test-receiver))
 
 (defun check-message (ctx msg)
-  (let ((key (message:head msg)))
+  (let ((key (shape:head msg)))
     (multiple-value-bind (val found) (gethash key (expected ctx))
       (if found
         (progn
-          (if (not (equalp (message:data msg) val))
+          (if (not (equalp (shape:data msg) val))
             (t:failure "data mismatch: ~s, expected: ~s" msg val))
           (remhash key (expected ctx)))
         (t:failure "unexpected: ~s" msg)))))
 
 (defun expect (ctx msg)
-  (setf (gethash (message:head msg) (expected ctx))
-        (message:data msg)))
+  (setf (gethash (shape:head msg) (expected ctx))
+        (shape:data msg)))
 
 (defun check-expected ()
   (let ((exp (alx:hash-table-keys (expected (receiver t:*test-suite*)))))

web/client.lisp

@@ -5,6 +5,7 @@
   (:local-nicknames (:config :scopes/config)
                     (:core :scopes/core)
                     (:message :scopes/core/message)
+                    (:shape :scopes/shape)
                     (:alx :alexandria))
   (:export #:config #:base-url #:api-path #:doc-path
            #:get-page #:send-message))
@@ -22,7 +23,7 @@
 
 (defun get-page (ctx msg)
   (let* ((cfg (core:config ctx))
-         (path (getf (message:data msg) :path))
+         (path (getf (shape:data msg) :path))
          (url (str:concat (base-url cfg) (doc-path cfg) path)))
     (dex:get url :headers '(("Accept". "text/html")))))
 
@@ -30,11 +31,11 @@
   (let* ((cfg (core:config ctx))
          (url (str:concat (base-url cfg) (api-path cfg) (msgpath msg))))
     (dex:post url 
-              :content (data-as-alist (message:data msg))
+              :content (data-as-alist (shape:data msg))
               :headers `(("Accept" . ,(accept cfg))))))
 
 (defun msgpath (msg)
-  (str:join "/" (loop for p in (message:head msg) 
+  (str:join "/" (loop for p in (shape:head msg) 
                       when p collect (string-downcase p))))
 
 (defun data-as-alist (data)

web/response.lisp

@@ -3,7 +3,8 @@
 (defpackage :scopes/web/response
   (:use :common-lisp)
   (:local-nicknames (:dom :scopes/web/dom)
-                    (:message :scopes/core/message))
+                    (:message :scopes/core/message)
+                    (:shape :scopes/shape))
   (:export #:setup
            #:html-response
            #:render #:render-content #:render-not-found))
@@ -31,7 +32,7 @@
   ((ctype :initform "text/html")))
 
 (defmethod render-content ((resp html-response) msg)
-  (dom:render (dom:dlist nil (message:data msg))))
+  (dom:render (dom:dlist nil (shape:data msg))))
 
 ;;;; common definitions