[isidorus-cvs] r326 - in trunk: docs src src/json src/rest_interface src/unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Oct 13 22:27:39 UTC 2010
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
More information about the Isidorus-cvs
mailing list