From e8730daf79d226e7806df230caeed381cfcd8460 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Thu, 25 Jul 2024 15:49:13 +0200
Subject: [PATCH] work in progress: move basic definitions from
 storage/tracking to shape

---
 scopes-core.asd       |  3 ++-
 shape/shape.lisp      |  9 ++++++++-
 storage/tracking.lisp | 14 ++++++++------
 test/test-web.lisp    |  2 +-
 web/server.lisp       |  3 ++-
 5 files changed, 21 insertions(+), 10 deletions(-)

diff --git a/scopes-core.asd b/scopes-core.asd
index 61b45ba..141dd77 100644
--- a/scopes-core.asd
+++ b/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."
diff --git a/shape/shape.lisp b/shape/shape.lisp
index e26f946..22b77f0 100644
--- a/shape/shape.lisp
+++ b/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)))
diff --git a/storage/tracking.lisp b/storage/tracking.lisp
index 58d9fd6..59adce9 100644
--- a/storage/tracking.lisp
+++ b/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) 
-                               (make-instance 'track :container cont :head head)))
-   (head-fields :reader head-fields :initform '(:taskid :username))
+  ((item-class :reader item-class :initarg :item-class :initform 'track)
    (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))
diff --git a/test/test-web.lisp b/test/test-web.lisp
index ca5da74..3d2e21a 100644
--- a/test/test-web.lisp
+++ b/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>")))
diff --git a/web/server.lisp b/web/server.lisp
index a5aa54a..a935b13 100644
--- a/web/server.lisp
+++ b/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)