Author: lgiessmann Date: Wed Oct 13 18:27:38 2010 New Revision: 326 Log: added a mark-as-deleted handler to the RESTful interface, so PSIs, ItemIdentifiers, SubjectLocators, Topics, Names, Variants, Occurrences, Associations and Roles can be deleted by this backend-handler; added the corresponding unit-tests Added: trunk/src/json/json_delete_interface.lisp Modified: trunk/docs/xtm_json.txt trunk/src/isidorus.asd trunk/src/json/json_tmcl_validation.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/json_test.lisp Modified: trunk/docs/xtm_json.txt ============================================================================== --- trunk/docs/xtm_json.txt (original) +++ trunk/docs/xtm_json.txt Wed Oct 13 18:27:38 2010 @@ -449,29 +449,70 @@ //+----------------------------------------------------------------------------- //+ *Part 4: Object notation for marking objects as deleted -//+ type: the type of the deleted object, e.g. Topic for TopicC -//+ topics: a list of PSIs, where every single PSI represents a topic that -//+ has to be deleted -//+ associations: a list of associations that have to be deleted -//+ parent-topic: a single PSI of the name's, occurrence's or variant's owner -//+ topic -//+ parent-name: the parent name of the variants that have to be deleted -//+ (in this case the parent-topic is the topic of the name) -//+ names: a list of the deletable names -//+ variants: a list of deletable names -//+ occurrences: a list of the deletable occurrences -//+ parent-association: the parent association of the deletable roles -//+ roles: a list of the deltable roles +//+ *Topic +//+ *PSI +//+ *ItemIdentifier +//+ *SubjectLocator +//+ *Name +//+ *Variant +//+ *Occurrence +//+ *Association +//+ *Role //+----------------------------------------------------------------------------- +Topic: { - "type":<"Topic" | "Occurrence" | "Name" | "Association" | "Role" | "Variant" >, - "topics": [<psi-top-1>, <psi-top-2>, <...>], - "associations": [<association-1>, <association-2>, <...>], - "parentTopic": "topic-psi", - "parentName": <name>, - "names": [<name-1>, <name-2>, <...>], - "variants": [<variant-1>, <variant-2>, <...>], - "occurrences": [<occurrence-1>, <occurrence-2>, <...>], - "parentAssociation": <association>, - "roles": [<role-1>, <role-2>, <...>] + \"type\":\"Topic\", + \"delete\":<topic> //only the topic's identifiers are evaluated +} + +PSI: +{ + \"type\":\"PSI\", + \"delete\":\"PSI-value\" +} + +Item-Identifier: +{ + \"type\":\"ItemIdentity\", + \"delete\":\"ItemIdentity-value\" +} + +Subject-Locator: +{ + \"type\":SubjectLocator\", + \"delete\":\"SubjectLocator-value\" +} + +Name: +{ + \"type\":\"Name\", + \"parent\":<Topic>, // the topic-identifiers are enough + \"delete\":<Name> +} + +Variant: +{ + \"type\":\"Variant\", + \"parent\":<Name>, // the full name that is needed for TMDM equality + \"parentOfParent\":<Topic>, // the topic-identifiers are enough + \"delete\" +} + +Occurrence: +{ + \"type\":\"Occurrence\", // the full occurrence that is neede for full TMDM equality + \"parent\":<Topic>, // the topic-identifiers are enough + \"delete\":<Occurrence> +} + +Association: +{ \"type\":\"Association\", + \"delete\":<Association> // the full association that is neede for full TMDM equality +} + +Role: +{ + \"type\":\"Role\", + \"parent\":<Association>, // the full association that is neede for full TMDM equality + \"delete\":<Role> // the full role that is neede for full TMDM equality } Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Oct 13 18:27:38 2010 @@ -165,10 +165,12 @@ :depends-on ("json_tmcl_constants")) (:file "json_importer") (:file "json_tmcl_validation" - :depends-on ("json_tmcl_constants" "json_exporter" )) + :depends-on ("json_tmcl_constants" "json_exporter" "json_importer")) (:file "json_tmcl_constants") (:file "json_tmcl" - :depends-on ("json_tmcl_validation" "json_importer"))) + :depends-on ("json_tmcl_validation" "json_importer")) + (:file "json_delete_interface" + :depends-on ("json_importer"))) :depends-on ("model" "xml")) (:module "ajax" Added: trunk/src/json/json_delete_interface.lisp ============================================================================== --- (empty file) +++ trunk/src/json/json_delete_interface.lisp Wed Oct 13 18:27:38 2010 @@ -0,0 +1,356 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(defpackage :json-delete-interface + (:use :cl :datamodel :json-importer) + (:export :mark-as-deleted-from-json)) + +(in-package :json-delete-interface) + + +(defun mark-as-deleted-from-json (json-data &key (revision *TM-REVISION*)) + "Marks an object that is specified by the given JSON data as deleted." + (declare (string json-data) (integer revision)) + (let ((json-list (json:decode-json-from-string json-data))) + (let ((type nil) + (parent nil) + (parent-of-parent nil) + (delete nil)) + (loop for json-entry in json-list + do (let ((st (car json-entry)) + (nd (cdr json-entry))) + (cond ((eql st :type) + (setf type nd)) + ((eql st :delete) + (setf delete nd)) + ((eql st :parent) + (setf parent nd)) + ((eql st :parent-of-parent) + (setf parent-of-parent nd))))) + (cond ((string= type "Topic") + (delete-topic-from-json delete :revision revision)) + ((string= type "PSI") + (delete-identifier-from-json delete 'd:PersistentIdC + #'d:delete-psi :revision revision)) + ((string= type "ItemIdentity") + (delete-identifier-from-json delete 'd:ItemIdentifierC + #'d:delete-item-identifier + :revision revision)) + ((string= type "SubjectLocator") + (delete-identifier-from-json delete 'd:SubjectLocatorC + #'d:delete-locator :revision revision)) + ((string= type "Name") + (delete-name-from-json + delete (find-parent parent :revision revision) :revision revision)) + ((string= type "Variant") + (let ((parent-top (find-parent parent-of-parent :revision revision))) + (delete-variant-from-json + delete (find-parent parent :parent-of-parent parent-top + :revision revision) :revision revision))) + ((string= type "Occurrence") + (delete-occurrence-from-json + delete (find-parent parent :revision revision) :revision revision)) + ((string= type "Association") + (delete-association-from-json delete :revision revision)) + ((string= type "Role") + (delete-role-from-json delete (find-parent parent :revision revision))) + (t + (error "Type \"~a\" is not defined" type)))))) + + +(defun delete-role-from-json (json-decoded-list parent-assoc + &key (revision *TM-REVISION*)) + "Deletes the passed role object and returns t otherwise this + function returns nil." + (declare (list json-decoded-list) (integer revision)) + (let ((j-role (make-role-plist json-decoded-list))) + (when parent-assoc + (let ((role-to-delete + (loop for role in (d:roles parent-assoc :revision revision) + when (and + (eql + (d:instance-of role :revision revision) + (getf j-role :type)) + (eql + (d:player role :revision revision) + (getf j-role :topicRef))) + return role))) + (when role-to-delete + (d:delete-role parent-assoc role-to-delete :revision revision) + t))))) + + +(defun delete-association-from-json (json-decoded-list &key + (revision *TM-REVISION*)) + "Deletes the passed association object and returns t otherwise this + function returns nil." + (declare (list json-decoded-list) (integer revision)) + (let ((assoc (find-association json-decoded-list :revision revision))) + (when assoc + (d:mark-as-deleted assoc :revision revision :source-locator nil) + t))) + + +(defun make-role-plist (json-decoded-list &key (revision *TM-REVISION*)) + "Returns a plist that represents a list of association roles + of the passed json-decoded-list." + (declare (list json-decoded-list) (integer revision)) + (let ((type nil) + (player nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :topic-Ref) + (setf player + (json-importer::psis-to-topic nd :revision revision))) + ((eql st :type) + (setf type + (json-importer::psis-to-topic nd :revision revision)))))) + (list :type type :topicRef player))) + + +(defun find-association (json-decoded-list &key (revision *TM-REVISION*)) + "Returns an association object." + (declare (list json-decoded-list) (integer revision)) + (let ((j-roles nil) + (type nil) + (scopes nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :roles) + (setf j-roles + (map 'list #'(lambda(j-role) + (make-role-plist j-role :revision revision)) + nd))) + ((eql st :type) + (setf type (json-importer::psis-to-topic nd :revision revision))) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision)))))) + (loop for assoc in (d:get-all-associations revision) + when (and + (not + (set-exclusive-or + (d:roles assoc :revision revision) + j-roles + :test #'(lambda(a-role j-role) + (and (eql (d:instance-of a-role :revision revision) + (getf j-role :type)) + (eql (d:player a-role :revision revision) + (getf j-role :topicRef)))))) + (eql type (d:instance-of assoc :revision revision)) + (not (set-exclusive-or scopes (d:themes assoc :revision revision)))) + return assoc))) + + +(defun find-parent (parent &key (parent-of-parent nil) + (revision *TM-REVISION*)) + "Returns the construct (Topic|Name|Association) corresponding to the + passed parameters." + (declare (list parent) (integer revision) + (type (or TopicC null) parent-of-parent)) + (let ((value nil) + (scopes nil) + (type nil) + (j-roles nil)) + (loop for j-entry in parent + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :value) + (setf value nd)) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision))) + ((eql st :type) + (setf type (json-importer::psis-to-topic nd :revision revision))) + ((eql st :roles) + (setf j-roles nd))))) + (cond (parent-of-parent + (loop for name in (d:names parent-of-parent :revision revision) + when (and (string= value (d:charvalue name)) + (eql type (d:instance-of name :revision revision)) + (not (set-exclusive-or scopes + (d:themes name :revision revision)))) + return name)) + (j-roles ;must be an association + (find-association parent :revision revision)) + (t ;must be a topic + (find-topic-from-json-identifiers + parent :revision revision))))) + + +(defun delete-variant-from-json (json-decoded-list parent-name + &key (revision *TM-REVISION*)) + "Deletes the passed variant from the given name and returns t if the + operation succeeded." + (declare (list json-decoded-list) (integer revision) + (type (or NameC null))) + (when parent-name + (let ((varvalue nil) + (vardatatype constants::*xml-uri*) + (scopes nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :resource-ref) + (setf varvalue nd)) + ((eql st :resource-data) + (loop for j-dt in nd + do (let ((dt-st (car j-dt)) + (dt-nd (cdr j-dt))) + (cond ((eql dt-st :datatype) + (setf vardatatype dt-nd)) + ((eql dt-st :value) + (setf varvalue dt-nd)))))) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision)))))) + (let ((var-to-delete + (loop for var in (d:variants parent-name :revision revision) + when (and (string= varvalue (d:charvalue var)) + (string= vardatatype (d:datatype var)) + (not (set-exclusive-or + scopes (d:themes var :revision revision)))) + return var))) (when var-to-delete + (delete-variant parent-name var-to-delete :revision revision) + t))))) + + +(defun delete-occurrence-from-json (json-decoded-list parent-top + &key (revision *TM-REVISION*)) + "Deletes the passed occurrence from the given topic and returns t if the + operation succeeded." + (declare (list json-decoded-list) (integer revision)) + (when parent-top + (let ((occvalue nil) + (occdatatype constants::*xml-uri*) + (scopes nil) + (type nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :resource-ref) + (setf occvalue nd)) + ((eql st :resource-data) + (loop for j-dt in nd + do (let ((dt-st (car j-dt)) + (dt-nd (cdr j-dt))) + (cond ((eql dt-st :datatype) + (setf occdatatype dt-nd)) + ((eql dt-st :value) + (setf occvalue dt-nd)))))) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision))) + ((eql st :type) + (setf type (json-importer::psis-to-topic + nd :revision revision)))))) + (let ((occ-to-delete + (loop for occ in (d:occurrences parent-top :revision revision) + when (and (string= occvalue (d:charvalue occ)) + (string= occdatatype (d:datatype occ)) + (eql type (d:instance-of occ :revision revision)) + (not (set-exclusive-or + scopes (d:themes occ :revision revision)))) + return occ))) + (when occ-to-delete + (delete-occurrence parent-top occ-to-delete :revision revision) + t))))) + + +(defun delete-name-from-json (json-decoded-list parent-top + &key (revision *TM-REVISION*)) + (declare (list json-decoded-list) (integer revision)) + (when parent-top + (let ((namevalue nil) + (scopes nil) + (type nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :value) + (setf namevalue nd)) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision))) + ((eql st :type) + (setf type (json-importer::psis-to-topic + nd :revision revision)))))) + (let ((name-to-delete + (loop for name in (names parent-top :revision revision) + when (and (string= namevalue (d:charvalue name)) + (eql type (d:instance-of name :revision revision)) + (not (set-exclusive-or + scopes (d:themes name :revision revision)))) + return name))) + (when name-to-delete + (delete-name parent-top name-to-delete :revision revision) + t))))) + + +(defun delete-identifier-from-json (uri class delete-function + &key (revision *TM-REVISION*)) + "Deleted the passed identifier of the construct it is associated with. + Returns t if there was deleted an item otherweise it returns nil." + (declare (string uri) (integer revision) (symbol class)) + (let ((id (elephant:get-instance-by-value + class 'd:uri uri))) + (if (and id (typep id class)) + (progn + (apply delete-function + (list (d:identified-construct id :revision revision) + id :revision revision)) + t) + nil))) + + +(defun delete-topic-from-json (json-decoded-list &key (revision *TM-REVISION*)) + "Searches for a topic corresponding to the given identifiers. + Returns t if there was deleted an item otherweise it returns nil." + (declare (list json-decoded-list) (integer revision)) + (let ((top-to-delete (find-topic-from-json-identifiers + json-decoded-list :revision revision))) + (when top-to-delete + (mark-as-deleted top-to-delete :source-locator nil :revision revision) + t))) + + +(defun get-ids-from-json (json-decoded-list) + "Returns all id uri formatted as plist generated from the json-list." + (let ((iis nil) + (psis nil) + (sls nil)) + (loop for json-entry in json-decoded-list + do (let ((st (car json-entry)) + (nd (cdr json-entry))) + (cond ((eql st :item-identities) + (setf iis nd)) + ((eql st :subject-locators) + (setf sls nd)) + ((eql st :subject-identifiers) + (setf psis nd))))) + (list :subjectIdentifiers psis + :itemIdentities iis + :subjectLocators sls))) + + +(defun find-topic-from-json-identifiers (json-decoded-list + &key (revision *TM-REVISION*)) + "Returns a topic corresponding to the passed identifiers." + (declare (list json-decoded-list) (integer revision)) + (let ((ids (get-ids-from-json json-decoded-list))) + (let ((identifier + (if (getf ids :itemIdentities) + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri (first (getf ids :itemIdentities))) + (if (getf ids :subjectIdentifiers) + (elephant:get-instance-by-value + 'd:PersistentIdC 'd:uri (first (getf ids :subjectIdentifiers))) + (when (getf ids :subjectLocators) + (elephant:get-instance-by-value + 'd:SubjectLocatorC 'd:uri + (first (getf ids :subjectLocators)))))))) + (when identifier + (d:identified-construct identifier :revision revision))))) \ No newline at end of file Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Wed Oct 13 18:27:38 2010 @@ -8,7 +8,7 @@ (defpackage :json-tmcl - (:use :cl :datamodel :constants :json-tmcl-constants) + (:use :cl :datamodel :constants :json-tmcl-constants :json-importer) (:export :get-constraints-of-fragment :topictype-p :abstract-p Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Wed Oct 13 18:27:38 2010 @@ -9,23 +9,46 @@ (in-package :rest-interface) -(defparameter *json-get-prefix* "/json/get/(.+)$") ;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi> -(defparameter *get-rdf-prefix* "/json/get/rdf/(.+)$") ;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi> -(defparameter *json-commit-url* "/json/commit/?$") ;the url to commit a json fragment by "put" or "post" -(defparameter *json-get-all-psis* "/json/psis/?$") ;the url to get all topic psis of isidorus -> localhost:8000/json/psis -(defparameter *json-get-summary-url* "/json/summary/?$") ;the url to get a summary of all topic stored in isidorus; you have to set the GET-parameter "start" for the start index of all topics within elephant and the GET-paramter "end" for the last index of the topic sequence -> http://localhost:8000/json/summary/?start=12&end=13 -(defparameter *json-get-all-type-psis* "/json/tmcl/types/?$") ;returns a list of all psis that can be a type -(defparameter *json-get-all-instance-psis* "/json/tmcl/instances/?$") ;returns a list of all psis that belongs to a valid topic-instance -(defparameter *json-get-topic-stub-prefix* "/json/topicstubs/(.+)$") ;the json prefix for getting some topic stub information of a topic -(defparameter *json-get-type-tmcl-url* "/json/tmcl/type/?$") ;the json url for getting some tmcl information of a topic treated as a type -(defparameter *json-get-instance-tmcl-url* "/json/tmcl/instance/?$") ;the json url for getting some tmcl information of a topic treated as an instance -(defparameter *json-get-overview* "/json/tmcl/overview/?$") ; returns a json-object representing a tree view -(defparameter *ajax-user-interface-url* "/isidorus") ;the url to the user interface; -(defparameter *ajax-user-interface-css-prefix* "/css") ;the url to the css files of the user interface -(defparameter *ajax-user-interface-css-directory-path* "ajax/css") ;the directory contains the css files -(defparameter *ajax-user-interface-file-path* "ajax/isidorus.html") ;the file path to the HTML file implements the user interface -(defparameter *ajax-javascript-directory-path* "ajax/javascripts") ;the directory which contains all necessary javascript files -(defparameter *ajax-javascript-url-prefix* "/javascripts") ; the url prefix of all javascript files +;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> +(defparameter *get-rdf-prefix* "/json/get/rdf/(.+)$") +;the url to commit a json fragment by "put" or "post" +(defparameter *json-commit-url* "/json/commit/?$") +;the url to get all topic psis of isidorus -> localhost:8000/json/psis +(defparameter *json-get-all-psis* "/json/psis/?$") +;the url to get a summary of all topic stored in isidorus; you have to set the +;GET-parameter "start" for the start index of all topics within elephant and the +;GET-paramter "end" for the last index of the topic sequence +; -> http://localhost:8000/json/summary/?start=12&end=13 +(defparameter *json-get-summary-url* "/json/summary/?$") +;returns a list of all psis that can be a type +(defparameter *json-get-all-type-psis* "/json/tmcl/types/?$") +;returns a list of all psis that belongs to a valid topic-instance +(defparameter *json-get-all-instance-psis* "/json/tmcl/instances/?$") +;the json prefix for getting some topic stub information of a topic +(defparameter *json-get-topic-stub-prefix* "/json/topicstubs/(.+)$") +;the json url for getting some tmcl information of a topic treated as a type +(defparameter *json-get-type-tmcl-url* "/json/tmcl/type/?$") +;the json url for getting some tmcl information of a topic treated as an instance +(defparameter *json-get-instance-tmcl-url* "/json/tmcl/instance/?$") +;returns a json-object representing a tree view +(defparameter *json-get-overview* "/json/tmcl/overview/?$") +;the url to the user interface +(defparameter *ajax-user-interface-url* "/isidorus") +;the url to the css files of the user interface +(defparameter *ajax-user-interface-css-prefix* "/css") +;the directory contains the css files +(defparameter *ajax-user-interface-css-directory-path* "ajax/css") +;the file path to the HTML file implements the user interface +(defparameter *ajax-user-interface-file-path* "ajax/isidorus.html") +;the directory which contains all necessary javascript files +(defparameter *ajax-javascript-directory-path* "ajax/javascripts") +;the url prefix of all javascript files +(defparameter *ajax-javascript-url-prefix* "/javascripts") +;the url suffix that calls the mark-as-deleted handler +(defparameter *mark-as-deleted-url* "/mark-as-deleted") + (defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*) (get-rdf-prefix *get-rdf-prefix*) @@ -43,7 +66,8 @@ (ajax-user-interface-css-prefix *ajax-user-interface-css-prefix*) (ajax-user-interface-css-directory-path *ajax-user-interface-css-directory-path*) (ajax-javascripts-directory-path *ajax-javascript-directory-path*) - (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*)) + (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*) + (mark-as-deleted-url *mark-as-deleted-url*)) "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table and also registers a file-hanlder to the html-user-interface" @@ -111,6 +135,9 @@ 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*)) ;; ============================================================================= @@ -356,6 +383,30 @@ (format nil "Condition: \"~a\"" err)))))) +(defun mark-as-deleted-handler (&optional param) + "Marks the corresponding elem as deleted." + (declare (ignorable param)) ;param is currently not used + (let ((http-method (hunchentoot:request-method*))) + (if (eq http-method :DELETE) + (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 ((result (json-delete-interface:mark-as-deleted-from-json + json-data :revision (d:get-revision)))) + (if result + (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)))))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + + ;; ============================================================================= ;; --- some helper functions --------------------------------------------------- ;; ============================================================================= Modified: trunk/src/unit_tests/json_test.lisp ============================================================================== --- trunk/src/unit_tests/json_test.lisp (original) +++ trunk/src/unit_tests/json_test.lisp Wed Oct 13 18:27:38 2010 @@ -13,9 +13,11 @@ :xml-importer :json-exporter :json-importer + :json-tmcl :datamodel :it.bese.FiveAM :unittests-constants + :json-delete-interface :fixtures) (:export :test-to-json-string-topics :test-to-json-string-associations @@ -37,7 +39,14 @@ :test-json-importer-merge-1 :test-json-importer-merge-2 :test-json-importer-merge-3 - :test-get-all-topic-psis)) + :test-get-all-topic-psis + :test-delete-from-json-identifiers + :test-delete-from-json-topic + :test-delete-from-json-name + :test-delete-from-json-occurrence + :test-delete-from-json-variant + :test-delete-from-json-association + :test-delete-from-json-role)) (in-package :json-test) @@ -1495,6 +1504,647 @@ (is-true (format t "found bad topic-psis: ~a" topic-psis))))))))) +(test test-delete-from-json-identifiers + "Tests the function delete-from-json with several identifiers." + (with-fixture with-empty-db ("data_base") + (let ((json-psi-1 "{\"type\":\"PSI\",\"delete\":\"psi-1-1\"}") + (json-psi-3 "{\"type\":\"PSI\",\"delete\":\"psi-1-3\"}") + (json-sl-1 "{\"type\":\"SubjectLocator\",\"delete\":\"sl-1-1\"}") + (json-sl-3 "{\"type\":\"SubjectLocator\",\"delete\":\"sl-1-3\"}") + (json-ii-1 "{\"type\":\"ItemIdentity\",\"delete\":\"ii-1-1\"}") + (json-ii-3 "{\"type\":\"ItemIdentity\",\"delete\":\"ii-1-3\"}") + (rev-1 100) + (rev-2 200)) + (let ((top (make-construct + 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1") + (make-construct 'PersistentIdC + :uri "psi-1-2")) + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-1") + (make-construct 'SubjectLocatorC + :uri "sl-1-2")) + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-2")) + :names (list (make-construct + 'NameC + :charvalue "name" + :start-revision rev-1 + :item-identifiers (list (make-construct + 'ItemIdentifierC + :uri "ii-1-1"))))))) + (with-revision rev-2 + (is (eql top (find-item-by-revision top rev-1))) + (is-false (mark-as-deleted-from-json json-psi-3)) + (is-false (mark-as-deleted-from-json json-sl-3)) + (is-false (mark-as-deleted-from-json json-ii-3)) + (is (= (length (psis top)) 2)) + (is (= (length (locators top)) 2)) + (is (= (length (item-identifiers top)) 1)) + (is (= (length (names top)) 1)) + (is (= (length (item-identifiers (first (names top)))) 1)) + (is-true (mark-as-deleted-from-json json-psi-1)) + (is (= (length (psis top)) 1)) + (is (string= (uri (first (psis top))) "psi-1-2")) + (is-true (mark-as-deleted-from-json json-sl-1)) + (is (= (length (locators top)) 1)) + (is (string= (uri (first (locators top))) "sl-1-2")) + (is-true (mark-as-deleted-from-json json-ii-1)) + (is (= (length (item-identifiers top)) 1)) + (is (string= (uri (first (item-identifiers top))) "ii-1-2")) + (is (= (length (item-identifiers (first (names top)))) 0))) + (with-revision rev-1 + (is (= (length (psis top)) 2)) + (is (= (length (locators top)) 2)) + (is (= (length (item-identifiers top)) 1)) + (is (= (length (names top)) 1)) + (is (= (length (item-identifiers (first (names top)))) 1))))))) + + +(test test-delete-from-json-topic + "Tests the function delete-from-json with several identifiers." + (with-fixture with-empty-db ("data_base") + (let ((j-top-1 "{\"type\":\"Topic\",\"delete\":{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-1\"],\"subjectLocators\":null,\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null}}") + (j-top-2 "{\"type\":\"Topic\",\"delete\":{\"id\":\"any-id\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"psi-1-1\"],\"instanceOfs\":null,\"names\":null,\"occurrence\":null}}") + (j-top-3 "{\"type\":\"Topic\",\"delete\":{\"id\":\"any-id\",\"itemIdentities\":null,\"subjectLocators\":[\"sl-1-1\"],\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null}}") + (j-top-4 "{\"type\":\"Topic\",\"delete\":{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-2\"],\"subjectLocators\":[\"sl-1-2\"],\"subjectIdentifiers\":[\"psi-1-2\"],\"instanceOfs\":null,\"names\":null,\"occurrence\":null}}") + (rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((top-1 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-1")))) + (top-2 (make-construct + 'TopicC + :start-revision rev-2 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1")))) + (top-3 (make-construct + 'TopicC + :start-revision rev-1 + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-1")))) + (top-4 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-3")) + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-3")) + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-3"))))) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-1 top-2 top-3 top-4))) + (is-false (mark-as-deleted-from-json j-top-4 :revision rev-2)) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-1 top-2 top-3 top-4))) + (is-true (mark-as-deleted-from-json j-top-1 :revision rev-2)) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-2 top-3 top-4))) + (is-true (mark-as-deleted-from-json j-top-2 :revision rev-3)) + (is-false (set-exclusive-or (get-all-topics rev-3) + (list top-3 top-4))) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-2 top-3 top-4))) + (is-true (mark-as-deleted-from-json j-top-3 :revision rev-2)) + (is-false (set-exclusive-or (get-all-topics rev-3) + (list top-4))) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-2 top-4))) + (is-false (set-exclusive-or (get-all-topics rev-3) + (list top-4))))))) + + +(test test-delete-from-json-name + (with-fixture with-empty-db ("data_base") + (let ((j-parent-1 "{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-1\"],\"subjectLocators\":null,\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-parent-2 "{\"id\":\"any-id\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"psi-1-1\"],\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-type "{\"type\":\"Name\",\"parent\":") + (j-name-1 "\"delete\":{\"type\":[\"nType-1\"],\"scopes\":null,\"value\":\"name-1\"}}") + (j-name-2 "\"delete\":{\"type\":null,\"scopes\":[[\"nScope-1\"],[\"nScope-2\"]],\"value\":\"name-2\"}}") + (j-name-3 "\"delete\":{\"type\":null,\"scopes\":null,\"value\":\"name-3\"}}") + (rev-1 100) + (rev-2 200)) + (let ((nType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "nType-1")))) + (nScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "nScope-1")))) + (nScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "nScope-2"))))) + (let ((j-req-1 (concatenate 'string j-type j-parent-1 j-name-1)) + (j-req-2 (concatenate 'string j-type j-parent-1 j-name-2)) + (j-req-3 (concatenate 'string j-type j-parent-1 j-name-3)) + (j-req-4 (concatenate 'string j-type j-parent-2 j-name-1)) + (j-req-5 (concatenate 'string j-type j-parent-2 j-name-2)) + (top-1 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-1")) + :names (list (make-construct 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1") + (make-construct 'NameC + :start-revision rev-1 + :themes (list nScope-1 nScope-2) + :charvalue "name-2") + (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3")))) + (top-2 (make-construct + 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1")) + :names (list (make-construct 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1") + (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3")))) + (top-3 (make-construct + 'TopicC + :start-revision rev-1 + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-1")) + :names (list (make-construct 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1") + (make-construct 'NameC + :start-revision rev-1 + :themes (list nScope-1 nScope-2) + :charvalue "name-2") + (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3"))))) + (with-revision rev-2 + (is (= (length (get-all-topics)) 6)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 8)) + (is (= (length (names top-1)) 3)) + (is (= (length (names top-2)) 2)) + (is (= (length (names top-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (names top-1)) + (list "name-2" "name-3") :test #'string=)) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (names top-1)) + (list "name-3") :test #'string=)) + (is-true (mark-as-deleted-from-json j-req-3)) + (is-false (names top-1)) + (is-false (mark-as-deleted-from-json j-req-3)) + (is-false (names top-1)) + (is (= (length (names top-2)) 2)) + (is (= (length (names top-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-4)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (names top-2)) + (list "name-3") :test #'string=)) + (is-false (mark-as-deleted-from-json j-req-5)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (names top-2)) + (list "name-3") :test #'string=)) + (is (= (length (names top-3)) 3)))))))) + + +(test test-delete-from-json-occurrence + (with-fixture with-empty-db ("data_base") + (let ((j-parent-1 "{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-1\"],\"subjectLocators\":null,\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-parent-2 "{\"id\":\"any-id\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"psi-1-1\"],\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-type "{\"type\":\"Occurrence\",\"parent\":") + (j-occ-1 "\"delete\":{\"type\":[\"oType-1\"],\"scopes\":null,\"resourceRef\":\"value-1\"}}") + (j-occ-2 "\"delete\":{\"type\":[\"oType-2\"],\"scopes\":[[\"oScope-1\"],[\"oScope-2\"]],\"resourceData\":{\"datatype\":\"datatype-1\",\"value\":\"value-2\"}}}") + (j-occ-3 "\"delete\":{\"type\":[\"oType-1\"],\"scopes\":null,\"resourceData\":{\"datatype\":\"datatype-2\",\"value\":\"value-3\"}}}") + (rev-1 100) + (rev-2 200)) + (let ((oType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "oType-1")))) + (oType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "oType-2")))) + (oScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "oScope-1")))) + (oScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "oScope-2"))))) + (let ((j-req-1 (concatenate 'string j-type j-parent-1 j-occ-1)) + (j-req-2 (concatenate 'string j-type j-parent-1 j-occ-2)) + (j-req-3 (concatenate 'string j-type j-parent-1 j-occ-3)) + (j-req-4 (concatenate 'string j-type j-parent-2 j-occ-1)) + (j-req-5 (concatenate 'string j-type j-parent-2 j-occ-2)) + (top-1 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-1")) + :occurrences + (list (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-1 + :charvalue "value-1" + :datatype constants::*xml-uri*) + (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-2 + :themes (list oScope-1 oScope-2) + :charvalue "value-2" + :datatype "datatype-1") + (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-1 + :charvalue "value-3" + :datatype "datatype-2")))) + (top-2 (make-construct + 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1")) + :occurrences + (list (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-1 + :charvalue "value-1" + :datatype constants::*xml-uri*) + (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "value-3" + :datatype "datatype-2")))) + (top-3 (make-construct + 'TopicC + :start-revision rev-1 + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-1")) + :occurrences + (list (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-1 + :charvalue "value-1" + :datatype constants::*xml-uri*) + (make-construct 'OccurrenceC + :start-revision rev-1 + :themes (list oScope-1 oScope-2) + :charvalue "value-2" + :datatype "datatype-1") + (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "value-3" + :datatype "datatype-2"))))) + (with-revision rev-2 + (is (= (length (get-all-topics)) 7)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 8)) + (is (= (length (occurrences top-1)) 3)) + (is (= (length (occurrences top-2)) 2)) + (is (= (length (occurrences top-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-false (set-exclusive-or (map 'list #'d:charvalue + (occurrences top-1)) + (list "value-2" "value-3") :test #'string=)) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or (map 'list #'d:charvalue + (occurrences top-1)) + (list "value-3") :test #'string=)) + (is-true (mark-as-deleted-from-json j-req-3)) + (is-false (occurrences top-1)) + (is (= (length (occurrences top-2)) 2)) + (is (= (length (occurrences top-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-4)) + (is-false (set-exclusive-or (map 'list #'d:charvalue + (occurrences top-2)) + (list "value-3") :test #'string=)) + (is-false (mark-as-deleted-from-json j-req-5)) + (is-false (set-exclusive-or (map 'list #'d:charvalue + (occurrences top-2)) + (list "value-3") :test #'string=)) + (is (= (length (occurrences top-3)) 3)))))))) + + +(test test-delete-from-json-variant + (with-fixture with-empty-db ("data_base") + (let ((j-parent-of-parent-1 "\"parentOfParent\":{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-1\"],\"subjectLocators\":null,\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-type "{\"type\":\"Variant\",") + (j-parent-1 "\"parent\":{\"type\":[\"nType-1\"],\"scopes\":null,\"value\":\"name-1\"},") + (j-parent-2 "\"parent\":{\"type\":null,\"scopes\":[[\"vScope-1\"],[\"vScope-2\"]],\"value\":\"name-2\"},") + (j-var-1 "\"delete\":{\"scopes\":[[\"vScope-1\"]],\"resourceRef\":\"value-1\"}}") + (j-var-2 "\"delete\":{\"scopes\":[[\"vScope-1\"],[\"vScope-2\"]],\"resourceData\":{\"datatype\":\"datatype-1\",\"value\":\"value-2\"}}}") + (rev-1 100) + (rev-2 200)) + (let ((nType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "nType-1")))) + (vScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "vScope-1")))) + (vScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "vScope-2"))))) + (let ((j-req-1 (concatenate 'string j-type j-parent-of-parent-1 + j-parent-1 j-var-1)) + (j-req-2 (concatenate 'string j-type j-parent-of-parent-1 + j-parent-1 j-var-2)) + (j-req-3 (concatenate 'string j-type j-parent-of-parent-1 + j-parent-2 j-var-1)) + (top-1 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-1")) + :names (list (make-construct + 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1" + :variants (list (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1) + :datatype constants::*xml-uri* + :charvalue "value-1") + (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1 vScope-2) + :datatype "datatype-1" + :charvalue "value-2") + (make-construct + 'VariantC + :start-revision rev-1 + :datatype "datatpye-1" + :charvalue "value-2"))) + (make-construct 'NameC + :start-revision rev-1 + :themes (list vScope-1 vScope-2) + :charvalue "name-2" + :variants (list (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1) + :datatype constants::*xml-uri* + :charvalue "value-1") + (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1 vScope-2) + :datatype "datatype-1" + :charvalue "value-2") + (make-construct + 'VariantC + :start-revision rev-1 + :datatype "datatpye-1" + :charvalue "value-2")))))) + (top-2 (make-construct + 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1")) + :names (list (make-construct + 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1" + :variants (list (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1) + :datatype constants::*xml-uri* + :charavalue "value-1") + (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1 vScope-2) + :datatype "datatype-1" + :charvalue "value-2") + (make-construct + 'VariantC + :start-revision rev-1 + :datatype "datatpye-1" + :charvalue "value-2"))))))) + (with-revision rev-2 + (is (= (length (get-all-topics)) 5)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 9)) + (let ((name-1 (find "name-1" (names top-1) :key #'charvalue + :test #'string=)) + (name-2 (find "name-2" (names top-1) :key #'charvalue + :test #'string=)) + (name-3 (first (names top-2)))) + (is-true name-1) + (is-true name-2) + (is-true name-3) + (is (= (length (variants name-1)) 3)) + (is (= (length (variants name-2)) 3)) + (is (= (length (variants name-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (variants name-1)) + (list "value-2" "value-2") :test #'string=)) + (is (= (length (variants name-1)) 2)) + (is (= (length (variants name-2)) 3)) + (is (= (length (variants name-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (variants name-1)) + (list "value-2" ) :test #'string=)) + (is (= (length (variants name-1)) 1)) + (is (= (length (variants name-2)) 3)) + (is (= (length (variants name-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-3)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (variants name-2)) + (list "value-2" ) :test #'string=)) + (is (= (length (variants name-1)) 1)) + (is (= (length (variants name-2)) 2)) + (is (= (length (variants name-3)) 3))))))))) + + +(test test-delete-from-json-association + (with-fixture with-empty-db ("data_base") + (let ((j-type "{\"type\":\"Association\",") + (j-role-1 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-1\"]}") + (j-role-2 "{\"type\":[\"rType-2\"],\"topicRef\":[\"player-1\"]}") + (j-role-3 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-2\"]}") + (rev-1 100) + (rev-2 200)) + (let ((j-req-1 (concatenate 'string j-type "\"delete\":{\"type\":[\"aType-1\"],\"scopes\":[[\"aScope-1\"]],\"roles\":[" j-role-1 "," j-role-2 "]}}")) + (j-req-2 (concatenate 'string j-type "\"delete\":{\"type\":[\"aType-2\"],\"scopes\":[[\"aScope-1\"],[\"aScope-2\"]],\"roles\":[" j-role-1 "," j-role-2 "]}}")) + (j-req-3 (concatenate 'string j-type "\"delete\":{\"type\":[\"aType-1\"],\"scopes\":null,\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]}}")) + (aType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aType-1")))) + (aType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aType-2")))) + (aScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aScope-1")))) + (aScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aScope-2")))) + (player-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "player-1")))) + (player-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "player-2")))) + (rType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "rType-1")))) + (rType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "rType-2"))))) + (let ((role-1 (list :start-revision rev-1 + :player player-1 + :instance-of rType-1)) + (role-2 (list :start-revision rev-1 + :player player-1 + :instance-of rType-2)) + (role-3 (list :start-revision rev-1 + :player player-2 + :instance-of rType-1))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-1 + :themes (list aScope-1) + :roles (list role-1 role-2))) + (assoc-2 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-2 + :themes (list aScope-1 aScope-2) + :roles (list role-1 role-2))) + (assoc-3 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-1 + :roles (list role-1 role-2 role-3)))) + (with-revision rev-2 + (is (= (length (get-all-associations)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-true (marked-as-deleted-p assoc-1)) + (is-false (set-exclusive-or (get-all-associations) + (list assoc-2 assoc-3))) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or (get-all-associations) + (list assoc-3))) + (is-true (mark-as-deleted-from-json j-req-3)) + (is-false (get-all-associations))))))))) + + +(test test-delete-from-json-role + (with-fixture with-empty-db ("data_base") + (let ((j-type "{\"type\":\"Role\",") + (j-role-1 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-1\"]}") + (j-role-2 "{\"type\":[\"rType-2\"],\"topicRef\":[\"player-1\"]}") + (j-role-3 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-2\"]}") + (rev-1 100) + (rev-2 200)) + (let ((j-req-1 (concatenate 'string j-type "\"parent\":{\"type\":[\"aType-1\"],\"scopes\":[[\"aScope-1\"]],\"roles\":[" j-role-1 "," j-role-2 "," j-role-3"]},\"delete\":" j-role-1 "}")) + (j-req-2 (concatenate 'string j-type "\"parent\":{\"type\":[\"aType-2\"],\"scopes\":[[\"aScope-1\"],[\"aScope-2\"]],\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]},\"delete\":" j-role-1 "}")) + (j-req-3 (concatenate 'string j-type "\"parent\":{\"type\":[\"aType-1\"],\"scopes\":null,\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]},\"delete\":" j-role-2 "}")) + (aType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aType-1")))) + (aType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aType-2")))) + (aScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aScope-1")))) + (aScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aScope-2")))) + (player-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "player-1")))) + (player-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "player-2")))) + (rType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "rType-1")))) + (rType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "rType-2"))))) + (let ((role-1 (list :start-revision rev-1 + :player player-1 + :instance-of rType-1)) + (role-2 (list :start-revision rev-1 + :player player-1 + :instance-of rType-2)) + (role-3 (list :start-revision rev-1 + :player player-2 + :instance-of rType-1))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-1 + :themes (list aScope-1) + :roles (list role-1 role-2 role-3))) + (assoc-2 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-2 + :themes (list aScope-1 aScope-2) + :roles (list role-1 role-2 role-3)))) + (with-revision rev-2 + (is (= (length (get-all-associations)) 2)) + (is (= (length (roles assoc-1)) 3)) + (is (= (length (roles assoc-2)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-false (set-exclusive-or + (roles assoc-1) + (list role-2 role-3) + :test #'(lambda(a-role j-role) + (and (eql (instance-of a-role) + (getf j-role :instance-of)) + (eql (player a-role) + (getf j-role :player)))))) + (is (= (length (roles assoc-1)) 2)) + (is (= (length (roles assoc-2)) 3)) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or + (roles assoc-2) + (list role-2 role-3) + :test #'(lambda(a-role j-role) + (and (eql (instance-of a-role) + (getf j-role :instance-of)) + (eql (player a-role) + (getf j-role :player)))))) + (is (= (length (roles assoc-1)) 2)) + (is (= (length (roles assoc-2)) 2)) + (is-false (mark-as-deleted-from-json j-req-3)) + (is (= (length (roles assoc-1)) 2)) + (is (= (length (roles assoc-2)) 2))))))))) + + + + (defun run-json-tests() (tear-down-test-db) (it.bese.fiveam:run! 'test-get-fragment-values-from-json-list-general) @@ -1516,4 +2166,11 @@ (it.bese.fiveam:run! 'test-to-json-string-associations) (it.bese.fiveam:run! 'test-to-json-string-fragments) (it.bese.fiveam:run! 'test-to-json-string-topics) - (it.bese.fiveam:run! 'test-get-all-topic-psis)) + (it.bese.fiveam:run! 'test-get-all-topic-psis) + (it.bese.fiveam:run! 'test-delete-from-json-identifiers) + (it.bese.fiveam:run! 'test-delete-from-json-topic) + (it.bese.fiveam:run! 'test-delete-from-json-name) + (it.bese.fiveam:run! 'test-delete-from-json-occurrence) + (it.bese.fiveam:run! 'test-delete-from-json-variant) + (it.bese.fiveam:run! 'test-delete-from-json-association) + (it.bese.fiveam:run! 'test-delete-from-json-role)) \ No newline at end of file