Mercurial > demo / examples/db/xdb/xdb.lisp

 (in-package :xdb)
 
 ;;; XDB
 (defclass xdb ()
   ((location :initarg :location
              :accessor location
              :initform (required-argument "Location is required"))
    (collections :initarg :collections
                 :accessor collections
                 :initform (make-hash-table :test 'equal))))
 
 (defclass dbs ()
   ((databases :initarg :databases
         :accessor databases
         :initform (make-hash-table :test 'equal))
    (base-path :initarg :base-path
               :initform "/tmp/db/"
               :accessor base-path)))
 
 (defmethod get-db ((dbs dbs) name)
   (gethash name (databases dbs)))
 
 (defun parse-db-path (path)
   (make-pathname :directory
                  (list* :relative
                         (etypecase path
                           (cons path
                            path)
                           (string path
                            (list path))))))
 
 (defmethod add-db ((dbs dbs) name &key base-path load-from-file-p)
   (unless (gethash name (databases dbs))
     (let* ((base-path (or base-path (base-path dbs)))
            (db-path (merge-pathnames (parse-db-path name) base-path))
            (db (make-instance 'xdb :location db-path)))
       (ensure-directories-exist db-path)
       (setf (gethash name (databases dbs)) db)
       (if load-from-file-p
           (load-db db :load-from-file-p load-from-file-p)))))
 
 (defparameter *dbs* nil)
 
 (defun dbs ()
   *dbs*)
 
 (defmethod initialize-doc-container ((collection collection))
   (setf (docs collection) (make-array 0 :adjustable t :fill-pointer 0)))
 
 (defmethod map-docs (result-type function (collection collection)
                      &rest more-collections)
   (let ((result
           (map result-type function (docs collection))))
     (loop for collection in more-collections
           for results = (map result-type function (docs collection))
           if result-type
           do (setf result (concatenate result-type result results)))
     result))
 
 (defmethod find-duplicate-doc ((collection collection) doc &key function)
   (let ((test (or function #'duplicate-doc-p)))
     (map-docs
      nil
      (lambda (docx)
        (when (funcall test doc docx)
          (return-from find-duplicate-doc docx)))
      collection)))
 
 (defmethod add-doc ((collection collection) doc &key duplicate-doc-p-func)
   (when doc
     (if duplicate-doc-p-func
         (let ((dup (find-duplicate-doc collection doc :function duplicate-doc-p-func)))
           (if (not dup)
               (vector-push-extend doc (docs collection))
               (setf dup doc) ;;doing this because
               ))
         (vector-push-extend doc (docs collection)))))
 
 (defmethod store-doc ((collection collection) doc
                       &key (duplicate-doc-p-func #'duplicate-doc-p))
   (let ((dup (and duplicate-doc-p-func
                   (find-duplicate-doc collection doc
                                       :function duplicate-doc-p-func))))
     ;; a document might be considered duplicate based on the data 
     ;;contained and not its eql status as lisp object so we have to replace
     ;;it in the array with the new object effectively updating the data.
     (if dup
         (setf dup doc)
         (vector-push-extend doc (docs collection)))
     (serialize-doc collection doc))
   collection)
 
 (defmethod serialize-doc ((collection collection) doc &key)
   (let ((path (make-pathname :type "log" :defaults (db::path collection))))
     (ensure-directories-exist path)
     (db::save-doc collection doc path))
   doc)
 
 (defmethod serialize-docs (collection &key duplicate-doc-p-func)
   (map-docs
    nil
    (lambda (doc)
      (store-doc collection doc
                 :duplicate-doc-p-func duplicate-doc-p-func))
    collection))
 
 (defmethod load-from-file ((collection collection) file)
   (when (probe-file file)
     (db::load-data collection file
                (lambda (object)
                  (add-doc collection object)))))
 
 (defmethod get-collection ((db xdb) name)
   (gethash name (collections db)))
 
 (defun make-new-collection (name db &key collection-class)
   (let ((collection
          (make-instance collection-class
                          :name name
                          :path (merge-pathnames name (location db)))))
     (initialize-doc-container collection)
     collection))
 
 (defmethod add-collection ((db xdb) name
                            &key (collection-class 'collection) load-from-file-p)
   (let ((collection (or (gethash name (collections db))
                         (setf (gethash name (collections db))
                               (make-new-collection name db
                                                    :collection-class collection-class)))))
     (ensure-directories-exist (db::path collection))
     (when load-from-file-p
       (load-from-file collection
                       (make-pathname :defaults (db::path collection)
                                      :type "snap"))
       (load-from-file collection
                       (make-pathname :defaults (db::path collection)
                                      :type "log")))
     collection))
 
 (defun append-date (name)
   (format nil "~a-~a" name (file-date)))
 
 (defmethod snapshot ((collection collection))
   (let* ((backup (merge-pathnames "backup/" (db::path collection)))
          (log (make-pathname :type "log" :defaults (db::path collection)))
          (snap (make-pathname :type "snap" :defaults (db::path collection)))
          (backup-name (append-date (db::name collection)))
          (log-backup (make-pathname :name backup-name
                                     :type "log"
                                     :defaults backup))
          (snap-backup (make-pathname :name backup-name
                                      :type "snap"
                                      :defaults backup)))
     (ensure-directories-exist backup)
     (when (probe-file snap)
       (rename-file snap snap-backup))
     (when (probe-file log)
       (rename-file log log-backup))
     (db::save-data collection snap)))
 
 (defmethod snapshot ((db xdb))
   (maphash (lambda (key value)
              (declare (ignore key))
              (snapshot value))
            (collections db)))
 
 (defmethod load-db ((db xdb) &key load-from-file-p)
   (let ((unique-collections (make-hash-table :test 'equal)))
     (dolist (path (directory (format nil "~A/*.*" (location db))))
       (when (pathname-name path)
         (setf (gethash (pathname-name path) unique-collections)
               (pathname-name path))))
     (maphash  #'(lambda (key value)
                   (declare (ignore key))
                   (add-collection db value :load-from-file-p load-from-file-p))
               unique-collections)))
 
 (defmethod get-docs ((db xdb) collection-name &key return-type)
   (let ((col (gethash collection-name (collections db))))
     (if return-type
         (coerce return-type
                 (docs col))
         (docs col))))
 
 (defmethod get-doc (collection value  &key (element 'key) (test #'equal))
   (map-docs
          nil
          (lambda (doc)
            (when (funcall test (get-val doc element) value)
              (return-from get-doc doc)))
          collection))
 
 (defmethod get-doc-complex (test element value collection &rest more-collections)
   (apply #'map-docs
          nil
          (lambda (doc)
            (when (apply test (list (get-val doc element) value))
              (return-from get-doc-complex doc)))
          collection
          more-collections))
 
 (defmethod find-doc (collection &key test)
   (if test
       (map-docs
        nil
        (lambda (doc)
          (when (funcall test doc)
            (return-from find-doc doc)))
        collection)))
 
 (defmethod find-doc-complex (test collection &rest more-collections)
   (apply #'map-docs
          (lambda (doc)
            (when (funcall test doc)
              (return-from find-doc-complex doc)))
          collection
          (cdr more-collections)))
 
 (defmethod find-docs (return-type test collection)
   (coerce (loop for doc across (docs collection)
                 when (funcall test doc)
                 collect doc)
           return-type))
 
 (defclass union-docs ()
   ((docs :initarg :docs
          :accessor :docs)))
 
 (defmethod union-collection (return-type (collection collection) &rest more-collections)
   (make-instance
    'union-docs
    :docs (apply #'map-docs (list return-type collection more-collections))))
 
 (defclass join-docs ()
   ((docs :initarg :docs
           :accessor :docs)))
 
 (defclass join-result ()
   ((docs :initarg :docs
           :accessor :docs)))
 
 (defun sort-key (doc)
   (get-val doc 'key))
 
 ;; TODO: How to update log if collection is sorted? Make a snapshot?
 (defmethod sort-collection ((collection collection)
                             &key return-sort
                             (sort-value-func #'sort-key) (sort-test-func  #'>))
   (setf (docs collection)
         (sort (docs collection)
               sort-test-func
               :key sort-value-func))
   (if return-sort
       (docs collection)
       t))
 
 (defmethod db::sort-collection-temporary ((collection collection)
                             &key (sort-value-func #'sort-key) (sort-test-func  #'>))
   (let ((sorted-array (copy-array (docs collection))))
    (setf sorted-array
          (sort sorted-array
                sort-test-func
                :key sort-value-func))
    sorted-array))
 
 (defun sort-docs (docs &key (sort-value-func #'sort-key) (sort-test-func  #'>))
   :documentation "Sorts array/list of docs and returns the sorted array."
   (sort docs
         sort-test-func
         :key sort-value-func))
 
 ;;Add method for validation when updating a collection.
 
 (defclass xdb-sequence ()
   ((key :initarg :key
          :accessor key)
    (value :initarg :value
           :accessor value)))
 
 (defmethod enable-sequences ((xdb xdb))
   (add-collection xdb "sequences" 
                 :collection-class 'collection
                 :load-from-file-p t))
 
 (defmethod next-sequence ((xdb xdb) key)
   (let ((doc (get-doc (get-collection xdb "sequences") key)))
     (unless doc
       (setf doc (make-instance 'xdb-sequence :key key :value 0)))
     (incf (get-val doc 'value))
     (store-doc (get-collection xdb "sequences")
                 doc)
     (get-val doc 'value)))