Mercurial > demo / examples/db/xdb/xdb.lisp
changeset 44: |
99d4ab4f8d53 |
parent: |
81b7333f27f8
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sun, 11 Aug 2024 01:50:18 -0400 |
permissions: |
-rw-r--r-- |
description: |
update |
5 ((location :initarg :location 7 :initform (required-argument "Location is required")) 8 (collections :initarg :collections 10 :initform (make-hash-table :test 'equal)))) 13 ((databases :initarg :databases 15 :initform (make-hash-table :test 'equal)) 16 (base-path :initarg :base-path 18 :accessor base-path))) 20 (defmethod get-db ((dbs dbs) name) 21 (gethash name (databases dbs))) 23 (defun parse-db-path (path) 24 (make-pathname :directory 32 (defmethod add-db ((dbs dbs) name &key base-path load-from-file-p) 33 (unless (gethash name (databases dbs)) 34 (let* ((base-path (or base-path (base-path dbs))) 35 (db-path (merge-pathnames (parse-db-path name) base-path)) 36 (db (make-instance 'xdb :location db-path))) 37 (ensure-directories-exist db-path) 38 (setf (gethash name (databases dbs)) db) 40 (load-db db :load-from-file-p load-from-file-p))))) 42 (defparameter *dbs* nil) 47 (defmethod initialize-doc-container ((collection collection)) 48 (setf (docs collection) (make-array 0 :adjustable t :fill-pointer 0))) 50 (defmethod map-docs (result-type function (collection collection) 51 &rest more-collections) 53 (map result-type function (docs collection)))) 54 (loop for collection in more-collections 55 for results = (map result-type function (docs collection)) 57 do (setf result (concatenate result-type result results))) 60 (defmethod find-duplicate-doc ((collection collection) doc &key function) 61 (let ((test (or function #'duplicate-doc-p))) 65 (when (funcall test doc docx) 66 (return-from find-duplicate-doc docx))) 69 (defmethod add-doc ((collection collection) doc &key duplicate-doc-p-func) 71 (if duplicate-doc-p-func 72 (let ((dup (find-duplicate-doc collection doc :function duplicate-doc-p-func))) 74 (vector-push-extend doc (docs collection)) 75 (setf dup doc) ;;doing this because 77 (vector-push-extend doc (docs collection))))) 79 (defmethod store-doc ((collection collection) doc 80 &key (duplicate-doc-p-func #'duplicate-doc-p)) 81 (let ((dup (and duplicate-doc-p-func 82 (find-duplicate-doc collection doc 83 :function duplicate-doc-p-func)))) 84 ;; a document might be considered duplicate based on the data 85 ;;contained and not its eql status as lisp object so we have to replace 86 ;;it in the array with the new object effectively updating the data. 89 (vector-push-extend doc (docs collection))) 90 (serialize-doc collection doc)) 93 (defmethod serialize-doc ((collection collection) doc &key) 94 (let ((path (make-pathname :type "log" :defaults (db::path collection)))) 95 (ensure-directories-exist path) 96 (db::save-doc collection doc path)) 99 (defmethod serialize-docs (collection &key duplicate-doc-p-func) 103 (store-doc collection doc 104 :duplicate-doc-p-func duplicate-doc-p-func)) 107 (defmethod load-from-file ((collection collection) file) 108 (when (probe-file file) 109 (db::load-data collection file 111 (add-doc collection object))))) 113 (defmethod get-collection ((db xdb) name) 114 (gethash name (collections db))) 116 (defun make-new-collection (name db &key collection-class) 118 (make-instance collection-class 120 :path (merge-pathnames name (location db))))) 121 (initialize-doc-container collection) 124 (defmethod add-collection ((db xdb) name 125 &key (collection-class 'collection) load-from-file-p) 126 (let ((collection (or (gethash name (collections db)) 127 (setf (gethash name (collections db)) 128 (make-new-collection name db 129 :collection-class collection-class))))) 130 (ensure-directories-exist (db::path collection)) 131 (when load-from-file-p 132 (load-from-file collection 133 (make-pathname :defaults (db::path collection) 135 (load-from-file collection 136 (make-pathname :defaults (db::path collection) 140 (defun append-date (name) 141 (format nil "~a-~a" name (file-date))) 143 (defmethod snapshot ((collection collection)) 144 (let* ((backup (merge-pathnames "backup/" (db::path collection))) 145 (log (make-pathname :type "log" :defaults (db::path collection))) 146 (snap (make-pathname :type "snap" :defaults (db::path collection))) 147 (backup-name (append-date (db::name collection))) 148 (log-backup (make-pathname :name backup-name 151 (snap-backup (make-pathname :name backup-name 154 (ensure-directories-exist backup) 155 (when (probe-file snap) 156 (rename-file snap snap-backup)) 157 (when (probe-file log) 158 (rename-file log log-backup)) 159 (db::save-data collection snap))) 161 (defmethod snapshot ((db xdb)) 162 (maphash (lambda (key value) 163 (declare (ignore key)) 167 (defmethod load-db ((db xdb) &key load-from-file-p) 168 (let ((unique-collections (make-hash-table :test 'equal))) 169 (dolist (path (directory (format nil "~A/*.*" (location db)))) 170 (when (pathname-name path) 171 (setf (gethash (pathname-name path) unique-collections) 172 (pathname-name path)))) 173 (maphash #'(lambda (key value) 174 (declare (ignore key)) 175 (add-collection db value :load-from-file-p load-from-file-p)) 176 unique-collections))) 178 (defmethod get-docs ((db xdb) collection-name &key return-type) 179 (let ((col (gethash collection-name (collections db)))) 185 (defmethod get-doc (collection value &key (element 'key) (test #'equal)) 189 (when (funcall test (get-val doc element) value) 190 (return-from get-doc doc))) 193 (defmethod get-doc-complex (test element value collection &rest more-collections) 197 (when (apply test (list (get-val doc element) value)) 198 (return-from get-doc-complex doc))) 202 (defmethod find-doc (collection &key test) 207 (when (funcall test doc) 208 (return-from find-doc doc))) 211 (defmethod find-doc-complex (test collection &rest more-collections) 214 (when (funcall test doc) 215 (return-from find-doc-complex doc))) 217 (cdr more-collections))) 219 (defmethod find-docs (return-type test collection) 220 (coerce (loop for doc across (docs collection) 221 when (funcall test doc) 225 (defclass union-docs () 226 ((docs :initarg :docs 229 (defmethod union-collection (return-type (collection collection) &rest more-collections) 232 :docs (apply #'map-docs (list return-type collection more-collections)))) 234 (defclass join-docs () 235 ((docs :initarg :docs 238 (defclass join-result () 239 ((docs :initarg :docs 242 (defun sort-key (doc) 245 ;; TODO: How to update log if collection is sorted? Make a snapshot? 246 (defmethod sort-collection ((collection collection) 248 (sort-value-func #'sort-key) (sort-test-func #'>)) 249 (setf (docs collection) 250 (sort (docs collection) 252 :key sort-value-func)) 257 (defmethod db::sort-collection-temporary ((collection collection) 258 &key (sort-value-func #'sort-key) (sort-test-func #'>)) 259 (let ((sorted-array (copy-array (docs collection)))) 263 :key sort-value-func)) 266 (defun sort-docs (docs &key (sort-value-func #'sort-key) (sort-test-func #'>)) 267 :documentation "Sorts array/list of docs and returns the sorted array." 270 :key sort-value-func)) 272 ;;Add method for validation when updating a collection. 274 (defclass xdb-sequence () 277 (value :initarg :value 280 (defmethod enable-sequences ((xdb xdb)) 281 (add-collection xdb "sequences" 282 :collection-class 'collection 283 :load-from-file-p t)) 285 (defmethod next-sequence ((xdb xdb) key) 286 (let ((doc (get-doc (get-collection xdb "sequences") key))) 288 (setf doc (make-instance 'xdb-sequence :key key :value 0))) 289 (incf (get-val doc 'value)) 290 (store-doc (get-collection xdb "sequences") 292 (get-val doc 'value)))