test set-up for storage: run tests with sqlite and postgresql settings

storage/storage.lisp

@@ -5,23 +5,39 @@
 (defpackage :scopes/storage
   (:use :common-lisp)
   (:export #:*db-config*
-           #:storage
+           #:make-storage
            #:drop-table))
 
 (in-package :scopes/storage)
 
 (defparameter *db-config* nil)
+(defparameter *db-engine* nil)
 
-(defclass storage-factory ()
+(defclass db-engine ()
   ((params :initarg :params)
    (config :initarg :config)))
 
 (defclass storage ()
-  ((factory :initarg :factory)
+  ((engine :initarg :engine)
    (db)
    (schema)))
 
+(defun make-storage ()
+  (let ((engine (make-engine (getf *db-config* :db-type) *db-config*)))
+    (make-instance 'storage :engine engine)))
+
 (defun drop-table (st tn)
   st
   (print (sxql:yield
     (sxql:drop-table tn :if-exists t))))
+
+;; db-driver-specific stuff
+
+(defun make-engine (db-type config)
+  (let ((params 
+          (cond 
+            ((eq db-type :sqlite3)
+             '(:id-type integer :json-type json))
+            ((eq db-type :postgres)
+             '(:id-type bigserial :json-type jsonb)))))
+    (make-instance 'db-engine :params params :config config)))

storage/tracking.lisp

@@ -4,6 +4,7 @@
 
 (defpackage :scopes/storage/tracking
   (:use :common-lisp)
+  (:local-nicknames (:storage :scopes/storage))
   (:export #:track #:time-stamp #:data
            #:container
            #:create-table))
@@ -21,13 +22,15 @@
 
 (defun create-table (storage table-name head-fields) 
   storage
-  (let 
+  (let*
-    ((id-type 'bigserial)
+    ((params (slot-value (slot-value storage 'storage::engine) 'storage::params))
+     (id-type (getf params :id-type))
+     (json-type (getf params :json-type))
      (hf-def (mapcar #'(lambda (x) (list x :type 'text)) head-fields)))
     (print (sxql:yield
       (sxql:make-statement :create-table table-name
         (nconc
           `((trackid :type ,id-type :primary-key t))
           hf-def
-          '((timestamp :type timestamp)
+          `((timestamp :type timestamp)
-            (data :type jsonb))))))))
+            (data :type ,json-type))))))))

test/test-forge.lisp

@@ -23,26 +23,26 @@
 
 (defun test-exec ()
   (forge:exec '(4 2 +))
-  (t:== (car (forge:dstack)) 6))
+  (== (car (forge:dstack)) 6))
 
 (defun test-def ()
   (forge:exec '((dup *) "square" def))
   (forge:exec '(7 square))
-  (t:== (car (forge:dstack)) 49))
+  (== (car (forge:dstack)) 49))
 
 (defun test-exec-str ()
   (forge:exec-str "16 square")
-  (t:== (car (forge:dstack)) 256))
+  (== (car (forge:dstack)) 256))
 
 (defun test-const ()
   (forge:exec-str "17 \"c1\" const")
   (forge:exec-str "c1 square")
-  (t:== (car (forge:dstack)) 289))
+  (== (car (forge:dstack)) 289))
 
 (defun test-var ()
   (forge:exec '(24 "v1" var))
   (forge:exec '(v1 get 2 *))
-  (t:== (car (forge:dstack)) 48)
+  (== (car (forge:dstack)) 48)
   (forge:exec '(5 v1 put))
   (forge:exec '(v1 get 2 *))
-  (t:== (car (forge:dstack)) 10))
+  (== (car (forge:dstack)) 10))

test/test-storage.lisp

@@ -7,8 +7,8 @@
   (:local-nicknames (:storage :scopes/storage)
                     (:tracking :scopes/storage/tracking) 
                     (:t :scopes/testing))
-  (:export #:run #:try
+  (:export #:*db-config-postgres* #:*db-config-sqlite*
-           #:*db-config-postgres* #:*db-config-sqlite*)
+           #:run #:run-all #:run-postgres #:run-sqlite #:try)
   (:import-from :scopes/testing #:==))
 
 (in-package :scopes/test-storage)
@@ -16,13 +16,26 @@
 (defparameter *db-config-sqlite* nil)
 (defparameter *db-config-postgres* nil)
 (load "test/etc")
+
 (defun try()
   (setf storage:*db-config* *db-config-sqlite*)
   (print storage:*db-config*)
   (print *db-config-postgres*))
 
+(defun run-all ()
+  (run-sqlite)
+  (run-postgres))
+
+(defun run-sqlite ()
+  (let ((storage:*db-config* *db-config-sqlite*))
+    (run)))
+
+(defun run-postgres ()
+  (let ((storage:*db-config* *db-config-postgres*))
+    (run)))
+
 (defun run ()
-  (let ((st (make-instance 'storage:storage))
+  (let ((st (storage:make-storage))
         (t:*tst* (t:test-suite)))
     (test-track st)
     (t:show-result)))