Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/encoding/sparql-results-xml.lisp

KindCoveredAll%
expression120597 20.1
branch550 10.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.implementation; -*-
2
 
3
 (in-package :org.datagraph.spocq.implementation)
4
 
5
 ;;; results+xml serializer
6
 ;;; http://www.w3.org/TR/rdf-sparql-XMLres/
7
 
8
 ;;; no reading
9
 
10
 
11
 ;;; solution field writing - either boolean or bindings                             
12
 
13
 (defgeneric write-sparql-results+xml (results stream)
14
   (:documentation "Encode the result field to the stream as results+xml.
15
  The results are a list of lists. The first element is a header, which specifies the variable names.
16
  The remaining entries aer solutions sets. if a variable is unbound, the solution element is etf:nil.")
17
 
18
   (:method ((result symbol) (stream t))
19
     (format stream
20
 "<?xml version='1.0' encoding=\"UTF-8\"?>
21
 <sparql xmlns='http://www.w3.org/2005/sparql-results#'>
22
   <head/>
23
   <boolean>~a</boolean>
24
 </sparql>~%" result)
25
     (incf-stat *statements-returned*))
26
 
27
   (:method ((results list-solution-field) (stream t))
28
     (write-sparql-results+xml (cons (list-solution-field-dimensions results)
29
                                      (list-solution-field-solutions results))
30
                                stream))
31
   
32
   (:method ((results cons) (stream t))
33
     (let* ((variables (first results))
34
            (solutions (rest results))
35
            (index 0)
36
            (start (or (response-offset) 0))
37
            (end (response-end)))
38
       (format stream
39
 "<?xml version='1.0' encoding=\"UTF-8\"?>
40
 <sparql xmlns='http://www.w3.org/2005/sparql-results#'>
41
  <head>")
42
       (format stream "~{~%  <variable name='~a'/>~}" variables)
43
       (format stream "~% </head>")
44
       (format stream "~% <results>")
45
       (dolist (result solutions)
46
         (when (>= index start)
47
           (when (and end (>= index end))
48
             (return))
49
           (format stream "~%  <result>")
50
           (loop for name in variables for value in result
51
                 do (case value
52
                      ((nil etf:nil))
53
                      (t (format stream "~%   <binding name='~a'>" name)
54
                         (encode-xml-object value stream)
55
                         (write-string "</binding>" stream))))
56
           (format stream "~%  </result>"))
57
         (incf index))
58
       (format stream "~% </results>")
59
       (format stream "~%</sparql>~%")
60
       (incf-stat *statements-returned* index)))
61
 
62
   (:method ((results boolean-generator) (stream t))
63
     (let* ((channel (boolean-generator-channel results))
64
            (table (get-field-page channel)))
65
       (format stream
66
               "<?xml version='1.0' encoding=\"UTF-8\"?>
67
 <sparql xmlns='http://www.w3.org/2005/sparql-results#'>
68
   <head/>
69
   <boolean>~a</boolean>
70
 </sparql>~%" (spocq:literal-lexical-form (if table spocq.a:|true| spocq.a:|false|)))
71
       (incf-stat *statements-returned*)))
72
 
73
   (:method ((results solution-generator) (stream t))
74
     (let* ((dimensions (solution-generator-dimensions results))
75
            (channel (solution-generator-channel results))
76
            (variable-count (length dimensions))
77
            (index 0)
78
            (start (or (response-offset) 0))
79
            (end (response-end)))
80
      (format stream
81
              "<?xml version='1.0' encoding=\"UTF-8\"?>
82
 <sparql xmlns='http://www.w3.org/2005/sparql-results#'>
83
  <head>")
84
      (format stream "~{ <variable name='~a'/>~}" dimensions)
85
      (format stream " </head>")
86
      (format stream "~% <results>")
87
      (do-pages (page channel)
88
        (if (and end (>= index end))
89
           (return)
90
           (if (>= (+ index (array-dimension page 0)) start)
91
             (cond ((= variable-count (array-dimension page 1))
92
                    (write-sparql-results-field+xml page dimensions stream index start end))
93
                   (t
94
                    (log-warn "field width mismatch: ~s : ~s."
95
                              dimensions (array-dimension page 1))
96
                    (incf index (array-dimension page 0))))
97
             ; otherwise skip the entire page
98
             (incf index (array-dimension page 0)))))
99
      (format stream " </results>")
100
      (format stream "~%</sparql>~%")
101
      (incf-stat *statements-returned* index))))
102
 
103
 (defun write-sparql-results-field+xml (page variables stream &optional (index 0) (start 0) end)
104
   (flet ((term-aspect-encoder (term-type term-literal term-language-tag term-datatype)
105
            (encode-xml-term-aspects term-type term-literal term-language-tag term-datatype stream)))
106
     (declare (dynamic-extent #'term-aspect-encoder))
107
     (let ((term-deconstructor (repository-term-deconstructor *transaction*)))
108
       (dotimes (page-index (array-dimension page 0))
109
         (when (>= index start)
110
           (when (and end (>= index end))
111
             (return))
112
           (write-string "  <result>" stream)
113
           (loop for value-index from 0
114
                 for name in variables
115
                 for term-id = (aref page page-index value-index)
116
                 unless (= term-id +null-term-id+)
117
                 do (progn (format stream " <binding name='~a'>" name)
118
                           (funcall term-deconstructor #'term-aspect-encoder *transaction* term-id)
119
                           (write-string "</binding>" stream)))
120
           (write-string " </result>" stream))
121
         (incf index))))
122
   index)
123
 
124
 
125
 ;;;
126
 
127
 (defgeneric cl-user::format-xml-iri-namestring (stream term &optional option arg)
128
   (:method (stream (object string) &optional option arg)
129
     (declare (ignore option arg))
130
     (write-string object stream))
131
 
132
   (:method (stream (object spocq:iri) &optional option arg)
133
     (declare (ignore option arg))
134
     (write-string (spocq:iri-lexical-form object) stream))
135
   
136
   (:method (stream (object symbol) &optional option arg)
137
     (declare (ignore option arg))
138
     (write-string (symbol-uri-namestring object) stream)))
139
 
140
 
141
 (defgeneric cl-user::format-xml-character-data (stream string &optional option arg)
142
   (:method ((stream t) (string string) &optional option arg)
143
     (declare (ignore option arg))
144
     (multiple-value-bind (writer arg) (stream-writer stream)
145
       (loop for char across string
146
         do (case char
147
              (#\< (write-string "&lt;" stream))
148
              (#\> (write-string "&gt;" stream))
149
              (#\& (write-string "&amp;" stream))
150
              (t (funcall writer arg char))))))
151
   (:method ((stream t) (data t) &optional option arg)
152
     (declare (ignore option arg))
153
     (cl-user::format-xml-character-data stream (format nil "~a" data))))
154
 
155
 ;;; (format *trace-output* ">~/format-xml-character-data/<" "asdf.<.>.&.qwer")
156
 
157
 (defgeneric encode-xml-object (term stream)
158
   (:method ((object function) stream)
159
     (funcall object stream))
160
 
161
   (:method ((object null) (stream t))
162
     )
163
 
164
   (:method ((object spocq:iri) stream)
165
     (format stream "<uri>~/format-xml-iri-namestring/</uri>" (spocq:iri-lexical-form object)))
166
 
167
   (:method ((object spocq:date) stream)
168
     (write-string "<literal datatype='http://www.w3.org/2001/XMLSchema#date'>" stream)
169
     (write-string (term-lexical-form object) stream)
170
     (write-string "</literal>" stream))
171
 
172
   (:method ((object spocq:date-time) stream)
173
     (write-string "<literal datatype='http://www.w3.org/2001/XMLSchema#dateTime'>" stream)
174
     (write-string (term-lexical-form object) stream)
175
     (write-string "</literal>" stream))
176
 
177
   (:method ((object spocq:time) stream)
178
     (write-string "<literal datatype='http://www.w3.org/2001/XMLSchema#dateTime'>" stream)
179
     (write-string (term-lexical-form object) stream)
180
     (write-string "</literal>" stream))
181
 
182
   (:method ((object spocq:day-time-duration) stream)
183
     (write-string "<literal datatype='http://www.w3.org/2001/XMLSchema#dayTimeDuration'>" stream)
184
     (write-string (term-lexical-form object) stream)
185
     (write-string "</literal>" stream))
186
 
187
   (:method ((object spocq:year-month-duration) stream)
188
     (write-string "<literal datatype='http://www.w3.org/2001/XMLSchema#yearMonthDuration'>" stream)
189
     (write-string (term-lexical-form object) stream)
190
     (write-string "</literal>" stream))
191
 
192
   (:method ((object spocq:blank-node) stream)
193
     (format stream "<bnode>~@[~a_~]~a</bnode>"
194
             (blank-node-prefix)
195
             (spocq:blank-node-label object)))
196
 
197
   (:method ((object symbol) stream)
198
     (case object
199
       (spocq.a:|true|
200
        (format stream "<literal datatype='http://www.w3.org/2001/XMLSchema#boolean'>~a</literal>"
201
                (spocq:literal-lexical-form spocq.a:|true|)))
202
       (spocq.a:|false|
203
        (format stream "<literal datatype='http://www.w3.org/2001/XMLSchema#boolean'>~a</literal>"
204
                (spocq:literal-lexical-form spocq.a:|false|)))
205
       (t
206
        (let ((uri-namestring (symbol-uri-namestring object)))
207
          (cond (uri-namestring
208
                 (format stream "<uri>~/format-xml-iri-namestring/</uri>" uri-namestring))
209
                ((eq object +null-term+) )
210
                (t
211
                 (error "encoding error: invalid value: ~s." object)))))))
212
 
213
   (:method ((object spocq:boolean) stream)
214
     (format stream "<literal datatype='http://www.w3.org/2001/XMLSchema#boolean'>~a</literal>"
215
                (spocq:literal-lexical-form object)))
216
 
217
   (:method ((object spocq:plain-literal) stream)
218
     (format stream "<literal xml:lang='~a'>~/format-xml-character-data/</literal>"
219
             (spocq:plain-literal-language-tag object)
220
             (spocq:literal-lexical-form object)))
221
 
222
   (:method ((object string) stream)
223
     (format stream "<literal>~/format-xml-character-data/</literal>" object))
224
 
225
   (:method ((object spocq:unbound-variable) stream)
226
     )
227
   
228
   (:method ((object spocq:atomic-typed-literal) stream)
229
     (format stream "<literal datatype='~/format-xml-iri-namestring/'>~/format-xml-character-data/</literal>"
230
             (spocq:literal-datatype-uri object)
231
             (spocq:literal-lexical-form object)))
232
     
233
   (:method ((object spocq:unsupported-typed-literal) stream)
234
     (format stream "<literal datatype='~/format-xml-iri-namestring/'>~/format-xml-character-data/</literal>"
235
             (spocq:unsupported-typed-literal-datatype-uri object)
236
             (spocq:literal-lexical-form object)))
237
 
238
   (:method ((object integer) stream)
239
     (format stream "<literal datatype='~a'>~a</literal>"
240
             (if *encode-object-subtypes*
241
               (typecase object
242
                 ((signed-byte 16) "http://www.w3.org/2001/XMLSchema#short")
243
                 (t "http://www.w3.org/2001/XMLSchema#integer"))
244
               "http://www.w3.org/2001/XMLSchema#integer")
245
             object))
246
 
247
   (:method ((object double-float) stream)
248
    (if (or (eql object double-float-nan)
249
            (eql object double-float-positive-infinity)
250
            (eql object double-float-negative-infinity))
251
      (error "encoding error: invalid float value: ~a" object)
252
      (let ((*read-default-float-format* 'double-float))
253
        (format stream "<literal datatype='http://www.w3.org/2001/XMLSchema#double'>~f</literal>" object))))
254
 
255
   (:method ((object single-float) stream)
256
    (if (or (eql object nan) (eql object +inf) (eql object -inf))
257
      (error "Invalid float value: ~a" object)
258
      (let ((*read-default-float-format* 'single-float))
259
        (format stream "<literal datatype='http://www.w3.org/2001/XMLSchema#float'>~f</literal>" object))))
260
 
261
   (:method ((object rational) stream)
262
     (let ((*read-default-float-format* 'single-float))
263
       (format stream "<literal datatype='http://www.w3.org/2001/XMLSchema#decimal'>~f</literal>"
264
               (float object 1.0s0)))))
265
 
266
 
267
 (defun encode-xml-term-id (term-number stream)
268
   (flet ((term-aspect-encoder (term-type term-literal term-language-tag term-datatype)
269
            (encode-xml-term-aspects term-type term-literal term-language-tag term-datatype stream)))
270
     (declare (dynamic-extent #'term-aspect-encoder))
271
     (repository-call-with-numbered-term-aspects #'term-aspect-encoder *transaction* term-number)))
272
 
273
 
274
 (defgeneric stream-write-external-utf8-string-as-xml (stream %string)
275
   (:method ((stream amqp:channel) %string)
276
     (macrolet ((emit (byte) `(amqp.i::amqp-stream-write-byte stream ,byte)))
277
       (flet ((write-vector (vector)
278
              (loop for byte across vector
279
                    do (amqp.i::amqp-stream-write-byte stream byte)))
280
              (emit-non-zero (byte)
281
                (if (zerop byte)
282
                  (return-from stream-write-external-utf8-string-as-xml)
283
                  (emit byte))))
284
         (let ((i 0))
285
           (loop (let ((byte (cffi:mem-ref %string :uint8 i)))
286
                   (declare (type (integer 0 255) byte))
287
                   (when (zerop byte) (return))
288
                   (cond ((= 0 (logand #x80 byte))
289
                          (cond ((= byte #.(char-code #\<))
290
                                 (write-vector #.(map 'vector #'char-code "&lt;")))
291
                                ((= byte #.(char-code #\>))
292
                                 (write-vector #.(map 'vector #'char-code "&gt;")))
293
                                ((= byte #.(char-code #\&))
294
                                 (write-vector #.(map 'vector #'char-code "&amp;")))
295
                                (t
296
                                 (emit byte)))
297
                          (incf i))
298
                         ((= #xc0 (logand #xe0 byte))
299
                          (emit byte)
300
                          (emit-non-zero (cffi:mem-ref %string :uint8 (incf i)))
301
                          (incf i))
302
                         ((= #xe0 (logand #xf0 byte))
303
                          (emit byte)
304
                          (emit-non-zero (cffi:mem-ref %string :uint8 (incf i)))
305
                          (emit-non-zero (cffi:mem-ref %string :uint8 (incf i)))
306
                          (incf i))
307
                         ((= #xf0 (logand #xf8 byte))
308
                          (emit byte)
309
                          (emit-non-zero (cffi:mem-ref %string :uint8 (incf i)))
310
                          (emit-non-zero (cffi:mem-ref %string :uint8 (incf i)))
311
                          (emit-non-zero (cffi:mem-ref %string :uint8 (incf i)))
312
                          (incf i))
313
                         (t
314
                          (log-error "Illegal UTF-8 data: x~2,'0x." byte)
315
                          (return)))))))))
316
   (:method ((stream stream) %string)
317
     (cl-user::format-xml-character-data stream (cffi:foreign-string-to-lisp %string))))
318
 
319
 (defun encode-xml-term (%term stream)
320
   (encode-xml-term-aspects (cffi:foreign-slot-value %term 'rdfcache::term 'rdfcache::type)
321
                            (cffi:foreign-slot-value %term 'rdfcache::term 'rdfcache::value)
322
                            (cffi:foreign-slot-value %term 'rdfcache::term 'rdfcache::language)
323
                            (cffi:foreign-slot-value %term 'rdfcache::term 'rdfcache::datatype)
324
                            stream))
325
 
326
 (defun encode-xml-term-aspects (term-type term-literal term-language-tag term-datatype stream)
327
   (ecase term-type
328
     (:none )
329
     (:node                            ; encode a blank node
330
      (format stream "<bnode>~@[~a_~]" (blank-node-prefix))
331
      (stream-write-external-utf8-string-as-xml stream term-literal)
332
      (write-string "</bnode>" stream))
333
     (:literal                         ; encode a typed or language-tagged literal
334
      (cond ((not (cffi:null-pointer-p term-language-tag))
335
             (write-string "<literal xml:lang='" stream)
336
             (stream-write-external-utf8-string-as-xml stream term-language-tag)
337
             (write-string "'>" stream)
338
             (stream-write-external-utf8-string-as-xml stream term-literal)
339
             (write-string "</literal>" stream))
340
            ((and (not (cffi:null-pointer-p term-datatype))
341
                  (not (%string-equal term-datatype (|%http://www.w3.org/2001/XMLSchema#string|))))
342
             (write-string "<literal datatype='" stream)
343
             (stream-write-external-utf8-string-as-xml stream term-datatype)
344
             (write-string "'>" stream)
345
             (stream-write-external-utf8-string-as-xml stream term-literal)
346
             (write-string "</literal>" stream))
347
            (t
348
             (write-string "<literal>" stream)
349
             (stream-write-external-utf8-string-as-xml stream term-literal)
350
             (write-string "</literal>" stream))))
351
     (:uri                             ; encode a uri
352
      (write-string "<uri>" stream)
353
      (stream-write-external-utf8-string-as-xml stream term-literal)
354
      (write-string "</uri>" stream))))
355
 
356
 
357
 ;;;
358
 
359
 (:documentation (send-error-message send-response-message)
360
   "The content-type application/sparql-results+xml indicates a response message message is to be coded
361
  as xml. This applies to responses only and corresponds to sparql requests.")
362
 
363
 
364
 
365
 (defmethod send-error-message ((body t) (stream t) (content-type mime:application/sparql-results+xml))
366
   "Send an error response encoded as xml"
367
   (send-error-message body stream mime:application/sparql-query+sse))
368
 
369
 (defmethod send-response-message ((operation t) (message-body t) (stream t) (content-type mime:application/sparql-results+xml))
370
   "Given a MESSAGE, and a STREAM with the application/sparql-results+xml CONTENT-TYPE, encode as an xml result document"
371
   (when *encoding-trace-output*
372
     (setf stream (make-broadcast-stream *encoding-trace-output* stream)))
373
   (let ((*package* *spocq-reader-package*))
374
     (write-sparql-results+xml message-body stream)))
375
 
376
 #|
377
 (write-sparql-results+xml '((?::a ?::s ?::z) (1 2 3) (<http://example/1> <http://example/2> <http://example/3>))
378
                           *trace-output*)
379
 |#