- isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

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

10 Aug '11

Author: lgiessmann Date: Wed Aug 10 12:45:20 2011 New Revision: 719 Log: trunk: rest-interface: fixed updated-fragments, that is invoked after a delete-operation. Now, it can handle multiple fragments that belongs to one topic 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 10 07:55:51 2011 (r718) +++ trunk/src/rest_interface/set-up-json-interface.lisp Wed Aug 10 12:45:20 2011 (r719) @@ -684,13 +684,20 @@ (loop for role in (roles inst :revision rev) collect (d:player role :revision rev))))))) (fragments - (delete-if #'null - (map 'list (lambda(top) - (elephant:get-instance-by-value - 'd:FragmentC 'd::topic top)) - (delete-duplicates - (delete deleted-topic - (delete-if #'null all-tops))))))) + (delete-if + #'null + (map 'list (lambda(top) + (let ((all-frgs + (sort + (elephant:get-instances-by-value + 'd:FragmentC 'd::topic top) + #'> :key 'revision))) + (let ((frg (first all-frgs))) + (map nil 'elephant:drop-instance (rest all-frgs)) + frg))) + (delete-duplicates + (delete deleted-topic + (delete-if #'null all-tops))))))) (map nil (lambda(frg) (setf (slot-value frg 'd::serializer-cache) nil) (d:serialize-fragment frg (fragment-serializer)))

1 0

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

10 Aug '11

Author: lgiessmann Date: Wed Aug 10 07:55:51 2011 New Revision: 718 Log: trunk: rest-interface: fixed a bug when updating the serializatiuon cache of fragments after another topic was deleted that was bound to an association which referenced other topics/fragments Modified: trunk/src/model/datamodel.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp Wed Aug 10 03:37:39 2011 (r717) +++ trunk/src/model/datamodel.lisp Wed Aug 10 07:55:51 2011 (r718) @@ -1577,7 +1577,7 @@ (when (or (and (not source-locator) sl-provided-p) (and sl-provided-p (some (lambda (psi) (string-starts-with (uri psi) source-locator)) - (psis top :revision 0)))) + (psis top :revision revision)))) (mapc (lambda(psi)(mark-as-deleted psi :revision revision :source-locator source-locator)) (psis top :revision revision)) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp Wed Aug 10 03:37:39 2011 (r717) +++ trunk/src/rest_interface/set-up-json-interface.lisp Wed Aug 10 07:55:51 2011 (r718) @@ -609,7 +609,8 @@ (when (eql (d:topic fragment) result) (elephant:drop-instance fragment))) (elephant:get-instances-by-value - 'd:FragmentC 'd:topic result))) + 'd:FragmentC 'd:topic result)) + (update-fragments result rev)) ((typep result 'd:AssociationC) (let ((players (delete-if @@ -654,6 +655,49 @@ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + +(defun update-fragments(deleted-topic delete-revision) + "Updates all fragments of topics that directly and indireclty + related to the delete-topic." + (declare (TopicC deleted-topic) + (Integer delete-revision)) + (let* ((rev (1- delete-revision)) + (all-tops + (append + (let ((assocs + (map 'list (lambda(role) + (d:parent role :revision rev)) + (d:player-in-roles deleted-topic :revision rev)))) + (loop for assoc in assocs + append (loop for role in (roles assoc :revision rev) + collect (d:player role :revision rev)))) + (let ((items + (append (used-as-theme deleted-topic :revision rev) + (used-as-type deleted-topic :revision rev)))) + (loop for item in items + when (or (typep item 'NameC) (typep item 'OccurrenceC)) + collect (parent item :revision rev) + when (or (typep item 'RoleC) (typep item 'AssociationC)) + append (let ((inst (if (typep item 'AssociationC) + item + (d:parent item :revision rev)))) + (loop for role in (roles inst :revision rev) + collect (d:player role :revision rev))))))) + (fragments + (delete-if #'null + (map 'list (lambda(top) + (elephant:get-instance-by-value + 'd:FragmentC 'd::topic top)) + (delete-duplicates + (delete deleted-topic + (delete-if #'null all-tops))))))) + (map nil (lambda(frg) + (setf (slot-value frg 'd::serializer-cache) nil) + (d:serialize-fragment frg (fragment-serializer))) + fragments))) + + + (defun return-latest-revision () "Returns an integer that represents the latest revision that is used in the storage."

1 0

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

10 Aug '11

Author: lgiessmann Date: Wed Aug 10 03:37:39 2011 New Revision: 717 Log: trunk: rest-interface: fixed a bug when deleting newly created associations of a topic Modified: trunk/src/model/datamodel.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp Mon Aug 8 02:35:56 2011 (r716) +++ trunk/src/model/datamodel.lisp Wed Aug 10 03:37:39 2011 (r717) @@ -1595,7 +1595,9 @@ (occurrences top :revision revision)) (mapc (lambda (ass) (mark-as-deleted ass :revision revision :source-locator source-locator)) - (find-all-associations top :revision 0)) + (map 'list (lambda(role) + (parent role :revision revision)) + (player-in-roles top :revision revision))) (let ((ref (reified-construct top :revision revision))) (when ref (private-delete-reified-construct top ref :revision revision)))

1 0

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

08 Aug '11

Author: lgiessmann Date: Mon Aug 8 02:35:56 2011 New Revision: 716 Log: trunk: rest-interface: added an additional stage of http-basic-authentication => 0: no authenticoation; 1: the host page 'isidorus.html' requires authentication; 2: all json-commit-handlers require authentication; 3: all json-get-handlers require authentication; note each stage activates the authentication of the previous stage, e.g. stage 3 is stage 1 + 2 + 3 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 Sat Aug 6 18:54:30 2011 (r715) +++ trunk/src/rest_interface/set-up-json-interface.lisp Mon Aug 8 02:35:56 2011 (r716) @@ -28,9 +28,11 @@ (defparameter *use-http-authentication* 0 "if this variable is set to > 0, the host page will require basic authentication. If it's value is set - to > 1, all json handlers will require - basic-authentication. If this value is - set to 0, no authentication is required.") + to > 1, all json-commit handlers will require + basic-authentication. If this value is set to + > 2 all json-handlers require authentication. + If this value is set to 0, no authentication + is required.") ;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi> @@ -167,7 +169,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-prefix - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional psi) (with-http-authentication (return-json-fragment psi))) @@ -175,7 +177,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher get-rdf-prefix - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional psi) (with-http-authentication (return-json-rdf-fragment psi))) @@ -183,7 +185,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-topic-stub-prefix - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional psi) (with-http-authentication (return-topic-stub-of-psi psi))) @@ -191,7 +193,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-all-type-psis - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional param) (with-http-authentication (return-all-tmcl-types param))) @@ -199,7 +201,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-all-instance-psis - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional param) (with-http-authentication (return-all-tmcl-instances param))) @@ -207,7 +209,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-type-tmcl-url - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional param) (declare (ignorable param)) (with-http-authentication @@ -218,7 +220,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-instance-tmcl-url - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional param) (declare (ignorable param)) (with-http-authentication @@ -229,7 +231,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-overview - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional param) (with-http-authentication (return-overview param))) @@ -245,7 +247,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-summary-url - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional param) (with-http-authentication (return-topic-summaries param))) @@ -269,7 +271,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher latest-revision-url - (if (> *use-http-authentication* 1) + (if (> *use-http-authentication* 2) (lambda(&optional param) (declare (ignorable param)) (with-http-authentication @@ -278,7 +280,7 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher sparql-url - (if *use-http-authentication* + (if (> *use-http-authentication* 1) (lambda(&optional param) (with-http-authentication (return-tm-sparql param)))

1 0

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

07 Aug '11

Author: lgiessmann Date: Sat Aug 6 18:54:30 2011 New Revision: 715 Log: fixed ticket #118 Modified: trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp Fri Aug 5 04:02:12 2011 (r714) +++ trunk/src/rest_interface/rest-interface.lisp Sat Aug 6 18:54:30 2011 (r715) @@ -61,7 +61,9 @@ :*xtm-commit-prefix* :*ready-to-die* :die-when-finished - :*sparql-url*)) + :*sparql-url* + :*use-http-authentication* + :*users*)) (in-package :rest-interface) @@ -89,6 +91,7 @@ (defvar *remote-backup-remote-address* "127.0.0.1") (defvar *local-backup-remote-address* "127.0.0.1") (defvar *shutdown-remote-address* "127.0.0.1") +(defvar *users* (list (list :uname "admin" :passwd "admin"))) (defun start-admin-server () @@ -168,3 +171,15 @@ (hunchentoot:stop *atom-server-acceptor*)) (setf *atom-server-acceptor* nil) (close-tm-store)) + + +(defmacro with-http-authentication (&rest body) + `(multiple-value-bind (username password) (hunchentoot:authorization) + (if (find-if (lambda(item) + (and (stringp (getf item :uname)) + (stringp (getf item :passwd)) + (string= (getf item :uname) username) + (string= (getf item :passwd) password))) + *users*) + ,@body + (hunchentoot:require-authorization "isidorus")))) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp Fri Aug 5 04:02:12 2011 (r714) +++ trunk/src/rest_interface/set-up-json-interface.lisp Sat Aug 6 18:54:30 2011 (r715) @@ -12,18 +12,27 @@ ;caching tables (defparameter *type-table* nil "Cointains integer==OIDs that represent a topic instance of a vylid type-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") - (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.") +(defparameter *use-http-authentication* 0 "if this variable is set to > 0, the + host page will require basic + authentication. If it's value is set + to > 1, all json handlers will require + basic-authentication. If this value is + set to 0, no authentication is required.") + + ;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> @@ -107,78 +116,173 @@ ;; e.g. a json error-message. (push hunchentoot:+http-internal-server-error+ hunchentoot:*approved-return-codes*) ;; === html and css files ==================================================== - (push - (create-static-file-dispatcher-and-handler ajax-user-interface-url ajax-user-interface-file-path "text/html") - hunchentoot:*dispatch-table*) - - (dolist (script-path-and-url (make-file-path-and-url ajax-user-interface-css-directory-path ajax-user-interface-css-prefix)) - (let ((script-path (getf script-path-and-url :path)) - (script-url (getf script-path-and-url :url))) - (push - (create-static-file-dispatcher-and-handler script-url script-path) - hunchentoot:*dispatch-table*))) + (if (> *use-http-authentication* 0) + (define-easy-handler (isidorus-ui :uri ajax-user-interface-url + :default-request-type :get) + () + (with-http-authentication + (serve-file ajax-user-interface-file-path "text/html"))) + (push + (create-static-file-dispatcher-and-handler + ajax-user-interface-url ajax-user-interface-file-path "text/html") + hunchentoot:*dispatch-table*)) + + (let ((files-and-urls + (make-file-path-and-url ajax-user-interface-css-directory-path + ajax-user-interface-css-prefix))) + (dotimes (idx (length files-and-urls)) + (let ((script-path (getf (elt files-and-urls idx) :path)) + (script-url (getf (elt files-and-urls idx) :url))) + (push + (create-static-file-dispatcher-and-handler script-url script-path) + hunchentoot:*dispatch-table*)))) ;; === ajax frameworks and javascript files ================================== - (dolist (script-path-and-url (make-file-path-and-url ajax-javascripts-directory-path ajax-javascripts-url-prefix)) - (let ((script-path (getf script-path-and-url :path)) - (script-url (getf script-path-and-url :url))) - (push - (create-static-file-dispatcher-and-handler script-url script-path) - hunchentoot:*dispatch-table*))) + (let ((files-and-urls (make-file-path-and-url ajax-javascripts-directory-path + ajax-javascripts-url-prefix))) + (dotimes (idx (length files-and-urls)) + (let ((script-path (getf (elt files-and-urls idx) :path)) + (script-url (getf (elt files-and-urls idx) :url))) + (push + (create-static-file-dispatcher-and-handler script-url script-path) + hunchentoot:*dispatch-table*)))) ;; === rest interface ======================================================== (push (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) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher get-rdf-prefix #'return-json-rdf-fragment) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher json-get-topic-stub-prefix #'return-topic-stub-of-psi) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher json-get-all-type-psis #'return-all-tmcl-types) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher json-get-all-instance-psis #'return-all-tmcl-instances) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher json-get-type-tmcl-url #'(lambda(&optional param) - (declare (ignorable param)) - (return-tmcl-info-of-psis 'json-tmcl::type))) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher json-get-instance-tmcl-url #'(lambda(&optional param) - (declare (ignorable param)) - (return-tmcl-info-of-psis 'json-tmcl::instance))) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher json-get-overview #'return-overview) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher json-commit-url #'json-commit) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher json-get-summary-url #'return-topic-summaries) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted-handler) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher xtm-commit-prefix #'xtm-import-handler) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher latest-revision-url #'return-latest-revision) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher sparql-url #'return-tm-sparql) + (create-regex-dispatcher json-get-all-psis + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (with-http-authentication + (cached-return-all-topic-psis param))) + #'cached-return-all-topic-psis)) + (create-regex-dispatcher json-get-all-psis + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (with-http-authentication + (return-all-topic-psis param))) + #'return-all-topic-psis))) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher json-get-prefix + (if (> *use-http-authentication* 1) + (lambda(&optional psi) + (with-http-authentication + (return-json-fragment psi))) + #'return-json-fragment)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher get-rdf-prefix + (if (> *use-http-authentication* 1) + (lambda(&optional psi) + (with-http-authentication + (return-json-rdf-fragment psi))) + #'return-json-rdf-fragment)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher json-get-topic-stub-prefix + (if (> *use-http-authentication* 1) + (lambda(&optional psi) + (with-http-authentication + (return-topic-stub-of-psi psi))) + #'return-topic-stub-of-psi)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher json-get-all-type-psis + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (with-http-authentication + (return-all-tmcl-types param))) + #'return-all-tmcl-types)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher json-get-all-instance-psis + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (with-http-authentication + (return-all-tmcl-instances param))) + #'return-all-tmcl-instances)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher json-get-type-tmcl-url + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (declare (ignorable param)) + (with-http-authentication + (return-tmcl-info-of-psis 'json-tmcl::type))) + (lambda(&optional param) + (declare (ignorable param)) + (return-tmcl-info-of-psis 'json-tmcl::type)))) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher json-get-instance-tmcl-url + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (declare (ignorable param)) + (with-http-authentication + (return-tmcl-info-of-psis 'json-tmcl::instance))) + (lambda(&optional param) + (declare (ignorable param)) + (return-tmcl-info-of-psis 'json-tmcl::instance)))) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher json-get-overview + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (with-http-authentication + (return-overview param))) + #'return-overview)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher json-commit-url + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (with-http-authentication + (json-commit param))) + #'json-commit)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher json-get-summary-url + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (with-http-authentication + (return-topic-summaries param))) + #'return-topic-summaries)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher mark-as-deleted-url + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (with-http-authentication + (mark-as-deleted-handler param))) + #'mark-as-deleted-handler)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher xtm-commit-prefix + (if (> *use-http-authentication* 1) + (lambda(&optional tm-id) + (with-http-authentication + (xtm-import-handler tm-id))) + #'xtm-import-handler)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher latest-revision-url + (if (> *use-http-authentication* 1) + (lambda(&optional param) + (declare (ignorable param)) + (with-http-authentication + (return-latest-revision))) + #'return-latest-revision)) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher sparql-url + (if *use-http-authentication* + (lambda(&optional param) + (with-http-authentication + (return-tm-sparql param))) + #'return-tm-sparql)) hunchentoot:*dispatch-table*)) ;; ============================================================================= @@ -462,17 +566,17 @@ "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) (with-reader-lock - (handler-case - (let ((json-string - (json-tmcl::tree-view-to-json-string - (json-tmcl::make-tree-view :revision 0)))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - json-string) - (Condition (err) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))))) + (handler-case + (let ((json-string + (json-tmcl::tree-view-to-json-string + (json-tmcl::make-tree-view :revision 0)))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + json-string) + (Condition (err) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) (defun mark-as-deleted-handler (&optional param) @@ -762,6 +866,18 @@ *overview-table*)) (psi-oids (map 'list #'elephant::oid psis))) (if node - (dolist (psi psi-oids) + (dolist (psi psi-oids)1 (pushnew psi (getf node :psis) :test #'=)) - (push (list :topic top-oid :psis psi-oids) *overview-table*))))) \ No newline at end of file + (push (list :topic top-oid :psis psi-oids) *overview-table*))))) + + +(defun serve-file (file-path &optional mime-type) + "Returns a stream of the corresponding file." + (with-open-file (in file-path :direction :input + :element-type 'flex:octet) + (when mime-type + (setf (hunchentoot:content-type*) mime-type)) + (let ((data (make-array (file-length in) + :element-type 'flex:octet))) + (read-sequence data in) + data))) \ No newline at end of file

1 0

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

05 Aug '11

Author: lgiessmann Date: Fri Aug 5 04:02:12 2011 New Revision: 714 Log: trunk: rest-interface: changed the serialization-handler of json-fragments 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 Fri Aug 5 00:51:26 2011 (r713) +++ trunk/src/rest_interface/set-up-json-interface.lisp Fri Aug 5 04:02:12 2011 (r714) @@ -340,8 +340,9 @@ (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) + (d:serialize-fragment fragment (fragment-serializer)) + ;(export-construct-as-isidorus-json-string + ;fragment :revision 0) (condition (err) (progn (setf (hunchentoot:return-code*)

1 0

[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