BKNR multistore sketch

bknr.multistore.lisp

;; unfinished - I'll think of finishing this some other time mayhaps

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; BKNR.MULTISTORE
;;;; © Michał "phoe" Herda 2017
;;;; bknr.multistore.lisp

(defpackage #:bknr.multistore
  (:shadowing-import-from #:closer-mop
                          #:standard-generic-function #:defmethod #:defgeneric
                          #:standard-method #:standard-class)
  (:use #:cl
        #:closer-mop
        #:bknr.datastore
        #:split-sequence))

(in-package #:bknr.multistore)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; STORES - UTILITY
(defvar *store* 'attempted-to-create-object-without-store-context)
(defvar *store-root* #p"/tmp/gateway/")

(defgeneric store-location (object))

(defmacro with-store (store &body body)
  `(let ((*store* ,store))
     ,@body))

(defmacro with-store-and-transaction ((store &optional label) &body body)
  `(with-store ,store
     (with-transaction (,label)
       ,@body)))

(defmacro make-stores (object &body stores)
  (flet ((make-store-definition (symbol)
           (let* ((name (string symbol)))
             `(,(intern (concatenate 'string name "-STORE"))
               ,(string-downcase (concatenate 'string name "/")))))
         (store-list (definition)
           (destructuring-bind (accessor folder) definition
             `((,accessor ,object)
               (make-object-store (merge-pathnames ,folder (store-location ,object)))))))
    (let ((definitions (mapcar #'make-store-definition stores)))
      `(setf ,@(mapcan #'store-list definitions)))))

(defun make-object-store (directory)
  (ensure-directories-exist directory)
  (make-instance 'mp-store
                 :make-default nil
                 :directory directory
                 :subsystems (list (make-instance 'store-object-subsystem))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; STORAGE-CLASS
(defclass storage-class (standard-class)
  ())

(defmethod initialize-instance :before ((class storage-class) &key))

(defmethod reinitialize-instance :before ((class storage-class) &key))

(defmethod validate-superclass ((class storage-class) (super standard-class))
  t)

(defun %storage-class-slot-definition (symbol)
  (let* ((slot-name symbol)
         (reader symbol)
         (initarg nil)
         (elements (split-sequence #\- (string-downcase (string symbol))))
         (directory (%ensure-slash (first elements)))
         (initform `(make-object-store ,directory)))
    (assert (= 2 (length elements)))
    (assert (string= "store" (second elements)))
    `(:name ,slot-name
      :readers (,reader)
      :writers ((setf ,reader))
      :initarg ,initarg
      :initform ,initform
      :initfunction #'(lambda () ,initform))))

(defun %ensure-slash (string)
  (if (eql #\/ (elt string (1- (length string))))
      string
      (concatenate 'string string "/")))