[isidorus-cvs] r277 - trunk/src/json

Lukas Giessmann lgiessmann at common-lisp.net
Wed Apr 14 14:51:13 UTC 2010


Author: lgiessmann
Date: Wed Apr 14 10:51:13 2010
New Revision: 277

Log:
rest-interface: finalized and tested the mark-as-deleted-handler of the RESTful interface; json: added some helpers for the rest-interface-mark-as-deleted-handler; added the corresponding docu into json.ebnf and xtm_json.txt

Modified:
   trunk/src/json/json_tmcl.lisp

Modified: trunk/src/json/json_tmcl.lisp
==============================================================================
--- trunk/src/json/json_tmcl.lisp	(original)
+++ trunk/src/json/json_tmcl.lisp	Wed Apr 14 10:51:13 2010
@@ -13,78 +13,9 @@
 ;; =============================================================================
 ;; --- mark-as-deleted handler -------------------------------------------------
 ;; =============================================================================
-; a test string ...
-(defvar cl-user::*js-1*
-  "{\"type\":\"Association\",
-    \"topics\":[\"http://textgrid.org/isidorus/tmcl/service\",
-                \"http://textgrid.org/isidorus/tmcl/parameter\"],
-    \"associations\":[{\"itemIdentities\":null,
-                      \"type\":[\"http://psi.topicmaps.org/tmcl/applies-to\"],
-                      \"scopes\":null,
-                      \"roles\":[{\"itemIdentities\":null,
-                                  \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"],
-                                  \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]},
-                                 {\"itemIdentities\":null,
-                                  \"type\":[\"http://psi.topicmaps.org/tmcl/topic-type-role\"],
-                                  \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/service\"]}]}],
-    \"parent-topic\":[\"http://textgrid.org/isidorus/my-service/my-service\"],
-    \"parent-name\":{\"itemIdentities\":null,
-                     \"type\":[\"http://textgrid.org/isidorus/tmcl/service-name\"],
-                     \"scopes\":null,
-                     \"value\":\"my-service\",
-                     \"variants\":null},
-    \"names\":[{\"itemIdentities\":null,
-                \"type\":[\"http://textgrid.org/isidorus/tmcl/service-name\"],
-                \"scopes\":null,
-                \"value\":\"my-service\",
-                \"variants\":null}],
-    \"variants\":[{\"itemIdentities\":null,
-                   \"scopes\":[[\"http://textgrid.org/isidorus/tmcl/display\"]],
-                   \"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\",
-                                     \"value\":\"http://textgrid.org/isidorus/tmcl/service\"},
-                   \"resourceRef\":null},
-                  {\"itemIdentities\":null,
-                   \"scopes\":[[\"http://textgrid.org/isidorus/tmcl/is-ref\"]],
-                   \"resourceData\":null,
-                   \"resourceRef\":\"http://any-ref.org\"}],
-    \"occurrences\":[{\"itemIdentities\":null,
-                      \"type\":[\"http://textgrid.org/isidorus/tmcl/service-key\"],
-                      \"scopes\":null,
-                      \"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\",
-                                        \"value\":\"service-key\"}}],
-    \"parent-association\":{\"itemIdentities\":null,
-                            \"type\":[\"http://psi.topicmaps.org/tmcl/applies-to\"],
-                            \"scopes\":null,
-                            \"roles\":[{\"itemIdentities\":null,
-                                        \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"],
-                                        \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]},
-                                       {\"itemIdentities\":null,
-                                        \"type\":[\"http://psi.topicmaps.org/tmcl/topictype-role\"],
-                                        \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/service\"]}]},
-    \"roles\":[{\"itemIdentities\":null,
-                \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"],
-                \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]}]}")
-
-
 (defun mark-as-deleted-from-json (json-data)
+  "Marks an object that is specified by the given JSON data as deleted."
   (declare (string json-data))
-  
-;{\"type\":<\"Topic\" | \"Occurrence\" | \"Name\"
-;           \"Association\" | \"Role\" | \"Variant\" >,
-; \"topics\": <one psi per topic of the topic that have to be deleted>,
-; \"associations\": <a list of associations that should be deleted in the
-;                   specified json format>,
-; \"parent-topic\": <one psi of the parent topic the deleted
-;                    objects are contained in or null if the
-;                    deleted object is the topic itself>,
-; \"parent-name\": <the owner parent of the deleted variants>,
-; \"names\": <a list of names that have to be deleted>,
-; \"variants\": <a list of variants that have to be deleted>,
-; \"occurrences\": <a list of occurrences that have to be deleted>,
-; \"parent-association\": <one association in the specified json
-;                          format, that is the parent of the passed
-;                          role>
-; \"roles\": <a list of roles in the specified json format>}
   (let ((values (json:decode-json-from-string json-data)))
     (let ((type nil)
 	  (topics nil)
@@ -116,18 +47,204 @@
 	    ((string= type "Association")
 	     (delete-associations-from-json associations rev))
 	    ((string= type "Occurrence")
-	     nil)
+	     (delete-occurrences-from-json occurrences parent-topic rev))
 	    ((string= type "Name")
-	     nil)
+	     (delete-names-from-json names parent-topic rev))
 	    ((string= type "Variant")
-	     nil)
+	     (delete-variants-from-json variants parent-topic parent-name rev))
 	    ((string= type "Role")
-	     nil)
+	     (delete-roles-from-json roles parent-association rev))
 	    (t
 	     (error "From mark-as-deleted-from-json(): the type ~a is not defined"
 		    type))))))
 
 
+(defun find-role-from-json (parent-association json-plist)
+  (declare (AssociationC parent-association) (list json-plist))
+  (let ((found-role
+	 (find-if
+	  #'(lambda(role)
+	      (let ((type (when (getf json-plist :type)
+			    (d:get-item-by-psi (first (getf json-plist :type)))))
+		    (player (when (getf json-plist :topicRef)
+			      (d:get-item-by-psi
+			       (first (getf json-plist :topicRef))))))
+		(and (eql type (d:instance-of role))
+		     (eql player (d:player role)))))
+	  (d:roles parent-association))))
+    found-role))
+
+
+(defun delete-roles-from-json (roles parent-association revision)
+  (declare (list roles parent-association) (integer revision))
+  (let ((err "From delete-roles-from-association(): ")
+	(parent-assoc
+	 (find-association-from-json
+	  (json-importer::get-association-values-from-json-list
+	   parent-association))))
+    (unless parent-assoc
+      (error "~a~a not found" err parent-association))
+    (dolist (j-role roles)
+      (let ((plist (json-importer::get-role-values-from-json-list j-role)))
+	(let ((role (find-role-from-json parent-assoc plist)))
+	  (unless role
+	    (error "~a~a not found" err plist))
+	  (format t "~a~%" role)
+	  (mark-as-deleted role :revision revision))))))
+
+
+(defun find-variant-from-json (parent-name json-plist)
+  (declare (NameC parent-name) (list json-plist))
+  (let ((err "From find-variant-from-json(): "))
+    (let ((found-var
+	   (find-if
+	    #'(lambda(var)
+		(let ((datatype (cond ((getf json-plist :datatype)
+				       (getf json-plist :datatype))
+				      ((getf json-plist :resourceRef)
+				       constants:*xml-uri*)
+				      ((getf json-plist :resourceData)
+				       (let ((val
+					      (getf
+					       (getf json-plist :resourceData)
+					       :datatype)))
+					 (if val val constants:*xml-string*)))
+				      (t
+				       constants:*xml-string*)))
+		      (charvalue (cond ((getf json-plist :resourceRef)
+					(getf json-plist :resourceRef))
+				       ((getf json-plist :resourceData)
+					(getf (getf json-plist :resourceData)
+					      :value))
+				       (t
+					"")))
+		      (scopes nil))
+		  (loop for scope-entry in (getf json-plist :scopes)
+		     do (let ((top (d:get-item-by-psi (first scope-entry))))
+			  (unless top
+			    (error "~a ~a not found" err (first scope-entry)))
+			  (pushnew top scopes)))
+		  (and (not (set-exclusive-or scopes (d:themes var)))
+		       (string= datatype (d:datatype var))
+		       (string= charvalue (d:charvalue var)))))
+	    (d:variants parent-name :revision 0))))
+      found-var)))
+
+
+(defun delete-variants-from-json (variants parent-psi parent-name revision)
+  (declare (string parent-psi) (list variants parent-name))
+  (let ((err "From delete-variants-from-json(): ")
+	(parent-topic (d:get-item-by-psi parent-psi)))
+    (unless parent-topic
+      (error "~a~a not found" err parent-psi))
+    (let ((v-name
+	   (find-name-from-json
+	    parent-topic
+	    (json-importer::get-name-values-from-json-list parent-name))))
+      (unless v-name
+	(error "~a~a not found" err parent-name))
+      (dolist (j-variant variants)
+	(let ((plist
+	       (json-importer::get-variant-values-from-json-list j-variant)))
+	  (let ((variant (find-variant-from-json v-name plist)))
+	    (unless variant
+	      (error "~a~a not found" err plist))
+	    (mark-as-deleted variant :revision revision)))))))
+
+
+(defun find-name-from-json(parent-topic json-plist)
+  (declare (TopicC parent-topic) (list json-plist))
+  (let ((err "From find-name-from-json(): "))
+    (let ((found-name
+	   (find-if
+	    #'(lambda(name)
+		(let ((type (when (getf json-plist :type)
+			      (d:get-item-by-psi (first (getf json-plist :type)))))
+		      (charvalue (if (getf json-plist :value)
+				     (getf json-plist :value)
+				     ""))
+		      (scopes nil))
+		  (loop for scope-entry in (getf json-plist :scopes)
+		     do (let ((top (d:get-item-by-psi (first scope-entry))))
+			  (unless top
+			    (error "~a ~a not found" err (first scope-entry)))
+			  (pushnew top scopes)))
+		  (and (eql type (d:instance-of name))
+		       (not (set-exclusive-or scopes (d:themes name)))
+		       (string= charvalue (d:charvalue name)))))
+	    (names parent-topic :revision 0))))
+      found-name)))
+
+
+(defun delete-names-from-json (names parent-psi revision)
+  (declare (list names) (string parent-psi) (integer revision))
+  (let ((parent-topic (d:get-item-by-psi parent-psi))
+	(err "From delete-name-from-json(): "))
+    (unless parent-topic
+      (error "~a~a not found"
+	     err parent-psi))
+    (dolist (j-name names)
+      (let ((plist (json-importer::get-name-values-from-json-list j-name)))
+	(let ((name (find-name-from-json parent-topic plist)))
+	  (unless name
+	    (error "~a~a not found" err plist))
+	  (mark-as-deleted name :revision revision))))))
+
+
+(defun find-occurrence-from-json(parent-topic json-plist)
+  (declare (TopicC parent-topic) (list json-plist))
+  (let ((err "From find-occurrence-from-json(): "))
+    (let ((found-occ
+	   (find-if
+	    #'(lambda(occ)
+		(let ((type (when (getf json-plist :type)
+			      (d:get-item-by-psi (first (getf json-plist :type)))))
+		      (datatype (cond ((getf json-plist :datatype)
+				       (getf json-plist :datatype))
+				      ((getf json-plist :resourceRef)
+				       constants:*xml-uri*)
+				      ((getf json-plist :resourceData)
+				       (let ((val
+					      (getf
+					       (getf json-plist :resourceData)
+					       :datatype)))
+					 (if val val constants:*xml-string*)))
+				      (t
+				       constants:*xml-string*)))
+		      (charvalue (cond ((getf json-plist :resourceRef)
+					(getf json-plist :resourceRef))
+				       ((getf json-plist :resourceData)
+					(getf (getf json-plist :resourceData)
+					      :value))
+				       (t
+					"")))
+		      (scopes nil))
+		  (loop for scope-entry in (getf json-plist :scopes)
+		     do (let ((top (d:get-item-by-psi (first scope-entry))))
+			  (unless top
+			    (error "~a ~a not found" err (first scope-entry)))
+			  (pushnew top scopes)))
+		  (and (eql type (d:instance-of occ))
+		       (not (set-exclusive-or scopes (d:themes occ)))
+		       (string= datatype (d:datatype occ))
+		       (string= charvalue (d:charvalue occ)))))
+	    (occurrences parent-topic :revision 0))))
+      found-occ)))
+
+
+(defun delete-occurrences-from-json(occurrences parent-psi revision)
+  (declare (list occurrences) (string parent-psi) (integer revision))
+  (let ((parent-topic (d:get-item-by-psi parent-psi))
+	(err "From delete-occurrence-from-json(): "))
+    (unless parent-topic
+      (error "~a~a not found" err parent-psi))
+    (dolist (j-occ occurrences)
+      (let ((plist (json-importer::get-occurrence-values-from-json-list j-occ)))
+	(let ((occ (find-occurrence-from-json parent-topic plist)))
+	  (unless occ
+	    (error "~a~a not found" err plist))
+	  (mark-as-deleted occ :revision revision))))))
+
 
 (defun find-association-from-json (json-plist)
   (declare (list json-plist))
@@ -140,8 +257,7 @@
     (loop for scope-entry in (getf json-plist :scopes)
        do (let ((top (d:get-item-by-psi (first scope-entry))))
 	    (unless top
-	      (error "~a ~a not found"
-		     err (first scope-entry)))
+	      (error "~a ~a not found" err (first scope-entry)))
 	    (pushnew top scopes)))
     (let ((scope-assocs
 	   (loop for assoc in type-assocs




More information about the Isidorus-cvs mailing list