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

KindCoveredAll%
expression0216 0.0
branch022 0.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
 ;;; persistence based on json encoding
6
 
7
 (defgeneric field-property-keyword (property)
8
   (:documentation "Translate a property uri to the string keyword to be used in
9
    or matched with decoded json object keys")
10
   (:method ((property null))    nil)
11
   (:method ((property symbol)) (symbol-name property))
12
   ;; strings, or uri and puri instances,
13
   (:method ((property t))      (spocq:iri-lexical-form property)))
14
 
15
 (defgeneric class-keyword-property (context keyword)
16
   (:documentation "Translate a presentation keyword - eg. from json, into the respective
17
    store predicate iri via the association present in the slot definitions")
18
   (:method ((class t) (keyword t)) nil)
19
   (:method ((class spocq.i::persistent-class) keyword)
20
     (loop for sd in (class-persistent-slots class)
21
           for property = (spocq.i::slot-definition-decode-presentation-property sd)
22
           when (and property
23
                     (string-equal (field-property-keyword property) keyword))
24
           return property)))
25
 
26
 
27
 (defgeneric decode-json-object (class data &key id)
28
   (:documentation "GIven a parsed json data structure, decode it to form a (s p o) statement field.
29
    If an id is provided, use that as the subject. Otherwise, if one is present in the parsed object,
30
    use that. Otherwise, generate a new local blank node.
31
    The data can represent one of
32
    - a single json object {key:value, ...}
33
    - a sequence of values [ value, ...]
34
    whereby each individual value may represent either further structured data or a primitive datum. 
35
 
36
    the cases in which the structure is of the form {type:value, ...} must be recognized and treated as
37
    terms rather than objects.")
38
 
39
   (:method ((context t) (data t) &key &allow-other-keys)
40
     ;; leave the json data model inchanced
41
     data)
42
 
43
   (:method ((class-name symbol) data &rest args)
44
     (declare (dynamic-extent args))
45
     (apply #'decode-json-object (find-class class-name) data args))
46
 
47
   (:method ((instance persistent-object) data &rest args)
48
     (declare (dynamic-extent args))
49
     (apply #'decode-json-object (class-of instance) data args))
50
 
51
   (:method ((class persistent-class) data &rest args)
52
     (declare (dynamic-extent args))
53
     (apply #'decode-json-object (class-persistent-slots class) data args))
54
 
55
   (:method ((slot-definitions list) (data vector) &rest args)
56
     (declare (dynamic-extent args))
57
     (loop for data across data
58
           append (apply #'decode-json-object slot-definitions data args)))
59
 
60
   (:method ((slot-definitions list) (data list) &key (id nil id-s))
61
     (labels ((id ()
62
                (cond (id-s id)
63
                      (id )
64
                      ((let ((id-term (rest (assoc "ID" data :test #'string-equal))))
65
                         (when id-term (setf id (decode-json-term id-term)))))
66
                      (t
67
                       (setf id (cons-blank-node "json")))))
68
              (slot-definition-keyword (sd)
69
                (let ((property (spocq.i::slot-definition-decode-presentation-property sd)))
70
                  (when property
71
                    (field-property-keyword property))))
72
              (decode-value (value &optional (type t))
73
                (typecase value
74
                  (string value)
75
                  (number value)
76
                  (list (let ((decoded-value (if (assoc "type" value :test #'string-equal)
77
                                               (decode-json-term value)
78
                                               (decode-json-object type value))))
79
                          decoded-value))))
80
              (value-statements (property decoded-value)
81
                (typecase decoded-value
82
                  (cons (let ((object-id (caar decoded-value)))
83
                          (cons `(,(id) ,property ,object-id)
84
                                decoded-value)))
85
                  (t `((,(id) ,property ,decoded-value))))))
86
       (when data
87
         ;; should do this on the fly
88
         (if (assoc "type" data :test #'string-equal)
89
           ;; iff just a typed literal, decode it as a term
90
           (decode-json-term data)
91
           (let* ((sd-map (loop for sd in slot-definitions
92
                                for key = (slot-definition-keyword sd)
93
                                when key
94
                                collect (cons key sd))))
95
             (loop for (key . value) in data
96
                   for sd = (rest (assoc key sd-map :test #'string-equal))
97
                   ;; for transcoding from json, use the presentation property
98
                   when sd append (let ((property (spocq.i::slot-definition-decode-presentation-property sd)))
99
                                    (typecase value
100
                                      (vector (loop for element-value across value
101
                                                    for decoded-value = (decode-value element-value (c2mop:slot-definition-type sd))
102
                                                    append (value-statements property decoded-value)))
103
                                      (t (value-statements property (decode-value value (c2mop:slot-definition-type sd)))))))))))))
104
 
105
 (defgeneric decode-json-term (term )
106
   (:documentation "Given a term represented as json data, translate it into a native term
107
     or a structured data object. If the form is not recognized, signal an error")
108
 
109
   (:method ((term t))
110
     (error "Invalid parsed JSON term: ~s." term))
111
   (:method ((term number))
112
     term)
113
   (:method ((term string))
114
     term)
115
   (:method ((term vector))
116
     (decode-json-object term))
117
   (:method ((term (eql :|false|)))
118
     spocq:|false|)
119
   (:method ((term (eql :|true|)))
120
     spocq:|true|)
121
 
122
   (:method ((term cons))
123
     "Convert a json a-list description of typed data into the equivalent native object"
124
     (labels ((invalid-term-error ()
125
                (error "Invalid parsed JSON term: ~s." term))
126
              (get-datatype ()
127
                (or (rest (assoc "datatype" term :test #'string-equal)) (invalid-term-error)))
128
              (get-language ()
129
                (or (rest (assoc "xml:lang" term  :test #'string-equal)) (invalid-term-error)))
130
              (get-type ()
131
                (or (rest (assoc "type" term :test #'string-equal)) (invalid-term-error)))
132
              (get-value ()
133
                (or (rest (assoc "value" term  :test #'string-equal)) (invalid-term-error))))
134
       (if (every #'consp term)
135
         (let ((type (get-type)))
136
           (cond ((equalp type "bnode")
137
                  (intern-term-aspects :node (get-value) nil nil))
138
                 ((equalp type "uri")
139
                  (intern-iri (get-value)))
140
                 ((equalp type "literal")
141
                  (intern-term-aspects :literal (get-value) nil (get-language)))
142
                 ((equalp type "typed-literal")
143
                  (intern-term-aspects :literal (get-value) (get-datatype) nil))
144
                 (t
145
                  (invalid-term-error))))
146
         (invalid-term-error))))
147
 
148
   ;; other particulars  ... none yet
149
   )
150
 
151
 #|
152
 (bnfp:compile-atn-system  *json-bnf*
153
                           :execute t :compile nil
154
                           :token-package (find-package :de.setf.json)
155
                           :source-package (find-package :de.setf.json)
156
                           :source-pathname #p"P-LIBRARY:org;datagraph;spocq-page-ring;src;core;encoding;json-grammar.lisp"
157
                           :input-function 'dsj::input-reference
158
                           :input-eof-function 'dsj::input-eof?
159
                           :ambiguous t        ; the property paths make it ambiguous
160
                           :trace nil)
161
 ;;; (load (compile-file "LIBRARY:org;datagraph;spocq;src;core;encoding;json-grammar.lisp" :output-file "json-grammar.fasl"))
162
 
163
 
164
 (parse-json "{\"a\": 1}")
165
 (parse-json "{
166
       \"Image\": {
167
           \"Width\":  800,
168
           \"Height\": 600,
169
           \"Title\":  \"View from 15th Floor\",
170
           \"Thumbnail\": {
171
               \"Url\":    \"http://www.example.com/image/481989943\",
172
               \"Height\": 125,
173
               \"Width\":  \"100\"
174
           },
175
           \"IDs\": [116, 943, 234, 38793] } }")
176
 (parse-json "[{}]")
177
 (parse-json "{}")
178
 (parse-json "[]")
179
 (parse-json "[{}, {}]")
180
 (parse-json "[1, 2]")
181
 |#