Permalink
Browse files

fix nasty bug in lookup-triple. add beginnings of test suite.

  • Loading branch information...
1 parent 0009248 commit c4eb32b70f615639f535aa63f2a71680f9522a04 @kraison committed Mar 1, 2011
Showing with 182 additions and 122 deletions.
  1. +4 −0 lock.lisp
  2. +42 −30 store.lisp
  3. +27 −0 test-scenarios.lisp
  4. +5 −5 transaction.lisp
  5. +55 −56 triples.lisp
  6. +8 −0 vg-test.lisp
  7. +1 −1 vivace-graph-v2-package.lisp
  8. +7 −0 vivace-graph-v2-test-package.lisp
  9. +6 −1 vivace-graph-v2-test.asd
  10. +27 −29 vivace-graph-v2-test.lisp
View
@@ -1,7 +1,11 @@
(in-package #:vivace-graph-v2)
+(defun print-rw-lock (lock stream depth)
+ (format stream "#<RW-LOCK, W: ~A, R: ~A>" (lock-writer lock) (lock-readers lock)))
+
(defstruct (rw-lock
(:conc-name lock-)
+ (:print-function print-rw-lock)
(:predicate rw-lock?))
(lock (sb-thread:make-mutex) :type sb-thread:mutex)
(readers 0 :type integer)
View
@@ -112,46 +112,58 @@
(defun add-to-delete-queue (thing &optional (store *store*))
(sb-concurrency:enqueue thing (delete-queue store)))
+(defun intern-spog (s p o g)
+ (values
+ (if (stringp s) (intern s :graph-words) s)
+ (if (stringp p) (intern p :graph-words) p)
+ (if (stringp o) (intern o :graph-words) o)
+ (if (stringp g) (intern g :graph-words) g)))
+
(defun lock-pattern (subject predicate object graph &key (kind :write) (store *store*))
- (let ((lock nil) (pattern (list subject predicate object graph)))
- (sb-ext:with-locked-hash-table ((locks store))
- (setq lock
- (or (gethash pattern (locks store))
- (setf (gethash pattern (locks store))
- (get-pool-lock (lock-pool store))))))
- (if (rw-lock? lock)
- (if (eq kind :write)
- (acquire-write-lock lock)
- (acquire-read-lock lock))
- (error "Unable to get lock for ~A" pattern))))
+ (multiple-value-bind (subject predicate object graph)
+ (intern-spog subject predicate object graph)
+ (let ((lock nil) (pattern (list subject predicate object graph)))
+ (logger :info "~A: Locking pattern ~A~%" *current-transaction* pattern)
+ (sb-ext:with-locked-hash-table ((locks store))
+ (setq lock
+ (or (gethash pattern (locks store))
+ (setf (gethash pattern (locks store))
+ (get-pool-lock (lock-pool store))))))
+ (if (rw-lock? lock)
+ (if (eq kind :write)
+ (acquire-write-lock lock)
+ (acquire-read-lock lock))
+ (error "Unable to get lock for ~A" pattern)))))
(defun lock-triple (triple &key (kind :write) (store *store*))
- (lock-pattern (subject triple)
- (predicate triple)
- (object triple)
- (graph triple)
+ (lock-pattern (triple-subject triple)
+ (triple-predicate triple)
+ (triple-object triple)
+ (triple-graph triple)
:kind kind
:store store))
(defun unlock-pattern (subject predicate object graph &key kind (store *store*))
- (let ((pattern (list subject predicate object graph)))
- (sb-ext:with-locked-hash-table ((locks store))
- (let ((lock (gethash pattern (locks store))))
- (when (rw-lock? lock)
- (sb-thread:with-recursive-lock ((lock-lock lock))
- (case kind
- (:write (release-write-lock lock))
- (:read (release-read-lock lock)))
- (when (lock-unused? lock)
- (remhash pattern (locks store))
- (release-pool-lock (lock-pool store) lock))))))))
+ (multiple-value-bind (subject predicate object graph)
+ (intern-spog subject predicate object graph)
+ (let ((pattern (list subject predicate object graph)))
+ (sb-ext:with-locked-hash-table ((locks store))
+ (let ((lock (gethash pattern (locks store))))
+ (when (rw-lock? lock)
+ (sb-thread:with-recursive-lock ((lock-lock lock))
+ (case kind
+ (:write (release-write-lock lock))
+ (:read (release-read-lock lock)))
+ (when (lock-unused? lock)
+ (remhash pattern (locks store))
+ (release-pool-lock (lock-pool store) lock)))))))))
(defun unlock-triple (triple &key kind (store *store*))
(funcall #'unlock-pattern
- (subject triple)
- (predicate triple)
- (object triple)
- (graph triple)
+ (triple-subject triple)
+ (triple-predicate triple)
+ (triple-object triple)
+ (triple-graph triple)
:kind kind
:store store))
View
@@ -0,0 +1,27 @@
+(in-package #:vivace-graph-v2-test)
+
+(defparameter *basic-concurrency-1* nil)
+
+(defun basic-concurrency-1 (&optional (store *store*))
+ (let ((*store* store))
+ (let ((thr1 (make-thread
+ #'(lambda ()
+ (with-graph-transaction (*store* :timeout 10)
+ (let ((triple (add-triple "This" "is-a" "test" :graph "VGT")))
+ (format t "~%basic-concurrency-1: ~A: ~A~%"
+ (triple-id triple) triple)
+ (setq *basic-concurrency-1* triple)
+ (sleep 8))))))
+ (thr2 (make-thread #'(lambda ()
+ (sleep 11)
+ (let ((triple (lookup-triple
+ "This" "is-a" "test" "VGT")))
+ (format t "basic-concurrency-1 lookup: ~A~%" triple)
+ (if (triple-equal triple *basic-concurrency-1*)
+ (setq *basic-concurrency-1* triple)
+ (setq *basic-concurrency-1* nil)))))))
+ (join-thread thr1)
+ (join-thread thr2)
+ (format t "~%basic-concurrency-1: ~A~%" *basic-concurrency-1*)
+ *basic-concurrency-1*)))
+
View
@@ -96,7 +96,7 @@
(maphash #'(lambda (id triple)
(declare (ignore id))
(when (persistent? triple)
- (logger :info "serializing ~A" triple)
+ (logger :info "serializing ~A: ~A" (triple-id triple) triple)
(serialize triple stream)))
(gethash :id-idx (index-table (main-idx store)))))
(logger :info "Recording null byte")
@@ -232,23 +232,23 @@
:reason (format nil "Unable to execute transaction. Too may retries (~A)."
retries))
(let ((*current-transaction* (make-transaction :store store)))
- (logger :info "execute-tx starting ~A" *current-transaction*)
+ (logger :info "~A execute-tx starting" *current-transaction*)
(handler-case
(sb-ext:with-timeout timeout
(funcall fn))
(sb-ext:timeout (condition)
- (logger :info "execute-tx timeout ~A" condition)
+ (logger :info "~A execute-tx timeout ~A" *current-transaction* condition)
(rollback-tx *current-transaction*)
(release-all-locks *current-transaction*)
(execute-tx store fn timeout max-tries (1+ retries)))
(error (condition)
- (logger :info "execute-tx error ~A" condition)
+ (logger :info "~A execute-tx error ~A" *current-transaction* condition)
(rollback-tx *current-transaction*)
(release-all-locks *current-transaction*)
(error 'transaction-error
:reason (format nil "Unable to execute transaction: ~A" condition)))
(:no-error (result)
- (logger :info "execute-tx success ~A" result)
+ (logger :info "~A execute-tx success (~A)" *current-transaction* result)
(when (tx-queue *current-transaction*)
(sb-concurrency:send-message (log-mailbox store) *current-transaction*))
(release-all-locks *current-transaction*)
View
@@ -225,69 +225,68 @@
(defun lookup-triple (subject predicate object graph &key retrieve-deleted?
already-locked?)
- (flet ((lookup (s p o g)
- (multiple-value-bind (subject predicate object graph)
- (intern-spog subject predicate object graph)
- (let ((cursor (get-from-index (main-idx *store*)
- :gspoi-idx graph subject predicate object)))
- (if (cursor-value cursor)
- (let ((triple (get-from-index (main-idx *store*)
- :id-idx (cursor-value cursor))))
+ (multiple-value-bind (subject predicate object graph)
+ (intern-spog subject predicate object graph)
+ (flet ((lookup (s p o g)
+ (let ((cursor (get-from-index (main-idx *store*) :gspoi-idx g s p o)))
+ (if (uuid:uuid? (cursor-value cursor))
+ (let ((triple (cursor-value
+ (get-from-index (main-idx *store*)
+ :id-idx
+ (cursor-value cursor)))))
(when (triple? triple)
(if (deleted? triple)
(when retrieve-deleted?
triple)
- triple))))))))
- (if (or *read-uncommitted* already-locked?)
- (lookup subject predicate object graph)
- (with-graph-transaction (*store*)
- (enqueue-lock (list subject predicate object graph)
- (lock-pattern subject predicate object graph :kind :read)
- :read)
- (lookup subject predicate object graph)))))
-
-(defun intern-spog (s p o g)
- (values
- (if (stringp s) (intern s :graph-words) s)
- (if (stringp p) (intern p :graph-words) p)
- (if (stringp o) (intern o :graph-words) o)
- (if (stringp g) (intern g :graph-words) g)))
+ triple)))))))
+ (if (or *read-uncommitted* already-locked?)
+ (lookup subject predicate object graph)
+ (with-graph-transaction (*store*)
+ (enqueue-lock (list subject predicate object graph)
+ (lock-pattern subject predicate object graph :kind :read)
+ :read)
+ (lookup subject predicate object graph))))))
(defun add-triple (subject predicate object &key (graph *graph*) (index-immediate? t)
cf (persistent? t))
- (with-graph-transaction (*store*)
- (let ((lock (lock-pattern subject predicate object graph :kind :write)))
- (enqueue-lock (list subject predicate object graph) lock :write))
- (multiple-value-bind (subject predicate object graph)
- (intern-spog subject predicate object graph)
- (or
- (let ((triple (lookup-triple subject predicate object graph
- :retrieve-deleted? t
- :already-locked? t)))
- (when (triple? triple)
- (when cf
- (set-triple-cf triple cf))
- (when (deleted? triple)
- (undelete-triple triple :persistent? persistent?))
- triple))
- (let ((id (uuid:make-v1-uuid)))
- (let ((triple (make-triple :subject subject
- :predicate predicate
- :object object
- :graph graph
- :cf (or cf +cf-true+)
- :persistent? persistent?
- :id id)))
- (when persistent?
- (push (list :add-triple subject predicate object graph id nil (cf triple))
- (tx-queue *current-transaction*)))
- (push (lambda () (delete-from-index (main-idx *store*) triple :id-idx id))
- (tx-rollback *current-transaction*))
- (add-to-index (main-idx *store*) triple :id-idx id)
- (if index-immediate?
- (index-triple triple *store*)
- (enqueue-triple-for-indexing triple))
- triple))))))
+ (multiple-value-bind (subject predicate object graph)
+ (intern-spog subject predicate object graph)
+ (with-graph-transaction (*store*)
+ (logger :info "~A enqueuing lock ~A/~A/~A/~A~%" *current-transaction*
+ subject predicate object graph)
+ (let ((lock (lock-pattern subject predicate object graph :kind :write)))
+ (enqueue-lock (list subject predicate object graph) lock :write)
+ (logger :info "~A enqueued lock ~A~%" *current-transaction* lock)
+ (or
+ (let ((triple (lookup-triple subject predicate object graph
+ :retrieve-deleted? t
+ :already-locked? t)))
+ (logger :info "~A lookup-triple got ~A~%" *current-transaction* triple)
+ (when (triple? triple)
+ (when cf
+ (set-triple-cf triple cf))
+ (when (deleted? triple)
+ (undelete-triple triple :persistent? persistent?))
+ triple))
+ (let ((id (uuid:make-v1-uuid)))
+ (let ((triple (make-triple :subject subject
+ :predicate predicate
+ :object object
+ :graph graph
+ :cf (or cf +cf-true+)
+ :persistent? persistent?
+ :id id)))
+ (when persistent?
+ (push (list :add-triple subject predicate object graph id nil
+ (cf triple))
+ (tx-queue *current-transaction*)))
+ (push (lambda () (delete-from-index (main-idx *store*) triple :id-idx id))
+ (tx-rollback *current-transaction*))
+ (add-to-index (main-idx *store*) triple :id-idx id)
+ (if index-immediate?
+ (index-triple triple *store*)
+ (enqueue-triple-for-indexing triple))
+ triple)))))))
(defun get-triple-by-id (id &optional (store *store*))
(cursor-value (get-from-index (main-idx store) :id-idx id)))
View
@@ -0,0 +1,8 @@
+(require 'asdf)
+(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
+ (user-homedir-pathname))))
+ (when (probe-file quicklisp-init)
+ (load quicklisp-init)))
+(asdf:oos 'asdf:load-op 'VIVACE-GRAPH-V2-TEST)
+(in-package #:VIVACE-GRAPH-V2-TEST)
+(run-all-tests)
@@ -49,7 +49,7 @@
#:id
#:cf
#:triple-eql
- #:triple-equalp
+ #:triple-equal
#:make-anonymous-node
#:add-triple
#:get-triples
@@ -0,0 +1,7 @@
+(in-package #:cl-user)
+
+(defpackage #:vivace-graph-v2-test
+ (:use #:cl #:vivace-graph-v2 #:bordeaux-threads)
+ (:export #:run-all-tests
+ #:*test-db-dir*))
+
View
@@ -11,6 +11,11 @@
:description "Vivace Graph Version 2 Test Suite"
:long-description "Vivace Graph Version 2 Test Suite."
:depends-on (:vivace-graph-v2
+ :bordeaux-threads
+ :cl-fad
:fiveam)
- :components ((:file "vivace-graph-v2-test")))
+ :components ((:file "vivace-graph-v2-test-package")
+ (:file "test-scenarios" :depends-on ("vivace-graph-v2-test-package"))
+ (:file "vivace-graph-v2-test" :depends-on ("test-scenarios"))))
+
View
@@ -1,10 +1,3 @@
-(in-package #:cl-user)
-
-(defpackage #:vivace-graph-v2-test
- (:use #:cl #:vivace-graph-v2 #:fiveam)
- (:export #:run-all-tests
- #:*test-db-dir*))
-
(in-package #:vivace-graph-v2-test)
(defparameter *test-db-dir* #P"/var/tmp/vivace-graph-v2-test-db/")
@@ -22,26 +15,31 @@
(ensure-directories-exist *test-db-dir*)
(format t "~%~%Preparing to run all VivaceGraph Tests.~%")
(fiveam:test (vg-tests)
- ;; Basic tests of graph db
- (fiveam:is (triple-store? (create-triple-store
- :name "VGT"
- :location *test-db-dir*)))
- (fiveam:is (triple-store? *store*))
- (fiveam:is (equal "VGT" *graph*))
- (fiveam:is (triple? (add-triple "VGT" "is-a" "thing" :cf 1.0)))
- (fiveam:is (triple? (first (get-triples-list))))
- (fiveam:is (test-select *store*))
- (fiveam:is-false (close-triple-store))
- (fiveam:is (null *store*))
- (fiveam:is (triple-store? (open-triple-store
- :name "VGT"
- :location *test-db-dir*)))
- (fiveam:is (triple-store? *store*))
- (fiveam:is (equal "VGT" *graph*))
- (fiveam:is (triple? (first (get-triples-list))))
- (fiveam:is (test-select *store*))
- (fiveam:is-false (close-triple-store))
- (fiveam:finishes (cl-fad:delete-directory-and-files *test-db-dir*)))
- (fiveam:run!)
- (cl-fad:delete-directory-and-files rfd::*test-db-dir*))
+ ;; Basic tests of graph db
+ (fiveam:is (triple-store? (create-triple-store
+ :name "VGT"
+ :location *test-db-dir*)))
+ (fiveam:is (triple-store? *store*))
+ (fiveam:is (equal "VGT" *graph*))
+ (fiveam:is (triple? (add-triple "VGT" "is-a" "thing" :cf 1.0)))
+ (fiveam:is (triple? (first (get-triples-list))))
+ (fiveam:is (test-select *store*))
+ (fiveam:is-false (close-triple-store))
+ (fiveam:is (null *store*))
+ (format t "~%")
+ (fiveam:is (triple-store? (open-triple-store
+ :name "VGT"
+ :location *test-db-dir*)))
+ (fiveam:is (triple-store? *store*))
+ (fiveam:is (equal "VGT" *graph*))
+ (fiveam:is (triple? (first (get-triples-list))))
+ (fiveam:is (test-select *store*))
+ ;; Concurrency tests
+ (fiveam:is (triple? (basic-concurrency-1 *store*)))
+ (fiveam:is-false (close-triple-store))
+ (fiveam:is (null *store*))
+ (fiveam:is-false (progn
+ (cl-fad:delete-directory-and-files *test-db-dir*)
+ (probe-file *test-db-dir*))))
+ (fiveam:run!))

0 comments on commit c4eb32b

Please sign in to comment.