Initial commit.
[software/guile-aws.git] / aws / utils / json.scm
1 ;;;; json.scm --- JSON reader/writer
2 ;;;; Copyright © 2015, 2017 David Thompson <davet@gnu.org>
3 ;;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;;;
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
9 ;;;;
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
18 ;;;; 02110-1301 USA
19
20 (define-module (aws utils json)
21 #:use-module (ice-9 match)
22 #:export (read-json write-json))
23
24 (define (json-error port)
25 (throw 'json-error port))
26
27 (define (assert-char port char)
28 "Read a character from PORT and throw an invalid JSON error if the
29 character is not CHAR."
30 (unless (eqv? (read-char port) char)
31 (json-error port)))
32
33 (define (whitespace? char)
34 "Return #t if CHAR is a whitespace character."
35 (char-set-contains? char-set:whitespace char))
36
37 (define (consume-whitespace port)
38 "Discard characters from PORT until a non-whitespace character is
39 encountered.."
40 (match (peek-char port)
41 ((? eof-object?) *unspecified*)
42 ((? whitespace?)
43 (read-char port)
44 (consume-whitespace port))
45 (_ *unspecified*)))
46
47 (define (make-keyword-reader keyword value)
48 "Parse the keyword symbol KEYWORD as VALUE."
49 (let ((str (symbol->string keyword)))
50 (lambda (port)
51 (let loop ((i 0))
52 (cond
53 ((= i (string-length str)) value)
54 ((eqv? (string-ref str i) (read-char port))
55 (loop (1+ i)))
56 (else (json-error port)))))))
57
58 (define read-true (make-keyword-reader 'true #t))
59 (define read-false (make-keyword-reader 'false #f))
60 (define read-null (make-keyword-reader 'null 'null))
61
62 (define (read-hex-digit port)
63 "Read a hexadecimal digit from PORT."
64 (match (read-char port)
65 (#\0 0)
66 (#\1 1)
67 (#\2 2)
68 (#\3 3)
69 (#\4 4)
70 (#\5 5)
71 (#\6 6)
72 (#\7 7)
73 (#\8 8)
74 (#\9 9)
75 ((or #\A #\a) 10)
76 ((or #\B #\b) 11)
77 ((or #\C #\c) 12)
78 ((or #\D #\d) 13)
79 ((or #\E #\e) 14)
80 ((or #\F #\f) 15)
81 (_ (json-error port))))
82
83 (define (read-utf16-character port)
84 "Read a hexadecimal encoded UTF-16 character from PORT."
85 (integer->char
86 (+ (* (read-hex-digit port) (expt 16 3))
87 (* (read-hex-digit port) (expt 16 2))
88 (* (read-hex-digit port) 16)
89 (read-hex-digit port))))
90
91 (define (read-escape-character port)
92 "Read escape character from PORT."
93 (match (read-char port)
94 (#\" #\")
95 (#\\ #\\)
96 (#\/ #\/)
97 (#\b #\backspace)
98 (#\f #\page)
99 (#\n #\newline)
100 (#\r #\return)
101 (#\t #\tab)
102 (#\u (read-utf16-character port))
103 (_ (json-error port))))
104
105 (define (read-string port)
106 "Read a JSON encoded string from PORT."
107 (assert-char port #\")
108 (let loop ((result '()))
109 (match (read-char port)
110 ((? eof-object?) (json-error port))
111 (#\" (list->string (reverse result)))
112 (#\\ (loop (cons (read-escape-character port) result)))
113 (char (loop (cons char result))))))
114
115 (define char-set:json-digit
116 (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
117
118 (define (digit? char)
119 (char-set-contains? char-set:json-digit char))
120
121 (define (read-digit port)
122 "Read a digit 0-9 from PORT."
123 (match (read-char port)
124 (#\0 0)
125 (#\1 1)
126 (#\2 2)
127 (#\3 3)
128 (#\4 4)
129 (#\5 5)
130 (#\6 6)
131 (#\7 7)
132 (#\8 8)
133 (#\9 9)
134 (else (json-error port))))
135
136 (define (read-digits port)
137 "Read a sequence of digits from PORT."
138 (let loop ((result '()))
139 (match (peek-char port)
140 ((? eof-object?)
141 (reverse result))
142 ((? digit?)
143 (loop (cons (read-digit port) result)))
144 (else (reverse result)))))
145
146 (define (list->integer digits)
147 "Convert the list DIGITS to an integer."
148 (let loop ((i (1- (length digits)))
149 (result 0)
150 (digits digits))
151 (match digits
152 (() result)
153 ((n . tail)
154 (loop (1- i)
155 (+ result (* n (expt 10 i)))
156 tail)))))
157
158 (define (read-positive-integer port)
159 "Read a positive integer with no leading zeroes from PORT."
160 (match (read-digits port)
161 ((0 . _)
162 (json-error port)) ; no leading zeroes allowed
163 ((digits ...)
164 (list->integer digits))))
165
166 (define (read-exponent port)
167 "Read exponent from PORT."
168 (define (read-expt)
169 (list->integer (read-digits port)))
170
171 (unless (memv (read-char port) '(#\e #\E))
172 (json-error port))
173
174 (match (peek-char port)
175 ((? eof-object?)
176 (json-error port))
177 (#\-
178 (read-char port)
179 (- (read-expt)))
180 (#\+
181 (read-char port)
182 (read-expt))
183 ((? digit?)
184 (read-expt))
185 (_ (json-error port))))
186
187 (define (read-fraction port)
188 "Read fractional number part from PORT as an inexact number."
189 (let* ((digits (read-digits port))
190 (numerator (list->integer digits))
191 (denomenator (expt 10 (length digits))))
192 (/ numerator denomenator)))
193
194 (define (read-positive-number port)
195 "Read a positive number from PORT."
196 (let* ((integer (match (peek-char port)
197 ((? eof-object?)
198 (json-error port))
199 (#\0
200 (read-char port)
201 0)
202 ((? digit?)
203 (read-positive-integer port))
204 (_ (json-error port))))
205 (fraction (match (peek-char port)
206 (#\.
207 (read-char port)
208 (read-fraction port))
209 (_ 0)))
210 (exponent (match (peek-char port)
211 ((or #\e #\E)
212 (read-exponent port))
213 (_ 0)))
214 (n (* (+ integer fraction) (expt 10 exponent))))
215
216 ;; Keep integers as exact numbers, but convert numbers encoded as
217 ;; floating point numbers to an inexact representation.
218 (if (zero? fraction)
219 n
220 (exact->inexact n))))
221
222 (define (read-number port)
223 "Read a number from PORT"
224 (match (peek-char port)
225 ((? eof-object?)
226 (json-error port))
227 (#\-
228 (read-char port)
229 (- (read-positive-number port)))
230 ((? digit?)
231 (read-positive-number port))
232 (_ (json-error port))))
233
234 (define (read-object port)
235 "Read key/value map from PORT."
236 (define (read-key+value-pair)
237 (let ((key (read-string port)))
238 (consume-whitespace port)
239 (assert-char port #\:)
240 (consume-whitespace port)
241 (let ((value (read-value port)))
242 (cons key value))))
243
244 (assert-char port #\{)
245 (consume-whitespace port)
246
247 (if (eqv? #\} (peek-char port))
248 (begin
249 (read-char port)
250 '()) ; empty object
251 (cons (read-key+value-pair)
252 (let loop ()
253 (consume-whitespace port)
254 (match (peek-char port)
255 (#\, ; read another value
256 (read-char port)
257 (consume-whitespace port)
258 (cons (read-key+value-pair) (loop)))
259 (#\} ; end of object
260 (read-char port)
261 '())
262 (_ (json-error port)))))))
263
264 (define (read-array port)
265 "Read array from PORT."
266 (assert-char port #\[)
267 (consume-whitespace port)
268
269 (list->vector
270 (if (eqv? #\] (peek-char port))
271 (begin
272 (read-char port)
273 '() ); empty array
274 (cons (read-value port)
275 (let loop ()
276 (consume-whitespace port)
277 (match (peek-char port)
278 (#\, ; read another value
279 (read-char port)
280 (consume-whitespace port)
281 (cons (read-value port) (loop)))
282 (#\] ; end of array
283 (read-char port)
284 '())
285 (_ (json-error port))))))))
286
287 (define (read-value port)
288 "Read a JSON value from PORT."
289 (consume-whitespace port)
290 (match (peek-char port)
291 ((? eof-object?) (json-error port))
292 (#\" (read-string port))
293 (#\{ (read-object port))
294 (#\[ (read-array port))
295 (#\t (read-true port))
296 (#\f (read-false port))
297 (#\n (read-null port))
298 ((or #\- (? digit?))
299 (read-number port))
300 (_ (json-error port))))
301
302 (define (read-json port)
303 "Read JSON text from port and return an s-expression representation."
304 (let ((result (read-value port)))
305 (consume-whitespace port)
306 (unless (eof-object? (peek-char port))
307 result
308 (json-error port))
309 result))
310
311 \f
312 ;;;
313 ;;; Writer
314 ;;;
315
316 (define (write-string str port)
317 "Write STR to PORT in JSON string format."
318 (define (escape-char char)
319 (display (match char
320 (#\" "\\\"")
321 (#\\ "\\\\")
322 (#\/ "\\/")
323 (#\backspace "\\b")
324 (#\page "\\f")
325 (#\newline "\\n")
326 (#\return "\\r")
327 (#\tab "\\t")
328 (_ char))
329 port))
330
331 (display "\"" port)
332 (string-for-each escape-char str)
333 (display "\"" port))
334
335 (define (write-object object port)
336 "Write ALIST to PORT in JSON object format."
337 ;; Keys may be strings or symbols.
338 (define key->string
339 (match-lambda
340 ((? string? key) key)
341 ((? symbol? key) (symbol->string key))))
342
343 (define (write-kv-pair key value)
344 (write-string (key->string key) port)
345 (display ":" port)
346 (write-json value port))
347
348 (display "{" port)
349 (match object
350 (() #f)
351 ((front ... (end-key . end-val))
352 (for-each (match-lambda
353 ((key . value)
354 (write-kv-pair key value)
355 (display "," port)))
356 front)
357 (write-kv-pair end-key end-val)))
358 (display "}" port))
359
360 (define (write-array lst port)
361 "Write LST to PORT in JSON array format."
362 (display "[" port)
363 (match lst
364 (() #f)
365 ((front ... end)
366 (for-each (lambda (val)
367 (write-json val port)
368 (display "," port))
369 front)
370 (write-json end port)))
371 (display "]" port))
372
373 (define (write-json exp port)
374 "Write EXP to PORT in JSON format."
375 (match exp
376 (#t (display "true" port))
377 (#f (display "false" port))
378 ('null (display "null" port))
379 ((? string? s) (write-string s port))
380 ((? real? n) (display n port))
381 (('@ . alist) (write-object alist port))
382 ((vals ...) (write-array vals port))))