racket update to http database server.

1 files changed, 198 insertions, 0 deletions

diff --git a/ebus-racket/util/json.rkt b/ebus-racket/util/json.rkt
new file mode 100644
index 0000000..39bef38
--- /dev/null
+++ b/ebus-racket/util/json.rkt
@@ -0,0 +1,198 @@
+#lang racket/base
+
+#| Roughly based on the PLaneT package by Dave Herman,
+   Originally released under MIT license.
+|#
+
+;; ----------------------------------------------------------------------------
+;; Customization
+
+;; The default translation for a JSON `null' value
+(provide json-null)
+(define json-null (make-parameter 'null))
+
+;; ----------------------------------------------------------------------------
+;; Predicate
+
+(provide jsexpr?)
+(define (jsexpr? x #:null [jsnull (json-null)])
+  (let loop ([x x])
+    (or (exact-integer? x)
+        (inexact-real? x)
+        (boolean? x)
+        (string? x)
+        (eq? x jsnull)
+        (and (list? x) (andmap loop x))
+        (and (hash? x) (for/and ([(k v) (in-hash x)])
+                         (and (symbol? k) (loop v)))))))
+
+;; ----------------------------------------------------------------------------
+;; Generation: Racket -> JSON
+
+(provide write-json)
+(define (write-json x [o (current-output-port)]
+                    #:null [jsnull (json-null)] #:encode [enc 'control])
+  (define (escape m)
+    (define ch (string-ref m 0))
+    (define r
+      (assoc ch '([#\backspace . "\\b"] [#\newline . "\\n"] [#\return . "\\r"]
+                  [#\page . "\\f"] [#\tab . "\\t"]
+                  [#\\ . "\\\\"] [#\" . "\\\""])))
+    (define (u-esc n)
+      (define str (number->string n 16))
+      (define pad (case (string-length str)
+                    [(1) "000"] [(2) "00"] [(3) "0"] [else ""]))
+      (string-append "\\u" pad str))
+    (if r
+      (cdr r)
+      (let ([n (char->integer ch)])
+        (if (n . < . #x10000)
+          (u-esc n)
+          ;; use the (utf-16 surrogate pair) double \u-encoding
+          (let ([n (- n #x10000)])
+            (string-append (u-esc (+ #xD800 (arithmetic-shift n -10)))
+                           (u-esc (+ #xDC00 (bitwise-and n #x3FF)))))))))
+  (define rx-to-encode
+    (case enc
+      [(control) #rx"[\0-\37\\\"\177]"]
+      [(all)     #rx"[\0-\37\\\"\177-\U10FFFF]"]
+      [else (raise-type-error 'write-json "encoding symbol" enc)]))
+  (define (write-json-string str)
+    (write-bytes #"\"" o)
+    (write-string (regexp-replace* rx-to-encode str escape) o)
+    (write-bytes #"\"" o))
+  (let loop ([x x])
+    (cond [(or (exact-integer? x) (inexact-real? x)) (write x o)]
+          [(eq? x #f)     (write-bytes #"false" o)]
+          [(eq? x #t)     (write-bytes #"true" o)]
+          [(eq? x jsnull) (write-bytes #"null" o)]
+          [(string? x) (write-json-string x)]
+          [(list? x)
+           (write-bytes #"[" o)
+           (when (pair? x)
+             (loop (car x))
+             (for ([x (in-list (cdr x))]) (write-bytes #"," o) (loop x)))
+           (write-bytes #"]" o)]
+          [(hash? x)
+           (write-bytes #"{" o)
+           (define first? #t)
+           (for ([(k v) (in-hash x)])
+             (unless (symbol? k)
+               (raise-type-error 'write-json "bad JSON key value" k))
+             (if first? (set! first? #f) (write-bytes #"," o))
+             (write (symbol->string k) o) ; no `printf' => proper escapes
+             (write-bytes #":" o)
+             (loop v))
+           (write-bytes #"}" o)]
+          [else (raise-type-error 'write-json "bad JSON value" x)]))
+  (void))
+
+;; ----------------------------------------------------------------------------
+;; Parsing: JSON -> Racket
+
+(require syntax/readerr)
+
+(provide read-json)
+(define (read-json [i (current-input-port)] #:null [jsnull (json-null)])
+  ;; Follows the specification (eg, at json.org) -- no extensions.
+  ;;
+  (define (err fmt . args)
+    (define-values [l c p] (port-next-location i))
+    (raise-read-error (format "read-json: ~a" (apply format fmt args))
+                      (object-name i) l c p #f))
+  (define (skip-whitespace) (regexp-match? #px#"^\\s*" i))
+  ;;
+  ;; Reading a string *could* have been nearly trivial using the racket
+  ;; reader, except that it won't handle a "\/"...
+  (define (read-string)
+    (let loop ([l* '()])
+      ;; note: use a string regexp to extract utf-8-able text
+      (define m (cdr (or (regexp-try-match #rx"^([^\"\\]*)(\"|\\\\(.))" i)
+                         (err "unterminated string"))))
+      (define l (if ((bytes-length (car m)) . > . 0) (cons (car m) l*) l*))
+      (define esc (caddr m))
+      (cond
+        [(not esc) (bytes->string/utf-8 (apply bytes-append (reverse l)))]
+        [(assoc esc '([#"b" . #"\b"] [#"n" . #"\n"] [#"r" . #"\r"]
+                      [#"f" . #"\f"] [#"t" . #"\t"]
+                      [#"\\" . #"\\"] [#"\"" . #"\""] [#"/" . #"/"]))
+         => (λ (m) (loop (cons (cdr m) l)))]
+        [(equal? esc #"u")
+         (let* ([e (or (regexp-try-match #px#"^[a-fA-F0-9]{4}" i)
+                       (err "bad string \\u escape"))]
+                [e (string->number (bytes->string/utf-8 (car e)) 16)])
+           (define e*
+             (if (<= #xD800 e #xDFFF)
+               ;; it's the first part of a UTF-16 surrogate pair
+               (let* ([e2 (or (regexp-try-match #px#"^\\\\u([a-fA-F0-9]{4})" i)
+                              (err "bad string \\u escape, ~a"
+                                   "missing second half of a UTF16 pair"))]
+                      [e2 (string->number (bytes->string/utf-8 (cadr e2)) 16)])
+                 (if (<= #xDC00 e2 #xDFFF)
+                   (+ (arithmetic-shift (- e #xD800) 10) (- e2 #xDC00) #x10000)
+                   (err "bad string \\u escape, ~a"
+                        "bad second half of a UTF16 pair")))
+               e)) ; single \u escape
+           (loop (cons (string->bytes/utf-8 (string (integer->char e*))) l)))]
+        [else (err "bad string escape: \"~a\"" esc)])))
+  ;;
+  (define (read-list what end-rx read-one)
+    (skip-whitespace)
+    (if (regexp-try-match end-rx i)
+      '()
+      (let loop ([l (list (read-one))])
+        (skip-whitespace)
+        (cond [(regexp-try-match end-rx i) (reverse l)]
+              [(regexp-try-match #rx#"^," i) (loop (cons (read-one) l))]
+              [else (err "error while parsing a json ~a" what)]))))
+  ;;
+  (define (read-hash)
+    (define (read-pair)
+      (define k (read-json))
+      (unless (string? k) (err "non-string value used for json object key"))
+      (skip-whitespace)
+      (unless (regexp-try-match #rx#"^:" i)
+        (err "error while parsing a json object pair"))
+      (list (string->symbol k) (read-json)))
+    (apply hasheq (apply append (read-list 'object #rx#"^}" read-pair))))
+  ;;
+  (define (read-json [top? #f])
+    (skip-whitespace)
+    (cond
+      [(and top? (eof-object? (peek-char i))) eof]
+      [(regexp-try-match #px#"^true\\b"  i) #t]
+      [(regexp-try-match #px#"^false\\b" i) #f]
+      [(regexp-try-match #px#"^null\\b"  i) jsnull]
+      [(regexp-try-match
+        #rx#"^-?(?:0|[1-9][0-9]*)(?:\\.[0-9]+)?(?:[eE][+-]?[0-9]+)?" i)
+       => (λ (bs) (string->number (bytes->string/utf-8 (car bs))))]
+      [(regexp-try-match #rx#"^[\"[{]" i)
+       => (λ (m)
+            (let ([m (car m)])
+              (cond [(equal? m #"\"") (read-string)]
+                    [(equal? m #"[")  (read-list 'array #rx#"^\\]" read-json)]
+                    [(equal? m #"{")  (read-hash)])))]
+      [else (err "bad input")]))
+  ;;
+  (read-json #t))
+
+;; ----------------------------------------------------------------------------
+;; Convenience functions
+
+(provide jsexpr->string jsexpr->bytes)
+(define (jsexpr->string x #:null [jsnull (json-null)] #:encode [enc 'control])
+  (define o (open-output-string))
+  (write-json x o #:null jsnull #:encode enc)
+  (get-output-string o))
+(define (jsexpr->bytes x #:null [jsnull (json-null)] #:encode [enc 'control])
+  (define o (open-output-bytes))
+  (write-json x o #:null jsnull #:encode enc)
+  (get-output-bytes o))
+
+(provide string->jsexpr bytes->jsexpr)
+(define (string->jsexpr str #:null [jsnull (json-null)])
+  (unless (string? str) (raise-type-error 'string->jsexpr "string" str))
+  (read-json (open-input-string str) #:null jsnull))
+(define (bytes->jsexpr str #:null [jsnull (json-null)])
+  (unless (bytes? str) (raise-type-error 'bytes->jsexpr "bytes" str))
+  (read-json (open-input-bytes str) #:null jsnull))