commit 9a894fbe1c966dbd6a613bbad720b98fe334cb13
parent cf177446e9bca4c62fa76a27ad803b454f83d818
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 27 Oct 2013 20:04:49 +0100
content addressable storage code added
Diffstat:
| A | cas.lisp | | | 178 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | cl-rw.asd | | | 3 | ++- |
2 files changed, 180 insertions(+), 1 deletion(-)
diff --git a/cas.lisp b/cas.lisp
@@ -0,0 +1,178 @@
+;;; Copyright (C) 2013 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Sofe without
+;;; restriction, irncluding without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :rw.cas
+ (:use :cl)
+ (:export :*db-pathname*
+ :defrecord
+ :defreference
+ :load-record
+ :reference-keys
+ :with-record
+ :with-record-cache))
+
+(in-package :rw.cas)
+
+(defvar *db-pathname*)
+(defvar *record-cache*)
+
+(defun object-pathname (oid)
+ (format nil "~a/objects/~a/~a" *db-pathname* (subseq oid 0 2) oid))
+
+(defun reference-pathname (kind key)
+ (format nil "~a/refs/~(~a~)/~a" *db-pathname* kind key))
+
+(defun reference-keys (kind)
+ (mapcar #'pathname-name (directory (format nil "~a/refs/~(~a~)/*" *db-pathname* kind))))
+
+(defun object-exists-p (oid)
+ (probe-file (object-pathname oid)))
+
+(defun store-object (pathname)
+ ;; cant use rename-file, errno cross device link on ccl
+ (let* ((oid (rw.os:sha1sum pathname))
+ (f (object-pathname oid)))
+ (ensure-directories-exist f)
+ ;; TODO atomic probe and move
+ (when (probe-file f)
+ (error "object ~s already exists" oid))
+ (rw.os:run-command "mv" (list "-n" (namestring pathname) (namestring f)))
+ oid))
+
+(defun store-record (record)
+ (let ((f (rw.os:make-temporary-file :template "/tmp/cafsXXXXXX")))
+ (with-open-file (s f
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :error)
+ (write record :stream s))
+ (store-object f)))
+
+(defun load-record (oid)
+ (or (gethash oid *record-cache*)
+ (setf (gethash oid *record-cache*)
+ (with-open-file (s (object-pathname oid))
+ (read s)))))
+
+(defmacro with-record-cache (() &body body)
+ `(let ((*record-cache* (make-hash-table :test #'equal)))
+ ,@body))
+
+(defun check-ptype (type value) ;; TODO
+ (assert type)
+ #+nil
+ (if (atom type)
+ (case type
+ (boolean '(q:boolean-type))
+ (integer '(q:integer-type))
+ (string '(q:varchar-type))
+ (pdate '(q:date-type))
+ (ptime '(q:time-type))
+ (ptimestamp-tz '(q:timestamp-with-timezone-type))
+ (universal-time '(q:timestamp-with-timezone-type))
+ (octet-vector '(q:blob-type))
+ (t (if (subtypep type 'persistent-type)
+ (expand-ptype-to-db (persistent-type-pkey-type type))
+ (or (get type 'db-type)
+ (expand-ptype-to-db (ptype-specifier type))))))
+ (ecase (car type)
+ (or
+ (destructuring-bind (a b) (cdr type)
+ (assert (eq 'null a))
+ (check-ptype b)))
+ (integer `(q:integer-type ,(cadr type)))
+ (string `(q:char-type ,(cadr type)))
+ (text `(q:varchar-type ,(cadr type)))))
+ value)
+
+(defun make-record (x)
+ (let ((oid (store-record x)))
+ (load-record oid) ;; TODO optimize, simply put into cache, but for now check storing works
+ oid))
+
+(defmacro defrecord (name super &body slots)
+ (let ((package (symbol-package name)))
+ `(progn
+ (defun ,(intern (format nil "MAKE-~a" name) package)
+ (&key ,@(loop
+ for slot in (car slots)
+ collect (destructuring-bind (name &key initform &allow-other-keys)
+ slot
+ (if initform
+ (list name initform)
+ name))))
+ (make-record (list ',name
+ ,@(loop
+ for slot in (car slots)
+ appending (destructuring-bind (name &key type initform)
+ slot
+ `(',name (check-ptype ',type ,name)))))))))
+ #+nil
+ `(progn
+ ,(build-defrecord name body)
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (get ',name 'defrecord-slots) ',(car body)
+ (get ',name 'defrecord-specs) ',(cdr body)))))
+
+(defmacro with-record (slots oid &body body)
+ (let ((r (gensym)))
+ `(let ((,r (load-record ,oid)))
+ (let ,(loop ;; TODO optimize, like destructuring-bind but with custom names
+ for (var slot) in slots
+ collect `(,var (getf (cdr ,r) ',slot)))
+ ,@body))))
+
+(defun load-reference (kind key)
+ (with-open-file (s (reference-pathname kind key))
+ (read s)))
+
+(defun store-reference (kind key oid how)
+ (let ((f (reference-pathname kind key)))
+ (multiple-value-bind (yes no) (ecase how
+ (:create (values :create :error))
+ (:update (values :error :supersede)))
+ (with-open-file (s f
+ :direction :output
+ :if-does-not-exist no
+ :if-exists yes)
+ (write oid :stream s)))))
+
+(defun make-reference (kind key oid)
+ (store-reference kind key oid :create))
+
+(defun update-reference (kind key oid)
+ (store-reference kind key oid :update))
+
+(defun dereference (kind key)
+ (let ((oid (load-reference kind key)))
+ (load-record oid)
+ oid))
+
+(defmacro defreference (name kind ptype) ;; TODO check ptype + sequence
+ (let ((package (symbol-package name)))
+ `(progn
+ (defun ,(intern (format nil "MAKE-~a" name) package) (key oid)
+ (make-reference ',kind key oid))
+ (defun ,(intern (format nil "UPDATE-~a" name) package) (key oid)
+ (update-reference ',kind key oid))
+ (defun ,(intern (format nil "FOLLOW-~a" name) package) (key)
+ (dereference ',kind key)))))
diff --git a/cl-rw.asd b/cl-rw.asd
@@ -49,4 +49,5 @@
(:file "http")
(:file "net")
(:file "calendar")
- (:file "ui")))
+ (:file "ui")
+ (:file "cas")))
