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

Kind	Covered	All	%
expression	239	480	49.8
branch	18	58	31.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

;;; simple json parser

6

7

;;; see

8

;;; http://www.ietf.org/rfc/rfc4627.txt?number=4627

9

;;; https://developers.google.com/shopping-search/v1/reference-request-parameters

10

;;;

11

12

(defpackage :de.setf.json

13

(:use :common-lisp)

14

(:nicknames :dsj))

15

16

(eval-when (:compile-toplevel :load-toplevel :execute)

17

(loop for name in (append (mapcar #'string (coerce "{}[],:" 'list)) '("true" "false" "null"))

18

for symbol = (intern name :keyword)

19

do (import symbol :de.setf.json)

20

do (export symbol :de.setf.json)))

21

22

(eval-when (:compile-toplevel :load-toplevel :execute)

23

(import '(cl-user::format-json

24

cl-user::format-json-array

25

cl-user::format-json-member

26

cl-user::format-json-object

27

cl-user::format-json-compact

28

cl-user::format-json-array-compact

29

cl-user::format-json-member-compact

30

cl-user::format-json-object-compact)

31

*package*))

32

33

34

(let ((json-float-pattern (cl-ppcre:parse-string "[+-]?([0-9]+([.][0-9]*)|[.][0-9]+)([eE][+-]?[0-9]+)?"))

35

(json-integer-pattern (cl-ppcre:parse-string "[+-]?[0-9]+"))

36

(json-name

37

;; like pn_local, but without #\:

38

`(:sequence (:alternation pn_chars_u (:char-class (:range #\0 #\9)) #\: plx)

39

                    (:greedy-repetition 0 1 (:sequence (:greedy-repetition 0 nil (:alternation pn_chars #\. plx))

40

                                                       (:alternation pn_chars plx))))))

41

(setf (cl-ppcre:parse-tree-synonym 'json-float-pattern) json-float-pattern)

42

(setf (cl-ppcre:parse-tree-synonym 'json-integer-pattern) json-integer-pattern)

43

(setf (cl-ppcre:parse-tree-synonym 'json-name) json-name))

44

45

(defparameter *json-scanner*

46

(cl-ppcre:create-scanner '(:ALTERNATION

47

                               (:register (:ALTERNATION (:CHAR-CLASS #\{ #\} #\[ #\] #\, #\:)

48

                                                       (:sequence #\" (:GREEDY-REPETITION 0 NIL

49

                                                                                          (:alternation (:sequence #\\ #\")

50

                                                                                                        (:INVERTED-CHAR-CLASS #\")))

51

                                                                  #\")

52

                                                       json-float-pattern

53

                                                       json-integer-pattern

54

                                                       (:ALTERNATION "false" "true" "null")

55

                                                       json-name))

56

(:GREEDY-REPETITION 1 NIL :WHITESPACE-CHAR-CLASS))))

57

58

59

;;; (cl-ppcre:all-matches-as-strings *json-scanner* "{\"a\" : 3}")

60

;;; (cl-ppcre:all-matches-as-strings *json-scanner* "{\"a\" : \"An `escaped` \\\"string\\\".\"}")

61

62

;;; note that, while http://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf

63

;;; is ambiguous, http://www.ietf.org/rfc/rfc4627.txt is not, in that a JSON text must be

64

;;; either an object or an array.

65

66

(defparameter *json-bnf* "

67

Json ::= Object | Array

68

Object ::= '{' ( Member ( ',' Member )* )? '}'

69

Array ::= '[' ValueList ? ']'

70

ValueList ::= Value ( ',' ValueList )?

71

Member ::= NAME ':' Value

72

73

Literal ::= 'false' | 'null' | 'true'

74

")

75

76

(defun dsj::is-number (x)

77

(numberp x))

78

79

(defun dsj::is-name (x)

80

(or (stringp x)

81

(and (symbolp x) (not (null x)))))

82

83

(defun dsj::is-string (x)

84

(stringp x))

85

86

(defparameter *tokenize-json.mode* :lax

87

"If :strict, then only known symbols (as per keyword, spocq.a and de.setf.json packages

88

are permitted as member names")

89

90

(defun tokenize-json (json-string &key (start 0) (end (length json-string)))

91

(let (tokens

92

(buffer (make-array 32 :adjustable t :fill-pointer 0 :element-type 'character)))

93

     (cl-ppcre:do-matches-as-strings (match *json-scanner* json-string (make-array (length tokens) :initial-contents (nreverse tokens))

94

:start start :end end)

95

(let* ((initial (char match 0))

96

(token (cond ((eql initial #\")

97

;; need to unescape

98

(let ((string (subseq match 1 (1- (length match)))))

99

(setf (fill-pointer buffer) 0)

100

(cond ((position #\\ string)

101

(loop with i = 0

102

until (>= i (length string))

103

for c = (char string i)

104

when (eql c #\\) do (incf i)

105

                                      do (vector-push-extend c buffer) (incf i))

106

(subseq buffer 0 (length buffer)))

107

(t

108

string))))

109

((find initial "+-0123456789")

110

(read-from-string match))

111

((find-symbol match :de.setf.json))

112

((find-symbol (string-downcase match) :spocq.a))

113

((find-symbol match :keyword))

114

((every #'cl-ppcre::whitespacep match)

115

nil)

116

((eq *tokenize-json.mode* :strict)

117

(warn "tokenize-json: invalid token: ~s" match)

118

nil)

119

(t

120

(intern match :keyword)))))

121

(when token (push token tokens))))))

122

;;; (tokenize-json "{\"a\" : 1}")

123

;;; (tokenize-json "{\"a\" : \"An `escaped` \\\"string\\\".\"}")

124

125

(defun dsj::|NUMBER-Constructor| (number)

126

(assert (numberp number) () "|NUMBER-Constructor|: invalid number: ~s." number)

127

number)

128

129

(defun dsj::|NAME-Constructor| (value)

130

(assert (dsj::is-name value)

131

()

132

"|NAME-Constructor|: invalid name: ~s." value)

133

value)

134

135

(defun dsj::|STRING-Constructor| (value)

136

(assert (stringp value)

137

()

138

"|STRING-Constructor|: invalid string: ~s." value)

139

value)

140

141

142

(defun dsj::|Array-Constructor| (ValueList?)

143

(make-array (length ValueList?) :initial-contents ValueList?))

144

145

(defun dsj::|Json-Constructor| (array object)

146

(or array object))

147

148

(defun dsj::|Literal-Constructor| (symbol)

149

(assert (member symbol '(dsj:|true| dsj:|false| dsj:|null|)) ()

150

"Value-Constructor: invalid literal name: ~s." symbol)

151

symbol)

152

153

(defun dsj::|Member-Constructor| (string value)

154

;; !!! leave the key as a string - do not presume the disposition

155

;; !!! to map it here to a keyword is a bad idea, as the generally nested

156

;; !!! structure means, this would apply also to things like the prefix

157

;; !!! keys in a parsed namespace prefix map, which would mean such things

158

;; !!! would have to be protected as encoded strings, which makes use at

159

;; !!! the endpoints more complicated

160

(cons string value))

161

162

(defun dsj::|Object-Constructor| (member*)

163

(reverse member*))

164

165

(defun dsj::|Value-Constructor| (array literal name number object string)

166

(or array literal name number object string))

167

168

(defun dsj::|ValueList-Constructor| (Value ValueList)

169

(cons Value ValueList))

170

171

172

(defparameter dsj::*max-input-index* 0)

173

174

(defun dsj::input-reference (index)

175

(when (< index (length atnp::*ATN-INPUT))

176

(setf dsj::*max-input-index* (max dsj::*max-input-index* index))

177

(aref atnp::*ATN-INPUT index)))

178

179

(defun dsj::input-eof? (index)

180

(>= index (length atnp::*ATN-INPUT)))

181

182

183

(defgeneric parse-json (source &key start end start-name accept)

184

(:method ((source stream) &rest args)

185

(declare (dynamic-extent args))

186

(apply #'parse-json (read-stream source) args))

187

188

(:method ((source pathname) &rest args)

189

(declare (dynamic-extent args))

190

(apply #'parse-json (read-file source) args))

191

192

(:method ((location spocq:iri) &rest args &key (accept "application/json") start end start-name)

193

(declare (ignore start end start-name))

194

(declare (dynamic-extent args))

195

(apply #'parse-json (with-http-request-stream (request-stream response-stream location :accept accept)

196

(declare (ignore request-stream))

197

(read-stream response-stream))

198

args))

199

200

(:method ((string string) &key (start 0) (end (length string)) (start-name 'dsj::|Json|) accept)

201

(declare (ignore accept))

202

(let ((tokens (remove nil (tokenize-json string :start start :end end)))

203

(dsj::*max-input-index* 0))

204

(when tokens

205

(multiple-value-bind (result index success)

206

                              (funcall 'dsj::|Json-Parser| tokens :start-name start-name)

207

(if success

208

(values result tokens index)

209

(flet ((_aref (array index)

210

                      (when (and (integerp index) (< -1 index (length array))) (aref array index))))

211

(spocq.e::message-syntax-error :expression string

212

                                              :token (loop for i from (- dsj::*max-input-index* 5)

213

                                                       below (+ dsj::*max-input-index* 5)

214

                                                       collect (_aref tokens i))

215

                                              :token-offset dsj::*max-input-index*)))))))

216

(:method ((source stream) &rest args)

217

(declare (dynamic-extent args))

218

(apply #'parse-json (read-stream source) args))

219

(:method ((location pathname) &rest args)

220

(declare (dynamic-extent args))

221

(apply #'parse-json (read-file location) args)))

222

223

224

(defgeneric format-json (stream json &optional colon at &rest args)

225

(:method ((stream t) (object list) &optional colon (at nil at-s) &rest args)

226

(declare (ignore args))

227

(let ((*encode-json-term.type-members* (if at-s (not (null at)) *encode-json-term.type-members*)))

228

(if (or *print-pretty* colon) ;; does not appear necessary to rebind *print-pretty*

229

(pprint-logical-block (stream object)

230

(format-json-object stream object))

231

(format-json-object stream object))))

232

(:method ((stream t) (object sequence) &optional colon (at nil at-s) &rest args)

233

(declare (ignore args))

234

(let ((*encode-json-term.type-members* (if at-s (not (null at)) *encode-json-term.type-members*)))

235

(if (or *print-pretty* colon) ;; does not appear necessary to rebind *print-pretty*

236

(pprint-logical-block (stream (list object))

237

(format-json-array stream object))

238

(format-json-array stream object))))

239

(:method ((stream t) (object string) &optional colon at &rest args)

240

(declare (ignore colon at args))

241

(encode-json-term object stream))

242

(:method ((stream t) (object symbol) &optional colon at &rest args)

243

(declare (ignore colon at args))

244

(if (iri-p object)

245

(encode-json-term object stream)

246

(case object

247

((spocq.a:|true| spocq.a:|false|)

248

(encode-json-term object stream))

249

(t

250

(encode-json-term (string object) stream)))))

251

(:method ((stream t) (object property-path) &optional colon (at nil at-s) &rest args)

252

(declare (ignore colon args))

253

;; this is present for query introspection

254

(let ((*encode-json-term.type-members* (if at-s (not (null at)) *encode-json-term.type-members*)))

255

(if *encode-json-term.type-members*

256

(format stream "{\"type\":\"uri-path\", \"value\":\"~s\"}" object)

257

(format stream "\"~s\"" object))))

258

(:method ((stream t) (object t) &optional colon (at nil at-s) &rest args)

259

(declare (ignore colon args))

260

(let ((*encode-json-term.type-members* (if at-s (not (null at)) *encode-json-term.type-members*)))

261

(if *encode-json-term.type-members*

262

(encode-json-term object stream)

263

(encode-json-term-compact object stream)))))

264

265

(defun format-json-object (stream object)

266

(format stream "{~:I~{~@[~/format-json-member/~^, ~_~]~}}"

267

           (remove-if #'(lambda (value) (or (null value) (spocq:unbound-variable-p value))) object :key #'rest)))

268

269

(defun format-json-member (stream member &optional colon at)

270

(declare (ignore colon at))

271

(destructuring-bind (name . value) member

272

(format stream "\"~a\": ~/format-json/" name value)))

273

274

(defun format-json-array (stream object &optional colon at)

275

(declare (ignore colon at))

276

(format stream "[~:I~{~@[~/format-json/~^, ~_~]~}]"

277

(loop for value across object collect value)))

278

279

280

(defgeneric format-json-compact (stream json &optional colon at &rest args)

281

(:method ((stream t) (object list) &optional colon at &rest args)

282

(declare (ignore args))

283

(let ((*encode-json-term.type-members* (not (null at))))

284

(if (or *print-pretty* colon) ;; does not appear necessary to rebind *print-pretty*

285

(pprint-logical-block (stream object)

286

(format-json-object-compact stream object))

287

(format-json-object-compact stream object))))

288

(:method ((stream t) (object sequence) &optional colon at &rest args)

289

(declare (ignore args))

290

(let ((*encode-json-term.type-members* (not (null at))))

291

(if (or *print-pretty* colon) ;; does not appear necessary to rebind *print-pretty*

292

(pprint-logical-block (stream (list object))

293

(format-json-array-compact stream object))

294

(format-json-array-compact stream object))))

295

(:method ((stream t) (object string) &optional colon at &rest args)

296

(declare (ignore colon at args))

297

(encode-json-term object stream))

298

(:method ((stream t) (object symbol) &optional colon at &rest args)

299

(declare (ignore colon at args))

300

(if (iri-p object)

301

(encode-json-term-compact object stream)

302

(case object

303

((spocq.a:|true| spocq.a:|false|)

304

(encode-json-term-compact object stream))

305

(t

306

(encode-json-term-compact (string object) stream)))))

307

(:method ((stream t) (object property-path) &optional colon at &rest args)

308

(declare (ignore colon at args))

309

;; this is present for query introspection

310

(format stream "\"~s\"" object))

311

312

(:method ((stream t) (object t) &optional colon at &rest args)

313

(declare (ignore colon at args))

314

(encode-json-term-compact object stream)))

315

316

(defun format-json-member-compact (stream member &optional colon at)

317

(declare (ignore colon at))

318

(destructuring-bind (name . value) member

319

(format stream "\"~a\": ~/format-json-compact/" name value)))

320

321

(defun format-json-object-compact (stream object)

322

(format stream "{~:I~{~@[~/format-json-member-compact/~^, ~_~]~}}"

323

           (remove-if #'(lambda (value) (or (null value) (spocq:unbound-variable-p value))) object :key #'rest)))

324

325

(defun format-json-array-compact (stream object &optional colon at)

326

(declare (ignore colon at))

327

(format stream "[~:I~{~@[~/format-json-compact/~^, ~_~]~}]"

328

(loop for value across object collect value)))

329

330

331

332

;;; json object operators

333

334

(defun json-member-value (object name &key (test #'string=))

335

(rest (assoc name object :test test)))

336

337

(defun json-type (object)

338

(json-member-value object :@type :test #'string-equal))

339

340

(defun json-id (object)

341

(json-member-value object :@id :test #'string-equal))

342

343

(defmacro json-bind (parameters source &body body)

344

(let* ((whole (when (eq (first parameters) '&whole) (second parameters)))

345

(object (or whole (gensym "json"))))

346

(when (eq (first parameters) '&whole) (setf parameters (cddr parameters)))

347

`((lambda (,object)

348

(let ,(loop for parameter in parameters

349

for variable = (if (consp parameter) (first parameter) parameter)

350

for key = (symbol-name (if (consp parameter) (second parameter) parameter))

351

collect `(,variable (json-member-value ,object ,key)))

352

,@body))

353

,source)))

354

355

(defun cl-user::format-json-table (stream object &optional colon at)

356

(declare (ignore colon at))

357

(format stream "~1:I<table>~:[~;~_~]" object)

358

(loop for (name . value) in object

359

when value

360

do (format stream "<tr><td>~a</td><td>~a</td></tr>~_" name value))

361

(write-string "</table>" stream))

362

363

364

;;; (subseq (tokenize-json (read-file #p"patches/test.jsonld")) 1680)

365

;;; (parse-json "{\"@context\": { \"type\": \"@type\", \"id\": \"@id\"} }")

366

;;; (parse-json "{\"a\" : \"An `escaped` \\\"string\\\".\"}")

367

;;; (tokenize-json "{\"@context\": { \"type\": \"@type\", \"id\": \"@id\"} }")

368

 ;;; (tokenize-json "\"A boolean atomic property that, if `true`, sets the escape character flag to `\\\"`.")

369

#|

370

(load #p"/development/source/library/org/datagraph/spocq-dev/src/core/encoding/json.lisp")

371

(bnfp:compile-atn-system *json-bnf*

372

:execute t :compile nil

373

:token-package (find-package :de.setf.json)

374

:source-package (find-package :de.setf.json)

375

                           :source-pathname #p"/development/source/library/org/datagraph/spocq-dev/src/core/encoding/json-grammar.lisp"

376

;;;:source-pathname #p"/tmp/json-grammar.lisp"

377

:input-function 'dsj::input-reference

378

:input-eof-function 'dsj::input-eof?

379

                           :ambiguous t        ; the property paths make it ambiguous

380

:trace nil)

381

;;; (load (compile-file "/tmp/json-grammar.lisp" :output-file "json-grammar.fasl"))

382

 ;;; (load (compile-file "LIBRARY:org;datagraph;spocq;src;core;encoding;json-grammar.lisp" :output-file "json-grammar.fasl"))

383

384

385

(parse-json "{\"a\": 1}")

386

(parse-json (format nil "{\"a\": \"~a\"}" "a\\\"thing\\\"."))

387

(parse-json "{a: 1}")

388

(parse-json "{a: \"1\"}")

389

(parse-json "{a: [\"1\", 2]}")

390

(parse-sparql+json "[1, 2, 3, 4]")

391

(parse-json "{

392

Image: {

393

\"Width\": 800,

394

\"Height\": 600,

395

\"Title\": \"View from 15th Floor\",

396

\"Thumbnail\": {

397

\"Url\": \"http://www.example.com/image/481989943\",

398

\"Height\": 125,

399

\"Width\": \"100\"

400

},

401

\"IDs\": [116, 943, 234, 38793] } }")

402

(parse-json "[{}]")

403

(parse-json "{}")

404

(parse-json "[]")

405

(parse-json "[{}, {}]")

406

(parse-json "[1, [2, 3]]")

407

(parse-json "[select, s, p, o]")

408

(parse-json "[\"select\", \"s\", \"p\", \"o\"]")

409

(format-json *trace-output* '((a . 1) (b . 2) (c . #(1 2 ((d . 5))))))

410

|#