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))))