source: branches/new-datamodel/src/json/json_exporter.lisp

Last change on this file was 306, checked in by lgiessmann, 14 years ago

new-datamodel: fixed bugs in get-latest-topic-by-psi, find-all-associations-for-topic, find-associations-for-topic, changed-p, with-tm; adapted the json-unit-tests to the new datamodel
  • Property svn:eol-style set to native
File size: 16.2 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
10(defpackage :json-exporter
11  (:use :cl :json :datamodel)
12  (:export :to-json-string
13           :get-all-topic-psis
14           :to-json-string-summary
15           :make-topic-summary))
16
17(in-package :json-exporter)
18
19;; the json schema for our datamodel is in ".../docs/xtm_json.txt"
20
21
22;; =============================================================================
23;; --- main json data model ----------------------------------------------------
24;; =============================================================================
25(defgeneric to-json-string (instance &key xtm-id revision)
26  (:documentation "converts the Topic Map construct instance to a json string"))
27
28
29(defun identifiers-to-json-string (parent-construct &key (what 'd:psis)
30                                   (revision *TM-REVISION*))
31  "returns the identifiers of a TopicMapConstructC as a json list"
32  (declare (TopicMapConstructC parent-construct)
33           (symbol what)
34           (type (or integer null) revision))
35  (when (and parent-construct
36             (or (eql what 'psis)
37                 (eql what 'item-identifiers)
38                 (eql what 'locators)))
39    (let ((items 
40           (map 'list #'uri (funcall what parent-construct :revision revision))))
41      (json:encode-json-to-string items))))
42
43
44(defun resourceX-to-json-string (value datatype &key (xtm-id d:*current-xtm*))
45  "returns a resourceRef and resourceData json object"
46  ;(declare (string value datatype))
47  (if (string= datatype "http://www.w3.org/2001/XMLSchema#anyURI")
48      (concatenate
49       'string "\"resourceRef\":"                 
50       (let ((inner-value
51              (let ((ref-topic (when (and (> (length value) 0)
52                                          (eql (elt value 0) #\#))
53                                 (get-item-by-id (subseq value 1) :xtm-id xtm-id))))
54                (if ref-topic
55                    (concatenate 'string "#" (topic-id ref-topic))
56                    value))))
57         (json:encode-json-to-string inner-value))
58       ",\"resourceData\":null")
59      (concatenate 'string "\"resourceRef\":null,"
60                   "\"resourceData\":{\"datatype\":"
61                   (json:encode-json-to-string datatype)
62                   ",\"value\":"
63                   (json:encode-json-to-string value) "}")))
64
65
66(defun ref-topics-to-json-string (topics &key (revision *TM-REVISION*))
67  "returns a json string of all psi-uris of the passed topics as a list of lists"
68  (declare (list topics)
69           (type (or integer null) revision))
70  (if topics
71      (let ((psis (json:encode-json-to-string
72                   (map 'list #'(lambda(topic)
73                                  (declare (topicC topic))
74                                  (map 'list #'uri (psis topic :revision revision)))
75                        topics))))
76        (declare (list topics))
77        psis)
78      "null"))
79
80
81(defun type-to-json-string (parent-elem &key (revision *TM-REVISION*))
82  "returns a json string of the type of the passed parent-elem"
83  (declare (TypableC parent-elem)
84           (type (or integer null) revision))
85  (concatenate
86   'string "\"type\":"
87   (if (instance-of parent-elem :revision revision)
88       (json:encode-json-to-string
89        (map 'list #'uri (psis (instance-of parent-elem :revision revision)
90                               :revision revision)))
91       "null")))
92
93
94(defmethod to-json-string ((instance VariantC) &key (xtm-id d:*current-xtm*)
95                           (revision *TM-REVISION*))
96  "transforms a VariantC object to a json string"
97  (declare (type (or string null) xtm-id)
98           (type (or integer null) revision))
99  (let ((itemIdentity
100         (concatenate
101          'string "\"itemIdentities\":"
102          (identifiers-to-json-string instance :what 'item-identifiers
103                                      :revision revision)))
104        (scope
105         (concatenate
106          'string "\"scopes\":" (ref-topics-to-json-string
107                                 (themes instance :revision revision)
108                                 :revision revision)))
109        (resourceX
110         (let ((value
111                (when (slot-boundp instance 'charvalue)
112                  (charvalue instance)))
113               (type
114                (when (slot-boundp instance 'datatype)
115                  (datatype instance))))
116           (resourceX-to-json-string value type :xtm-id xtm-id))))
117    (concatenate 'string "{" itemIdentity "," scope "," resourceX "}")))
118
119
120(defmethod to-json-string ((instance NameC) &key (xtm-id d:*current-xtm*)
121                           (revision *TM-REVISION*))
122  "transforms a NameC object to a json string"
123  (declare (type (or string null) xtm-id)
124           (type (or integer null) revision))
125  (let ((itemIdentity
126         (concatenate
127          'string "\"itemIdentities\":"
128          (identifiers-to-json-string instance :what 'item-identifiers
129                                      :revision revision)))
130        (type
131         (type-to-json-string instance :revision revision))
132        (scope
133         (concatenate 
134          'string "\"scopes\":"
135          (ref-topics-to-json-string (themes instance :revision revision)
136                                     :revision revision)))
137        (value
138         (concatenate 'string "\"value\":"
139                      (if (slot-boundp instance 'charvalue)
140                          (json:encode-json-to-string (charvalue instance))
141                          "null")))
142        (variant
143         (if (variants instance :revision revision)
144             (concatenate
145              'string "\"variants\":"
146              (let ((j-variants "["))
147                (loop for variant in (variants instance :revision revision)
148                   do (setf j-variants
149                            (concatenate
150                             'string j-variants
151                             (json-exporter::to-json-string variant :xtm-id xtm-id
152                                                            :revision revision)
153                             ",")))
154                            (concatenate
155                             'string (subseq j-variants 0
156                                             (- (length j-variants) 1)) "]")))
157             (concatenate 'string "\"variants\":null"))))
158    (concatenate 'string "{" itemIdentity "," type "," scope "," value
159                 "," variant "}")))
160
161
162(defmethod to-json-string ((instance OccurrenceC) &key (xtm-id d:*current-xtm*)
163                           (revision *TM-REVISION*))
164  "transforms an OccurrenceC object to a json string"
165  (declare (type (or string null) xtm-id)
166           (type (or integer null) revision))
167  (let ((itemIdentity
168         (concatenate
169          'string "\"itemIdentities\":"
170          (identifiers-to-json-string instance :what 'item-identifiers
171                                      :revision revision)))
172        (type
173         (type-to-json-string instance :revision revision))
174        (scope
175         (concatenate
176          'string "\"scopes\":"
177          (ref-topics-to-json-string (themes instance :revision revision)
178                                     :revision revision)))
179        (resourceX
180         (let ((value
181                (when (slot-boundp instance 'charvalue)
182                  (charvalue instance)))
183               (type
184                (when (slot-boundp instance 'datatype)
185                  (datatype instance))))
186           (resourceX-to-json-string value type :xtm-id xtm-id))))
187    (concatenate 'string "{" itemIdentity "," type "," scope "," resourceX "}")))
188
189
190(defmethod to-json-string ((instance TopicC) &key (xtm-id d:*current-xtm*)
191                           (revision *TM-REVISION*))
192  "transforms an TopicC object to a json string"
193  (declare (type (or string null) xtm-id)
194           (type (or integer null) revision))
195  (let ((id
196         (concatenate
197          'string "\"id\":"
198          (json:encode-json-to-string (topic-id instance revision))))
199        (itemIdentity
200         (concatenate
201          'string "\"itemIdentities\":"
202          (identifiers-to-json-string instance :what 'item-identifiers
203                                      :revision revision)))
204        (subjectLocator 
205         (concatenate
206          'string "\"subjectLocators\":"
207          (identifiers-to-json-string instance :what 'locators
208                                      :revision revision)))
209        (subjectIdentifier
210         (concatenate
211          'string "\"subjectIdentifiers\":"
212          (identifiers-to-json-string instance :what 'psis
213                                      :revision revision)))
214        (instanceOf
215         (concatenate
216          'string "\"instanceOfs\":"
217          (ref-topics-to-json-string (list-instanceOf instance :revision revision)
218                                     :revision revision)))
219        (name
220         (concatenate
221          'string "\"names\":"
222          (if (names instance :revision revision)
223              (let ((j-names "["))
224                (loop for item in (names instance :revision revision)
225                   do (setf j-names
226                            (concatenate 
227                             'string j-names (to-json-string item :xtm-id xtm-id
228                                                             :revision revision)
229                             ",")))
230                (concatenate 'string (subseq j-names 0 (- (length j-names) 1)) "]"))
231              "null")))
232        (occurrence
233         (concatenate
234          'string "\"occurrences\":"
235          (if (occurrences instance :revision revision)
236              (let ((j-occurrences "["))
237                (loop for item in (occurrences instance :revision revision)
238                   do (setf j-occurrences
239                            (concatenate
240                             'string j-occurrences
241                             (to-json-string item :xtm-id xtm-id :revision revision)
242                             ",")))
243                (concatenate
244                 'string (subseq j-occurrences 0 (- (length j-occurrences) 1)) "]"))
245              "null"))))
246    (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," 
247                 subjectIdentifier ","
248                 instanceOf "," name "," occurrence "}")))
249
250
251(defun to-json-topicStub-string (topic &key (revision *TM-REVISION*))
252  "transforms the passed TopicC object to a topic stub
253   string in the json format, which contains an id,
254   all itemIdentities, all subjectLocators and all
255   subjectIdentifiers"
256  (declare (type (or TopicC null) topic)
257           (type (or integer null) revision))
258  (when topic
259    (let ((id
260           (concatenate
261            'string "\"id\":"
262            (json:encode-json-to-string (topic-id topic revision))))
263          (itemIdentity
264           (concatenate
265            'string "\"itemIdentities\":"
266            (identifiers-to-json-string topic :what 'item-identifiers
267                                        :revision revision)))
268          (subjectLocator 
269           (concatenate
270            'string "\"subjectLocators\":"
271            (identifiers-to-json-string topic :what 'locators :revision revision)))
272          (subjectIdentifier
273           (concatenate
274            'string "\"subjectIdentifiers\":"
275            (identifiers-to-json-string topic :what 'psis :revision revision))))
276      (concatenate 'string "{" id "," itemIdentity "," subjectLocator ","
277                   subjectIdentifier "}"))))
278
279
280(defmethod to-json-string ((instance RoleC) &key (xtm-id d:*current-xtm*)
281                           (revision *TM-REVISION*))
282  "transforms an RoleC object to a json string"
283  (declare (ignorable xtm-id)
284           (type (or integer null) revision))
285  (let ((itemIdentity
286         (concatenate
287          'string "\"itemIdentities\":"
288          (identifiers-to-json-string instance :what 'item-identifiers
289                                      :revision revision)))
290        (type
291         (type-to-json-string instance :revision revision))
292        (topicRef
293         (concatenate
294          'string "\"topicRef\":"
295          (if (player instance :revision revision)
296              (json:encode-json-to-string
297               (map 'list #'uri (psis (player instance :revision revision)
298                                      :revision revision)))
299              "null"))))
300    (concatenate 'string "{" itemIdentity "," type "," topicRef "}")))
301
302
303(defmethod to-json-string ((instance AssociationC) &key (xtm-id d:*current-xtm*)
304                           (revision *TM-REVISION*))
305  "transforms an AssociationC object to a json string"
306  (let ((itemIdentity
307         (concatenate 
308          'string "\"itemIdentities\":"
309          (identifiers-to-json-string instance :what 'item-identifiers
310                                      :revision revision)))
311        (type
312         (type-to-json-string instance :revision revision))
313        (scope
314         (concatenate
315          'string "\"scopes\":"
316          (ref-topics-to-json-string (themes instance :revision revision)
317                                     :revision revision)))
318        (role
319         (concatenate
320          'string "\"roles\":"
321          (if (roles instance :revision revision)
322              (let ((j-roles "["))
323                (loop for item in (roles instance :revision revision)
324                   do (setf j-roles
325                            (concatenate
326                             'string j-roles (to-json-string item :xtm-id xtm-id
327                                                             :revision revision)
328                             ",")))
329                (concatenate 'string (subseq j-roles 0 (- (length j-roles) 1)) "]"))
330              "null"))))
331    (concatenate 'string "{" itemIdentity "," type "," scope "," role "}")))
332
333
334(defmethod to-json-string ((instance TopicMapC) &key (xtm-id d:*current-xtm*)
335                           (revision *TM-REVISION*))
336  "returns the ItemIdentifier's uri"
337  (declare (ignorable xtm-id)
338           (type (or integer null) revision))
339  (let ((ii (item-identifiers instance :revision revision)))
340    (when ii
341      (uri (first ii)))))
342
343
344(defmethod to-json-string ((instance FragmentC) &key (xtm-id d:*current-xtm*)
345                           (revision *TM-REVISION*))
346  "transforms an FragmentC object to a json string,
347   which contains the main topic, all depending topicStubs
348   and all associations depending on the main topic"
349  (declare (type (or string null) xtm-id)
350           (type (or integer null) revision))
351  (let ((main-topic
352         (concatenate
353          'string "\"topic\":"
354          (to-json-string (topic instance) :xtm-id xtm-id :revision revision)))
355        (topicStubs
356         (concatenate
357          'string "\"topicStubs\":"
358          (if (referenced-topics instance)
359              (let ((j-topicStubs "["))
360                (loop for item in (referenced-topics instance)
361                   do (setf j-topicStubs
362                            (concatenate
363                             'string j-topicStubs
364                             (to-json-topicStub-string item :revision revision)
365                             ",")))
366                (concatenate
367                 'string (subseq j-topicStubs 0 (- (length j-topicStubs) 1)) "]"))
368              "null")))
369        (associations
370         (concatenate
371          'string "\"associations\":"
372          (if (associations instance)
373              (let ((j-associations "["))
374                (loop for item in (associations instance)
375                   do (setf j-associations
376                            (concatenate 'string j-associations
377                                         (to-json-string item :xtm-id xtm-id
378                                                         :revision revision) ",")))
379                (concatenate 'string (subseq j-associations 0
380                                             (- (length j-associations) 1)) "]"))
381              "null")))
382        (tm-ids
383         (concatenate
384          'string "\"tmIds\":"
385          (if (in-topicmaps (topic instance))
386              (let ((j-tm-ids "["))
387                (loop for item in (in-topicmaps (topic instance))
388                   do (setf j-tm-ids
389                            (concatenate
390                             'string j-tm-ids 
391                             (json:encode-json-to-string
392                              (d:uri (first (d:item-identifiers item
393                                                                :revision revision))))
394                             ",")))
395                (concatenate 'string (subseq j-tm-ids 0 (- (length j-tm-ids) 1)) "]"))
396              "null"))))
397    (concatenate 'string "{" main-topic "," topicStubs "," associations
398                 "," tm-ids "}")))
399
400
401;; =============================================================================
402;; --- json data summeries -----------------------------------------------------
403;; =============================================================================
404(defun get-all-topic-psis(&key (revision *TM-REVISION*))
405  "returns all topic psis as a json list of the form
406   [[topic-1-psi-1, topic-1-psi-2],[topic-2-psi-1, topic-2-psi-2],...]"
407  (declare (type (or integer null) revision))
408  (encode-json-to-string
409   (remove-if #'null
410              (map 'list
411                   #'(lambda(psi-list)
412                       (when psi-list
413                         (map 'list #'uri psi-list)))
414                   (map 'list #'psis (get-all-topics revision))))))
415
416
417(defun to-json-string-summary (topic &key (revision *TM-REVISION*))
418  "creates a json string of called topic element. the following elements are within this
419   summary:
420    *topic id
421    *all identifiers
422    *names (only the real name value)
423    *occurrences (jonly the resourceRef and resourceData elements)"
424  (declare (TopicC topic)
425           (type (or integer null) revision))
426  (let ((id
427         (concatenate 'string "\"id\":\"" (topic-id topic revision) "\""))
428        (itemIdentity
429         (concatenate
430          'string "\"itemIdentities\":"
431          (identifiers-to-json-string topic :what 'item-identifiers
432                                      :revision revision)))
433        (subjectLocator 
434         (concatenate
435          'string "\"subjectLocators\":"
436          (identifiers-to-json-string topic :what 'locators :revision revision)))
437        (subjectIdentifier
438         (concatenate
439          'string "\"subjectIdentifiers\":"
440          (identifiers-to-json-string topic :what 'psis :revision revision)))
441        (instanceOf
442         (concatenate
443          'string "\"instanceOfs\":"
444          (ref-topics-to-json-string (list-instanceOf topic :revision revision)
445                                     :revision revision)))
446        (name
447         (concatenate
448          'string "\"names\":"
449          (if (names topic :revision revision)
450              (json:encode-json-to-string
451               (loop for name in (names topic :revision revision)
452                  when (slot-boundp name 'charvalue)
453                  collect (charvalue name)))
454              "null")))
455        (occurrence
456         (concatenate
457          'string "\"occurrences\":"
458          (if (occurrences topic :revision revision)
459              (json:encode-json-to-string
460               (loop for occurrence in (occurrences topic :revision revision)
461                  when (slot-boundp occurrence 'charvalue)
462                  collect (charvalue occurrence)))
463              "null"))))
464    (concatenate 'string "{" id "," itemIdentity "," subjectLocator ","
465                 subjectIdentifier "," instanceOf "," name "," occurrence "}")))
466
467
468(defun make-topic-summary (topic-list &key (revision *TM-REVISION*))
469  "creates a json list of the produced json-strings by to-json-string-summary"
470  (declare (list topic-list)
471           (type (or integer null) revision))
472  (if topic-list
473      (let ((json-string
474             (let ((inner-string nil))
475               (concatenate
476                'string
477                (loop for topic in topic-list
478                   do (setf inner-string
479                            (concatenate
480                             'string inner-string
481                             (to-json-string-summary topic :revision revision) ","))))
482               (subseq inner-string 0 (- (length inner-string) 1)))))
483        (concatenate 'string "[" json-string "]"))
484      "null"))
Note: See TracBrowser for help on using the repository browser.