;;; 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 (:jzon :com.inuoe.jzon)
                    (:storage :scopes/storage))
  (:export #:track #:trackid #:head #:head-plist #:time-stamp #:data
           #:container #:insert
           #:make-item
           #:get-track
           #:create-indexes #:create-table))

(in-package :scopes/storage/tracking)

(defclass track ()
  ((trackid :accessor trackid :initform nil)
   (head :accessor head :initarg :head)
   (time-stamp :accessor time-stamp :initform nil)
   (data :accessor data :initform nil)
   (container :reader container :initarg :container)))

(defun engine (tr)
  (storage:engine (storage (container tr))))

(defun timestamp-to-sql (tr ts)
  (funcall (getf (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))
   (table-name :reader table-name :initform :tracks)
   (indexes :reader indexes :initform '((taskid username) (username)))
   (storage :reader storage :initarg :storage)))

(defun make-item (cont &rest head)
  (funcall (slot-value cont 'item-factory) cont head))

(defun head-plist (track)
  (let (pl (hv (head track)))
    (dolist (hf (head-fields (container track)))
      (setf (getf pl hf) (if (car hv) (car hv) ""))
      (setf hv (cdr hv)))
    pl))

(defun ensure-timestamp (track)
  (if (not (time-stamp track))
    (setf (time-stamp track) (get-universal-time))))

(defun plist (track)
  (let ((vl (head-plist track)))
    (with-slots ((trid trackid) (ts time-stamp) data) track
      (if trid (setf (getf vl :trackid) trid))
      (if ts (setf (getf vl :timestamp) 
                   (storage:timestamp-to-sql (engine 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* ((st (storage cont))
         (table (storage:qualified-table-name st (table-name cont)))
         (cols (append (head-fields cont) '(:timestamp :data)))
         (row (storage:normalize-plist (car (storage:query st
           (sxql:select cols
             (sxql:from table) 
             (sxql:where (:= :trackid trid))))))))
    (build-track cont row)))

(defun build-track (cont row)
  (let* ((hv (mapcar #'(lambda (x) (getf row x)) (head-fields cont)))
         (tr (apply #'make-item cont hv)))
    (setf (trackid tr) (getf row :trackid))
    (setf (time-stamp tr) (getf row :timestamp))
    (setf (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))
     (head-fields (head-fields cont))
     (params (storage:db-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 '|''|)) 
                     head-fields)))
    (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))))))