isidorus-cvs

isidorus-cvs@common-lisp.net

1037 discussions

[isidorus-cvs] r709 - trunk/src/model
by lgiessmann＠common-lisp.net 04 Aug '11

04 Aug '11

Author: lgiessmann Date: Thu Aug 4 09:24:29 2011 New Revision: 709 Log: trunk: datamodel: replaced all remove-if by the destructive pendant delete-if. This change causes no problems, since elephant builds the cons-cells each time they are requested from scratch Modified: trunk/src/model/changes.lisp trunk/src/model/datamodel.lisp Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp Thu Aug 4 08:25:31 2011 (r708) +++ trunk/src/model/changes.lisp Thu Aug 4 09:24:29 2011 (r709) @@ -37,11 +37,11 @@ (:documentation "Finds all associations for a topic.") (:method ((instance TopicC) &key (revision *TM-REVISION*)) (declare (type (or integer null) revision)) - (remove-null - (remove-duplicates - (map 'list #'(lambda(role) - (parent role :revision revision)) - (player-in-roles instance :revision revision)))))) + (delete-if #'null + (remove-duplicates + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles instance :revision revision)))))) (defgeneric find-associations (instance &key revision) @@ -53,7 +53,7 @@ (d:identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri *type-instance-psi*)))) - (remove-if + (delete-if #'(lambda(assoc) (eql (instance-of assoc :revision revision) type-instance-topic)) @@ -80,7 +80,7 @@ (list (instance-of characteristic :revision revision))) (when (and (typep characteristic 'NameC) (variants characteristic :revision revision)) - (remove-if #'null + (delete-if #'null (loop for var in (variants characteristic :revision revision) append (find-referenced-topics var :revision revision)))) (when (and (typep characteristic 'OccurrenceC) @@ -274,7 +274,7 @@ (locators construct :revision revision)) (union (names construct :revision revision) (occurrences construct :revision revision))) - (remove-if-not + (delete-if-not (lambda (assoc) (eq (player (first (roles assoc :revision revision)) :revision revision) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp Thu Aug 4 08:25:31 2011 (r708) +++ trunk/src/model/datamodel.lisp Thu Aug 4 09:24:29 2011 (r709) @@ -750,11 +750,11 @@ stored in the db." (declare (symbol class-symbol) (type (or null integer) revision)) (let ((db-instances (elephant:get-instances-by-class class-symbol))) - (let ((filtered-instances (remove-if-not #'(lambda(inst) + (let ((filtered-instances (delete-if-not #'(lambda(inst) (typep inst class-symbol)) db-instances))) (if revision - (remove-null + (delete-if #'null (map 'list #'(lambda(inst) (if (or (typep inst 'CharacteristicC) (typep inst 'RoleC)) @@ -823,7 +823,7 @@ (elephant:get-instances-by-value 'OccurrenceC 'Charvalue content) (elephant:get-instances-by-value 'VariantC 'Charvalue content)))) (first - (remove-if + (delete-if #'(lambda(construct) (or (string/= (charvalue construct) content) (not (find-item-by-revision construct revision @@ -884,10 +884,10 @@ (cond ((not properties) nil) ;no properties were found -> nil ((= 0 revision) - (remove-if #'null + (delete-if #'null (map 'list #'find-most-recent-revision properties))) (t - (remove-if #'null + (delete-if #'null (map 'list #'(lambda(prop) (find-item-by-revision prop revision)) properties)))))) @@ -1379,7 +1379,7 @@ (if parent-construct (let ((parent-assoc (let ((assocs - (remove-if + (delete-if #'null (map 'list #'(lambda(assoc) (when (eql (parent-construct assoc) @@ -1738,7 +1738,7 @@ (type (or integer null) revision)) (if xtm-id (let ((possible-identifiers - (remove-if-not + (delete-if-not #'(lambda(top-id) (string= (xtm-id top-id) xtm-id)) (topic-identifiers construct :revision revision)))) @@ -2341,7 +2341,7 @@ (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*)) (declare (type (or null TopicMapC) tm) (integer revision)) - (remove-if + (delete-if #'null (map 'list #'(lambda(x) @@ -2356,7 +2356,7 @@ when (not (eq role x)) return (player role :revision revision)))) (if tm - (remove-if-not + (delete-if-not (lambda (role) (in-topicmap tm (parent role :revision revision) :revision revision)) @@ -2370,7 +2370,7 @@ (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*)) (declare (type (or null TopicMapC) tm) (integer revision)) - (remove-if + (delete-if #'null (map 'list #'(lambda(x) @@ -2383,7 +2383,7 @@ when (not (eq role x)) return (player role :revision revision)))) (if tm - (remove-if-not + (delete-if-not (lambda (role) (in-topicmap tm (parent role :revision revision) :revision revision)) @@ -2429,7 +2429,7 @@ (if self self (let ((equal-char - (remove-if #'null + (delete-if #'null (map 'list #'(lambda(char) (strictly-equivalent-constructs @@ -2506,7 +2506,7 @@ (if parent-construct (let ((parent-assoc (let ((assocs - (remove-if + (delete-if #'null (map 'list #'(lambda(assoc) (when (eql (parent-construct assoc) @@ -2655,7 +2655,7 @@ (if self self (let ((equal-var - (remove-if #'null + (delete-if #'null (map 'list #'(lambda(var) (strictly-equivalent-constructs @@ -3006,7 +3006,7 @@ (if self self (let ((equal-role - (remove-if #'null + (delete-if #'null (map 'list #'(lambda(role) (strictly-equivalent-constructs @@ -3071,7 +3071,7 @@ (if parent-construct (let ((parent-assoc (let ((assocs - (remove-if + (delete-if #'null (map 'list #'(lambda(assoc) (when (eql (parent-construct assoc) @@ -3843,7 +3843,7 @@ (error (make-missing-argument-condition "From make-association(): start-revision must be set" 'start-revision 'make-association))) (let ((association (let ((existing-associations - (remove-if + (delete-if #'null (map 'list #'(lambda(existing-association) (when (equivalent-construct @@ -3882,7 +3882,7 @@ (let ((role (let ((existing-roles (when parent - (remove-if + (delete-if #'null (map 'list #'(lambda(existing-role) (when (equivalent-construct @@ -3923,7 +3923,7 @@ (error (make-missing-argument-condition "From make-tm(): start-revision must be set" 'start-revision 'make-tm))) (let ((tm (let ((existing-tms - (remove-if + (delete-if #'null (map 'list #'(lambda(existing-tm) (when (equivalent-construct @@ -3961,7 +3961,7 @@ (error (make-missing-argument-condition "From make-topic(): start-revision must be set" 'start-revision 'make-topic))) (let ((topic (let ((existing-topics - (remove-if + (delete-if #'null (map 'list #'(lambda(existing-topic) (when (equivalent-construct @@ -4018,7 +4018,7 @@ (let ((characteristic (let ((existing-characteristics (when parent - (remove-if + (delete-if #'null (map 'list #'(lambda(existing-characteristic) (when (equivalent-construct @@ -4070,7 +4070,7 @@ (error (make-duplicate-identifier-condition (format nil "From make-pointer(): cannot create ~a with the uri ~a, since the identifier ~a with this uri already exists (merging is only supported for identifiers of the same type)" class-symbol uri existing-identifier) uri))))) (let ((identifier (let ((existing-pointer - (remove-if + (delete-if #'null (map 'list #'(lambda(existing-pointer) @@ -4144,7 +4144,7 @@ (destination ReifiableConstructC) &key (revision *TM-REVISION*)) (declare (integer revision)) - (remove-if + (delete-if #'null (append (move-identifiers source destination :revision revision) @@ -4198,7 +4198,7 @@ (dolist (typable typables) (private-delete-type typable source :revision revision) (add-type typable destination :revision revision)) - (remove-if #'null (append roles scopables typables ids)))) + (delete-if #'null (append roles scopables typables ids)))) (defgeneric move-reified-construct (source destination &key revision) @@ -4325,7 +4325,7 @@ ((typep construct 'RoleC) (roles parent :revision revision))))) (let ((all-equivalent - (remove-if + (delete-if #'null (map 'list #'(lambda(other) (when (strictly-equivalent-constructs @@ -4345,12 +4345,12 @@ (let ((all-assocs (remove-duplicates (append - (remove-if + (delete-if #'null (map 'list #'(lambda(role) (parent role :revision revision)) (player-in-roles older-topic :revision revision))) - (remove-if + (delete-if #'null (map 'list #'(lambda(constr) @@ -4360,7 +4360,7 @@ (used-as-theme older-topic :revision revision)))))))) (dolist (assoc all-assocs) (let ((all-equivalent - (remove-if + (delete-if #'null (map 'list #'(lambda(db-assoc) (when (strictly-equivalent-constructs @@ -4580,12 +4580,12 @@ &key (revision *TM-REVISION*)) (declare (integer revision)) (let ((possible-roles - (remove-if #'(lambda(role) + (delete-if #'(lambda(role) (when (parent role :revision revision) role)) (map 'list #'role (slot-p parent-construct 'roles))))) (let ((equivalent-role - (remove-if + (delete-if #'null (map 'list #'(lambda(role) @@ -4613,11 +4613,11 @@ (slot-p parent-construct 'variants)))))) (let ((possible-characteristics ;all characteristics that are not referenced ;other constructs at the given revision - (remove-if #'(lambda(char) + (delete-if #'(lambda(char) (parent char :revision revision)) all-existing-characteristics))) (let ((equivalent-construct - (remove-if + (delete-if #'null (map 'list #'(lambda(char) @@ -4647,7 +4647,7 @@ (type-instance-topic (get-item-by-psi *type-instance-psi* :revision revision)) (topics-to-hold - (remove-null + (delete-if #'null (map 'list #'(lambda(top) (let ((refs (append (used-as-type top :revision revision) @@ -4688,7 +4688,7 @@ when (and tm (typep ref 'd:TopicMapC) (eql tm ref)) return top)))) - (remove-null (list type-topic instance-topic type-instance-topic))))) + (delete-if #'null (list type-topic instance-topic type-instance-topic))))) (topics-to-remove (set-difference (list type-topic instance-topic type-instance-topic) topics-to-hold)))

1 0

[isidorus-cvs] r708 - in trunk/src: json/isidorus-json model rest_interface
by lgiessmann＠common-lisp.net 04 Aug '11

04 Aug '11

Author: lgiessmann Date: Thu Aug 4 08:25:31 2011 New Revision: 708 Log: trunk: datamode + json-exporter: implemented cahcing for the isidorus-json serialization format of fragments, i.e. a fragment is only serialized if it has changed, otherwise the stored serialization string is returned. The serialization string itself is created if the fragment changed and added to the slot serializer-cache of each fragment instance Modified: trunk/src/json/isidorus-json/json_exporter.lisp trunk/src/model/changes.lisp trunk/src/model/datamodel.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/json/isidorus-json/json_exporter.lisp ============================================================================== --- trunk/src/json/isidorus-json/json_exporter.lisp Thu Aug 4 06:35:48 2011 (r707) +++ trunk/src/json/isidorus-json/json_exporter.lisp Thu Aug 4 08:25:31 2011 (r708) @@ -12,7 +12,8 @@ (:export :export-construct-as-isidorus-json-string :get-all-topic-psis :to-json-string-summary - :make-topic-summary)) + :make-topic-summary + :serialize-fragment)) (in-package :json-exporter) @@ -478,4 +479,46 @@ (json:encode-json-to-string (getf entry :variable)) ":" (json:encode-json-to-string (getf entry :result)) ",") j-str)) - (concat (subseq j-str 0 (- (length j-str) 1)) "}"))))) \ No newline at end of file + (concat (subseq j-str 0 (- (length j-str) 1)) "}"))))) + + +;; ============================================================================= +;; --- json data fragment-serializer-cache ------------------------------------- +;; ============================================================================= + +(defgeneric set-fragment-cache (fragment) + (:documentation "sets the fragment cache, no matter if the + fragment chaged or not.") + (:method ((fragment FragmentC)) + (let ((top (topic fragment))) + (setf (slot-value fragment 'serializer-notes) + (list :psis (length (psis top :revision 0)) + :iis (length (item-identifiers top :revision 0)) + :sls (length (locators top :revision 0)) + :names (length (names top :revision 0)) + :occurrences (length (occurrences top :revision 0)) + :roles (length (player-in-roles top :revision 0)))) + (setf (slot-value fragment 'serializer-cache) + (json-exporter:export-construct-as-isidorus-json-string + fragment :revision 0)) + (serializer-cache fragment)))) + + +(defgeneric serialize-fragment (fragment) + (:documentation "returns a string that represent the isidours-json + serialization of the passed fragment instance. + This method uses the fragments serializer-cache + slot to perform faster, i.e. if the fragment has + not changed since the last time, the serializer-cache + is returned, otherwise the serialization is invoked + again.") + (:method ((fragment FragmentC)) + (cond ((null (serializer-notes fragment)) + (set-fragment-cache fragment)) + ((serializer-notes-changed-p fragment) + (set-fragment-cache fragment)) + (t + (serializer-cache fragment))))) + + + \ No newline at end of file Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp Thu Aug 4 06:35:48 2011 (r707) +++ trunk/src/model/changes.lisp Thu Aug 4 08:25:31 2011 (r708) @@ -324,6 +324,26 @@ :accessor topic :index t :documentation "changed topic (topicSI in Atom") + (serializer-cache :type String + :initform nil + :initarg :serializer-cache + :documentation "contains te serialized string + value of this FragmentC instance, + that can contain any string format, + e.g. JTM, XTM, ... depending on the + setter method.") + (serializer-notes :type List + :initform nil + :initarg :serializer-notes + :documentation "contains a list of the forms + (:psis <int> :iis <int> :sls <int> + :names <int> :occurrences <int> + :roles <int>) that indicates the + number of elements this fragment's + topic is bound to. It is only necessary + to recognize mark-as-deleted elements, + since newly added elements will result + in a completely new fragment.") (referenced-topics :type list :initarg :referenced-topics @@ -449,4 +469,41 @@ (when existing-fragments (first (sort existing-fragments #'(lambda(frg-1 frg-2) - (> (revision frg-1) (revision frg-2)))))))))) \ No newline at end of file + (> (revision frg-1) (revision frg-2)))))))))) + + +(defgeneric serializer-cache (fragment) + (:documentation "returns the slot value of serializer-cache or nil, + if it is unbound.") + (:method ((fragment FragmentC)) + (when (slot-boundp fragment 'serializer-cache) + (slot-value fragment 'serializer-cache)))) + + +(defgeneric serializer-notes (fragment) + (:documentation "returns the slot value of serializer-notes or nil, + if it is unbound.") + (:method ((fragment FragmentC)) + (when (slot-boundp fragment 'serializer-notes) + (slot-value fragment 'serializer-notes)))) + + +(defgeneric serializer-notes-changed-p (fragment) + (:documentation "Returns t if the serializer-notes slot contains + a value that does not correspond to the actual + values of the fragment.") + (:method ((fragment FragmentC)) + (let ((top (topic fragment)) + (sn (serializer-notes fragment))) + (or (/= (length (psis top :revision 0)) + (getf sn :psis)) + (/= (length (item-identifiers top :revision 0)) + (getf sn :iis)) + (/= (length (locators top :revision 0)) + (getf sn :sls)) + (/= (length (names top :revision 0)) + (getf sn :names)) + (/= (length (occurrences top :revision 0)) + (getf sn :occurrences)) + (/= (length (player-in-roles top :revision 0)) + (getf sn :roles)))))) \ No newline at end of file Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp Thu Aug 4 06:35:48 2011 (r707) +++ trunk/src/model/datamodel.lisp Thu Aug 4 08:25:31 2011 (r708) @@ -43,6 +43,9 @@ :FragmentC ;;methods, functions and macros + :serializer-notes + :serializer-cache + :serializer-notes-changed-p :instanceOf-association-p :has-identifier :get-all-identifiers-of-construct Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp Thu Aug 4 06:35:48 2011 (r707) +++ trunk/src/rest_interface/set-up-json-interface.lisp Thu Aug 4 08:25:31 2011 (r708) @@ -657,7 +657,11 @@ (let ((psis-of-top (psis top))) (when psis-of-top (format t ".") - (create-latest-fragment-of-topic (uri (first psis-of-top)))))) + (let ((fragment + (create-latest-fragment-of-topic + (uri (first psis-of-top))))) + (json-exporter:serialize-fragment fragment) + fragment)))) (elephant:get-instances-by-class 'd:TopicC)))

1 0

[isidorus-cvs] r707 - in trunk: playground src/rest_interface
by lgiessmann＠common-lisp.net 04 Aug '11

04 Aug '11

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

1 0

[isidorus-cvs] r706 - trunk/src/rest_interface
by lgiessmann＠common-lisp.net 03 Aug '11

03 Aug '11

Author: lgiessmann Date: Wed Aug 3 12:22:06 2011 New Revision: 706 Log: trunk: added the infrastructure for the caching of topics and their psis => can be used for /json/psis Modified: trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp Wed Aug 3 11:18:51 2011 (r705) +++ trunk/src/rest_interface/set-up-json-interface.lisp Wed Aug 3 12:22:06 2011 (r706) @@ -12,8 +12,12 @@ ;caching tables (defparameter *type-table* nil "Cointains integer==OIDs that represent a topic instance of a vylid type-topic") -(defparameter *instance-table* nil "Cointains integer==OIDs that represent a topic +(defparameter *instance-table* nil "Contains integer==OIDs that represent a topic instance of a valid instance-topic") +(defparameter *overview-table* nil "Is of the following structure + ((:topic <oid> :psis (<oid> <oid> <...>)) (...)) + that represents a list of topics and their + valid psi object id's") ;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi> (defparameter *json-get-prefix* "/json/get/(.+)$") @@ -602,4 +606,50 @@ (when psis-of-top (format t ".") (create-latest-fragment-of-topic (uri (first psis-of-top)))))) - (elephant:get-instances-by-class 'd:TopicC))) \ No newline at end of file + (elephant:get-instances-by-class 'd:TopicC))) + + +(defun update-list (top psis) + "Sets the psi list that is bound to the topic top to the passed + 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*)))) + + +(defun remove-psis-from-list (top psis) + "Removes the passed psis from the psi list that is bound + 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 #'=)))))) + + +(defun add-to-list (top psis) + "Adds the psis contained in the list psis to the psi list that is + 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*)) + (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

1 0

[isidorus-cvs] r705 - trunk/src/rest_interface
by lgiessmann＠common-lisp.net 03 Aug '11

03 Aug '11

Author: lgiessmann Date: Wed Aug 3 11:18:51 2011 New Revision: 705 Log: trunk: rest-interface: admin-interface: remove a debug console output from die-when-finished Modified: trunk/src/rest_interface/admin-interface.lisp Modified: trunk/src/rest_interface/admin-interface.lisp ============================================================================== --- trunk/src/rest_interface/admin-interface.lisp Wed Aug 3 01:46:00 2011 (r704) +++ trunk/src/rest_interface/admin-interface.lisp Wed Aug 3 11:18:51 2011 (r705) @@ -97,6 +97,5 @@ (defun die-when-finished() (do () (rest-interface:*ready-to-die*) - (format t "*ready-to-die*: ~a~%" rest-interface:*ready-to-die*) (sleep 1)) (sb-ext:quit)) \ No newline at end of file

1 0

[isidorus-cvs] r704 - trunk/src/rest_interface
by lgiessmann＠common-lisp.net 03 Aug '11

03 Aug '11

Author: lgiessmann Date: Wed Aug 3 01:46:00 2011 New Revision: 704 Log: trunk: rest-interface: changed the usage of reader- and writrer-locks in the rest-handlers Modified: trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp Tue Aug 2 05:17:52 2011 (r703) +++ trunk/src/rest_interface/set-up-json-interface.lisp Wed Aug 3 01:46:00 2011 (r704) @@ -177,17 +177,17 @@ "Returns all topic-psi that are valid types -> so they have to be valid to the topictype-constraint (if it exists) and the can't be abstract." (declare (ignorable param)) - (handler-case (let ((topic-types - (with-reader-lock - (map 'list #'(lambda (oid) - (elephant::controller-recreate-instance - elephant::*store-controller* oid)) - *type-table*)))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (json:encode-json-to-string - (map 'list #'(lambda(y) - (map 'list #'uri y)) - (map 'list #'psis topic-types)))) + (handler-case (with-reader-lock + (let ((topic-types + (map 'list #'(lambda (oid) + (elephant::controller-recreate-instance + elephant::*store-controller* oid)) + *type-table*))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + (json:encode-json-to-string + (map 'list #'(lambda(y) + (map 'list #'uri y)) + (map 'list #'psis topic-types))))) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -199,17 +199,17 @@ The validity is only oriented on the typing of topics, e.g. type-instance or supertype-subtype." (declare (ignorable param)) - (handler-case (let ((topic-instances - (with-reader-lock - (map 'list #'(lambda (oid) - (elephant::controller-recreate-instance - elephant::*store-controller* oid)) - *instance-table*)))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (json:encode-json-to-string - (map 'list #'(lambda(y) - (map 'list #'uri y)) - (map 'list #'psis topic-instances)))) + (handler-case (with-reader-lock + (let ((topic-instances + (map 'list #'(lambda (oid) + (elephant::controller-recreate-instance + elephant::*store-controller* oid)) + *instance-table*))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + (json:encode-json-to-string + (map 'list #'(lambda(y) + (map 'list #'uri y)) + (map 'list #'psis topic-instances))))) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -220,22 +220,22 @@ "Returns a json string of a topic depending on the passed psi as a topic-stub-construct." (assert psi) - (let ((topic (d:get-item-by-psi psi))) - (if topic - (let ((topic-json - (handler-case - (with-reader-lock + (with-reader-lock + (let ((topic (d:get-item-by-psi psi))) + (if topic + (handler-case + (progn (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (json-exporter::to-json-topicStub-string topic :revision 0)) - (condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - topic-json) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: Topic \"~a\" not found" psi))))) + (condition (err) + (progn + (setf (hunchentoot:return-code*) + hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: Topic \"~a\" not found" psi)))))) (defun return-tmcl-info-of-psis(treat-as) @@ -250,22 +250,20 @@ (hunchentoot:raw-post-data :external-format external-format :force-text t))) (handler-case - (let ((psis - (json:decode-json-from-string json-data))) - (let ((tmcl - (with-reader-lock - (json-tmcl:get-constraints-of-fragment - psis :treat-as treat-as :revision 0)))) - (if tmcl - (progn - (setf (hunchentoot:content-type*) - "application/json") ;RFC 4627 - tmcl) - (progn - (setf (hunchentoot:return-code*) - hunchentoot:+http-not-found+) - (setf (hunchentoot:content-type*) "text") - (format nil "Topic \"~a\" not found." psis))))) + (with-reader-lock + (let ((psis (json:decode-json-from-string json-data))) + (let ((tmcl (json-tmcl:get-constraints-of-fragment + psis :treat-as treat-as :revision 0))) + (if tmcl + (progn + (setf (hunchentoot:content-type*) + "application/json") ;RFC 4627 + tmcl) + (progn + (setf (hunchentoot:return-code*) + hunchentoot:+http-not-found+) + (setf (hunchentoot:content-type*) "text") + (format nil "Topic \"~a\" not found." psis)))))) (condition () (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 "{\"topicConstraints\":{\"exclusiveInstances\":null,\"subjectIdentifierConstraints\":null,\"subjectLocatorConstraints\":null,\"topicNameConstraints\":null,\"topicOccurrenceConstraints\":null,\"abstractConstraint\":false},\"associationsConstraints\":null}")))) @@ -280,10 +278,12 @@ (if (eq http-method :GET) (progn (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (handler-case (with-reader-lock - (get-all-topic-psis :revision 0)) + (handler-case + (with-reader-lock + (get-all-topic-psis :revision 0)) (condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (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+)))) @@ -298,23 +298,22 @@ (if (eq http-method :GET) (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (let ((fragment - (with-reader-lock - (get-latest-fragment-of-topic identifier)))) - (if (and fragment - (find-item-by-revision (topic fragment) 0)) - (handler-case (with-reader-lock - (export-construct-as-isidorus-json-string - fragment :revision 0)) - (condition (err) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) - (setf (hunchentoot:content-type*) "text") - (format nil "Topic \"~a\" not found" psi))))) + (with-reader-lock + (let ((fragment (get-latest-fragment-of-topic identifier))) + (if (and fragment (find-item-by-revision (topic fragment) 0)) + (handler-case + (export-construct-as-isidorus-json-string + fragment :revision 0) + (condition (err) + (progn + (setf (hunchentoot:return-code*) + hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) + (setf (hunchentoot:content-type*) "text") + (format nil "Topic \"~a\" not found" psi)))))) (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) @@ -325,22 +324,21 @@ (if (eq http-method :GET) (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (let ((fragment - (with-reader-lock - (get-latest-fragment-of-topic identifier)))) - (if (and fragment - (find-item-by-revision (topic fragment) 0)) - (handler-case (with-reader-lock - (rdf-exporter:to-rdf-string fragment)) - (condition (err) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) - (setf (hunchentoot:content-type*) "text") - (format nil "Topic \"~a\" not found" psi))))) + (with-reader-lock + (let ((fragment (get-latest-fragment-of-topic identifier))) + (if (and fragment (find-item-by-revision (topic fragment) 0)) + (handler-case + (rdf-exporter:to-rdf-string fragment) + (condition (err) + (progn + (setf (hunchentoot:return-code*) + hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) + (setf (hunchentoot:content-type*) "text") + (format nil "Topic \"~a\" not found" psi)))))) (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) @@ -351,18 +349,22 @@ (let ((http-method (hunchentoot:request-method*))) (if (or (eq http-method :PUT) (eq http-method :POST)) - (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) - (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t))) - (handler-case - (with-writer-lock + (let ((external-format + (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) + (let ((json-data + (hunchentoot:raw-post-data :external-format external-format + :force-text t))) + (with-writer-lock + (handler-case (let ((frag (json-importer:import-from-isidorus-json json-data))) (when frag - (push-to-cache (d:topic frag))))) - (condition (err) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))))) + (push-to-cache (d:topic frag)))) + (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+)))) @@ -375,42 +377,44 @@ (end-idx (handler-case (parse-integer (hunchentoot:get-parameter "end")) (condition () nil)))) - (handler-case (with-reader-lock - (let ((topics - (remove-null - (map 'list - #'(lambda(top) - (when (find-item-by-revision top 0) - top)) - (elephant:get-instances-by-class 'd:TopicC))))) - (let ((end - (cond - ((not end-idx) - (length topics)) - ((> end-idx (length topics)) - (length topics)) - ((< end-idx 0) - 0) - (t - end-idx)))) - (let ((start - (cond - ((> start-idx (length topics)) - end) - ((< start-idx 0) - 0) - (t - start-idx)))) - (let ((topics-in-range - (if (<= start end) - (subseq topics start end) - (reverse (subseq topics end start))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (json-exporter:make-topic-summary topics-in-range)))))) - (condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))))) + (with-reader-lock + (handler-case + (let ((topics + (remove-null + (map 'list + #'(lambda(top) + (when (find-item-by-revision top 0) + top)) + (elephant:get-instances-by-class 'd:TopicC))))) + (let ((end + (cond + ((not end-idx) + (length topics)) + ((> end-idx (length topics)) + (length topics)) + ((< end-idx 0) + 0) + (t + end-idx)))) + (let ((start + (cond + ((> start-idx (length topics)) + end) + ((< start-idx 0) + 0) + (t + start-idx)))) + (let ((topics-in-range + (if (<= start end) + (subseq topics start end) + (reverse (subseq topics end start))))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + (json-exporter:make-topic-summary topics-in-range))))) + (condition (err) (progn + (setf (hunchentoot:return-code*) + hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err))))))) (defun return-overview (&optional param) @@ -436,10 +440,13 @@ (let ((http-method (hunchentoot:request-method*))) (if (or (eq http-method :DELETE) (eq http-method :POST)) ;not nice - but the current ui-library can't send http-delete messages - (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) - (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t))) - (handler-case - (with-writer-lock + (let ((external-format + (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) + (let ((json-data + (hunchentoot:raw-post-data :external-format external-format + :force-text t))) + (with-writer-lock + (handler-case (let ((result (json-delete-interface:mark-as-deleted-from-json json-data :revision (d:get-revision)))) (if result @@ -452,12 +459,13 @@ (format nil "")) ;operation succeeded (progn (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) - (format nil "object not found"))))) - (condition (err) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))))) + (format nil "object not found")))) + (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+))))

1 0

[isidorus-cvs] r703 - trunk/src/json/isidorus-json
by lgiessmann＠common-lisp.net 02 Aug '11

02 Aug '11

Author: lgiessmann Date: Tue Aug 2 05:17:52 2011 New Revision: 703 Log: trunk: improved the performance of 'get-all-psis' Modified: trunk/src/json/isidorus-json/json_exporter.lisp Modified: trunk/src/json/isidorus-json/json_exporter.lisp ============================================================================== --- trunk/src/json/isidorus-json/json_exporter.lisp Tue Aug 2 01:05:59 2011 (r702) +++ trunk/src/json/isidorus-json/json_exporter.lisp Tue Aug 2 05:17:52 2011 (r703) @@ -389,18 +389,14 @@ "returns all topic psis as a json list of the form [[topic-1-psi-1, topic-1-psi-2],[topic-2-psi-1, topic-2-psi-2],...]" (declare (type (or integer null) revision)) - (encode-json-to-string - (remove-if #'null - (map 'list - #'(lambda(psi-list) - (when psi-list - (map 'list #'uri psi-list))) - (map 'list #'psis - (remove-null - (map 'list #'(lambda(top) - (when (find-item-by-revision top revision) - top)) - (get-all-topics revision)))))))) + (let ((psi-lists + (map 'list (lambda(top) + (when (d:find-item-by-revision top revision) + (let ((psis (d:psis top :revision revision))) + (when psis + (map 'list #'d:uri psis))))) + (elephant:get-instances-by-class 'd:TopicC)))) + (json:encode-json-to-string (tools:remove-null psi-lists)))) (defun to-json-string-summary (topic &key (revision *TM-REVISION*))

1 0

[isidorus-cvs] r702 - trunk/playground
by lgiessmann＠common-lisp.net 02 Aug '11

02 Aug '11

Author: lgiessmann Date: Tue Aug 2 01:05:59 2011 New Revision: 702 Log: trunk: playground: replaced string-starts-with and string-ends-with by the correpondings functions defined in 'base-tools' Modified: trunk/playground/tcp-connector.lisp Modified: trunk/playground/tcp-connector.lisp ============================================================================== --- trunk/playground/tcp-connector.lisp Tue Aug 2 00:54:16 2011 (r701) +++ trunk/playground/tcp-connector.lisp Tue Aug 2 01:05:59 2011 (r702) @@ -84,11 +84,11 @@ (handler-case (let ((client-data (read-from-client client-socket))) (let ((response - (cond ((string-starts-with (first (getf client-data :headers)) - "GET /json/psis") + (cond ((tools:string-starts-with (first (getf client-data :headers)) + "GET /json/psis") (get-psis)) - ((string-starts-with (first (getf client-data :headers)) - "GET /json/get/") + ((tools-string-starts-with (first (getf client-data :headers)) + "GET /json/get/") (get-fragment (get-requested-psi-of-http-header (first (getf client-data :headers))))) (t @@ -133,49 +133,15 @@ (defun get-requested-psi-of-http-header (first-header-line) (declare (String first-header-line)) - (when (and (string-starts-with first-header-line "GET /json/get/") - (or (string-ends-with first-header-line "HTTP/1.0") - (string-ends-with first-header-line "HTTP/1.1"))) + (when (and (tools:string-starts-with first-header-line "GET /json/get/") + (or (tools:string-ends-with first-header-line "HTTP/1.0") + (tools:string-ends-with first-header-line "HTTP/1.1"))) (let ((psi (subseq first-header-line (length "GET /json/get/") (- (length first-header-line) (length "HTTP/1.0"))))) (hunchentoot:url-decode (string-trim '(#\space) psi))))) -(defun string-starts-with (str prefix &key (ignore-case nil)) - "Checks if string str starts with a given prefix." - (declare (String str prefix) - (Boolean ignore-case)) - (let ((str-i (if ignore-case - (string-downcase str :start 0 :end (min (length str) - (length prefix))) - str)) - (prefix-i (if ignore-case - (string-downcase prefix) - prefix))) - (string= str-i prefix-i :start1 0 :end1 - (min (length prefix-i) - (length str-i))))) - - -(defun string-ends-with (str suffix &key (ignore-case nil)) - "Checks if string str ends with a given suffix." - (declare (String str suffix) - (Boolean ignore-case)) - (let ((str-i (if ignore-case - (string-downcase str :start (max (- (length str) - (length suffix)) - 0) - :end (length str)) - str)) - (suffix-i (if ignore-case - (string-downcase suffix) - suffix))) - (string= str-i suffix-i :start1 (max (- (length str) - (length suffix)) - 0)))) - - (defun main() (format t ">> entered (main)") (base-tools:open-tm-store "/home/lukas/.sbcl/site/isidorus/trunk/src/data_base")

1 0

[isidorus-cvs] r701 - trunk/playground
by lgiessmann＠common-lisp.net 02 Aug '11

02 Aug '11

Author: lgiessmann Date: Tue Aug 2 00:54:16 2011 New Revision: 701 Log: trunk: playground: implemented an interface that returns all psis and a json fragment via usocket's tcp-sockets - instead of using hunchentoot Modified: trunk/playground/tcp-connector.lisp Modified: trunk/playground/tcp-connector.lisp ============================================================================== --- trunk/playground/tcp-connector.lisp Mon Aug 1 07:56:39 2011 (r700) +++ trunk/playground/tcp-connector.lisp Tue Aug 2 00:54:16 2011 (r701) @@ -9,8 +9,7 @@ ;; source: http://mihai.bazon.net/blog/howto-multi-threaded-tcp-server-in-common-lisp -(asdf:operate 'asdf:load-op :usocket) -(asdf:operate 'asdf:load-op :bordeaux-threads) +(asdf:operate 'asdf:load-op :isidorus) (defun make-server (&key (hostname "localhost") (port 8000)) @@ -71,22 +70,33 @@ (usocket:socket-close client-socket)) -(defun task (client-socket mega-loops name) - (declare (String name) - (integer mega-loops) - (usocket:stream-usocket client-socket)) - (let ((loops (* 1000000 mega-loops))) - (dotimes (counter loops) - (/ (* loops loops) loops)) - (read-from-client client-socket) ;ignore cient data - (send-to-client client-socket (format nil "~a finished ~a loops" name loops)))) +(defvar *stop-listen* nil "if this variable is set to t, the listener stops to listen after the next client has been accepted") -(defvar *stop-listen* nil "if tis variable is set to t, te listener stops to listen after the next client is accepted") +(defun stop-listen-for-clients (server) + (setf *stop-listen* t) + (usocket:socket-close server) + (base-tools:close-tm-store)) -(defun stop-listen-for-clients () - (setf *stop-listen* t)) +(defun client-task (client-socket) + (declare (usocket:stream-usocket client-socket)) + (handler-case + (let ((client-data (read-from-client client-socket))) + (let ((response + (cond ((string-starts-with (first (getf client-data :headers)) + "GET /json/psis") + (get-psis)) + ((string-starts-with (first (getf client-data :headers)) + "GET /json/get/") + (get-fragment (get-requested-psi-of-http-header + (first (getf client-data :headers))))) + (t + (concatenate 'string ">> bad request: ~a~%" + (first (getf client-data :headers))))))) + (send-to-client client-socket response))) + (condition () + (usocket:socket-close client-socket)))) (defun listen-for-clients (server) @@ -99,14 +109,78 @@ (let ((client (wait-for-client srv))) (format t "client # ~a connected~%" counter) (sb-thread:make-thread - (lambda() - (funcall (lambda(client-socket thread-name) - (declare (usocket:stream-usocket client-socket) - (String thread-name)) - (read-from-client client-socket) ;ignore client data - (send-to-client client-socket thread-name)) - client (format nil "thread-~a" counter))) + (lambda() (funcall #'client-task client)) :name (format nil "worker-thread: ~a" counter))) (incf counter) (setf stop-p *stop-listen*))) - server)))) + server)) + :name "server-listener")) + + +(defun get-psis () + (isidorus-threading:with-reader-lock + (json-exporter:get-all-topic-psis :revision 0))) + + +(defun get-fragment(psi) + (let ((fragment (isidorus-threading:with-reader-lock + (d:get-latest-fragment-of-topic psi)))) + (if (and fragment + (d:find-item-by-revision (d:topic fragment) 0)) + (json-exporter:export-construct-as-isidorus-json-string fragment :revision 0) + (concatenate 'string psi " not found")))) + + +(defun get-requested-psi-of-http-header (first-header-line) + (declare (String first-header-line)) + (when (and (string-starts-with first-header-line "GET /json/get/") + (or (string-ends-with first-header-line "HTTP/1.0") + (string-ends-with first-header-line "HTTP/1.1"))) + (let ((psi (subseq first-header-line + (length "GET /json/get/") + (- (length first-header-line) (length "HTTP/1.0"))))) + (hunchentoot:url-decode (string-trim '(#\space) psi))))) + + +(defun string-starts-with (str prefix &key (ignore-case nil)) + "Checks if string str starts with a given prefix." + (declare (String str prefix) + (Boolean ignore-case)) + (let ((str-i (if ignore-case + (string-downcase str :start 0 :end (min (length str) + (length prefix))) + str)) + (prefix-i (if ignore-case + (string-downcase prefix) + prefix))) + (string= str-i prefix-i :start1 0 :end1 + (min (length prefix-i) + (length str-i))))) + + +(defun string-ends-with (str suffix &key (ignore-case nil)) + "Checks if string str ends with a given suffix." + (declare (String str suffix) + (Boolean ignore-case)) + (let ((str-i (if ignore-case + (string-downcase str :start (max (- (length str) + (length suffix)) + 0) + :end (length str)) + str)) + (suffix-i (if ignore-case + (string-downcase suffix) + suffix))) + (string= str-i suffix-i :start1 (max (- (length str) + (length suffix)) + 0)))) + + +(defun main() + (format t ">> entered (main)") + (base-tools:open-tm-store "/home/lukas/.sbcl/site/isidorus/trunk/src/data_base") + (defvar *server* (make-server :port 8080)) + (listen-for-clients *server*)) + + +(main) \ No newline at end of file

1 0

[isidorus-cvs] r700 - trunk/playground
by lgiessmann＠common-lisp.net 01 Aug '11

01 Aug '11

Author: lgiessmann Date: Mon Aug 1 07:56:39 2011 New Revision: 700 Log: trunk: playground: added a client-acceptor function that accepts new client connections and starts a thread for each client Modified: trunk/playground/tcp-connector.lisp Modified: trunk/playground/tcp-connector.lisp ============================================================================== --- trunk/playground/tcp-connector.lisp Mon Aug 1 06:57:28 2011 (r699) +++ trunk/playground/tcp-connector.lisp Mon Aug 1 07:56:39 2011 (r700) @@ -9,6 +9,9 @@ ;; source: http://mihai.bazon.net/blog/howto-multi-threaded-tcp-server-in-common-lisp +(asdf:operate 'asdf:load-op :usocket) +(asdf:operate 'asdf:load-op :bordeaux-threads) + (defun make-server (&key (hostname "localhost") (port 8000)) (declare (string hostname) (number port)) @@ -68,3 +71,42 @@ (usocket:socket-close client-socket)) +(defun task (client-socket mega-loops name) + (declare (String name) + (integer mega-loops) + (usocket:stream-usocket client-socket)) + (let ((loops (* 1000000 mega-loops))) + (dotimes (counter loops) + (/ (* loops loops) loops)) + (read-from-client client-socket) ;ignore cient data + (send-to-client client-socket (format nil "~a finished ~a loops" name loops)))) + + +(defvar *stop-listen* nil "if tis variable is set to t, te listener stops to listen after the next client is accepted") + + +(defun stop-listen-for-clients () + (setf *stop-listen* t)) + + +(defun listen-for-clients (server) + (declare (usocket:stream-server-usocket server)) + (setf *stop-listen* nil) + (sb-thread:make-thread + (lambda() + (funcall (lambda(srv) + (do ((stop-p *stop-listen*) (counter 0)) ((not (null stop-p))) + (let ((client (wait-for-client srv))) + (format t "client # ~a connected~%" counter) + (sb-thread:make-thread + (lambda() + (funcall (lambda(client-socket thread-name) + (declare (usocket:stream-usocket client-socket) + (String thread-name)) + (read-from-client client-socket) ;ignore client data + (send-to-client client-socket thread-name)) + client (format nil "thread-~a" counter))) + :name (format nil "worker-thread: ~a" counter))) + (incf counter) + (setf stop-p *stop-listen*))) + server))))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs