[isidorus-cvs] r78 - in trunk/src: ajax/javascripts json rest_interface unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Jun 29 14:24:54 UTC 2009
Author: lgiessmann
Date: Mon Jun 29 10:24:53 2009
New Revision: 78
Log:
json-server: fixed a bug with topic-, association, role-, name- and occurrence-types; added the RESTful-handler "json/tmcl/overview/?" that returns a json-object representing the topics as a (or more) tree-view(s)
Modified:
trunk/src/ajax/javascripts/constants.js
trunk/src/json/json_tmcl.lisp
trunk/src/json/json_tmcl_validation.lisp
trunk/src/rest_interface/rest-interface.lisp
trunk/src/rest_interface/set-up-json-interface.lisp
trunk/src/unit_tests/poems.xtm
Modified: trunk/src/ajax/javascripts/constants.js
==============================================================================
--- trunk/src/ajax/javascripts/constants.js (original)
+++ trunk/src/ajax/javascripts/constants.js Mon Jun 29 10:24:53 2009
@@ -22,6 +22,7 @@
var INSTANCE_PSIS_URL = HOST_PREF + "json/tmcl/instances/";
var OWN_URL = HOST_PREF + "isidorus";
var SUMMARY_URL = HOST_PREF + "json/summary"
+var TM_OVERVIEW = "/json/tmcl/overview/";
var TIMEOUT = 10000; // const TIMEOUT = 10000 --> "const" doesn't work under IE
Modified: trunk/src/json/json_tmcl.lisp
==============================================================================
--- trunk/src/json/json_tmcl.lisp (original)
+++ trunk/src/json/json_tmcl.lisp Mon Jun 29 10:24:53 2009
@@ -18,7 +18,7 @@
topic-psis must contain one item if it is treated as instance other wiese there can be more psis
then the fragment will be treated as an instanceOf all passed psis."
(let ((associationtype (get-item-by-psi *associationtype-psi*))
- (associationtype-constraint (get-item-by-psi *associationtype-constraint-psi*))
+ (associationtype-constraint (is-type-constrained :what *associationtype-constraint-psi*))
(topics nil))
(when (and (not (eql treat-as 'type))
(> (length topic-psis) 1))
@@ -102,9 +102,9 @@
(othertopictype-role (get-item-by-psi *othertopictype-role-psi*))
(otherroletype-role (get-item-by-psi *otherroletype-role-psi*))
(roletype (get-item-by-psi *roletype-psi*))
- (roletype-constraint (get-item-by-psi *roletype-constraint-psi*))
+ (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*))
(topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*)))
+ (topictype-constraint (is-type-constrained)))
(let ((otherrole-constraints
(loop for constraint-topic in constraint-topics
append (let ((players nil)
@@ -233,9 +233,9 @@
(topictype-role (get-item-by-psI *topictype-role-psi*))
(roletype-role (get-item-by-psi *roletype-role-psi*))
(roletype (get-item-by-psi *roletype-psi*))
- (roletype-constraint (get-item-by-psi *roletype-constraint-psi*))
+ (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*))
(topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*)))
+ (topictype-constraint (is-type-constrained)))
(let ((roleplayer-constraints
(loop for constraint-topic in constraint-topics
append (let ((constraint-list
@@ -327,7 +327,7 @@
(roletype-role (get-item-by-psi *roletype-role-psi*))
(constraint-role (get-item-by-psi *constraint-role-psi*))
(roletype (get-item-by-psi *roletype-psi*))
- (roletype-constraint (get-item-by-psi *roletype-constraint-psi*)))
+ (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*)))
(let ((associationrole-constraints
(loop for constraint-topic in constraint-topics
append (let ((constraint-list
@@ -465,7 +465,7 @@
(applies-to (get-item-by-psi *applies-to-psi*))
(topictype-role (get-item-by-psi *topictype-role-psi*))
(topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*)))
+ (topictype-constraint (is-type-constrained)))
(let ((topics
(remove-duplicates
(loop for exclusive-instances-list in exclusive-instances-lists
@@ -536,7 +536,7 @@
(applies-to (get-item-by-psi *applies-to-psi*))
(nametype-role (get-item-by-psi *nametype-role-psi*))
(nametype (get-item-by-psi *nametype-psi*))
- (nametype-constraint (get-item-by-psi *nametype-constraint-psi*)))
+ (nametype-constraint (is-type-constrained :what *nametype-constraint-psi*)))
(let ((topicname-constraints
(remove-if #'null
(loop for constraint-topic in constraint-topics
@@ -603,7 +603,7 @@
(applies-to (get-item-by-psi *applies-to-psi*))
(occurrencetype-role (get-item-by-psi *occurrencetype-role-psi*))
(occurrencetype (get-item-by-psi *occurrencetype-psi*))
- (occurrencetype-constraint (get-item-by-psi *occurrencetype-constraint-psi*)))
+ (occurrencetype-constraint (is-type-constrained :what *occurrencetype-constraint-psi*)))
(let ((topicoccurrence-constraints
(remove-if #'null
(loop for constraint-topic in constraint-topics
@@ -1069,7 +1069,7 @@
"Returns all constraint topics defined for associations if
the passed associationtype-topic."
(let ((akos-and-isas-of-this
- (topictype-p associationtype-topic (get-item-by-psi *associationtype-psi*) (get-item-by-psi *associationtype-constraint-psi*))))
+ (topictype-p associationtype-topic (get-item-by-psi *associationtype-psi*) (is-type-constrained :what *associationtype-constraint-psi*))))
(let ((all-associationrole-constraints nil)
(all-roleplayer-constraints nil)
(all-otherrole-constraints nil))
@@ -1133,3 +1133,159 @@
(map 'list #'(lambda(topic)
(map 'list #'uri (psis topic)))
topics)))
+
+
+(defun tree-view-to-json-string (tree-views)
+ "Returns a full tree-view as json-string."
+ (let ((json-string
+ (concatenate 'string "["
+ (if tree-views
+ (let ((inner-string ""))
+ (loop for tree-view in tree-views
+ do (setf inner-string (concatenate 'string inner-string (node-to-json-string tree-view) ",")))
+ (concatenate 'string (subseq inner-string 0 (- (length inner-string) 1)) "]"))
+ "null"))))
+ json-string))
+
+(defun make-tree-view ()
+ "Returns a list of the form:
+ ((<topictype> (direct-instances) (direc-subtypes)) (<...>));
+ -> direct-instances: (<any-topic> (direct-instances) (direct-subtypes))
+ -> direct-subtypes: (<any-topic> (direct-instances) (direct-subtypes))"
+ (let ((topictype (d:get-item-by-psi json-tmcl-constants::*topictype-psi*))
+ (topictype-constraint (is-type-constrained)))
+ (if topictype-constraint
+ (progn
+ (unless topictype
+ (error "From make-tree-view(): The topictype-constraint \"~a\" exists but the topictype \"~a\" is missing!"
+ json-tmcl-constants::*topictype-constraint-psi*
+ json-tmcl-constants::*topictype-psi*))
+ (list (make-nodes topictype t t)))
+ (let ((tree-roots
+ (get-all-tree-roots)))
+ (let ((tree-list
+ (loop for root in tree-roots
+ collect (let ((l-is-type
+ (handler-case (progn
+ (topictype-p root topictype topictype-constraint)
+ t)
+ (Condition () nil)))
+ (l-is-instance
+ (handler-case (progn
+ (valid-instance-p root)
+ t)
+ (Condition () nil))))
+ (make-nodes root l-is-type l-is-instance)))))
+ tree-list)))))
+
+
+(defun node-to-json-string(node)
+ "Returns a json-object of the form
+ {topic: [<psis>], isType: <bool>, isInstance: <bool>,
+ instances: [<nodes>], subtypes: [<nodes>]}."
+ (let ((topic-psis
+ (concatenate 'string "\"topic\":"
+ (json:encode-json-to-string (map 'list #'d:uri (d:psis (getf node :topic))))))
+ (is-type
+ (concatenate 'string "\"isType\":"
+ (if (getf node :is-type)
+ "true"
+ "false")))
+ (is-instance
+ (concatenate 'string "\"isInstance\":"
+ (if (getf node :is-instance)
+ "true"
+ "false")))
+ (instances
+ (concatenate 'string "\"instances\":"
+ (if (getf node :instances)
+ (let ((inner-string "["))
+ (loop for instance-node in (getf node :instances)
+ do (setf inner-string (concatenate 'string inner-string (node-to-json-string instance-node) ",")))
+ (concatenate 'string (subseq inner-string 0 (- (length inner-string) 1)) "]"))
+ "null")))
+ (subtypes
+ (concatenate 'string "\"subtypes\":"
+ (if (getf node :subtypes)
+ (let ((inner-string "["))
+ (loop for instance-node in (getf node :subtypes)
+ do (setf inner-string (concatenate 'string inner-string (node-to-json-string instance-node) ",")))
+ (concatenate 'string (subseq inner-string 0 (- (length inner-string) 1)) "]"))
+ "null"))))
+ (concatenate 'string "{" topic-psis "," is-type "," is-instance "," instances "," subtypes"}")))
+
+
+(defun make-nodes (topic-instance is-type is-instance)
+ "Creates a li of nodes.
+ A node looks like
+ (:topic <topic> :is-type <bool> :is-instance <bool> :instances <node> :subtypes <nodes>)."
+ (declare (d:TopicC topic-instance))
+ (let ((topictype (d:get-item-by-psi json-tmcl-constants::*topictype-psi*))
+ (topictype-constraint (is-type-constrained)))
+ (let ((isas-of-this
+ (map 'list #'(lambda(z)
+ (let ((l-is-type
+ (handler-case (progn
+ (topictype-p z topictype topictype-constraint)
+ t)
+ (Condition () nil)))
+ (l-is-instance
+ (handler-case (progn
+ (valid-instance-p z)
+ t)
+ (Condition () nil))))
+ (list :topic z :is-type l-is-type :is-instance l-is-instance)))
+ (remove-duplicates
+ (remove-if #'null
+ (remove-if #'(lambda(x) (when (eql topic-instance x)
+ t))
+ (get-direct-instances-of-topic topic-instance))))))
+ (akos-of-this
+ (map 'list #'(lambda(z)
+ (let ((l-is-type
+ (handler-case (progn
+ (topictype-p z topictype topictype-constraint)
+ t)
+ (Condition () nil)))
+ (l-is-instance
+ (handler-case (progn
+ (valid-instance-p z)
+ t)
+ (Condition () nil))))
+ (list :topic z :is-type l-is-type :is-instance l-is-instance)))
+ (remove-duplicates
+ (remove-if #'null
+ (remove-if #'(lambda(x) (when (eql topic-instance x)
+ t))
+ (get-direct-subtypes-of-topic topic-instance)))))))
+ (list :topic topic-instance
+ :is-type is-type
+ :is-instance is-instance
+ :instances (map 'list #'(lambda(x)
+ (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance)))
+ isas-of-this)
+ :subtypes (map 'list #'(lambda(x)
+ (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance)))
+ akos-of-this)))))
+
+
+(defun get-all-tree-roots ()
+ "Returns all topics that are no instanceOf and no subtype
+ of any other topic."
+ (let ((all-topics
+ (elephant:get-instances-by-class 'd:TopicC)))
+ (remove-if #'null
+ (map 'list #'(lambda(x)
+ (let ((isas-of-x
+ (remove-if #'(lambda(y)
+ (when (eql y x)
+ t))
+ (get-direct-types-of-topic x)))
+ (akos-of-x
+ (remove-if #'(lambda(y)
+ (when (eql y x)
+ t))
+ (get-direct-supertypes-of-topic x))))
+ (unless (or isas-of-x akos-of-x)
+ x)))
+ all-topics))))
\ 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 Mon Jun 29 10:24:53 2009
@@ -36,7 +36,7 @@
(defun topictype-of-p (topic-instance type-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))
+ (topictype-constraint (is-type-constrained))
checked-topics)
"Returns a list of all types and supertypes of this topic if this topic is a
valid instance-topic of the type-topic called type-instance. TMCL 4.4.2.
@@ -75,7 +75,7 @@
(defun topictype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))
+ (topictype-constraint (is-type-constrained))
(checked-topics nil))
"Returns a list of all instanceOf-topics and all Supertypes of this topic
if this topic is a valid topic (-type). I.e. the passed topic is the
@@ -188,6 +188,26 @@
(remove-if #'null topic-types)))))
+(defun get-direct-instances-of-topic(topic-instance)
+ "Returns the direct instances of the topic as a list.
+ This function only returns the types of the type-instance-relationship -> TMDM 7.2
+ This function was defined for the use in topictype-p and not for a standalone
+ usage."
+ (let ((type-instance (get-item-by-psi *type-instance-psi*))
+ (instance (get-item-by-psi *instance-psi*))
+ (type (get-item-by-psi *type-psi*)))
+ (let ((topic-instances
+ (loop for role in (player-in-roles topic-instance)
+ when (eq type (instance-of role))
+ collect (loop for other-role in (roles (parent role))
+ when (and (not (eq role other-role))
+ (eq type-instance (instance-of (parent role)))
+ (eq instance (instance-of other-role)))
+ return (player other-role)))))
+ (when topic-instances
+ (remove-if #'null topic-instances)))))
+
+
(defun get-direct-supertypes-of-topic(topic-instance)
"Returns the direct supertypes of the topic as a list passed to this function.
This function only returns the types of the supertype-subtype-relationship -> TMDM 7.3.
@@ -204,11 +224,32 @@
(eq supertype-subtype (instance-of (parent role)))
(eq supertype (instance-of other-role)))
collect (player other-role)))))
- (remove-if #'null supertypes))))
+ (when supertypes
+ (remove-if #'null supertypes)))))
+
+
+(defun get-direct-subtypes-of-topic(topic-instance)
+ "Returns the direct subtypes of the topic as a list.
+ This function only returns the types of the supertype-subtype-relationship -> TMDM 7.3.
+ This function was defined for the use in topictype-p and not for a standalone
+ usage."
+ (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi*))
+ (supertype (get-item-by-psi *supertype-psi*))
+ (subtype (get-item-by-psi *subtype-psi*)))
+ (let ((subtypes
+ (loop for role in (player-in-roles topic-instance)
+ when (eq supertype (instance-of role))
+ append (loop for other-role in (roles (parent role))
+ when (and (not (eq role other-role))
+ (eq supertype-subtype (instance-of (parent role)))
+ (eq subtype (instance-of other-role)))
+ collect (player other-role)))))
+ (when subtypes
+ (remove-if #'null subtypes)))))
(defun list-subtypes (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))
+ (topictype-constraint (is-type-constrained))
(checked-topics nil) (valid-subtypes nil))
"Returns all valid subtypes of a topic, e.g.:
nametype-constraint ako constraint .
@@ -241,7 +282,7 @@
(defun list-instances (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*)))
+ (topictype-constraint (is-type-constrained)))
"Returns the topic-instance, all subtypes found by the function list-subtypes and all direct
instances for the found subtypes."
(let ((all-subtypes-of-this
@@ -282,7 +323,7 @@
(get-direct-supertypes-of-topic topic-instance))
(psi-of-this (uri (first (psis topic-instance))))
(topictype (d:get-item-by-psi json-tmcl-constants::*topictype-psi*))
- (topictype-constraint (d:get-item-by-psi json-tmcl-constants::*topictype-constraint-psi*))
+ (topictype-constraint (is-type-constrained))
(local-all-checked-topics all-checked-topics)
(local-akos-checked))
@@ -292,7 +333,7 @@
(when (and topictype-constraint
(not topictype))
(error (format nil "From valid-instance-p(): The topic \"~a\" does not exist - please create it or remove the topic \"~a\""
- json-tmcl-constants::*topictype-psi* json-tmcl-constants::*topictype-constraint-psi*)))
+ json-tmcl-constants::*topictype-psi* (d:uri (first (d:psis topictype-constraint))))))
(when (eql topic-instance topictype)
(return-from valid-instance-p (remove-duplicates (append all-checked-topics (list topic-instance)))))
@@ -336,7 +377,7 @@
(let ((all-topics
(elephant:get-instances-by-class 'd:TopicC))
(topictype (get-item-by-psi json-tmcl-constants::*topictype-psi*))
- (topictype-constraint (get-item-by-psi json-tmcl-constants::*topictype-constraint-psi*)))
+ (topictype-constraint (is-type-constrained)))
(let ((all-types
(remove-if #'null
(map 'list #'(lambda(x)
@@ -366,4 +407,17 @@
(valid-instance-p x)
x)
(condition () nil))) all-topics))))
- valid-instances)))
\ No newline at end of file
+ valid-instances)))
+
+
+(defun is-type-constrained (&key (what json-tmcl::*topictype-constraint-psi*))
+ "Returns nil if there is no type-constraint otherwise the instance of the type-constraint."
+ (let ((topictype-constraint (d:get-item-by-psi what)))
+ (when topictype-constraint
+ (let ((ttc
+ (remove-duplicates
+ (remove-if #'null
+ (remove-if #'(lambda(x) (when (eql topictype-constraint x)
+ t))
+ (get-direct-instances-of-topic topictype-constraint))))))
+ ttc))))
\ No newline at end of file
Modified: trunk/src/rest_interface/rest-interface.lisp
==============================================================================
--- trunk/src/rest_interface/rest-interface.lisp (original)
+++ trunk/src/rest_interface/rest-interface.lisp Mon Jun 29 10:24:53 2009
@@ -34,6 +34,7 @@
:*json-get-topic-stub-prefix*
:*json-get-type-tmcl-prefix*
:*json-get-instance-tmcl-prefix*
+ :*json-get-overview*
:*ajax-user-interface-url*
:*ajax-user-interface-file-path*
:*ajax-javascript-directory-path*
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 Mon Jun 29 10:24:53 2009
@@ -18,6 +18,7 @@
(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; if you want to get all topics set start=0&end=nil -> localhost:8000/isidorus
(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
@@ -34,6 +35,7 @@
(json-get-topic-stub-prefix *json-get-topic-stub-prefix*)
(json-get-type-tmcl-url *json-get-type-tmcl-url*)
(json-get-instance-tmcl-url *json-get-instance-tmcl-url*)
+ (json-get-overview *json-get-overview*)
(ajax-user-interface-url *ajax-user-interface-url*)
(ajax-user-interface-file-path *ajax-user-interface-file-path*)
(ajax-user-interface-css-prefix *ajax-user-interface-css-prefix*)
@@ -99,6 +101,9 @@
(return-tmcl-info-of-psis 'json-tmcl::instance)))
hunchentoot:*dispatch-table*)
(push
+ (create-regex-dispatcher json-get-overview #'return-overview)
+ hunchentoot:*dispatch-table*)
+ (push
(create-regex-dispatcher json-commit-url #'json-commit)
hunchentoot:*dispatch-table*)
(push
@@ -283,6 +288,19 @@
(format nil "Condition: \"~a\"" err))))))
+(defun return-overview (&optional param)
+ "Returns a json-object representing a topic map overview as a tree(s)"
+ (declare (ignorable param))
+ (handler-case (let ((json-string
+ (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))
+ (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
+ json-string)
+ (Condition (err) (progn
+ (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
+ (setf (hunchentoot:content-type*) "text")
+ (format nil "Condition: \"~a\"" err)))))
+
+
;; =============================================================================
;; --- some helper functions ---------------------------------------------------
;; =============================================================================
Modified: trunk/src/unit_tests/poems.xtm
==============================================================================
--- trunk/src/unit_tests/poems.xtm (original)
+++ trunk/src/unit_tests/poems.xtm Mon Jun 29 10:24:53 2009
@@ -148,7 +148,7 @@
<!-- the constraint roletype -->
<tm:topic id="constraint-role">
<tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/constraint-role"/>
- <tm:instanceOf><tm:topicref href="#roletype"/></tm:instanceOf>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
</tm:topic>
<!-- ===================================================================== -->
@@ -225,7 +225,7 @@
<!-- constraints can be bound to a schema -->
<tm:topic id="schema">
<tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/schema"/>
- <tm:instanceOf><tm:topicref href="#topictype"/></tm:instanceOf>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
</tm:topic>
More information about the Isidorus-cvs
mailing list