cas.lisp (6653B)
1 ;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Sofe without 6 ;;; restriction, irncluding without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to the following conditions: 10 ;;; 11 ;;; The above copyright notice and this permission notice shall be 12 ;;; included in all copies or substantial portions of the Software. 13 ;;; 14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 (defpackage :rw.cas 24 (:use :cl) 25 (:export :*db-pathname* 26 :defrecord 27 :defreference 28 :load-record 29 :reference-keys 30 :with-record 31 :with-record-cache)) 32 33 (in-package :rw.cas) 34 35 (defvar *db-pathname*) 36 (defvar *record-cache*) 37 38 (defun object-pathname (oid) 39 (format nil "~a/objects/~a/~a" *db-pathname* (subseq oid 0 2) oid)) 40 41 (defun reference-pathname (kind key) 42 (format nil "~a/refs/~(~a~)/~a" *db-pathname* kind key)) 43 44 (defun reference-keys (kind) 45 (mapcar #'pathname-name (directory (format nil "~a/refs/~(~a~)/*" *db-pathname* kind)))) 46 47 (defun object-exists-p (oid) 48 (probe-file (object-pathname oid))) 49 50 (defun store-object (pathname) 51 ;; cant use rename-file, errno cross device link on ccl 52 (let* ((oid (rw.os:sha1sum pathname)) 53 (f (object-pathname oid))) 54 (ensure-directories-exist f) 55 ;; TODO atomic probe and move 56 (when (probe-file f) 57 (error "object ~s already exists" oid)) 58 (rw.os:run-command "mv" (list "-n" (namestring pathname) (namestring f))) 59 oid)) 60 61 (defun store-record (record) 62 (let ((f (rw.os:make-temporary-file :template "/tmp/cafsXXXXXX"))) 63 (with-open-file (s f 64 :direction :output 65 :if-exists :supersede 66 :if-does-not-exist :error) 67 (write record :stream s)) 68 (store-object f))) 69 70 (defun load-record (oid) 71 (or (gethash oid *record-cache*) 72 (setf (gethash oid *record-cache*) 73 (with-open-file (s (object-pathname oid)) 74 (read s))))) 75 76 (defmacro with-record-cache (() &body body) 77 `(let ((*record-cache* (make-hash-table :test #'equal))) 78 ,@body)) 79 80 (defun check-ptype (type value) ;; TODO 81 (assert type) 82 #+nil 83 (if (atom type) 84 (case type 85 (boolean '(q:boolean-type)) 86 (integer '(q:integer-type)) 87 (string '(q:varchar-type)) 88 (pdate '(q:date-type)) 89 (ptime '(q:time-type)) 90 (ptimestamp-tz '(q:timestamp-with-timezone-type)) 91 (universal-time '(q:timestamp-with-timezone-type)) 92 (octet-vector '(q:blob-type)) 93 (t (if (subtypep type 'persistent-type) 94 (expand-ptype-to-db (persistent-type-pkey-type type)) 95 (or (get type 'db-type) 96 (expand-ptype-to-db (ptype-specifier type)))))) 97 (ecase (car type) 98 (or 99 (destructuring-bind (a b) (cdr type) 100 (assert (eq 'null a)) 101 (check-ptype b))) 102 (integer `(q:integer-type ,(cadr type))) 103 (string `(q:char-type ,(cadr type))) 104 (text `(q:varchar-type ,(cadr type))))) 105 value) 106 107 (defun make-record (x) 108 (let ((oid (store-record x))) 109 (load-record oid) ;; TODO optimize, simply put into cache, but for now check storing works 110 oid)) 111 112 (defmacro defrecord (name super &body slots) 113 (let ((package (symbol-package name))) 114 `(progn 115 (defun ,(intern (format nil "MAKE-~a" name) package) 116 (&key ,@(loop 117 for slot in (car slots) 118 collect (destructuring-bind (name &key initform &allow-other-keys) 119 slot 120 (if initform 121 (list name initform) 122 name)))) 123 (make-record (list ',name 124 ,@(loop 125 for slot in (car slots) 126 appending (destructuring-bind (name &key type initform) 127 slot 128 `(',name (check-ptype ',type ,name))))))))) 129 #+nil 130 `(progn 131 ,(build-defrecord name body) 132 (eval-when (:compile-toplevel :load-toplevel :execute) 133 (setf (get ',name 'defrecord-slots) ',(car body) 134 (get ',name 'defrecord-specs) ',(cdr body))))) 135 136 (defmacro with-record (slots oid &body body) 137 (let ((r (gensym))) 138 `(let ((,r (load-record ,oid))) 139 (let ,(loop ;; TODO optimize, like destructuring-bind but with custom names 140 for (var slot) in slots 141 collect `(,var (getf (cdr ,r) ',slot))) 142 ,@body)))) 143 144 (defun load-reference (kind key) 145 (with-open-file (s (reference-pathname kind key)) 146 (read s))) 147 148 (defun store-reference (kind key oid how) 149 (let ((f (reference-pathname kind key))) 150 (ensure-directories-exist f) 151 (multiple-value-bind (n y) (ecase how 152 (:create (values :create :error)) 153 (:update (values :error :supersede))) 154 (with-open-file (s f 155 :direction :output 156 :if-does-not-exist n 157 :if-exists y) 158 (write oid :stream s))))) 159 160 (defun make-reference (kind key oid) 161 (store-reference kind key oid :create)) 162 163 (defun update-reference (kind key oid) 164 (store-reference kind key oid :update)) 165 166 (defun dereference (kind key) 167 (let ((oid (load-reference kind key))) 168 (load-record oid) 169 oid)) 170 171 (defmacro defreference (name kind ptype) ;; TODO check ptype + sequence 172 (let ((package (symbol-package name))) 173 `(progn 174 (defun ,(intern (format nil "MAKE-~a" name) package) (key oid) 175 (make-reference ',kind key oid)) 176 (defun ,(intern (format nil "UPDATE-~a" name) package) (key oid) 177 (update-reference ',kind key oid)) 178 (defun ,(intern (format nil "FOLLOW-~a" name) package) (key) 179 (dereference ',kind key)))))