Author: lgiessmann Date: Thu Aug 4 06:35:48 2011 New Revision: 707 Log: trunk: rest-interface: added the caching of topics and their psis => can be used for /json/psis Added: trunk/playground/binary-tree.lisp Modified: trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp Added: trunk/playground/binary-tree.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/playground/binary-tree.lisp Thu Aug 4 06:35:48 2011 (r707) @@ -0,0 +1,359 @@ +;;; File: binary-tree.lisp -*- Mode: Lisp; Syntax: Common-Lisp -*- + +;; source: http://aima.cs.berkeley.edu/lisp/utilities/binary-tree.lisp + + +;;;; The following definitions implement binary search trees. + +;;; They are not balanced as yet. Currently, they all order their +;;; elements by #'<, and test for identity of elements by #'eq. + + +(defstruct search-tree-node + "node for binary search tree" + value ;; list of objects with equal key + num-elements ;; size of the value set + key ;; f-cost of the a-star-nodes + parent ;; parent of search-tree-node + leftson ;; direction of search-tree-nodes with lesser f-cost + rightson ;; direction of search-tree-nodes with greater f-cost + ) + + + +(defun make-search-tree (root-elem root-key &aux root) + "return dummy header for binary search tree, with initial + element root-elem whose key is root-key." + (setq root + (make-search-tree-node + :value nil + :parent nil + :rightson nil + :leftson (make-search-tree-node + :value (list root-elem) + :num-elements 1 + :key root-key + :leftson nil :rightson nil))) + (setf (search-tree-node-parent + (search-tree-node-leftson root)) root) + root) + + + +(defun create-sorted-tree (list-of-elems key-fun &aux root-elem root) + "return binary search tree containing list-of-elems ordered according + tp key-fun" + (if (null list-of-elems) + nil + (progn + (setq root-elem (nth (random (length list-of-elems)) list-of-elems)) + (setq list-of-elems (remove root-elem list-of-elems :test #'eq)) + (setq root (make-search-tree root-elem + (funcall key-fun root-elem))) + (dolist (elem list-of-elems) + (insert-element elem root (funcall key-fun elem))) + root))) + + + +(defun empty-tree (root) + "Predicate of search trees; return t iff empty." + (null (search-tree-node-leftson root))) + + + +(defun leftmost (tree-node &aux next) + "return leftmost descendant of tree-node" + ;; used by pop-least-element and inorder-successor + (loop (if (null (setq next (search-tree-node-leftson tree-node))) + (return tree-node) + (setq tree-node next)))) + + + +(defun rightmost (header &aux next tree-node) + "return rightmost descendant of header" + ;; used by pop-largest-element + ;; recall that root of tree is leftson of header, which is a dummy + (setq tree-node (search-tree-node-leftson header)) + (loop (if (null (setq next (search-tree-node-rightson tree-node))) + (return tree-node) + (setq tree-node next)))) + + + +(defun pop-least-element (header) + "return least element of binary search tree; delete from tree as side-effect" + ;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of + ;; which have same f-cost = key slot of search-tree-node. This function + ;; arbitrarily returns first element of list with smallest f-cost, + ;; then deletes it from the list. If it was the last element of the list + ;; for the node with smallest key, that node is deleted from the search + ;; tree. (That's why we have a pointer to the node's parent). + ;; Node with smallest f-cost is leftmost descendant of header. + (let* ( (place (leftmost header)) + (result (pop (search-tree-node-value place))) ) + (decf (search-tree-node-num-elements place)) + (when (null (search-tree-node-value place)) + (when (search-tree-node-rightson place) + (setf (search-tree-node-parent + (search-tree-node-rightson place)) + (search-tree-node-parent place))) + (setf (search-tree-node-leftson + (search-tree-node-parent place)) + (search-tree-node-rightson place))) + result)) + + + + +(defun pop-largest-element (header) + "return largest element of binary search tree; delete from tree as side-effect" + ;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of + ;; which have same key slot of search-tree-node. This function + ;; arbitrarily returns first element of list with largest key + ;; then deletes it from the list. If it was the last element of the list + ;; for the node with largest key, that node is deleted from the search + ;; tree. We need to take special account of the case when the largest element + ;; is the last element in the root node of the search-tree. In this case, it + ;; will be in the leftson of the dummy header. In all other cases, + ;; it will be in the rightson of its parent. + (let* ( (place (rightmost header)) + (result (pop (search-tree-node-value place))) ) + (decf (search-tree-node-num-elements place)) + (when (null (search-tree-node-value place)) + (cond ( (eq place (search-tree-node-leftson header)) + (setf (search-tree-node-leftson header) + (search-tree-node-leftson place)) ) + (t (when (search-tree-node-leftson place) + (setf (search-tree-node-parent + (search-tree-node-leftson place)) + (search-tree-node-parent place))) + (setf (search-tree-node-rightson + (search-tree-node-parent place)) + (search-tree-node-leftson place))))) + result)) + + + + +(defun least-key (header) + "return least key of binary search tree; no side effects" + (search-tree-node-key (leftmost header))) + + +(defun largest-key (header) + "return least key of binary search tree; no side effects" + (search-tree-node-key (rightmost header))) + + + +(defun insert-element (element parent key + &optional (direction #'search-tree-node-leftson) + &aux place) + "insert new element at proper place in binary search tree" + ;; See Reingold and Hansen, Data Structures, sect. 7.2. + ;; When called initially, parent will be the header, hence go left. + ;; Element is an a-star-node. If tree node with key = f-cost of + ;; element already exists, just push element onto list in that + ;; node's value slot. Else have to make new tree node. + (loop (cond ( (null (setq place (funcall direction parent))) + (let ( (new-node (make-search-tree-node + :value (list element) :num-elements 1 + :parent parent :key key + :leftson nil :rightson nil)) ) + (if (eq direction #'search-tree-node-leftson) + (setf (search-tree-node-leftson parent) new-node) + (setf (search-tree-node-rightson parent) new-node))) + (return t)) + ( (= key (search-tree-node-key place)) + (push element (search-tree-node-value place)) + (incf (search-tree-node-num-elements place)) + (return t)) + ( (< key (search-tree-node-key place)) + (setq parent place) + (setq direction #'search-tree-node-leftson) ) + (t (setq parent place) + (setq direction #'search-tree-node-rightson))))) + + + + +(defun randomized-insert-element (element parent key + &optional (direction #'search-tree-node-leftson) + &aux place) + "insert new element at proper place in binary search tree -- break + ties randomly" + ;; This is just like the above, except that elements with equal keys + ;; are shuffled randomly. Not a "perfect shuffle", but the point is + ;; just to randomize whenever an arbitrary choice is to be made. + + (loop (cond ( (null (setq place (funcall direction parent))) + (let ( (new-node (make-search-tree-node + :value (list element) :num-elements 1 + :parent parent :key key + :leftson nil :rightson nil)) ) + (if (eq direction #'search-tree-node-leftson) + (setf (search-tree-node-leftson parent) new-node) + (setf (search-tree-node-rightson parent) new-node))) + (return t)) + ( (= key (search-tree-node-key place)) + (setf (search-tree-node-value place) + (randomized-push element (search-tree-node-value place))) + (incf (search-tree-node-num-elements place)) + (return t)) + ( (< key (search-tree-node-key place)) + (setq parent place) + (setq direction #'search-tree-node-leftson) ) + (t (setq parent place) + (setq direction #'search-tree-node-rightson))))) + + + + +(defun randomized-push (element list) + "return list with element destructively inserted at random into list" + (let ((n (random (+ 1 (length list)))) ) + (cond ((= 0 n) + (cons element list)) + (t (push element (cdr (nthcdr (- n 1) list))) + list)))) + + + + +(defun find-element (element parent key + &optional (direction #'search-tree-node-leftson) + &aux place) + "return t if element is int tree" + (loop (cond ( (null (setq place (funcall direction parent))) + (return nil) ) + ( (= key (search-tree-node-key place)) + (return (find element (search-tree-node-value place) + :test #'eq)) ) + ( (< key (search-tree-node-key place)) + (setq parent place) + (setq direction #'search-tree-node-leftson) ) + (t (setq parent place) + (setq direction #'search-tree-node-rightson))))) + + + + + +(defun delete-element (element parent key &optional (error-p t) + &aux (direction #'search-tree-node-leftson) + place) + "delete element from binary search tree" + ;; When called initially, parent will be the header. + ;; Have to search for node containing element, using key, also + ;; keep track of parent of node. Delete element from list for + ;; node; if it's the last element on that list, delete node from + ;; binary tree. See Reingold and Hansen, Data Structures, pp. 301, 309. + ;; if error-p is t, signals error if element not found; else just + ;; returns t if element found, nil otherwise. + (loop (setq place (funcall direction parent)) + (cond ( (null place) (if error-p + (error "delete-element: element not found") + (return nil)) ) + ( (= key (search-tree-node-key place)) + (cond ( (find element (search-tree-node-value place) :test #'eq) + ;; In this case we've found the right binary + ;; search-tree node, so we should delete the + ;; element from the list of nodes + (setf (search-tree-node-value place) + (remove element (search-tree-node-value place) + :test #'eq)) + (decf (search-tree-node-num-elements place)) + (when (null (search-tree-node-value place)) + ;; If we've deleted the last element, we + ;; should delete the node from the binary search tree. + (cond ( (null (search-tree-node-leftson place)) + ;; If place has no leftson sub-tree, replace it + ;; by its right sub-tree. + (when (search-tree-node-rightson place) + (setf (search-tree-node-parent + (search-tree-node-rightson place)) + parent)) + (if (eq direction #'search-tree-node-leftson) + (setf (search-tree-node-leftson parent) + (search-tree-node-rightson place)) + (setf (search-tree-node-rightson parent) + (search-tree-node-rightson place))) ) + ( (null (search-tree-node-rightson place) ) + ;; Else if place has no right sub-tree, + ;; replace it by its left sub-tree. + (when (search-tree-node-leftson place) + (setf (search-tree-node-parent + (search-tree-node-leftson place)) + parent)) + (if (eq direction #'search-tree-node-leftson) + (setf (search-tree-node-leftson parent) + (search-tree-node-leftson place)) + (setf (search-tree-node-rightson parent) + (search-tree-node-leftson place))) ) + (t ;; Else find the "inorder-successor" of + ;; place, which must have nil leftson. + ;; Let it replace place, making its left + ;; sub-tree be place's current left + ;; sub-tree, and replace it by its own + ;; right sub-tree. (For details, see + ;; Reingold & Hansen, Data Structures, p. 301.) + (let ( (next (inorder-successor place)) ) + (setf (search-tree-node-leftson next) + (search-tree-node-leftson place)) + (setf (search-tree-node-parent + (search-tree-node-leftson next)) + next) + (if (eq direction #'search-tree-node-leftson) + (setf (search-tree-node-leftson + parent) next) + (setf (search-tree-node-rightson parent) + next)) + (unless (eq next (search-tree-node-rightson + place)) + (setf (search-tree-node-leftson + (search-tree-node-parent next)) + (search-tree-node-rightson next)) + (when (search-tree-node-rightson next) + (setf (search-tree-node-parent + (search-tree-node-rightson next)) + (search-tree-node-parent next))) + (setf (search-tree-node-rightson next) + (search-tree-node-rightson + place)) + (setf (search-tree-node-parent + (search-tree-node-rightson next)) + next)) + (setf (search-tree-node-parent next) + (search-tree-node-parent place)))))) + (return t)) + (t (if error-p + (error "delete-element: element not found") + (return nil)))) ) + ( (< key (search-tree-node-key place)) + (setq parent place) + (setq direction #'search-tree-node-leftson)) + (t (setq parent place) + (setq direction #'search-tree-node-rightson))))) + + + + + +(defun inorder-successor (tree-node) + "return inorder-successor of tree-node assuming it has a right son" + ;; this is used by function delete-element when deleting a node from + ;; the binary search tree. See Reingold and Hansen, pp. 301, 309. + ;; The inorder-successor is the leftmost descendant of the rightson. + (leftmost (search-tree-node-rightson tree-node))) + + + +(defun list-elements (parent &aux child) + "return list of elements in tree" + (append (when (setq child (search-tree-node-leftson parent)) + (list-elements child)) + (search-tree-node-value parent) + (when (setq child (search-tree-node-rightson parent)) + (list-elements child)))) Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp Wed Aug 3 12:22:06 2011 (r706) +++ trunk/src/rest_interface/rest-interface.lisp Thu Aug 4 06:35:48 2011 (r707) @@ -23,8 +23,9 @@ :json-importer :base-tools :isidorus-threading) - (:export :import-fragments-feed - :import-snapshots-feed + (:export :*use-overview-cache* + :import-fragments-feed + :import-snapshots-feed :import-tm-feed :read-url :read-fragment-feed Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp Wed Aug 3 12:22:06 2011 (r706) +++ trunk/src/rest_interface/set-up-json-interface.lisp Thu Aug 4 06:35:48 2011 (r707) @@ -19,6 +19,11 @@ that represents a list of topics and their valid psi object id's") + +(defparameter *use-overview-cache* t "if this boolean vaue is set to t, the rest + interface uses the *verview-table*-list to + cache topics and their psis.") + ;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi> (defparameter *json-get-prefix* "/json/get/(.+)$") ;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi> @@ -125,7 +130,9 @@ ;; === rest interface ======================================================== (push - (create-regex-dispatcher json-get-all-psis #'return-all-topic-psis) + (if *use-overview-cache* + (create-regex-dispatcher json-get-all-psis #'cached-return-all-topic-psis) + (create-regex-dispatcher json-get-all-psis #'return-all-topic-psis)) hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-prefix #'return-json-fragment) @@ -293,6 +300,33 @@ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) +(defun cached-return-all-topic-psis (&optional param) + "return all psis currently existing in isidorus as a list of list. every topic is a list + of psis and the entire list contains a list of topics" + (declare (ignorable param)) + (let ((http-method (hunchentoot:request-method*))) + (if (eq http-method :GET) + (progn + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + (handler-case + (with-reader-lock + (json:encode-json-to-string + (map 'list + (lambda(item) + (map 'list + (lambda(psi-oid) + (d:uri (elephant::controller-recreate-instance + elephant:*store-controller* psi-oid))) + (getf item :psis))) + *overview-table*))) + (condition (err) (progn + (setf (hunchentoot:return-code*) + hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err))))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + + (defun return-json-fragment(&optional psi) "returns the json-fragmen belonging to the psi passed by the parameter psi. If the topic is marked as deleted the corresponding fragment is treated @@ -362,7 +396,9 @@ (handler-case (let ((frag (json-importer:import-from-isidorus-json json-data))) (when frag - (push-to-cache (d:topic frag)))) + (push-to-cache (d:topic frag)) + (update-list (d:topic frag) + (d:psis (d:topic frag) :revision 0)))) (condition (err) (progn (setf (hunchentoot:return-code*) @@ -458,8 +494,11 @@ (when (typep result 'd:TopicC) (append ;;the append function is used only for suppress ;;style warnings of unused delete return values - (delete (elephant::oid result) *type-table*) - (delete (elephant::oid result) *instance-table*))) + (setf *type-table* + (delete (elephant::oid result) *type-table*)) + (setf *instance-table* + (delete (elephant::oid result) *instance-table*)) + (remove-topic-from-list result))) (format nil "")) ;operation succeeded (progn (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) @@ -506,6 +545,9 @@ (cxml:parse xml-data (cxml-dom:make-dom-builder))))) (xtm-importer:importer xml-dom :tm-id tm-id :xtm-id (xtm-importer::get-uuid)) + (with-writer-lock + (init-cache) + (init-fragments)) (format nil "")))) (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)) (condition (err) @@ -569,6 +611,7 @@ (with-writer-lock (setf *type-table* nil) (setf *instance-table* nil) + (setf *overview-table* nil) (let ((topictype (get-item-by-psi json-tmcl-constants::*topictype-psi* :revision 0)) (topictype-constraint (json-tmcl::is-type-constrained :revision 0))) @@ -576,7 +619,16 @@ (map 'list #'(lambda(top) (format t ".") (push-to-cache top topictype topictype-constraint)) - (elephant:get-instances-by-class 'TopicC))))) + (elephant:get-instances-by-class 'TopicC))) + (when *use-overview-cache* + (setf *overview-table* + (remove-null + (map 'list (lambda(top) + (when (find-item-by-revision top 0) + (list :topic (elephant::oid top) + :psis (map 'list #'elephant::oid + (psis top :revision 0))))) + (elephant:get-instances-by-class 'TopicC))))))) (defun push-to-cache (topic-instance &optional @@ -614,15 +666,16 @@ psi list." (declare (TopicC top) (List psis)) - (let ((node - (find-if (lambda(item) - (= (getf item :topic) (elephant::oid top))) - *overview-table*)) - (psi-oids (map 'list #'elephant::oid psis))) - (if node - (setf (getf node :psis) psi-oids) - (push (list :topic (elephant::oid top) :psis psi-oids) - *overview-table*)))) + (let ((top-oid (elephant::oid top))) + (let ((node + (find-if (lambda(item) + (= (getf item :topic) top-oid)) + *overview-table*)) + (psi-oids (map 'list #'elephant::oid psis))) + (if node + (setf (getf node :psis) psi-oids) + (push (list :topic top-oid :psis psi-oids) + *overview-table*))))) (defun remove-psis-from-list (top psis) @@ -630,14 +683,24 @@ to the passed topic." (declare (TopicC top) (List psis)) - (let ((node - (find-if (lambda(item) - (= (getf item :topic) (elephant::oid top))) - *overview-table*)) - (psi-oids (map 'list #'elephant::oid psis))) - (when node - (dolist (psi psi-oids) - (setf (getf node :psis) (delete psi (getf node :psis) :test #'=)))))) + (let ((top-oid (elephant::oid top))) + (let ((node + (find-if (lambda(item) + (= (getf item :topic) top-oid)) + *overview-table*)) + (psi-oids (map 'list #'elephant::oid psis))) + (when node + (dolist (psi psi-oids) + (setf (getf node :psis) (delete psi (getf node :psis) :test #'=))))))) + + +(defun remove-topic-from-list (top) + "Removes the node that represents the passed topic item." + (declare (TopicC top)) + (let ((top-oid (elephant::oid top))) + (setf *overview-table* + (delete-if (lambda(item) (= (getf item :topic) top-oid)) + *overview-table*)))) (defun add-to-list (top psis) @@ -645,11 +708,12 @@ bound to the psi list of the topic top." (declare (TopicC top) (List psis)) - (let ((node - (find-if (lambda(item) (= (getf item :topic) (elephant::oid top))) - *overview-table*)) + (let ((top-oid (elephant::oid top))) + (let ((node + (find-if (lambda(item) (= (getf item :topic) top-oid)) + *overview-table*)) (psi-oids (map 'list #'elephant::oid psis))) - (if node - (dolist (psi psi-oids) - (pushnew psi (getf node :psis) :test #'=)) - (push (list :topic top :psis psi-oids) *overview-table*)))) \ No newline at end of file + (if node + (dolist (psi psi-oids) + (pushnew psi (getf node :psis) :test #'=)) + (push (list :topic top-oid :psis psi-oids) *overview-table*))))) \ No newline at end of file