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

KindCoveredAll%
expression3181282 24.8
branch23136 16.9
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
 ;;; (load "patches/sparql-results-json.lisp")
3
 
4
 (in-package :org.datagraph.spocq.implementation)
5
 
6
 ;;; results+json serializer
7
 ;;; http://www.ietf.org/rfc/rfc4627.txt
8
 
9
 ;;; no reading
10
 
11
 
12
 ;;; writing - either boolean or bindings                             
13
 
14
 #+(or)
15
 (progn
16
   (defmethod write-sparql-results+json :before (results stream)
17
     ;(write-string "before" stream) (finish-output stream)
18
     )  
19
   (defmethod write-sparql-results+json :after (results stream)
20
     ;(write-string "after" stream) (finish-output stream)
21
     ))
22
 
23
 
24
 (defgeneric write-sparql-results+json (results stream)
25
   (:documentation "Encode the result field to the stream as results+json.
26
  The results are a list of lists. The first element is a header, which specifies the variable names.
27
  The remaining entries aer solutions sets. if a variable is unbound, the solution element is etf:nil.
28
  WRT term encoding, note https://www.w3.org/TR/sparql11-results-json/#select-encode-terms, which
29
  specifies to use dictionaries for all terms, but to omit the type members for strings")
30
   
31
   (:method ((result symbol) (stream t))
32
     (format stream "{ \"head\": {}, \"boolean\": ~a }"
33
             (spocq.e:boolean result))
34
     (incf-stat *statements-returned*))
35
 
36
   (:method ((results list-solution-field) (stream t))
37
     (write-sparql-results+json (cons (list-solution-field-dimensions results)
38
                                      (list-solution-field-solutions results))
39
                                stream))
40
   
41
   (:method ((results cons) (stream t))
42
     (let* ((variables (first results))
43
            (solutions (rest results))
44
            (index 0)
45
            (start (or (response-offset) 0))
46
            (end (response-end))
47
            (*expand-literal-values* t)
48
            (*encode-json-term.type-members* '(not string)))
49
       (format stream "{ \"head\": { \"vars\": [~{ \"~a\"~^,~} ] }," variables)
50
       (format stream "~:[~;~%~] \"results\": {~:[~;~%~]  \"bindings\": [" *print-pretty* *print-pretty*)
51
       (dolist (result solutions)
52
         (when (>= index start)
53
           (when (and end (>= index end))
54
             (return))
55
           (format stream "~:[~;, ~]~:[~;~%~]    { " (> index start) *print-pretty*)
56
           (loop for name in variables for value in result
57
                 with first = t
58
                 do (typecase value
59
                      ;; emit non-null values and enable commas
60
                      ((or null spocq:unbound-variable (member etf:nil)))
61
                      (t (format stream "~:[, ~;~]\"~a\": " first name)
62
                         (setf first nil)
63
                         (encode-json-term value stream))))
64
           (format stream " }"))
65
         (incf index))
66
       (format stream " ] } }~:[~;~%~]" *print-pretty*)
67
       (incf-stat *statements-returned* index)
68
       index))
69
   
70
   (:method ((results boolean-generator) (stream t))
71
     (let* ((channel (boolean-generator-channel results)))
72
       (write-string "{ \"head\": {}, \"boolean\": " stream)
73
       (write-string (spocq:literal-lexical-form (if (get-field-page channel) spocq.a:|true| spocq.a:|false|)) stream)
74
       (write-string " }" stream)
75
       (incf-stat *statements-returned*)))
76
   
77
   (:method ((results solution-generator) (stream t))
78
     (let* ((dimensions (solution-generator-dimensions results))
79
            (channel (solution-generator-channel results))
80
            (base-width (length dimensions))
81
            (index 0)
82
            (start (or (response-offset) 0))
83
            (end (response-end))
84
            (*expand-literal-values* t)
85
            (*encode-json-term.type-members* '(not string)))
86
       (format stream "{ \"head\": { \"vars\": [~{ \"~a\"~^,~} ] }," dimensions)
87
       (format stream "~:[~;~%~]   \"results\": {~:[~;~%~]   \"bindings\": [" *print-pretty* *print-pretty*)
88
       (do-pages (page channel)
89
         (if (and end (>= index end))
90
           (return)
91
           (if (>= (+ index (array-dimension page 0)) start)
92
             (cond ((= base-width (array-dimension page 1))
93
                    (trace-data write-sparql-results+json dimensions (term-value-field page))
94
                    (setf index (write-sparql-results-field+json page dimensions stream index start end)))
95
                   (t
96
                    (log-warn "field width mismatch: ~s : ~s."
97
                              dimensions (array-dimension page 1))
98
                    (incf index (array-dimension page 0))))
99
             ; otherwise skip the entire page
100
             (incf index (array-dimension page 0)))))
101
       (format stream " ] } }~:[~;~%~]" *print-pretty*)
102
       (incf-stat *statements-returned* index)
103
       index))
104
 
105
   (:method ((result-field true-matrix-field) (stream t))
106
     (format stream "{ \"head\": {}, \"boolean\": ~a }" (spocq:literal-lexical-form spocq.a:|true|))
107
     (incf-stat *statements-returned*))
108
 
109
   (:method ((result-field false-matrix-field) (stream t))
110
     (format stream "{ \"head\": {}, \"boolean\": ~a }" (spocq:literal-lexical-form spocq.a:|false|))
111
     (incf-stat *statements-returned*))
112
 
113
   (:method ((result-field matrix-field) (stream t))
114
     (flet ((term-aspect-encoder (term-type term-literal term-language-tag term-datatype)
115
              (encode-json-term-aspects term-type term-literal term-language-tag term-datatype stream)))
116
       (declare (dynamic-extent #'term-aspect-encoder))
117
       (let ((term-deconstructor (repository-term-deconstructor *transaction*)))
118
         (let* ((dimensions (solution-field-dimensions result-field))
119
                (base-width (length dimensions))
120
                (start (or (response-offset) 0))
121
                (end (response-end))
122
                (result-count 0)
123
                (first t)
124
                (*expand-literal-values* t)
125
                (*encode-json-term.type-members* '(not string)))
126
           (with-input-fields (result-field)
127
             (format stream "{ \"head\": { \"vars\": [~{ \"~a\"~^,~} ] },"
128
                     (remove-if-not #'distinguished-variable-p dimensions))
129
             (format stream "~:[~;~%~]   \"results\": {~:[~;~%~]   \"bindings\": [" *print-pretty* *print-pretty*)
130
             (let ((%source-data (cffi::null-pointer))
131
                   (source-row 0))
132
               (setf (values %source-data source-row) (first-field-row result-field))
133
               (loop until (and end (>= result-count (the fixnum end)))
134
                     until (cffi:null-pointer-p %source-data)
135
                     do (progn
136
                          (trace-matrix "~& write-sparql-results+json.next ~@{~a ~}" :source-row source-row)
137
                          (when (> (incf result-count) start)
138
                            (format stream "~:[,~;~]~:[~;~%~]     " (shiftf first nil) *print-pretty*)
139
                            (write-string " {" stream)
140
                            (loop with first = t
141
                                  for term-offset from (* base-width source-row)
142
                                  for name in dimensions
143
                                  when (distinguished-variable-p name)
144
                                  do (let ((term-id (#.+matrix-accessor+ (the sb-sys:system-area-pointer %source-data)
145
                                                     (the fixnum (* #.(cffi:foreign-type-size +matrix-element-type+) term-offset)))))
146
                                       (unless (= term-id +null-term-id+)
147
                                         (if (shiftf first nil) (write-char #\space stream) (format stream ", "))
148
                                         (format stream "\"~a\": " name)
149
                                         (funcall term-deconstructor #'term-aspect-encoder *transaction* term-id))))
150
                            (write-string " }" stream))
151
                          (setf (values %source-data source-row) (next-field-row result-field)))))
152
             (incf-stat *statements-returned* (- result-count start))
153
             (format stream " ] } }~:[~;~%~]" *print-pretty*))
154
           result-count)))))
155
 
156
 
157
 (defun write-sparql-results-field+json (page variables stream &optional (index 0) (start 0) end)
158
   (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))
159
   (flet ((term-aspect-encoder (term-type term-literal term-language-tag term-datatype)
160
            (encode-json-term-aspects term-type term-literal term-language-tag term-datatype stream)))
161
     (declare (dynamic-extent #'term-aspect-encoder))
162
     (let ((term-deconstructor (repository-term-deconstructor *transaction*)))
163
       (dotimes (page-index (array-dimension page 0))
164
         (when (>= index start)
165
           (when (and end (>= index end))
166
             (return))
167
           (when (> index start)
168
             (write-char #\, stream))
169
           (format stream "~:[~;~%~] {" *print-pretty*)
170
           (loop for value-index from 0
171
                 with first = t
172
                 for name in variables
173
                 do (let ((term-id (aref page page-index value-index)))
174
                      (unless (= term-id +null-term-id+)
175
                        (if first (write-char #\space stream) (format stream ",~:[~;~%~]     " *print-pretty*))
176
                        (setf first nil)
177
                        (format stream "\"~a\": " name)
178
                        (funcall term-deconstructor #'term-aspect-encoder *transaction* term-id))))
179
           (write-string " }" stream))
180
         (incf index))))
181
   index)
182
 
183
 
184
 ;;; string encoding
185
 
186
 (defun stream-write-external-utf8-string-json-bytes (stream %string)
187
   "Accept a string in utf8, transcode it to the output stream with escapes
188
    emit the escaped buffer as a byte sequence"
189
   (declare (type stream stream)
190
            (type sb-sys:system-area-pointer %string)
191
            ;; (optimize (speed 3) (safety 0))
192
            (optimize (debug 3) (safety 3)))
193
   (unless (cffi:null-pointer-p %string)
194
     (let ((buffer (thread-byte-buffer))
195
           (in-position 0)
196
           (out-position 0))
197
       (declare (type (simple-array (unsigned-byte 8) (*)))
198
                (type fixnum in-position out-position))
199
       (macrolet ((emit-string (string)
200
                    (if (stringp string)
201
                        `(progn ,@(loop for char across string
202
                                    collect `(emit ,(char-code char))))
203
                        `(loop for char across ,string for byte = (char-code char)
204
                           do (emit byte))))
205
                  (next-byte ()
206
                    `(let ((byte (cffi:mem-ref %string :uint8 in-position)))
207
                       (incf in-position)
208
                       byte)))
209
         (labels ((emit (byte)
210
                    (when (>= out-position (length buffer))
211
                      (setf buffer (adjust-array buffer (+ (length buffer)
212
                                                           *thread-byte-buffer-increment*))))
213
                    (setf (aref buffer out-position) byte
214
                          out-position (1+ out-position))
215
                    ;;(print (list out-position byte (type-of buffer)))
216
                    )
217
                  (emit-non-zero (byte)
218
                    (if (zerop byte)
219
                        (complete)
220
                        (emit byte)))
221
                  (emit-escape (byte)
222
                    (emit-string "\\u")
223
                    (emit-string (format nil "~4,'0x" byte)))
224
                  (complete ()
225
                    ;;(print (list out-position (type-of buffer)))
226
                    (write-sequence buffer stream :end out-position)
227
                    (return-from stream-write-external-utf8-string-json-bytes
228
                      (values in-position out-position))))
229
           ;; as per rfc4627
230
           ;; All Unicode characters may be placed within the
231
           ;; quotation marks except for the characters that must be escaped:
232
           ;; quotation mark, reverse solidus, and the control characters
233
           ;; (U+0000 through U+001F).
234
           (loop (let ((byte (next-byte)))
235
                   (declare (type (integer 0 255) byte))
236
                   (cond ((= 0 byte) (complete))
237
                         ((<= byte #x1f)      ; C0 control : http://en.wikipedia.org/wiki/Control_character
238
                          (case byte
239
                            (#.(char-code #\backspace) (emit-string "\\b"))
240
                            (#.(char-code #\page) (emit-string "\\f"))
241
                            (#.(char-code #\linefeed) (emit-string "\\n"))
242
                            (#.(char-code #\return) (emit-string "\\r"))
243
                            (#.(char-code #\tab) (emit-string "\\t"))
244
                            (t
245
                             (emit-escape byte))))
246
                         ((< byte #x80)
247
                          (case byte
248
                            (#.(char-code #\") (emit-string "\\\""))
249
                            (#.(char-code #\\) (emit-string "\\\\"))
250
                            (t
251
                             (emit byte))))
252
                         ((and (<= #x80 byte) (<= byte #x9f))
253
                          (emit-escape byte))
254
                         ((= #xc0 (logand #xe0 byte))
255
                          (emit byte)
256
                          (emit-non-zero (next-byte))
257
                          )
258
                         ((= #xe0 (logand #xf0 byte))
259
                          (emit byte)
260
                          (emit-non-zero (next-byte))
261
                          (emit-non-zero (next-byte))
262
                          )
263
                         ((= #xf0 (logand #xf8 byte))
264
                          (emit byte)
265
                          (emit-non-zero (next-byte))
266
                          (emit-non-zero (next-byte))
267
                          (emit-non-zero (next-byte))
268
                          )
269
                         (t
270
                          (log-error "Illegal UTF-8 data: x~2,'0x." byte)
271
                          (complete))))))))))
272
 
273
 (defun amqp-stream-write-external-utf8-string-as-json (stream %string)
274
   (stream-write-external-utf8-string-json-bytes stream %string))
275
 
276
 (defun fd-stream-write-external-utf8-string-as-json (stream %string)
277
   (stream-write-external-utf8-string-json-bytes stream %string))
278
 
279
 (defun character-stream-write-external-utf8-string-as-json (stream %string)
280
   ;; encode utf8 on the fly, rather than converting the entire string
281
   ;; but emit characters v/s amqp case, where binary output is possible
282
   (let ((decoder (content-encoding-byte-decoder (content-encoding :utf-8)))
283
         (i 0))
284
     (flet ((utf8-byte-scanner (ignore)
285
              (declare (ignore ignore))
286
              (let ((byte (cffi:mem-ref %string :uint8 i)))
287
                (when (or (null byte) (zerop byte))
288
                  (return-from character-stream-write-external-utf8-string-as-json i))
289
                (incf i)
290
                byte)))
291
       (declare (dynamic-extent #'utf8-byte-scanner))
292
       (loop for char = (funcall decoder #'utf8-byte-scanner nil)
293
         do (case char
294
              (#\" (write-string "\\\"" stream))
295
              (#\\ (write-string "\\\\" stream))
296
              ;;(#\/ (write-string "\\/" stream))
297
              (#\backspace (write-string "\\b" stream))
298
              (#\page (write-string "\\f" stream))
299
              (#\linefeed (write-string "\\n" stream))
300
              (#\return (write-string "\\r" stream))
301
              (#\tab (write-string "\\t" stream))
302
              (t (let ((code (char-code char)))
303
                   (if (or (<= code #x1f)      ; C0 control : http://en.wikipedia.org/wiki/Control_character
304
                           (and (<= #x80 code) (<= code #x9f)))        ; C1 control
305
                       (format stream "\\u~4,'0x" code)
306
                       (write-char char stream)))))))))
307
 
308
 (defun standard-stream-write-external-utf8-string-as-json (stream %string)
309
   ;; encode utf8 on the fly, rather than converting the entire string
310
   ;; but emit characters v/s amqp case, where binary output is possible
311
   (let ((decoder (content-encoding-byte-decoder (content-encoding :utf-8)))
312
         (i 0))
313
     (flet ((utf8-byte-scanner (ignore)
314
              (declare (ignore ignore))
315
              (let ((byte (cffi:mem-ref %string :uint8 i)))
316
                (when (or (null byte) (zerop byte))
317
                  (return-from standard-stream-write-external-utf8-string-as-json i))
318
                (incf i)
319
                byte)))
320
       (declare (dynamic-extent #'utf8-byte-scanner))
321
       (loop for char = (funcall decoder #'utf8-byte-scanner nil)
322
         do (case char
323
              (#\" (write-string "\\\"" stream))
324
              (#\\ (write-string "\\\\" stream))
325
              ;;(#\/ (write-string "\\/" stream))
326
              (#\backspace (write-string "\\b" stream))
327
              (#\page (write-string "\\f" stream))
328
              (#\linefeed (write-string "\\n" stream))
329
              (#\return (write-string "\\r" stream))
330
              (#\tab (write-string "\\t" stream))
331
              (t (let ((code (char-code char)))
332
                   (if (or (<= code #x1f)      ; C0 control : http://en.wikipedia.org/wiki/Control_character
333
                           (and (<= #x80 code) (<= code #x9f)))        ; C1 control
334
                       (format stream "\\u~4,'0x" code)
335
                       (write-char char stream)))))))))
336
 
337
 
338
 (defun stream-write-utf8-string-as-json (stream string)
339
   ;; can presume only character streams
340
   (loop for char across string
341
         do (case char
342
              (#\" (write-string "\\\"" stream))
343
              (#\\ (write-string "\\\\" stream))
344
              ;;(#\/ (write-string "\\/" stream))
345
              (#\backspace (write-string "\\b" stream))
346
              (#\page (write-string "\\f" stream))
347
              (#\linefeed (write-string "\\n" stream))
348
              (#\return (write-string "\\r" stream))
349
              (#\tab (write-string "\\t" stream))
350
              (t (let ((code (char-code char)))
351
                   (if (or (<= code #x1f)      ; C0 control : http://en.wikipedia.org/wiki/Control_character
352
                           (and (<= #x80 code) (<= code #x9f)))        ; C1 control
353
                     (format stream "\\u~4,'0x" code)
354
                     (write-char char stream)))))))
355
 
356
 
357
 ;;; specify storage form statically or determine dynamicaly
358
 
359
 (defgeneric stream-write-external-utf8-string-as-json (stream %string)
360
   (:method ((stream amqp:channel) (%string sb-sys:system-area-pointer))
361
     (amqp-stream-write-external-utf8-string-as-json stream %string))
362
   (:method ((stream sb-sys:fd-stream) (%string sb-sys:system-area-pointer))
363
     (fd-stream-write-external-utf8-string-as-json stream %string))
364
   (:method ((stream synonym-stream) (%string sb-sys:system-area-pointer))
365
     (stream-write-external-utf8-string-as-json (symbol-value (synonym-stream-symbol stream))
366
                                                %string))
367
   (:method ((stream stream) (%string sb-sys:system-area-pointer))
368
     (character-stream-write-external-utf8-string-as-json stream %string)))
369
 
370
 (defgeneric stream-write-string-as-json (stream string)
371
   (:method ((stream stream) (%string sb-sys:system-area-pointer))
372
     (stream-write-external-utf8-string-as-json stream %string))
373
   (:method ((stream stream) (string string))
374
     (stream-write-utf8-string-as-json stream string)))
375
 
376
 (defgeneric cl-user::format-json-iri-namestring (stream term &optional option arg)
377
   (:method (stream (object string) &optional option arg)
378
     (declare (ignore option arg))
379
     (stream-write-utf8-string-as-json stream object))
380
   
381
   (:method (stream (object spocq:iri) &optional option arg)
382
     (declare (ignore option arg))
383
     (stream-write-utf8-string-as-json stream (spocq:iri-lexical-form object)))
384
   
385
   (:method (stream (object symbol) &optional option arg)
386
     (declare (ignore option arg))
387
     ;; vocabulary iri should not require escaping
388
     (stream-write-utf8-string-as-json (symbol-uri-namestring object) stream))
389
   (:method (stream (object sb-sys:system-area-pointer) &optional option arg)
390
     (declare (ignore option arg))
391
     (stream-write-external-utf8-string-as-json stream object)))
392
 
393
 (defun cl-user::format-json-character-data (stream string &optional option arg)
394
   (declare (ignore option arg))
395
   (stream-write-string-as-json stream string))
396
 
397
 ;;; (format *trace-output* ">~/format-json-character-data/<" (concatenate 'string "asdf.\"." `(,(code-char 31)) ".qwer"))
398
 
399
 (defgeneric encode-json-term (term stream)
400
   (:method ((object function) stream)
401
     (funcall object stream))
402
 
403
   (:method ((object null) (stream t))
404
     (write-string "{}" stream))
405
 
406
   (:method ((object spocq:iri) stream)
407
     (format stream "{\"type\":\"uri\", \"value\":\"~/format-json-iri-namestring/\"}" object))
408
 
409
   (:method ((object spocq:date-time) stream)
410
     (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#dateTime\", \"value\":\"")
411
     (write-string (term-lexical-form object) stream)
412
     (write-string "\"}" stream))
413
 
414
   (:method ((object spocq:date) stream)
415
     (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#date\", \"value\":\"")
416
     (write-string (term-lexical-form object) stream)
417
     (write-string "\"}" stream))
418
 
419
   (:method ((object spocq:time) stream)
420
     (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#time\", \"value\":\"")
421
     (write-string (term-lexical-form object) stream)
422
     (write-string "\"}" stream))
423
 
424
   (:method ((object spocq:day-time-duration) stream)
425
     (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#dayTimeDuration\", \"value\":\"")
426
     (write-string (term-lexical-form object) stream)
427
     (write-string "\"}" stream))
428
 
429
   (:method ((object spocq:year-month-duration) stream)
430
     (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#yearMonthDuration\", \"value\":\"")
431
     (write-string (term-lexical-form object) stream)
432
     (write-string "\"}" stream))
433
 
434
   (:method ((object spocq:blank-node) stream)
435
     (format stream "{\"type\":\"bnode\", \"value\":\"~@[~a_~]~a\"}"
436
             (blank-node-prefix)
437
             (spocq:blank-node-label object)))
438
 
439
   (:method ((object symbol) stream)
440
     (case object
441
       (spocq.a:|true|
442
        (write-string (spocq:literal-lexical-form spocq.a:|true|) stream))
443
       (spocq.a:|false|
444
        (write-string (spocq:literal-lexical-form spocq.a:|false|) stream))
445
       (t
446
        (let ((uri-namestring (symbol-uri-namestring object)))
447
          (cond (uri-namestring
448
                 (format stream "{\"type\":\"uri\", \"value\":\"~/format-json-iri-namestring/\"}"
449
                         uri-namestring))
450
                ((eq object +null-term+)
451
                 (write-string "{}" stream))
452
                (t
453
                 (error "encoding error: invalid value: ~s." object)))))))
454
 
455
   (:method ((object spocq:boolean) stream)
456
     (if (subtypep 'boolean *expand-literal-values*)
457
         (if (subtypep 'boolean *encode-json-term.type-members*)
458
             (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#boolean\", \"value\":\"~a\"}"
459
                     (spocq:literal-lexical-form object))
460
             (format stream "{\"type\":\"literal\", \"value\":\"~a\"}" (spocq:literal-lexical-form object)))
461
         (write-string (spocq:literal-lexical-form object) stream)))
462
   (:method ((object (eql t)) stream)
463
     (encode-json-term spocq.a:|true| stream))
464
   (:method ((object (eql :|true|)) stream)
465
     (encode-json-term spocq.a:|true| stream))
466
   (:method ((object null) stream)
467
     (encode-json-term spocq.a:|false| stream))
468
   (:method ((object (eql :|false|)) stream)
469
     (encode-json-term spocq.a:|false| stream))
470
 
471
   (:method ((object spocq:plain-literal) stream)
472
     (format stream "{\"type\":\"literal\", \"xml:lang\":\"~a\", \"value\":\"~/format-json-character-data/\"}"
473
             (spocq:plain-literal-language-tag object)
474
             (spocq:literal-lexical-form object)))
475
 
476
   (:method ((object string) stream)
477
     (if (typep "" *expand-literal-values*) 
478
         (if (typep "" *encode-json-term.type-members*)
479
             (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", \"value\":\"~/format-json-character-data/\"}"
480
                     object)
481
             (format stream "{\"type\":\"literal\", \"value\":\"~/format-json-character-data/\"}" object))
482
         (format stream "\"~/format-json-character-data/\"" object)))
483
   (:method ((object spocq:string) stream)
484
     (if (typep "" *expand-literal-values*) 
485
         (if (typep "" *encode-json-term.type-members*)
486
             (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", \"value\":\"~/format-json-character-data/\"}"
487
                     object)
488
             (format stream "{\"type\":\"literal\", \"value\":\"~/format-json-character-data/\"}" object))
489
         (format stream "\"~/format-json-character-data/\"" object)))
490
 
491
   (:method ((object spocq:unbound-variable) stream)
492
     (write-string "{}" stream))
493
 
494
   (:method ((object spocq:atomic-typed-literal) stream)
495
     (format stream "{\"type\":\"literal\", \"datatype\":\"~/format-json-iri-namestring/\", \"value\":\"~/format-json-character-data/\"}"
496
             (spocq:literal-datatype-uri object)
497
             (spocq:literal-lexical-form object)))
498
     
499
   (:method ((object spocq:unsupported-typed-literal) stream)
500
     (format stream "{\"type\":\"literal\", \"datatype\":\"~/format-json-iri-namestring/\", \"value\":\"~/format-json-character-data/\"}"
501
             (spocq:unsupported-typed-literal-datatype-uri object)
502
             (spocq:literal-lexical-form object)))
503
 
504
   (:method ((object spocq:number) stream)
505
     (encode-json-term (spocq:atomic-typed-literal-value object) stream))
506
 
507
   (:method ((object integer) stream)
508
     (if (typep object *expand-literal-values*)
509
         (if (typep object *encode-json-term.type-members*)
510
             (format stream "{\"type\":\"literal\", \"datatype\":\"~a\", \"value\":\"~a\"}"
511
                     (if *encode-object-subtypes*
512
                         (typecase object
513
                           ((signed-byte 16) "http://www.w3.org/2001/XMLSchema#short")
514
                           (t "http://www.w3.org/2001/XMLSchema#integer"))
515
                         "http://www.w3.org/2001/XMLSchema#integer")
516
                     object)
517
             (format stream "{\"type\":\"literal\", \"value\":\"~a\"}" object))
518
       (format stream "~a" object)))
519
 
520
   (:method ((object double-float) stream)
521
    (if (or (eql object double-float-nan)
522
            (eql object double-float-positive-infinity)
523
            (eql object double-float-negative-infinity))
524
      (error "encoding error: invalid float value: ~a" object)
525
      (let ((*read-default-float-format* 'double-float))
526
        (if (typep object *expand-literal-values*)
527
            (if (typep object *encode-json-term.type-members*)
528
                (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#double\", \"value\":\"~f\"}"
529
                        object)
530
                (format stream "{\"type\":\"literal\", \"value\":\"~f\"}" object))
531
          (format stream "~f" object)))))
532
 
533
   (:method ((object single-float) stream)
534
    (if (or (eql object nan) (eql object +inf) (eql object -inf))
535
      (error "Invalid float value: ~a" object)
536
      (let ((*read-default-float-format* 'single-float))
537
        (if (typep object *expand-literal-values*)
538
            (if (typep object *encode-json-term.type-members*)
539
                (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#float\", \"value\":\"~f\"}"
540
                        object)
541
                (format stream "{\"type\":\"literal\", \"value\":\"~f\"}" object))
542
          (format stream "~f" object)))))
543
 
544
   (:method ((object rational) stream)
545
     (let ((*read-default-float-format* 'single-float))
546
       (if (typep object *expand-literal-values*)
547
           (if (typep object *encode-json-term.type-members*)
548
               (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#decimal\", \"value\":\"~f\"}"
549
                       (float object 1.0s0))
550
               (format stream "{\"type\":\"literal\", \"value\":\"~f\"}" (float object 1.0s0)))
551
           (format stream "~f" (float object 1.0s0))))))
552
 
553
 (defun encode-json-term-id (term-number stream)
554
   (flet ((term-aspect-encoder (term-type term-literal term-language-tag term-datatype)
555
            (encode-json-term-aspects term-type term-literal term-language-tag term-datatype stream)))
556
     (declare (dynamic-extent #'term-aspect-encoder))
557
     (repository-call-with-numbered-term-aspects #'term-aspect-encoder *transaction* term-number)))
558
 
559
 
560
 (defun encode-json-term-record (%term stream)
561
   (encode-json-term-aspects (cffi:foreign-slot-value %term 'rdfcache::term 'rdfcache::type)
562
                             (cffi:foreign-slot-value %term 'rdfcache::term 'rdfcache::value)
563
                             (cffi:foreign-slot-value %term 'rdfcache::term 'rdfcache::language)
564
                             (cffi:foreign-slot-value %term 'rdfcache::term 'rdfcache::datatype)
565
                             stream))
566
 
567
 (defun encode-json-term-aspects (term-type term-literal term-language-tag term-datatype stream)
568
   (ecase term-type
569
     (:none (write-string "{}" stream))
570
     (:node                            ; encode a blank node
571
      (format stream "{\"type\":\"bnode\", \"value\":\"~@[~a_~]" (blank-node-prefix))
572
      (stream-write-external-utf8-string-as-json stream term-literal)
573
      (write-string "\"}" stream))
574
     (:literal                         ; encode a typed or language-tagged literal
575
      (cond ((not (cffi:null-pointer-p term-language-tag))
576
             (write-string "{\"type\":\"literal\", \"xml:lang\":\"" stream)
577
             (stream-write-external-utf8-string-as-json stream term-language-tag)
578
             (write-string "\", \"value\":\"" stream)
579
             (stream-write-external-utf8-string-as-json stream term-literal)
580
             (write-string "\"}" stream))
581
            ((or (cffi:null-pointer-p term-datatype)
582
                 (%string-equal term-datatype (|%http://www.w3.org/2001/XMLSchema#string|)))
583
             (cond ((typep "" *expand-literal-values*)
584
                    (cond ((typep "" *encode-json-term.type-members*)
585
                           (write-string "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", \"value\":\"" stream)
586
                           (stream-write-external-utf8-string-as-json stream term-literal)
587
                           (write-string "\"}" stream))
588
                          (t
589
                           (write-string "{\"type\":\"literal\", \"value\":\"" stream)
590
                           (stream-write-external-utf8-string-as-json stream term-literal)
591
                           (write-string "\"}" stream))))
592
                   (t
593
                     (write-char #\" stream)
594
                     (stream-write-external-utf8-string-as-json stream term-literal)
595
                     (write-char #\" stream))))
596
            (t
597
             (write-string "{\"type\":\"literal\", \"datatype\":\"" stream)
598
             (stream-write-external-utf8-string-as-json stream term-datatype)
599
             (write-string "\", \"value\":\"" stream)
600
             (stream-write-external-utf8-string-as-json stream term-literal)
601
             (write-string "\"}" stream))))
602
     (:uri                             ; encode a uri
603
      (write-string "{\"type\":\"uri\", \"value\":\"" stream)
604
      (stream-write-external-utf8-string-as-json stream term-literal)
605
      (write-string "\"}" stream))))
606
 
607
 ;;;
608
 ;;; reading
609
 
610
 (defgeneric parse-json-sparql-results (location)
611
   (:method ((location spocq:iri))
612
     (parse-json-sparql-results (parse-json location)))
613
   (:method ((stream stream))
614
     (parse-json-sparql-results (parse-json stream)))
615
   (:method ((document-model cons))
616
     (labels ((json-field-value (name object)
617
              (rest (assoc name object :test #'string=)))
618
            (decode-json-value (value)
619
              (let ((type (json-field-value "type" value)))
620
                (cond ((equal type "uri") (intern-iri (json-field-value "value" value)))
621
                      ((equal type "bnode") (spocq:make-blank-node (json-field-value "value" value)))
622
                      (t (let ((type (json-field-value "datatype" value))
623
                               (lang (json-field-value "lang" value)))
624
                           (decode-sparql-result-literal  (json-field-value "value" value) type lang)))))))
625
       (let* ((head (json-field-value "head" document-model))
626
              (vars (json-field-value "vars" head))
627
              (boolean (json-field-value "boolean" document-model))
628
              (results (json-field-value "results" document-model))
629
              (bindings (or (json-field-value "bindings" results)
630
                            (json-field-value "bindings" document-model))))
631
         (unless (and vars (or boolean bindings)) ()
632
           (error "parse-json-sparql-results: invalid sparql results document: ~s" document-model))
633
         (if bindings
634
             (let ((variables (etypecase vars
635
                                (vector (loop for name across vars collect (make-variable name)))
636
                                (list (loop for name in vars collect (make-variable name)))))
637
                   (count 0))
638
               (values (loop for solution across bindings
639
                         do (incf count)
640
                         collect (loop for variable in variables
641
                                   for value = (rest (assoc variable solution :test #'string=))
642
                                   collect (if value (decode-json-value value)
643
                                               (spocq:make-unbound-variable variable))))
644
                       variables
645
                       count))
646
             (values (if (string-equal "true" boolean) '(nil) nil) nil 1))))))
647
 
648
 (defun decode-sparql-result-literal (lexical-form type lang)
649
   (cond ((equalp type "http://www.w3.org/2001/XMLSchema#integer")
650
          (intern-term-aspects :literal lexical-form <http://www.w3.org/2001/XMLSchema#integer> nil))
651
         ((equalp type "http://www.w3.org/2001/XMLSchema#date")
652
          (spocq.e:date lexical-form))
653
         ((equalp type "http://www.w3.org/2001/XMLSchema#time")
654
          (spocq.e:time lexical-form))
655
         ((equalp type "http://www.w3.org/2001/XMLSchema#dateTime")
656
          (spocq.e:date-time lexical-form))
657
         ((or (equalp type "http://www.w3.org/2001/XMLSchema#decimal")
658
              (equalp type "http://www.w3.org/2001/XMLSchema#double")
659
              (equalp type "http://www.w3.org/2001/XMLSchema#float"))
660
          (read-from-string lexical-form))
661
         ((equalp type "http://www.w3.org/2001/XMLSchema#string")
662
          (or lexical-form ""))
663
         ((equalp type "http://www.w3.org/2001/XMLSchema#boolean")
664
          (spocq.e:boolean lexical-form))
665
         (lang
666
          (spocq:make-plain-literal (or lexical-form "") lang))
667
         (type
668
          (spocq:make-unsupported-typed-literal lexical-form (intern-iri type)))
669
         (t
670
          (or lexical-form ""))))
671
 
672
 ;;;
673
 ;;; message comminication methods
674
 
675
 (defmethod receive-message ((stream t) (type mime:application/sparql-results+json) &key)
676
   ;;(parse-json-sparql-results (parse-json stream)))
677
   (parse-json stream))
678
 
679
 (defmethod send-response-message ((operation t) (message t) (stream stream) (content-type mime:application/sparql-results+json))
680
   "Given a MESSAGE, and a STREAM with the application/sparql-results+json CONTENT-TYPE, encode as json"
681
   (when *encoding-trace-output*
682
     (setf stream (make-broadcast-stream *encoding-trace-output* stream)))
683
   (let ((*package* *spocq-reader-package*))
684
     (write-sparql-results+json message stream)))
685
 
686
 #|
687
 (write-sparql-results+json '((?::a ?::s ?::z) (1 2 3) (<http://example/1> <http://example/2> 1))
688
                            *trace-output*)
689
 |#