#lang scheme
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SHP: Hypertext Processor
;;
;; a PHP like web framework for PLT Scheme
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; json.ss - json parser & generator (might be extracted to other package in the future).
;; yc 7/7/2010 - first version.
(require "base.ss"
         "depend.ss" 
         "request.ss"
         "response.ss"
         (planet bzlib/parseq:1:3/example/json)
         )

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; json spec - http://json.org


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; json generator.
;;
;; same as the xmlrpc generator, we use a cond-registry to check the type of the value to map to a particular converter
;;
;; the generator returns in strings
(define json (make-cond-registry)) 

;; '() <-> null
(registry-set! json null? (lambda (v) "null"))

;; void? <-> undefined
(registry-set! json void? (lambda (v) "undefined"))

;; number? <-> number?
(registry-set! json number? number->string)

;; string <-> string printed.
(registry-set! json string? (lambda (v) (format "~s" v)))

;; unknown throws error.
(define (unknown v)
  (error 'any->json "unknown type: ~v" v))

;; any->json is the workhorse.
(define (any->json v) 
  ((registry-ref json v unknown) v))

;; vector -> [ v1 , v2 , ... ]
(define (vector->json v)
  (string-append "["
                 (string-join (vector->list (vector-map any->json v)) ",")
                 "]"))

(registry-set! json vector? vector->json)

;; hash -> { k1 : v2 , k2 : v2 , ... }
(define (hash->json v) ;; the key is the
  (string-append "{"
                 (string-join (hash-map v
                                        (lambda (k v) 
                                          (string-append (any->json k)
                                                         ":"
                                                         (any->json v))))
                              ",")
                 "}"))

(registry-set! json hash? hash->json)

;; handling errors.
(define-struct (exn:extend exn) (code type inner) #:transparent) 

(define (exn->type e) 
  (cond ((exn:extend? e) (exn:extend-type e))
        ((exn:break? e) "break")
        ((exn:fail:user? e) "fail:user")
        ((exn:fail:unsupported? e) "fail:unsupported")
        ((exn:fail:out-of-memory? e) "out of memory")
        ((exn:fail:network? e) "network")
        ((exn:fail:filesystem:version? e) "filesystem:version")
        ((exn:fail:filesystem:exists? e) "filesystem:exists")
        ((exn:fail:filesystem? e) "filesystem")
        ((exn:fail:read:non-char? e) "reader:non-char")
        ((exn:fail:read:eof? e) "reader:eof")
        ((exn:fail:read? e) "reader")
        ((exn:fail:syntax? e) "syntax")
        ((exn:fail:contract:variable? e) "contract:variable")
        ((exn:fail:contract:continuation? e) "contract:continuation")
        ((exn? e) "error")
        (else "not an error")))

(define (exn->code e) 
  (cond ((exn:extend? e) (exn:extend-code e))
        (else "")))

(define (exn->message e) 
  (exn-message e)) 

(define (error->xexpr e) 
  `(error (type ,(exn->type e))
          (code ,(exn->code e))
          (message ,(exn->message e))))

;; exn? -> new Error ( str )
(define (error->json e)
  (string-append "new Error(" (any->json (exn-message e)) ")"))

(registry-set! json exn? error->json)

;; exposed registration
(define (any->json-set! cond convert) 
  (unless (registry-ref json cond)
    (registry-set! json cond convert)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; shp handler adapter

;; (-> result? text/json)
(define (handle-json-result result)
  (define (helper json callback) 
    (if callback 
        (string-join (list "return" callback "(" json ");") " ")
        json))
  ($content-type "text/json; charset=utf-8")
  (helper (any->json result) ($query "~jsonp")))

(provide handle-json-result
         any->json
         any->json-set!)

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; json parser
;; a json parser is already defined in bzlib/parseq:1:3/example/json
(provide read-json)