110 lines
4 KiB
Common Lisp
110 lines
4 KiB
Common Lisp
;;; cl-scopes/storage/tracking.lisp
|
|
|
|
;;;; A simple generic (SQL-based) storage for tracks, messages, and other stuff.
|
|
|
|
(defpackage :scopes/storage/tracking
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:shape :scopes/shape)
|
|
(:storage :scopes/storage)
|
|
(:jzon :com.inuoe.jzon))
|
|
(:export #:track #:trackid #:time-stamp
|
|
#:container #:insert
|
|
#:make-item
|
|
#:get-track
|
|
#:create-indexes #:create-table))
|
|
|
|
(in-package :scopes/storage/tracking)
|
|
|
|
(defclass track (shape:record)
|
|
((trackid :accessor trackid :initform nil)
|
|
(time-stamp :accessor time-stamp :initform nil)
|
|
(container :reader container :initarg :container)))
|
|
|
|
(defun timestamp-to-sql (tr ts)
|
|
(funcall (getf (storage:params (storage (container tr))) :ts-sql) ts))
|
|
|
|
(defclass container ()
|
|
((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)))
|
|
|
|
(defun item-head-fields (cont)
|
|
(shape:head-fields (make-instance (item-class cont))))
|
|
|
|
(defun make-item (cont &rest head)
|
|
(make-instance (item-class cont) :head head :container cont))
|
|
|
|
(defun ensure-timestamp (track)
|
|
(if (not (time-stamp track))
|
|
(setf (time-stamp track) (get-universal-time))))
|
|
|
|
(defun plist (track)
|
|
(let ((vl (shape:head-plist track)))
|
|
(with-slots ((trid trackid) (ts time-stamp) (data shape:data)) track
|
|
(if trid (setf (getf vl :trackid) trid))
|
|
(if ts (setf (getf vl :timestamp) (timestamp-to-sql track ts)))
|
|
(if data (setf (getf vl :data) (jzon:stringify data))))
|
|
vl))
|
|
|
|
(defun insert (track)
|
|
(ensure-timestamp track)
|
|
(let* ((cont (container track))
|
|
(st (storage cont))
|
|
(table (storage:qualified-table-name st (table-name cont)))
|
|
(res (car (storage:query st
|
|
(sxql:insert-into table
|
|
(apply #'sxql:make-clause ':set= (plist track))
|
|
(sxql:returning :trackid))))))
|
|
(setf (trackid track) (cadr res))
|
|
track))
|
|
|
|
(defun get-track (cont trid)
|
|
(let* ((tr (make-item cont))
|
|
(st (storage cont))
|
|
(table (storage:qualified-table-name st (table-name cont)))
|
|
(cols (append (shape:head-fields tr) '(:timestamp :data)))
|
|
(row (storage:normalize-plist (car (storage:query st
|
|
(sxql:select cols
|
|
(sxql:from table)
|
|
(sxql:where (:= :trackid trid))))))))
|
|
(setup-track tr row)))
|
|
|
|
(defun setup-track (tr row)
|
|
(let ((hv (mapcar #'(lambda (x) (getf row x)) (shape:head-fields tr))))
|
|
(setf (shape:head tr) hv)
|
|
(setf (trackid tr) (getf row :trackid))
|
|
(setf (time-stamp tr) (getf row :timestamp))
|
|
(setf (shape:data tr)
|
|
(jzon:parse (getf row :data) :key-fn #'storage:normalize-keyword))
|
|
tr))
|
|
|
|
(defun create-table (cont)
|
|
(let* ((st (storage cont))
|
|
(tn (table-name cont))
|
|
(table (storage:qualified-table-name st tn))
|
|
(params (storage:params st))
|
|
(id-type (getf params :id-type))
|
|
(json-type (getf params :json-type))
|
|
(hf-def (mapcar #'(lambda (x) (list x :type 'text :not-null t :default '|''|))
|
|
(item-head-fields cont))))
|
|
(storage:do-sql st
|
|
(sxql:make-statement :create-table table
|
|
(nconc
|
|
`((trackid :type ,id-type :primary-key t :not-null t))
|
|
hf-def
|
|
`((timestamp :type timestamptz :not-null t :default current_timestamp)
|
|
(data :type ,json-type :not-null t :default |'{}'|)))))
|
|
(create-indexes st table tn (indexes cont))))
|
|
|
|
(defun create-indexes (st table tname ixs)
|
|
(let ((i 1)
|
|
(tn (symbol-name tname)))
|
|
(dolist (ix ixs)
|
|
(let ((ixname (intern (format nil "IDX_~a_~d" tn i))))
|
|
(incf i)
|
|
(storage:do-sql st
|
|
(sxql:create-index ixname :on (cons table ix)))))
|
|
(storage:do-sql st
|
|
(sxql:create-index (intern (format nil "IDX_~a_TS" tn))
|
|
:on (cons table '(timestamp))))))
|