source: branches/new-datamodel/src/xml/rdf/rdf_tools.lisp

Last change on this file was 160, checked in by lgiessmann, 15 years ago

changed the rdf2tm-mapping when exporting reifiers; fixed some problems in the rdf-reification-test-file
File size: 17.3 KB
Line 
1;;+-----------------------------------------------------------------------------
2;;+  Isidorus
3;;+  (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann
4;;+
5;;+  Isidorus is freely distributable under the LGPL license.
6;;+  You can find a detailed description in trunk/docs/LGPL-LICENSE.txt.
7;;+-----------------------------------------------------------------------------
8
9(defpackage :rdf-importer
10  (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel)
11  (:import-from :constants
12                *rdf-ns*
13                *rdfs-ns*
14                *xml-ns*
15                *xmlns-ns*
16                *xml-string*
17                *rdf2tm-ns*
18                *xtm2.0-ns*
19                *type-instance-psi*
20                *type-psi*
21                *instance-psi*
22                *rdf-statement*
23                *rdf-object*
24                *rdf-subject*
25                *rdf-predicate*
26                *rdf2tm-object*
27                *rdf2tm-subject*
28                *supertype-psi*
29                *subtype-psi*
30                *supertype-subtype-psi*
31                *rdf-nil*
32                *rdf-first*
33                *rdf-rest*
34                *rdf2tm-scope-prefix*
35                *tm2rdf-topic-type-uri*
36                *tm2rdf-name-type-uri*
37                *tm2rdf-name-property*
38                *tm2rdf-variant-type-uri*
39                *tm2rdf-variant-property*
40                *tm2rdf-occurrence-type-uri*
41                *tm2rdf-occurrence-property*
42                *tm2rdf-role-type-uri*
43                *tm2rdf-role-property*
44                *tm2rdf-association-type-uri*
45                *tm2rdf-association-property*
46                *tm2rdf-subjectIdentifier-property*
47                *tm2rdf-itemIdentity-property*
48                *tm2rdf-subjectLocator-property*
49                *tm2rdf-ns*
50                *tm2rdf-value-property*
51                *tm2rdf-scope-property*
52                *tm2rdf-nametype-property*
53                *tm2rdf-occurrencetype-property*
54                *tm2rdf-roletype-property*
55                *tm2rdf-player-property*
56                *tm2rdf-associationtype-property*
57                *rdf2tm-blank-node-prefix*
58                *tm2rdf-reifier-property*)
59  (:import-from :xml-constants
60                *rdf_core_psis.xtm*
61                *core_psis.xtm*)
62  (:import-from :xml-tools
63                get-attribute
64                xpath-fn-string
65                xpath-child-elems-by-qname
66                xpath-single-child-elem-by-qname
67                xpath-select-location-path
68                xpath-select-single-location-path
69                get-ns-attribute
70                clear-child-nodes
71                has-qname
72                absolute-uri-p
73                get-node-name
74                child-nodes-or-text
75                get-xml-lang
76                get-xml-base
77                absolutize-value
78                absolutize-id
79                concatenate-uri
80                push-string
81                node-to-string)
82  (:import-from :xml-importer
83                get-uuid
84                get-store-spec
85                with-tm
86                from-topic-elem-to-stub)
87  (:import-from :isidorus-threading
88                with-reader-lock
89                with-writer-lock)
90  (:import-from :exceptions
91                missing-reference-error
92                duplicate-identifier-error)
93  (:export :setup-rdf-module 
94           :rdf-importer
95           :init-rdf-module
96           :*rdf-core-xtm*
97           :*document-id*))
98
99(in-package :rdf-importer)
100
101(defvar *rdf-types* (list "Description" "List" "Alt" "Bag" "Seq"
102                          "Statement" "Property" "XMLLiteral" "nil"))
103
104(defvar *rdf-properties* (list "type" "first" "rest" "subject" "predicate"
105                               "object" "li" "first" "rest"))
106
107(defvar *rdfs-types* (list "Resource" "Literal" "Class" "Datatype"
108                           "Container" "ContainerMembershipProperty"))
109
110(defvar *rdfs-properties* (list "subClassOf" "subPropertyOf" "domain"
111                                "range" "range" "label" "comment"
112                                "member" "seeAlso" "isDefinedBy"))
113
114(defvar *rdf-core-xtm* "rdf_core.xtm")
115
116(defvar *_n-map* nil)
117
118(defvar *document-id* "isidorus-rdf-document")
119
120
121(defun _n-p (node)
122  "Returns t if the given value is of the form _[0-9]+"
123  (let ((node-name (get-node-name node)))
124    (when (and node-name
125               (> (length node-name) 0)
126               (eql (elt node-name 0) #\_))
127      (let ((rest
128             (subseq node-name 1 (length node-name))))
129        (declare (string node-name))
130        (handler-case (let ((int
131                             (parse-integer rest)))
132                        int)
133          (condition () nil))))))
134
135
136
137(defun find-_n-name-of-property (property)
138  "Returns the properties name of the form rdf:_n or nil."
139  (let ((owner
140         (find-if
141          #'(lambda(x)
142              (find-if
143               #'(lambda(y)
144                   (eql (getf y :elem) property))
145               (getf x :props)))
146          *_n-map*)))
147    (let ((elem (find-if #'(lambda(x)
148                             (eql (getf x :elem) property))
149                         (getf owner :props))))
150      (when elem
151        (getf elem :name)))))
152
153
154
155(defun find-_n-name (owner-identifier property)
156  "Returns a name of the form rdf:_n of the property element
157   when it owns the tagname rdf:li and exists in the *_n-map* list.
158   Otherwise the return value is nil."
159  (let ((owner (find-if #'(lambda(x)
160                            (string= (getf x :owner) owner-identifier))
161                        *_n-map*)))
162   (when owner
163     (let ((prop (find-if #'(lambda(x)
164                              (eql (getf x :elem) property))
165                          (getf owner :props))))
166       (getf prop :name)))))
167
168
169(defun set-_n-name (owner-identifier property)
170  "Sets a new name of the form _n for the passed property element and
171   adds it to the list *_n-map*. If the property already exists in the
172   *_n-map* list, there won't be created a new entry but returned the
173   stored value name."
174  (let ((name (find-_n-name owner-identifier property)))
175    (if name
176        name
177        (let ((owner (find-if #'(lambda(x)
178                                  (string= (getf x :owner) owner-identifier))
179                              *_n-map*)))
180          (if owner
181              (let ((new-name
182                     (concatenate
183                      'string *rdf-ns* "_"
184                      (write-to-string (+ (length (getf owner :props)) 1)))))
185                (push (list :elem property
186                            :name new-name)
187                      (getf owner :props))
188                new-name)
189              (progn
190                (push 
191                 (list :owner owner-identifier
192                       :props (list
193                               (list :elem property
194                                     :name (concatenate 'string *rdf-ns* "_1"))))
195                 *_n-map*)
196                "_1"))))))
197
198
199(defun get-type-of-node-name (node)
200  (let ((map-item (find-_n-name-of-property node)))
201    (if map-item
202        map-item
203        (let ((node-name (get-node-name node))
204              (node-ns (dom:namespace-uri node)))
205          (concatenate-uri node-ns node-name)))))
206
207
208(defun parse-node-name (node)
209  "Parses the given node's name to the known rdf/rdfs nodes and arcs.
210   If the given name es equal to a property an error is thrown otherwise
211   there is displayed a warning when the rdf ord rdfs namespace is used."
212  (declare (dom:element node))
213  (let ((node-name (get-node-name node))
214        (node-ns (dom:namespace-uri node))
215        (err-pref "From parse-node-name(): "))
216    (when (string= node-ns *rdf-ns*)
217      (when (find node-name *rdf-properties* :test #'string=)
218        (error "~ardf:~a is a property and not allowed here!"
219               err-pref node-name))
220      (when (string= node-name "RDF")
221        (error "~ardf:RDF not allowed here!"
222               err-pref))
223      (unless (find node-name *rdf-types* :test #'string=)
224        (format t "~aWarning: ~a is not a known RDF type!~%"
225                err-pref node-name)))
226    (when (string= node-ns *rdfs-ns*)
227      (when (find node-name *rdfs-properties* :test #'string=)
228        (error "~ardfs:~a is a property and not allowed here!"
229               err-pref node-name))
230      (unless (find node-name *rdfs-types* :test #'string=)
231        (format t "~aWarning: rdfs:~a is not a known rdfs:type!~%"
232                err-pref node-name))))
233  t)
234
235
236(defun parse-node(node)
237  "Parses a node that represents a rdf-resource."
238  (declare (dom:element node))
239  (parse-node-name node)
240  (let ((ID  (get-ns-attribute node "ID"))
241        (nodeID (get-ns-attribute node "nodeID"))
242        (about (get-ns-attribute node "about"))
243        (err-pref "From parse-node(): ")
244        (resource (get-ns-attribute node "resource"))
245        (datatype (get-ns-attribute node "datatype"))
246        (parseType (get-ns-attribute node "parseType"))
247        (class (get-ns-attribute node "Class" :ns-uri *rdfs-ns*))
248        (subClassOf (get-ns-attribute node "subClassOf" :ns-uri *rdfs-ns*)))
249    (when (and about nodeID)
250      (error "~ardf:about and rdf:nodeID are not allowed in parallel use: (~a) (~a)!"
251             err-pref about nodeID))
252    (when (and ID
253               (or about nodeID))
254      (error "~awhen rdf:ID is set the attributes rdf:~a is not allowed: ~a!"
255             err-pref (if about "about" "nodeID") (or about nodeID)))
256    (unless (or ID nodeID about (dom:has-attribute-ns node *rdf2tm-ns* "UUID"))
257      (dom:set-attribute-ns node *rdf2tm-ns* "UUID" (get-uuid)))
258    (handler-case (let ((content (child-nodes-or-text node :trim t)))
259                    (when (stringp content)
260                      (error "text-content not allowed here!")))
261      (condition (err) (error "~a~a" err-pref err)))
262    (when (or resource datatype parseType class subClassOf)
263      (error "~a~a is not allowed here (~a)!"
264             err-pref (cond
265                        (resource (concatenate 'string "resource("
266                                               resource ")"))
267                        (datatype (concatenate 'string "datatype("
268                                               datatype ")"))
269                        (parseType (concatenate 'string "parseType("
270                                                parseType ")"))
271                        (class (concatenate 'string "Class(" class ")"))
272                        (subClassOf (concatenate 'string "subClassOf("
273                                                 subClassOf ")")))
274             (dom:node-name node)))
275    (dolist (item *rdf-types*)
276      (when (get-ns-attribute node item)
277        (error "~ardf:~a is a type and not allowed here!"
278               err-pref item)))
279    (dolist (item *rdfs-types*)
280      (when (get-ns-attribute node item :ns-uri *rdfs-ns*)
281        (error "~ardfs:~a is a type and not allowed here!"
282               err-pref item))))
283  t)
284
285
286(defun get-node-refs (nodes tm-id parent-xml-base)
287  "Returns a list of node references that can be used as topic IDs."
288  (when (and nodes
289             (> (length nodes) 0))
290    (loop for node across nodes
291       collect (let ((xml-base (get-xml-base node :old-base parent-xml-base)))
292                 (parse-node node)
293                 (let ((ID (when (get-ns-attribute node "ID")
294                             (absolutize-id (get-ns-attribute node "ID")
295                                            xml-base tm-id)))
296                       (nodeID (get-ns-attribute node "nodeID"))
297                       (about (when (get-ns-attribute node "about")
298                                (absolutize-value
299                                 (get-ns-attribute node "about")
300                                 xml-base tm-id)))
301                       (UUID (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)))
302                   (list :topicid (or ID about nodeID UUID)
303                         :psi (or ID about)))))))
304
305
306(defun parse-property-name (property owner-identifier)
307  "Parses the given property's name to the known rdf/rdfs nodes and arcs.
308   If the given name es equal to an node an error is thrown otherwise
309   there is displayed a warning when the rdf ord rdfs namespace is used."
310  (declare (dom:element property))
311  (let ((property-name (get-node-name property))
312        (property-ns (dom:namespace-uri property))
313        (err-pref "From parse-property-name(): "))
314    (when (string= property-ns *rdf-ns*)
315      (when (find property-name *rdf-types* :test #'string=)
316        (error "~ardf:~a is a node and not allowed here!"
317               err-pref property-name))
318      (when (string= property-name "RDF")
319        (error "~ardf:RDF not allowed here!"
320               err-pref))
321      (unless (or (find property-name *rdf-properties* :test #'string=)
322                  (_n-p property))
323        (format t "~aWarning: rdf:~a is not a known RDF property!~%"
324                err-pref property-name)))
325    (when (string= property-ns *rdfs-ns*)
326      (when (find property-name *rdfs-types* :test #'string=)
327        (error "~ardfs:~a is a type and not allowed here!"
328               err-pref property-name))
329      (unless (find property-name *rdfs-properties* :test #'string=)
330        (format t "~aWarning: rdfs:~a is not a known rdfs:type!~%"
331                err-pref property-name)))
332    (when (and (string= property-ns *rdf-ns*)
333               (string= property-name "li"))
334      (set-_n-name owner-identifier property)))
335  t)
336
337
338(defun parse-property (property owner-identifier)
339  "Parses a property that represents a rdf-arc."
340  (declare (dom:element property))
341  (let ((err-pref "From parse-property(): ")
342        (node-name (get-node-name property))
343        (node-ns (dom:namespace-uri property))
344        (nodeID (get-ns-attribute property "nodeID"))
345        (resource (get-ns-attribute property "resource"))
346        (datatype (get-ns-attribute property "datatype"))
347        (type (get-ns-attribute property "type"))
348        (parseType (get-ns-attribute property "parseType"))
349        (about (get-ns-attribute property "about"))
350        (subClassOf (get-ns-attribute property "subClassOf" :ns-uri *rdfs-ns*))
351        (literals (get-literals-of-property property nil))
352        (content (child-nodes-or-text property :trim t)))
353    (parse-property-name property owner-identifier)
354    (when (and parseType
355               (or nodeID resource datatype type literals))
356      (error "~awhen rdf:parseType is set the attributes: ~a => ~a are not allowed!"
357             err-pref
358             (append (list (cond (nodeID "rdf:nodeID")
359                                 (resource "rdf:resource")
360                                 (datatype "rdf:datatype")
361                                 (type "rdf:type")))
362                     (map 'list #'(lambda(x)(getf x :type)) literals))
363             (append (list (or nodeID resource datatype type))
364                     (map 'list #'(lambda(x)(getf x :value)) literals))))
365    (when (and parseType
366               (not (or (string= parseType "Resource")
367                        (string= parseType "Literal")
368                        (string= parseType "Collection"))))
369      (error "~aunknown rdf:parseType: ~a"
370             err-pref parseType))
371    (when (and parseType
372               (or (string= parseType "Resource")
373                   (string= parseType "Collection")))
374      (unless (dom:has-attribute-ns property *rdf2tm-ns* "UUID")
375        (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))))
376    (when (and parseType (string= parseType "Resource") (stringp content))
377      (error "~ardf:parseType is set to 'Resource' expecting xml content: ~a!"
378             err-pref content))
379    (when (and parseType
380               (string= parseType "Collection")
381               (stringp content))
382      (error "~ardf:parseType is set to 'Collection' expecting resource content: ~a"
383             err-pref content))
384    (when (and nodeID resource)
385      (error "~aondly one of rdf:nodeID and rdf:resource is allowed: (~a) (~a)!"
386             err-pref nodeID resource))
387    (when (and (or nodeID resource type literals)
388               datatype)
389      (error "~aonly one of ~a and rdf:datatype (~a) is allowed!"
390             err-pref
391             (cond
392               (nodeID (concatenate 'string "rdf:nodeID (" nodeID ")"))
393               (resource (concatenate 'string "rdf:resource (" resource ")"))
394               (type (concatenate 'string "rdf:type (" type ")"))
395               (literals literals))
396             datatype))
397    (when (and (or nodeID resource)
398               (> (length content) 0))
399     (error "~awhen ~a is set no content is allowed: ~a!"
400             err-pref
401             (cond
402               (nodeID (concatenate 'string "rdf:nodeID (" nodeID ")"))
403               (resource (concatenate 'string "rdf:resource (" resource ")")))
404             content))
405    (when (and type
406               (stringp content)
407               (> (length content) 0))
408      (error "~awhen rdf:type is set no literal content is allowed: ~a!"
409             err-pref content))
410    (when (and (or type
411                   (and (string= node-name "type")
412                        (string= node-ns *rdf-ns*))
413                   (> (length literals) 0))
414               (not (or nodeID resource))
415               (not content))
416      (unless (dom:has-attribute-ns property *rdf2tm-ns* "UUID")
417        (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))))
418    (when (or about subClassOf)
419      (error "~a~a not allowed here!"
420             err-pref
421             (if about
422                 (concatenate 'string "rdf:about (" about ")")
423                 (concatenate 'string "rdfs:subClassOf (" subClassOf ")"))))
424    (when (and (string= node-name "subClassOf")
425               (string= node-ns *rdfs-ns*)
426               (not (or nodeID resource content)))
427      (unless (dom:has-attribute-ns property *rdf2tm-ns* "UUID")
428        (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))))
429    (when (and (or (and (string= node-name "type")
430                        (string= node-ns *rdf-ns*))
431                   (and (string= node-name "subClassOf")
432                        (string= node-ns *rdfs-ns*)))
433               (and (> (length content) 0)
434                    (stringp content)))
435      (error "~awhen property is ~a literal content is not allowed: ~a!"
436             err-pref (if (string= node-name "type")
437                          "rdf:type"
438                          "rdfs:subClassOf")
439             content))
440    (dolist (item *rdf-types*)
441      (when (get-ns-attribute property item)
442        (error "~ardf:~a is a type and not allowed here!"
443               err-pref item)))
444    (dolist (item *rdfs-types*)
445      (when (get-ns-attribute property item :ns-uri *rdfs-ns*)
446        (error "~ardfs:~a is a type and not allowed here!"
447               err-pref item))))
448  t)
449
450
451(defun parse-properties-of-node (node owner-identifier)
452  "Parses all node's properties by calling the parse-propery
453   function and sets all rdf:li properties as a tupple to the
454   *_n-map* list."
455  (let ((child-nodes (child-nodes-or-text node :trim t)))
456    (when (get-ns-attribute node "li")
457      (dom:map-node-map
458       #'(lambda(attr)
459           (when (and (string= (get-node-name attr) "li")
460                      (string= (dom:namespace-uri attr) *rdf-ns*))
461             (set-_n-name owner-identifier attr)))
462             (dom:attributes node)))
463    (when child-nodes
464      (loop for property across child-nodes
465         do (parse-property property owner-identifier))))
466  t)
467
468
469(defun get-absolute-attribute (elem tm-id parent-xml-base attr-name
470                               &key (ns-uri *rdf-ns*))
471  "Returns an absolute 'attribute' or nil."
472  (declare (dom:element elem))
473  (declare (string attr-name))
474  (tm-id-p tm-id "get-ID")
475  (let ((attr (get-ns-attribute elem attr-name :ns-uri ns-uri))
476        (xml-base (get-xml-base elem :old-base parent-xml-base)))
477    (when attr
478      (if (and (string= ns-uri *rdf-ns*)
479               (string= attr-name "ID"))
480          (absolutize-id attr xml-base tm-id)
481          (absolutize-value attr xml-base tm-id)))))
482
483
484(defun get-datatype (elem tm-id parent-xml-base)
485  "Returns a datatype value. The default is xml:string."
486  (let ((datatype
487         (get-absolute-attribute elem tm-id parent-xml-base "datatype")))
488    (if datatype
489        datatype
490        *xml-string*)))
491
492
493(defun tm-id-p (tm-id fun-name)
494  "Checks the validity of the passed tm-id."
495  (unless (absolute-uri-p tm-id)
496    (error "From ~a(): you must provide a stable identifier (PSI-style) for this TM: ~a!"
497           fun-name tm-id)))
498
499
500(defun get-types-of-node (elem tm-id &key (parent-xml-base nil))
501  "Returns a plist of all node's types of the form
502   (:topicid <string> :psi <string> :ID <string>)."
503  (remove-if
504   #'null
505   (append (unless (string= (get-type-of-node-name elem)
506                            (concatenate 'string *rdf-ns*
507                                         "Description"))
508             (list 
509              (list :topicid (get-type-of-node-name elem)
510                    :psi (get-type-of-node-name elem)
511                    :ID nil)))
512           (get-types-of-node-content elem tm-id parent-xml-base))))
Note: See TracBrowser for help on using the repository browser.