#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SHP: Hypertext Processor
;;
;; a PHP like web framework for PLT Scheme
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; xmlrpc.ss - xmlrpc converter (from xexpr/sxml) and generator.
;; yc 7/7/2010 - first version.
(require "base.ss"
         "depend.ss"
         "request.ss"
         "response.ss"
         (planet bzlib/date:1:3/srfi)
         )

;; xmlrpc spec - http://www.xmlrpc.com/spec

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GENERATOR

;; we want to generate xmlrpc based on the type of the value - cond-registry will handle the registration of the types
(define xmlrpc (make-cond-registry)) 

;; based on the xmlrpc spec, the following are the only scalar types:
;; int (it can be i4 or i8 - but since scheme has arbitrary numeric tower we will just return int)
;; double (we need to split from scheme's number into either int or double)
;; boolean
;; string
;; dateTime.iso8601
;; base64 - we current do not support base64 generation until we understand the use case better

;; make-scalar-type simplifies the converter generation for each of the scalar types.
;; (->* (symbol?) ((-> any/c string?)) (-> any/c xexpr?))
(define (make-scalar-type type
                          (convert (lambda (v)
                                     (format "~a" v))))
  (lambda (v) 
    `(,type ,(convert v))))

;; register the base scalar types.
;; integer?
(registry-set! xmlrpc integer? (make-scalar-type 'int))
;; boolean?
(registry-set! xmlrpc boolean? 
               (make-scalar-type 'boolean 
                                 (lambda (v) 
                                   (format "~a" (if (eq? v #t) 
                                                    1 
                                                    0)))))
;; string?
(registry-set! xmlrpc string? (make-scalar-type 'string))
;; symbol? - simplifies the conversion into string.
(registry-set! xmlrpc symbol? (make-scalar-type 'string))
;; double?
(define (double? x) 
  (and (real? x) (not (integer? x))))
(registry-set! xmlrpc double? (make-scalar-type 'double))
;; dateTime.iso8601
(registry-set! xmlrpc date? 
               (make-scalar-type 'dateTime.iso8601 date->iso8601))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; conversion functions
;; (-> any/c throw?)
(define (unknown v) 
  (error 'any->xmlrpc "unknown type: ~a" v))

;; (-> any/c xepxr)
;; this is the base function that converts any type registered. will throw error if unknown. 
(define (any->xmlrpc v)
  ((registry-ref xmlrpc v unknown) v)) 

;; (-> any/c xexpr)
;; this wraps any->xmlrpc with `(value ) xexpr.
(define (any->xmlrpc/value v)
  `(value ,(any->xmlrpc v))) 

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; conversion of composite types.
;; based on the spec there are only two composite types in xmlrpc.
;; * array
;; * struct
;;
;; both list and vector maps well into array.  and hash maps to struct.
;; other scheme objects (specifically structs) should first map to hash so it can easily be mapped into struct.
;; this is because structs are non-opaque and requires additional mapping code anyways, so we will have to
;; first convert struct to something else.  Also - some struct actually represent scalar values (such as url?).


;; (-> vector? xexpr)
(define (array->xmlrpc v) 
  `(array (data ,@(vector->list 
                   (vector-map any->xmlrpc/value v)))))
;; register for vector
(registry-set! xmlrpc vector? array->xmlrpc)

;; (-> list? xexpr)
(define (list->xmlrpc v)
  `(array (data ,@(map any->xmlrpc/value v))))
;; register for list
(registry-set! xmlrpc list? list->xmlrpc)

;; (-> hash? xexpr)
(define (hash->xmlrpc v) 
  `(struct ,@(hash-map v (lambda (k v)
                           `(member (name ,(format "~a" k))
                                    ,(any->xmlrpc/value v))))))
;; register for hash.
(registry-set! xmlrpc hash? hash->xmlrpc)

;; register for error. this might need to be fixed in the future.
(define (error->xmlrpc e) 
  (any->xmlrpc (exn-message e))) 

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

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; adapter to web handler

(define (handle-xmlrpc-result result)
  ($content-type "text/xml; charset=utf-8")
  `(methodResponse 
    ,(if (exn? result) 
         `(fault ,(any->xmlrpc/value result))
         `(params (param ,(any->xmlrpc/value result))))))

(provide/contract 
 (handle-xmlrpc-result (-> any/c any))
 )

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parser (not a true parser from strings - it parses from sxml)

;; sxpath to retrieve the parameter values
(define param-helper (sxpath "/methodCall/params/param/value/node()"))

;; convert the parameter to value. since all types are known in advance this function
;; hardcodes the types instead of using registry for now (can be extended in the future if it makes sense).
(define (param->value v) 
  (define (name-helper name) 
    (match name 
      ((list 'name name) name)))
  (define (member-helper member)
    (match member 
      ((list 'member 
             (list 'name name)
             (list 'value value))
       (cons name 
             (param->value value)))))
  (define (value-helper value)
    (match value 
      ((list 'value v)
       (param->value v))))
  (match v 
    ((list 'int num)
     (string->number num)) 
    ((list 'double num)
     (string->number num)) 
    ((list 'string str)
     str) 
    ((list 'boolean "0") #f)
    ((list 'boolean "1") #t) 
    ((list 'dateTime.iso8601 date)
     (read-iso8601 date))
    ((list-rest 'struct members) 
     (make-immutable-hash (map member-helper members)))
    ((list 'array (list-rest 'data values))
     (map value-helper values))))

;; sxml-helper helps to ensure the sxml can be used by sxpath function.
(define (sxml-helper xml)
  (match xml
    ((list-rest '*TOP* any) xml)
    (else `(*TOP* ,xml))))

;; xmlrpc-params returns the actual parameters in scheme values.
(define (xmlrpc-params xml) 
  (map param->value (param-helper (sxml-helper xml))))

;; xmlrpc-method returns the method name.
(define (xmlrpc-method xml)
  (define (helper v) 
    (match v 
      ((list name) name)))
  (helper ((sxpath "/methodCall/methodName/text()") (sxml-helper xml))))

(provide/contract 
 (xmlrpc-method (-> any/c any)) 
 (xmlrpc-params (-> any/c any))
 )