divorce
b735900f2e
ddat interop with dat js cable interop with cabal js ddat's frontend = dat-thang cable fe = cable-thang dillo support based on cel's dillo-dat bootstrap node xplatform support Signed-off-by: divo <418@cryspace.space>
245 lines
11 KiB
Scheme
245 lines
11 KiB
Scheme
;;; Strict JSON reader shared by the S7-backed Dat application layer.
|
|
;;; Objects become (json:object ("key" . value) ...), arrays become
|
|
;;; (json:array value ...), and JSON null is the symbol json:null.
|
|
|
|
(define (json:codepoint->utf8 code)
|
|
(if (<= code #x7f)
|
|
(list (integer->char code))
|
|
(if (<= code #x7ff)
|
|
(list
|
|
(integer->char (+ #xc0 (quotient code 64)))
|
|
(integer->char (+ #x80 (modulo code 64))))
|
|
(if (<= code #xffff)
|
|
(list
|
|
(integer->char (+ #xe0 (quotient code 4096)))
|
|
(integer->char (+ #x80 (modulo (quotient code 64) 64)))
|
|
(integer->char (+ #x80 (modulo code 64))))
|
|
(list
|
|
(integer->char (+ #xf0 (quotient code 262144)))
|
|
(integer->char (+ #x80 (modulo (quotient code 4096) 64)))
|
|
(integer->char (+ #x80 (modulo (quotient code 64) 64)))
|
|
(integer->char (+ #x80 (modulo code 64))))))))
|
|
|
|
(define (dat:json-parse source)
|
|
(if (not (string? source))
|
|
(error 'wrong-type-arg "dat:json-parse expects a string" source))
|
|
(let ((port (open-input-string source)))
|
|
(define (fail message)
|
|
(error 'json-parse-error message))
|
|
(define (peek) (peek-char port))
|
|
(define (take) (read-char port))
|
|
(define (ws?)
|
|
(let ((c (peek)))
|
|
(and (char? c)
|
|
(or (char=? c #\space) (char=? c #\tab)
|
|
(char=? c #\newline) (char=? c #\return)))))
|
|
(define (skip-ws)
|
|
(do () ((not (ws?))) (take)))
|
|
(define (expect character)
|
|
(if (or (not (char? (peek))) (not (char=? (take) character)))
|
|
(fail (string-append "expected " (string character)))))
|
|
(define (hex-value c)
|
|
(cond ((and (char>=? c #\0) (char<=? c #\9))
|
|
(- (char->integer c) (char->integer #\0)))
|
|
((and (char>=? c #\a) (char<=? c #\f))
|
|
(+ 10 (- (char->integer c) (char->integer #\a))))
|
|
((and (char>=? c #\A) (char<=? c #\F))
|
|
(+ 10 (- (char->integer c) (char->integer #\A))))
|
|
(else (fail "invalid hexadecimal escape"))))
|
|
(define (hex4)
|
|
(let loop ((left 4) (value 0))
|
|
(if (= left 0) value
|
|
(let ((c (take)))
|
|
(if (not (char? c)) (fail "incomplete unicode escape"))
|
|
(loop (- left 1) (+ (* value 16) (hex-value c)))))))
|
|
(define (parse-string)
|
|
(expect #\")
|
|
(let loop ((reversed '()))
|
|
(let ((c (take)))
|
|
(cond ((not (char? c)) (fail "unterminated string"))
|
|
((char=? c #\") (list->string (reverse reversed)))
|
|
((char=? c #\\)
|
|
(let ((escape (take)))
|
|
(cond ((not (char? escape)) (fail "incomplete escape"))
|
|
((char=? escape #\") (loop (cons #\" reversed)))
|
|
((char=? escape #\\) (loop (cons #\\ reversed)))
|
|
((char=? escape #\/) (loop (cons #\/ reversed)))
|
|
((char=? escape #\b) (loop (cons (integer->char 8) reversed)))
|
|
((char=? escape #\f) (loop (cons (integer->char 12) reversed)))
|
|
((char=? escape #\n) (loop (cons #\newline reversed)))
|
|
((char=? escape #\r) (loop (cons #\return reversed)))
|
|
((char=? escape #\t) (loop (cons #\tab reversed)))
|
|
((char=? escape #\u)
|
|
(let* ((first (hex4))
|
|
(code
|
|
(cond ((and (>= first #xd800) (<= first #xdbff))
|
|
(expect #\\) (expect #\u)
|
|
(let ((second (hex4)))
|
|
(if (or (< second #xdc00) (> second #xdfff))
|
|
(fail "invalid unicode surrogate pair"))
|
|
(+ #x10000 (* (- first #xd800) #x400)
|
|
(- second #xdc00))))
|
|
((and (>= first #xdc00) (<= first #xdfff))
|
|
(fail "unpaired unicode low surrogate"))
|
|
(else first))))
|
|
(if (< code 32) (fail "invalid control character escape"))
|
|
(loop (append (reverse (json:codepoint->utf8 code))
|
|
reversed))))
|
|
(else (fail "invalid string escape")))))
|
|
((< (char->integer c) 32) (fail "unescaped control character"))
|
|
(else (loop (cons c reversed)))))))
|
|
(define (digit? c)
|
|
(and (char? c) (char>=? c #\0) (char<=? c #\9)))
|
|
(define (parse-number)
|
|
(let loop ((chars '()))
|
|
(let ((c (peek)))
|
|
(if (and (char? c)
|
|
(or (digit? c) (memv c '(#\- #\+ #\. #\e #\E))))
|
|
(begin (take) (loop (cons c chars)))
|
|
(let* ((text (list->string (reverse chars)))
|
|
(number (string->number text)))
|
|
(if (or (string=? text "") (not number)
|
|
(not (json:number-token? text)))
|
|
(fail "invalid JSON number"))
|
|
number)))))
|
|
(define (parse-array)
|
|
(expect #\[)
|
|
(skip-ws)
|
|
(if (and (char? (peek)) (char=? (peek) #\]))
|
|
(begin (take) '(json:array))
|
|
(let loop ((values '()))
|
|
(let ((value (parse-value)))
|
|
(skip-ws)
|
|
(cond ((and (char? (peek)) (char=? (peek) #\]))
|
|
(take) (cons 'json:array (reverse (cons value values))))
|
|
((and (char? (peek)) (char=? (peek) #\,))
|
|
(take) (skip-ws) (loop (cons value values)))
|
|
(else (fail "expected comma or closing bracket")))))))
|
|
(define (parse-object)
|
|
(expect #\{)
|
|
(skip-ws)
|
|
(if (and (char? (peek)) (char=? (peek) #\}))
|
|
(begin (take) '(json:object))
|
|
(let loop ((fields '()))
|
|
(if (or (not (char? (peek))) (not (char=? (peek) #\")))
|
|
(fail "object key must be a string"))
|
|
(let ((key (parse-string)))
|
|
(skip-ws) (expect #\:) (skip-ws)
|
|
(let ((field (cons key (parse-value))))
|
|
(skip-ws)
|
|
(cond ((and (char? (peek)) (char=? (peek) #\}))
|
|
(take) (cons 'json:object (reverse (cons field fields))))
|
|
((and (char? (peek)) (char=? (peek) #\,))
|
|
(take) (skip-ws) (loop (cons field fields)))
|
|
(else (fail "expected comma or closing brace"))))))))
|
|
(define (literal token value)
|
|
(for-each (lambda (expected)
|
|
(if (or (not (char? (peek)))
|
|
(not (char=? (take) expected)))
|
|
(fail "invalid JSON literal")))
|
|
(string->list token))
|
|
value)
|
|
(define (parse-value)
|
|
(skip-ws)
|
|
(let ((c (peek)))
|
|
(cond ((not (char? c)) (fail "expected a JSON value"))
|
|
((char=? c #\") (parse-string))
|
|
((char=? c #\{) (parse-object))
|
|
((char=? c #\[) (parse-array))
|
|
((char=? c #\t) (literal "true" #t))
|
|
((char=? c #\f) (literal "false" #f))
|
|
((char=? c #\n) (literal "null" 'json:null))
|
|
((or (digit? c) (char=? c #\-)) (parse-number))
|
|
(else (fail "unexpected character in JSON")))))
|
|
(let ((value (parse-value)))
|
|
(skip-ws)
|
|
(if (not (eof-object? (peek))) (fail "trailing data after JSON value"))
|
|
value)))
|
|
|
|
;;; Validate the RFC 8259 number grammar before string->number, which accepts
|
|
;;; Scheme-specific forms that are not valid JSON.
|
|
(define (json:number-token? text)
|
|
(let* ((n (string-length text)) (i 0))
|
|
(define (at c) (and (< i n) (char=? (string-ref text i) c)))
|
|
(define (digits)
|
|
(let ((start i))
|
|
(do () ((or (>= i n)
|
|
(not (char<=? #\0 (string-ref text i) #\9))))
|
|
(set! i (+ i 1)))
|
|
(> i start)))
|
|
(if (at #\-) (set! i (+ i 1)))
|
|
(let ((integer-ok
|
|
(cond ((at #\0) (set! i (+ i 1)) (not (and (< i n) (char<=? #\0 (string-ref text i) #\9))))
|
|
(else (and (< i n) (char<=? #\1 (string-ref text i) #\9)
|
|
(begin (set! i (+ i 1)) (digits) #t))))))
|
|
(and integer-ok
|
|
(or (not (at #\.))
|
|
(begin (set! i (+ i 1)) (digits)))
|
|
(or (not (or (at #\e) (at #\E)))
|
|
(begin (set! i (+ i 1))
|
|
(if (or (at #\+) (at #\-)) (set! i (+ i 1)))
|
|
(digits)))
|
|
(= i n)))))
|
|
|
|
(define (dat:json-object-ref object key . fallback)
|
|
(if (or (not (pair? object)) (not (eq? (car object) 'json:object)))
|
|
(error 'wrong-type-arg "expected a parsed JSON object" object)
|
|
(let ((field (assoc key (cdr object))))
|
|
(if field (cdr field) (if (pair? fallback) (car fallback) #f)))))
|
|
|
|
;;; Encode the same tagged values returned by dat:json-parse. Scheme records
|
|
;;; remain the native representation; this is the narrow adapter used when a
|
|
;;; compatible peer requires JSON bytes on the wire.
|
|
(define (dat:json-stringify value)
|
|
(define (write-unicode-escape n port)
|
|
(let ((digits "0123456789abcdef"))
|
|
(display "\\u" port)
|
|
(for-each
|
|
(lambda (shift)
|
|
(write-char (string-ref digits (modulo (quotient n shift) 16)) port))
|
|
'(4096 256 16 1))))
|
|
(define (string-encode text)
|
|
(let ((port (open-output-string)))
|
|
(write-char #\" port)
|
|
(for-each
|
|
(lambda (c)
|
|
(let ((n (char->integer c)))
|
|
(cond ((char=? c #\") (display "\\\"" port))
|
|
((char=? c #\\) (display "\\\\" port))
|
|
((char=? c #\backspace) (display "\\b" port))
|
|
((char=? c #\newline) (display "\\n" port))
|
|
((char=? c #\return) (display "\\r" port))
|
|
((char=? c #\tab) (display "\\t" port))
|
|
((< n 32) (write-unicode-escape n port))
|
|
(else (write-char c port)))))
|
|
(string->list text))
|
|
(write-char #\" port)
|
|
(get-output-string port)))
|
|
(define (encode item)
|
|
(cond ((string? item) (string-encode item))
|
|
((eq? item 'json:null) "null")
|
|
((eq? item #t) "true")
|
|
((eq? item #f) "false")
|
|
((number? item)
|
|
(let ((text (number->string item)))
|
|
(if (json:number-token? text) text
|
|
(error 'json-encode-error "number is not representable in JSON" item))))
|
|
((and (pair? item) (eq? (car item) 'json:array))
|
|
(string-append "[" (join "," (map encode (cdr item))) "]"))
|
|
((and (pair? item) (eq? (car item) 'json:object))
|
|
(string-append "{" (join ","
|
|
(map (lambda (field)
|
|
(if (or (not (pair? field)) (not (string? (car field))))
|
|
(error 'json-encode-error "object keys must be strings" field))
|
|
(string-append (string-encode (car field)) ":" (encode (cdr field))))
|
|
(cdr item))) "}"))
|
|
(else (error 'json-encode-error "unsupported JSON value" item))))
|
|
(define (join separator strings)
|
|
(if (null? strings) ""
|
|
(let loop ((rest (cdr strings)) (out (car strings)))
|
|
(if (null? rest) out
|
|
(loop (cdr rest) (string-append out separator (car rest)))))))
|
|
(encode value))
|
|
|
|
(provide 'dat:json)
|