August 2011 - isidorus-cvs@common-lisp.net

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

05 Aug '11

Author: lgiessmann Date: Fri Aug 5 00:51:26 2011 New Revision: 713 Log: trunk: datamodel: changed get-latest-topic-by-psi due to poerformance reasons Modified: trunk/src/model/datamodel.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp Fri Aug 5 00:29:30 2011 (r712) +++ trunk/src/model/datamodel.lisp Fri Aug 5 00:51:26 2011 (r713) @@ -736,12 +736,13 @@ (elephant:get-instance-by-value 'PersistentIdC 'uri topic-psi))) (when psi-inst - (let ((latest-va - (get-most-recent-versioned-assoc - psi-inst 'identified-construct))) - (when (and latest-va (versions latest-va)) - (identified-construct - psi-inst :revision (start-revision (first (versions latest-va))))))))) + (identified-construct psi-inst :revision 0)))) + ;(let ((latest-va + ;(get-most-recent-versioned-assoc + ;psi-inst 'identified-construct))) + ;(when (and latest-va (versions latest-va)) + ;(identified-construct + ;psi-inst :revision (start-revision (first (versions latest-va))))))))) (defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*))

1 0

[isidorus-cvs] r712 - trunk/src/shell_scripts
by lgiessmann＠common-lisp.net 05 Aug '11

05 Aug '11

Author: lgiessmann Date: Fri Aug 5 00:29:30 2011 New Revision: 712 Log: trunk: shell_scripts: fixed a bug in the startIsidorus.lisp file => port Modified: trunk/src/shell_scripts/startIsidorus.lisp Modified: trunk/src/shell_scripts/startIsidorus.lisp ============================================================================== --- trunk/src/shell_scripts/startIsidorus.lisp Thu Aug 4 12:01:13 2011 (r711) +++ trunk/src/shell_scripts/startIsidorus.lisp Fri Aug 5 00:29:30 2011 (r712) @@ -4,7 +4,7 @@ (setf rest-interface:*local-backup-remote-address* "143.93.190.247") (setf rest-interface:*remote-backup-remote-address* "143.93.190.247") (setf rest-interface:*shutdown-remote-address* "127.0.0.1") -(rest-interface:start-json-engine "/home/servreg/data_base" :host-name "143.93.190.176" :port 9999) +(rest-interface:start-json-engine "/home/servreg/data_base" :host-name "143.93.190.176" :port 7000) (rest-interface:start-admin-server) (rest-interface:die-when-finished)

1 0

[isidorus-cvs] r711 - 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 12:01:13 2011 New Revision: 711 Log: trunk: datamodel: improved caching of serialized fragments 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 09:42:28 2011 (r710) +++ trunk/src/json/isidorus-json/json_exporter.lisp Thu Aug 4 12:01:13 2011 (r711) @@ -479,46 +479,4 @@ (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)) "}"))))) - - -;; ============================================================================= -;; --- 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 + (concat (subseq j-str 0 (- (length j-str) 1)) "}"))))) \ No newline at end of file Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp Thu Aug 4 09:42:28 2011 (r710) +++ trunk/src/model/changes.lisp Thu Aug 4 12:01:13 2011 (r711) @@ -332,18 +332,6 @@ 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 @@ -432,10 +420,12 @@ (find-associations top :revision revision))) -(defun create-latest-fragment-of-topic (topic-psi) +(defun create-latest-fragment-of-topic (topic-or-psi) "Returns the latest fragment of the passed topic-psi" - (declare (string topic-psi)) - (let ((topic (get-latest-topic-by-psi topic-psi))) + (declare (type (or TopicC String) topic-or-psi)) + (let ((topic (if (stringp topic-or-psi) + (get-latest-topic-by-psi topic-or-psi) + topic-or-psi))) (when topic (let ((start-revision (start-revision @@ -459,10 +449,12 @@ :topic topic))))))) -(defun get-latest-fragment-of-topic (topic-psi) +(defun get-latest-fragment-of-topic (topic-or-psi) "Returns the latest existing fragment of the passed topic-psi." - (declare (string topic-psi)) - (let ((topic (get-latest-topic-by-psi topic-psi))) + (declare (type (or String TopicC) topic-or-psi)) + (let ((topic (if (stringp topic-or-psi) + (get-latest-topic-by-psi topic-or-psi) + topic-or-psi))) (when topic (let ((existing-fragments (elephant:get-instances-by-value 'FragmentC 'topic topic))) @@ -480,30 +472,19 @@ (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 +(defgeneric serialize-fragment (fragment serializer) + (:documentation "returns a string that represents the serialization + of the passed fragment instance. + This method uses the fragments serializer-cache + slot to perform faster, i.e. if the fragment was + once serialized, the next time the cached serialized + data is used again.") + (:method ((fragment FragmentC) (serializer Function)) + (cond ((null (serializer-cache fragment)) + (setf (slot-value fragment 'serializer-cache) + (funcall serializer fragment))) + (t + (serializer-cache fragment))))) + + + \ No newline at end of file Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp Thu Aug 4 09:42:28 2011 (r710) +++ trunk/src/model/datamodel.lisp Thu Aug 4 12:01:13 2011 (r711) @@ -43,9 +43,8 @@ :FragmentC ;;methods, functions and macros - :serializer-notes + :serialize-fragment :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 09:42:28 2011 (r710) +++ trunk/src/rest_interface/set-up-json-interface.lisp Thu Aug 4 12:01:13 2011 (r711) @@ -487,18 +487,53 @@ :force-text t))) (with-writer-lock (handler-case - (let ((result (json-delete-interface:mark-as-deleted-from-json - json-data :revision (d:get-revision)))) + (let* ((rev (d:get-revision)) + (result (json-delete-interface:mark-as-deleted-from-json + json-data :revision rev))) (if result (progn - (when (typep result 'd:TopicC) - (append ;;the append function is used only for suppress - ;;style warnings of unused delete return values - (setf *type-table* - (delete (elephant::oid result) *type-table*)) - (setf *instance-table* - (delete (elephant::oid result) *instance-table*)) - (remove-topic-from-list result))) + (cond ((typep result 'd:TopicC) + (setf *type-table* + (delete (elephant::oid result) *type-table*)) + (setf *instance-table* + (delete (elephant::oid result) *instance-table*)) + (remove-topic-from-list result) + (map nil (lambda(fragment) + (when (eql (d:topic fragment) result) + (elephant:drop-instance fragment))) + (elephant:get-instances-by-value + 'd:FragmentC 'd:topic result))) + ((typep result 'd:AssociationC) + (let ((players + (delete-if + #'null + (map 'list + (lambda(role) + (let ((top (player role + :revision (1- rev)))) + (when (psis top :revision 0) + top))) + (roles result :revision (1- rev)))))) + (map nil + (lambda(plr) + (map nil #'elephant:drop-instance + (elephant:get-instances-by-value + 'd:FragmentC 'd:topic plr)) + (d:serialize-fragment + (create-latest-fragment-of-topic plr) + (fragment-serializer))) + players))) + ((or (typep result 'd:NameC) + (typep result 'd:OccurrenceC)) + (let ((top (parent result :revision (1- rev)))) + (when (and top (psis top :revision 0)) + (map nil (lambda(frg) + (setf (slot-value frg 'd::serializer-cache) nil) + (d:serialize-fragment + (get-latest-fragment-of-topic top) + (fragment-serializer))) + (elephant:get-instances-by-value + 'd:FragmentC 'd:topic top)))))) (format nil "")) ;operation succeeded (progn (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) @@ -653,16 +688,24 @@ (defun init-fragments () "Creates fragments of all topics that have a PSI." (format t "creating fragments: ") - (map 'list #'(lambda(top) - (let ((psis-of-top (psis top))) - (when psis-of-top - (format t ".") - (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))) + (map + nil + (lambda(top) + (let ((psis-of-top (psis top))) + (when psis-of-top + (format t ".") + (let ((fragment + (create-latest-fragment-of-topic + (uri (first psis-of-top))))) + (d:serialize-fragment fragment (fragment-serializer)) + fragment)))) + (elephant:get-instances-by-class 'd:TopicC))) + + +(defun fragment-serializer () + (lambda(frg) + (json-exporter:export-construct-as-isidorus-json-string + frg :revision 0))) (defun update-list (top psis)

1 0

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

04 Aug '11

Author: lgiessmann Date: Thu Aug 4 09:42:28 2011 New Revision: 710 Log: trunk: datamodel: improved the function find-most-recent-version-info for searach operation that searches for the end-revision 0, that is frequently used Modified: trunk/src/model/datamodel.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp Thu Aug 4 09:24:29 2011 (r709) +++ trunk/src/model/datamodel.lisp Thu Aug 4 09:42:28 2011 (r710) @@ -1140,8 +1140,8 @@ (when (find-if #'(lambda(vi) (and (>= revision (start-revision vi)) - (or (< revision (end-revision vi)) - (= 0 (end-revision vi))))) + (or (= 0 (end-revision vi)) + (< revision (end-revision vi))))) (versions construct)) construct))))

1 0

[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