From ca7c4a824ef3de0c273da01d995f8f22e343c1d2 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Wed, 7 Aug 2024 09:42:52 +0200
Subject: [PATCH] tracking:save: use - optionally restricted - key-fields
 instead of all head-fields for query

---
 storage/tracking.lisp  | 16 ++++++++++++++--
 test/test-storage.lisp |  3 ++-
 util.lisp              |  7 ++++++-
 3 files changed, 22 insertions(+), 4 deletions(-)

diff --git a/storage/tracking.lisp b/storage/tracking.lisp
index 7300d77..94f0bec 100644
--- a/storage/tracking.lisp
+++ b/storage/tracking.lisp
@@ -21,10 +21,21 @@
 (defvar *build-track-data* #'alx:hash-table-plist)
 
 (defclass track (shape:record)
-  ((trackid :accessor trackid :initform nil)
+  ((key-fields :reader key-fields :initarg :key-fields :initform nil :allocation :class)
+   (trackid :accessor trackid :initform nil)
    (timestamp :accessor timestamp :initform nil)
    (container :reader container :initarg :container)))
 
+(defun keys-plist (rec)
+  (let ((kf (key-fields rec))
+        (hv (shape:head-plist rec)))
+    (if kf
+      (util:filter-plist hv kf)
+      hv)))
+
+(defun uid (tr)
+  (format nil "~(~a~)-~a" (short-name (container tr)) (trackid tr)))
+
 (defun timestamp-to-sql (tr ts)
   (funcall (getf (storage:params (storage (container tr))) :ts-sql) ts))
 
@@ -77,7 +88,8 @@
          (force-insert (force-insert-when cont)))
     (if (eql force-insert :always)
       (insert track)
-      (let ((found (query-last cont (shape:head-plist track))))
+      ;(let ((found (query-last cont (shape:head-plist track))))
+      (let ((found (query-last cont (keys-plist track))))
         (if found
           (if (track-equal found track)
             found
diff --git a/test/test-storage.lisp b/test/test-storage.lisp
index 95c386e..5ce2303 100644
--- a/test/test-storage.lisp
+++ b/test/test-storage.lisp
@@ -84,8 +84,9 @@
 (deftest test-folder (ctx)
   (let ((st (storage:storage ctx))
         (data (make-hash-table))
-        cont f1 f2 f3)
+        cont root f1 f2 f3)
     (setf cont (folder:make-container st))
     (storage:drop-table st :folders)
     (tracking:create-table cont)
+    ;(setf root (folder:root))
     ))
diff --git a/util.lisp b/util.lisp
index 1e9b797..18e6584 100644
--- a/util.lisp
+++ b/util.lisp
@@ -3,7 +3,7 @@
 (defpackage :scopes/util
   (:use :common-lisp)
   (:export #:lg #:lgd #:lgi
-           #:rtrim #:loop-plist #:plist-pairs #:plist-equal
+           #:rtrim #:loop-plist #:filter-plist #:plist-pairs #:plist-equal
            #:flatten-str #:to-keyword #:keyword-to-string #:to-string
            #:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string
            #:relative-path #:runtime-path #:system-path))
@@ -26,10 +26,15 @@
 (defmacro loop-plist (plist kvar vvar &body body)
   `(loop for (,kvar ,vvar . nil) on ,plist by #'cddr ,@body))
 
+(defun filter-plist (pl keys)
+  (loop-plist pl k v when (find k keys) collect v))
+
 (defun plist-pairs (pl)
   (loop-plist pl k v collect (list k v)))
 
 (defun plist-equal (l1 l2)
+  (unless (= (length l1) (length l2))
+    (return-from plist-equal nil))
   (loop-plist l1 k v do
     (unless (equal (getf l2 k) v)
       (return-from plist-equal nil)))