;;;; xml-rpc-lolevel.scm
;
;; An implementation of the XML-RPC protocol
;;
;; This file contains the plumbing for XML RPC value marshaling/unmarshaling.
;
; Copyright (c) 2009-2012, 2016, Peter Bex
; Parts Copyright (c) Felix Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
;    notice, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notice, this list of conditions and the following disclaimer in the
;    documentation and/or other materials provided with the distribution.
; 3. Neither the name of the author nor the names of its
;    contributors may be used to endorse or promote products derived
;    from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGE.
;
; Please report bugs, suggestions and ideas to the Chicken Trac
; ticket tracking system (assign tickets to user 'sjamaan'):
; http://trac.callcc.org

(module xml-rpc-lolevel
  (signal-xml-rpc-error
   xml-rpc-unparsers value->xml-rpc-fragment
   list->xml-rpc-array vector->xml-rpc-array
   number->xml-rpc-int number->xml-rpc-double
   boolean->xml-rpc-boolean ->xml-rpc-string
   u8vector->xml-rpc-base64 blob->xml-rpc-base64
   alist->xml-rpc-struct hash-table->xml-rpc-struct
   vector->xml-rpc-iso8601
   nonempty-symbol-keyed-alist?

   xml-rpc-parsers xml-rpc-fragment->value
   xml-rpc-int->number xml-rpc-double->number
   xml-rpc-boolean->number xml-rpc-string->string
   xml-rpc-array->vector xml-rpc-array->list
   xml-rpc-struct->alist xml-rpc-struct->hash-table
   xml-rpc-base64->string xml-rpc-base64->u8vector xml-rpc-base64->blob
   xml-rpc-datetime->vector)

(import (chicken base) scheme  srfi-1 srfi-4 srfi-69 base64 sxpath-lolevel (chicken time posix) (chicken condition) (chicken string) (chicken blob))

(define (signal-xml-rpc-error code msg . args)
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'message msg 'arguments args)
    (make-property-condition 'xml-rpc 'code code))))

(define (list->xml-rpc-array v)
  `(array (data ,@(map (lambda (el)
                         `(value ,(value->xml-rpc-fragment el)))
                       v))))

(define (vector->xml-rpc-array v)
  (list->xml-rpc-array (vector->list v)))

(define (number->xml-rpc-int v)
  `(i4 ,(number->string (inexact->exact (round v)))))

(define (number->xml-rpc-double v)
  `(double ,(number->string (exact->inexact v))))

(define (boolean->xml-rpc-boolean v)
  `(boolean ,(if v "1" "0")))

(define (->xml-rpc-string v)
  `(string ,(->string v)))

(define (u8vector->xml-rpc-base64 v)
  (blob->xml-rpc-base64 (u8vector->blob/shared v)))

(define (blob->xml-rpc-base64 v)
  `(base64 ,(base64-encode (blob->string v))))

(define (alist->xml-rpc-struct v)
  `(struct ,@(map (lambda (p)
                    `(member
                      (name ,(->string (car p)))
                      (value ,(value->xml-rpc-fragment (cdr p)))))
                  v)))

(define (hash-table->xml-rpc-struct v)
  (alist->xml-rpc-struct (hash-table->alist v)))

(define (vector->xml-rpc-iso8601 v)
  `(dateTime.iso8601 ,(time->string v "%Y%m%dT%H:%M:%S")))

(define (nonempty-symbol-keyed-alist? v)
  (and (not (null? v))
       (list? v)
       (every (lambda (p)
                (and (pair? p) (symbol? (car p))))
              v)))

(define xml-rpc-unparsers
  (make-parameter `((,vector? . ,vector->xml-rpc-array)
                    (,(disjoin flonum? ratnum?) . ,number->xml-rpc-double)
                    (,integer? . ,number->xml-rpc-int)
                    (,boolean? . ,boolean->xml-rpc-boolean)
                    (,string? . ,->xml-rpc-string)
                    (,symbol? . ,->xml-rpc-string)
                    (,u8vector? . ,u8vector->xml-rpc-base64)
                    (,blob? . ,blob->xml-rpc-base64)
                    (,hash-table? . ,hash-table->xml-rpc-struct)
                    (,nonempty-symbol-keyed-alist? . ,alist->xml-rpc-struct)
                    (,list? . ,list->xml-rpc-array))))

(define (value->xml-rpc-fragment value)
  (let ((pred&unparser (find (lambda (p&u) ((car p&u) value))
                             (xml-rpc-unparsers))))
    (if pred&unparser
        ((cdr pred&unparser) value)
        (error "No parser for value " value))))

(define (xml-rpc-int->number fragment)
  (string->number (sxml:text fragment)))

(define (xml-rpc-double->number fragment)
  (string->number (sxml:text fragment)))

(define (xml-rpc-boolean->number fragment)
  (not (= (string->number (sxml:text fragment)) 0)))

(define xml-rpc-string->string sxml:text)

(define (xml-rpc-base64->string fragment)
  (base64-decode (sxml:text fragment)))

(define (xml-rpc-base64->u8vector fragment)
  (blob->u8vector/shared (string->blob (base64-decode (sxml:text fragment)))))

(define (xml-rpc-array->vector fragment)
  (list->vector (xml-rpc-array->list fragment)))

(define (xml-rpc-array->list fragment)
  (map (lambda (v)
         (xml-rpc-fragment->value v))
       ((node-join (select-first-kid (ntype?? 'data))
                   (select-kids (ntype?? 'value))
                   sxml:content)
        fragment)))

(define (xml-rpc-struct->alist fragment)
  (map (lambda (v)
         (cons (string->symbol
                (sxml:text ((select-first-kid (ntype?? 'name)) v)))
               (xml-rpc-fragment->value
                (car (sxml:content ((select-first-kid (ntype?? 'value)) v))))))
       (sxml:content fragment)))

(define (xml-rpc-struct->hash-table fragment)
  (alist->hash-table (xml-rpc-struct->alist fragment)))

(define (xml-rpc-base64->blob fragment)
  (u8vector->blob/shared (base64-decode (cadr fragment))))

(define (xml-rpc-datetime->vector fragment)
  (string->time (cadr fragment) "%Y%m%dT%H:%M:%S"))

(define xml-rpc-parsers
  (make-parameter `((i4 . ,xml-rpc-int->number)
                    (int . ,xml-rpc-int->number)
                    (double . ,xml-rpc-double->number)
                    (boolean . ,xml-rpc-boolean->number)
                    (string . ,xml-rpc-string->string)
                    (base64 . ,xml-rpc-base64->u8vector)
                    (dateTime.iso8601 . ,xml-rpc-datetime->vector)
                    (array . ,xml-rpc-array->vector)
                    (struct . ,xml-rpc-struct->hash-table))))

(define (xml-rpc-fragment->value fragment)
  ((alist-ref (sxml:element-name fragment) (xml-rpc-parsers) eq?
              (lambda _ (error "No unparser for tag " (car fragment))))
   fragment))

)