;;;; xml-rpc-client.scm
;
;; An implementation of the XML-RPC protocol
;;
;; This file contains a client implementation.
;
; 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-client
  (xml-rpc-server xml-rpc-response->values xml-rpc-methodcall)

(import (chicken base) scheme srfi-13 http-client uri-common intarweb xml-rpc-lolevel ssax sxpath-lolevel)

(define (xml-rpc-response->values response-sxml)
  (let* ((resp ((select-first-kid (ntype?? 'methodResponse)) response-sxml)))
    (cond
     (((select-first-kid (ntype?? 'fault)) resp) =>
      (lambda (fault)
        ;; Ensure the unparsing of the fault is handled so we can understand
        ;; the result value.
        (parameterize ((xml-rpc-parsers `((i4 . ,xml-rpc-int->number)
                                          (int . ,xml-rpc-int->number)
                                          (struct . ,xml-rpc-struct->alist)
                                          (string . ,xml-rpc-string->string))))
          (let ((val (xml-rpc-fragment->value
                      (car ((node-join (select-first-kid (ntype?? 'value))
                                       sxml:content)
                            fault)))))
            (signal-xml-rpc-error (alist-ref 'faultCode val)
                                  (alist-ref 'faultString val))))))
     (((select-first-kid (ntype?? 'params)) resp) =>
      (lambda (params)
        (apply values
               (map
                xml-rpc-fragment->value
                ((node-join
                  (select-kids (ntype?? 'param))
                  (select-first-kid (ntype?? 'value))
                  sxml:content)
                 params)))))
     (else (signal-xml-rpc-error 0 "Malformed response data" response-sxml)))))

;; Unfortunately, we need this; spec says "Content-Length" header is required
(define (sxml->string sxml)
  (string-concatenate (flatten (sxml:sxml->xml sxml))))

(define (xml-rpc-methodcall method-name args)
  (if (null? args)
      `(methodCall (methodName ,method-name))
      `(methodCall
        (methodName ,method-name)
        (params
         ,(map (lambda (p)
                 `(param
                   (value ,(value->xml-rpc-fragment p))))
               args)))))

(define (xml-rpc-server uri)
  (when (string? uri)
    (set! uri (uri-reference uri)))
  (lambda (method-name)
    (lambda args
      (let* ((xml
              (string-append
               "<?xml version=\"1.0\"?>\n"
               (sxml->string (xml-rpc-methodcall method-name args))))
             (req (make-request
                   method: 'POST uri: uri
                   headers: (headers `((content-length ,(string-length xml))
                                       (content-type text/xml))))))
        (xml-rpc-response->values
         (call-with-input-request
          req
          (lambda (p) (display xml p))
          (lambda (p) (ssax:xml->sxml p '()))))))))

)