work in progress: move basic definitions from storage/tracking to shape

scopes-core.asd

@@ -12,9 +12,10 @@
                (:file "core/core" 
                       :depends-on ("core/message" "config" 
                                    "forge/forge" "logging" "util"))
-               (:file "core/message")
+               (:file "core/message" :depends-on ("shape/shape"))
                (:file "forge/forge")
                (:file "logging" :depends-on ("config" "util"))
+               (:file "shape/shape")
                (:file "util")
                (:file "testing" :depends-on ("util")))
   :long-description "scopes/core: The core packages of the scopes project."

shape/shape.lisp

@@ -1,4 +1,11 @@
 ;;;; cl-scopes/shape - really abstract basic data shape definitions.
 
 (defpackage :scopes/shape
-  (:use :common-lisp))
+  (:use :common-lisp)
+  (:export #:record))
+
+(in-package :scopes/shape)
+
+(defclass record ()
+  ((head :accessor head :initarg :head)
+   (data :accessor data :initform nil)))

storage/tracking.lisp

@@ -15,7 +15,8 @@
 (in-package :scopes/storage/tracking)
 
 (defclass track ()
-  ((trackid :accessor trackid :initform nil)
+  ((head-fields :reader head-fields :initarg :head-fields :initform '(:taskid :username))
+   (trackid :accessor trackid :initform nil)
    (head :accessor head :initarg :head)
    (time-stamp :accessor time-stamp :initform nil)
    (data :accessor data :initform nil)
@@ -25,19 +26,20 @@
   (funcall (getf (storage:params (storage (container tr))) :ts-sql) ts))
 
 (defclass container ()
-  ((item-factory :initform #'(lambda (cont head) 
+  ((item-class :reader item-class :initarg :item-class :initform 'track)
-                               (make-instance 'track :container cont :head head)))
-   (head-fields :reader head-fields :initform '(:taskid :username))
    (table-name :reader table-name :initform :tracks)
    (indexes :reader indexes :initform '((taskid username) (username)))
    (storage :reader storage :initarg :storage)))
 
+(defmethod head-fields ((cont container))
+  (head-fields (make-instance (item-class cont))))
+
 (defun make-item (cont &rest head)
-  (funcall (slot-value cont 'item-factory) cont head))
+  (make-instance (item-class cont) :head head :container cont))
 
 (defun head-plist (track)
   (let (pl (hv (head track)))
-    (dolist (hf (head-fields (container track)))
+    (dolist (hf (head-fields track))
       (setf (getf pl hf) (if (car hv) (car hv) ""))
       (setf hv (cdr hv)))
     pl))

test/test-web.lisp

@@ -53,6 +53,6 @@
 
 (deftest test-message (client)
   (let ((msg (message:create '(:test :data :field :info) :data '(:info "test data"))))
-    (== (util:flatten-str (client:send-message client msg)) 
+    (== (client:send-message client msg)
         "<div><div><label>info</label>: test data</div></div>")))
         ;"<dl><dt>info</dt><dd>test data</dd></dl>")))

web/server.lisp

@@ -40,6 +40,7 @@
             (getf env :request-method) 
             (getf env :request-uri)
             (gethash "accept" (getf env :headers)))
+  ;(log:debug "request: ~s" env)
   (funcall (select-app ctx env)))
 
 (defun start (ctx)
@@ -63,7 +64,7 @@
         (setf (getf env :message-head) (nthcdr (length (car r)) path))
         (return-from select-app 
                      #'(lambda () (apply (cadr r) ctx env (cddr r)))))))
-  (message-handler ctx env))
+  #'(lambda () (message-handler ctx env)))
 
 (defun match (pattern path)
     (dolist (e pattern)