summaryrefslogtreecommitdiff
path: root/aws/utils/json.scm
blob: 2117a2c10015678d0aaa65b6b8bdf85c186b4950 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
;;;; json.scm --- JSON reader/writer
;;;; Copyright © 2015, 2017 David Thompson <davet@gnu.org>
;;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;;; 02110-1301 USA

(define-module (aws utils json)
  #:use-module (ice-9 match)
  #:export (read-json write-json))

(define (json-error port)
  (throw 'json-error port))

(define (assert-char port char)
  "Read a character from PORT and throw an invalid JSON error if the
character is not CHAR."
  (unless (eqv? (read-char port) char)
    (json-error port)))

(define (whitespace? char)
  "Return #t if CHAR is a whitespace character."
  (char-set-contains? char-set:whitespace char))

(define (consume-whitespace port)
  "Discard characters from PORT until a non-whitespace character is
encountered.."
  (match (peek-char port)
    ((? eof-object?) *unspecified*)
    ((? whitespace?)
     (read-char port)
     (consume-whitespace port))
    (_ *unspecified*)))

(define (make-keyword-reader keyword value)
  "Parse the keyword symbol KEYWORD as VALUE."
  (let ((str (symbol->string keyword)))
    (lambda (port)
      (let loop ((i 0))
        (cond
         ((= i (string-length str)) value)
         ((eqv? (string-ref str i) (read-char port))
          (loop (1+ i)))
         (else (json-error port)))))))

(define read-true (make-keyword-reader 'true #t))
(define read-false (make-keyword-reader 'false #f))
(define read-null (make-keyword-reader 'null 'null))

(define (read-hex-digit port)
  "Read a hexadecimal digit from PORT."
  (match (read-char port)
    (#\0 0)
    (#\1 1)
    (#\2 2)
    (#\3 3)
    (#\4 4)
    (#\5 5)
    (#\6 6)
    (#\7 7)
    (#\8 8)
    (#\9 9)
    ((or #\A #\a) 10)
    ((or #\B #\b) 11)
    ((or #\C #\c) 12)
    ((or #\D #\d) 13)
    ((or #\E #\e) 14)
    ((or #\F #\f) 15)
    (_ (json-error port))))

(define (read-utf16-character port)
  "Read a hexadecimal encoded UTF-16 character from PORT."
  (integer->char
   (+ (* (read-hex-digit port) (expt 16 3))
      (* (read-hex-digit port) (expt 16 2))
      (* (read-hex-digit port) 16)
      (read-hex-digit port))))

(define (read-escape-character port)
  "Read escape character from PORT."
  (match (read-char port)
    (#\" #\")
    (#\\ #\\)
    (#\/ #\/)
    (#\b #\backspace)
    (#\f #\page)
    (#\n #\newline)
    (#\r #\return)
    (#\t #\tab)
    (#\u (read-utf16-character port))
    (_ (json-error port))))

(define (read-string port)
  "Read a JSON encoded string from PORT."
  (assert-char port #\")
  (let loop ((result '()))
    (match (read-char port)
      ((? eof-object?) (json-error port))
      (#\" (list->string (reverse result)))
      (#\\ (loop (cons (read-escape-character port) result)))
      (char (loop (cons char result))))))

(define char-set:json-digit
  (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))

(define (digit? char)
  (char-set-contains? char-set:json-digit char))

(define (read-digit port)
  "Read a digit 0-9 from PORT."
  (match (read-char port)
    (#\0 0)
    (#\1 1)
    (#\2 2)
    (#\3 3)
    (#\4 4)
    (#\5 5)
    (#\6 6)
    (#\7 7)
    (#\8 8)
    (#\9 9)
    (else (json-error port))))

(define (read-digits port)
  "Read a sequence of digits from PORT."
  (let loop ((result '()))
    (match (peek-char port)
      ((? eof-object?)
       (reverse result))
      ((? digit?)
       (loop (cons (read-digit port) result)))
      (else (reverse result)))))

(define (list->integer digits)
  "Convert the list DIGITS to an integer."
  (let loop ((i (1- (length digits)))
             (result 0)
             (digits digits))
    (match digits
      (() result)
      ((n . tail)
       (loop (1- i)
             (+ result (* n (expt 10 i)))
             tail)))))

(define (read-positive-integer port)
  "Read a positive integer with no leading zeroes from PORT."
  (match (read-digits port)
    ((0 . _)
     (json-error port)) ; no leading zeroes allowed
    ((digits ...)
     (list->integer digits))))

(define (read-exponent port)
  "Read exponent from PORT."
  (define (read-expt)
    (list->integer (read-digits port)))

  (unless (memv (read-char port) '(#\e #\E))
    (json-error port))

  (match (peek-char port)
    ((? eof-object?)
     (json-error port))
    (#\-
     (read-char port)
     (- (read-expt)))
    (#\+
     (read-char port)
     (read-expt))
    ((? digit?)
     (read-expt))
    (_ (json-error port))))

(define (read-fraction port)
  "Read fractional number part from PORT as an inexact number."
  (let* ((digits      (read-digits port))
         (numerator   (list->integer digits))
         (denomenator (expt 10 (length digits))))
    (/ numerator denomenator)))

(define (read-positive-number port)
  "Read a positive number from PORT."
  (let* ((integer (match (peek-char port)
                    ((? eof-object?)
                     (json-error port))
                    (#\0
                     (read-char port)
                     0)
                    ((? digit?)
                     (read-positive-integer port))
                    (_ (json-error port))))
         (fraction (match (peek-char port)
                     (#\.
                      (read-char port)
                      (read-fraction port))
                     (_ 0)))
         (exponent (match (peek-char port)
                     ((or #\e #\E)
                      (read-exponent port))
                     (_ 0)))
         (n (* (+ integer fraction) (expt 10 exponent))))

    ;; Keep integers as exact numbers, but convert numbers encoded as
    ;; floating point numbers to an inexact representation.
    (if (zero? fraction)
        n
        (exact->inexact n))))

(define (read-number port)
  "Read a number from PORT"
  (match (peek-char port)
    ((? eof-object?)
     (json-error port))
    (#\-
     (read-char port)
     (- (read-positive-number port)))
    ((? digit?)
     (read-positive-number port))
    (_ (json-error port))))

(define (read-object port)
  "Read key/value map from PORT."
  (define (read-key+value-pair)
    (let ((key (read-string port)))
      (consume-whitespace port)
      (assert-char port #\:)
      (consume-whitespace port)
      (let ((value (read-value port)))
        (cons key value))))

  (assert-char port #\{)
  (consume-whitespace port)

  (if (eqv? #\} (peek-char port))
      (begin
        (read-char port)
        '()) ; empty object
      (cons (read-key+value-pair)
            (let loop ()
              (consume-whitespace port)
              (match (peek-char port)
                (#\, ; read another value
                 (read-char port)
                 (consume-whitespace port)
                 (cons (read-key+value-pair) (loop)))
                (#\} ; end of object
                 (read-char port)
                 '())
                (_ (json-error port)))))))

(define (read-array port)
  "Read array from PORT."
  (assert-char port #\[)
  (consume-whitespace port)

  (list->vector
   (if (eqv? #\] (peek-char port))
       (begin
         (read-char port)
         '() ); empty array
       (cons (read-value port)
             (let loop ()
               (consume-whitespace port)
               (match (peek-char port)
                 (#\, ; read another value
                  (read-char port)
                  (consume-whitespace port)
                  (cons (read-value port) (loop)))
                 (#\] ; end of array
                  (read-char port)
                  '())
                 (_ (json-error port))))))))

(define (read-value port)
  "Read a JSON value from PORT."
  (consume-whitespace port)
  (match (peek-char port)
    ((? eof-object?) (json-error port))
    (#\" (read-string port))
    (#\{ (read-object port))
    (#\[ (read-array port))
    (#\t (read-true port))
    (#\f (read-false port))
    (#\n (read-null port))
    ((or #\- (? digit?))
     (read-number port))
    (_ (json-error port))))

(define (read-json port)
  "Read JSON text from port and return an s-expression representation."
  (let ((result (read-value port)))
    (consume-whitespace port)
    (unless (eof-object? (peek-char port))
      result
      (json-error port))
    result))


;;;
;;; Writer
;;;

(define (write-string str port)
  "Write STR to PORT in JSON string format."
  (define (escape-char char)
    (display (match char
               (#\" "\\\"")
               (#\\ "\\\\")
               (#\/ "\\/")
               (#\backspace "\\b")
               (#\page "\\f")
               (#\newline "\\n")
               (#\return "\\r")
               (#\tab "\\t")
               (_ char))
             port))

  (display "\"" port)
  (string-for-each escape-char str)
  (display "\"" port))

(define (write-object object port)
  "Write ALIST to PORT in JSON object format."
  ;; Keys may be strings or symbols.
  (define key->string
    (match-lambda
     ((? string? key) key)
     ((? symbol? key) (symbol->string key))))

  (define (write-kv-pair key value)
    (write-string (key->string key) port)
    (display ":" port)
    (write-json value port))

  (display "{" port)
  (match object
    (() #f)
    ((front ... (end-key . end-val))
     (for-each (match-lambda
                 ((key . value)
                  (write-kv-pair key value)
                  (display "," port)))
               front)
     (write-kv-pair end-key end-val)))
  (display "}" port))

(define (write-array lst port)
  "Write LST to PORT in JSON array format."
  (display "[" port)
  (match lst
    (() #f)
    ((front ... end)
     (for-each (lambda (val)
                 (write-json val port)
                 (display "," port))
               front)
     (write-json end port)))
  (display "]" port))

(define (write-json exp port)
  "Write EXP to PORT in JSON format."
  (match exp
    (#t (display "true" port))
    (#f (display "false" port))
    ('null (display "null" port))
    ((? string? s) (write-string s port))
    ((? real? n) (display n port))
    (('@ . alist) (write-object alist port))
    ((vals ...) (write-array vals port))))