;;;; xml-rpc-server.scm
;
;; An implementation of the XML-RPC protocol
;;
;; This file contains a server 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-server
  (call-xml-rpc-proc xml-rpc-call->xml-rpc-response
   make-xml-rpc-request-handler start-simple-xml-rpc-server)

(import (chicken base) (chicken condition) (chicken format) (chicken io) scheme srfi-13 srfi-18  (chicken tcp) xml-rpc-lolevel sxpath-lolevel ssax intarweb)

(define (call-xml-rpc-proc call-sxml procedures)
  (or (and-let* ((call ((select-first-kid (ntype?? 'methodCall)) call-sxml))
                 (method ((select-first-kid (ntype?? 'methodName)) call))
                 (method-name (string->symbol (sxml:text method)))
                 (args ((node-join
                         (select-first-kid (ntype?? 'params))
                         (select-kids (ntype?? 'param))
                         (select-first-kid (ntype?? 'value))
                         sxml:content)
                        call)))
        (cond
         ((alist-ref method-name procedures) =>
          (lambda (proc)
            (apply proc (map xml-rpc-fragment->value args))))
         (else (signal-xml-rpc-error
                1 (sprintf "Unknown procedure \"~A\"" method-name)))))
      (signal-xml-rpc-error 2 "Bad request XML" call-sxml)))

(define (xml-rpc-call->xml-rpc-response call-sxml procedures)
  `(methodResponse
    ,(handle-exceptions exn
       `(fault
         (value
          ,(value->xml-rpc-fragment
            `((faultCode . ,(or ((condition-property-accessor 'xml-rpc 'code)
                                 exn)
                                -1))
              (faultString . ,(or ((condition-property-accessor 'exn 'message)
                                   exn)
                                  "Unknown internal error"))))))
       (call-with-values
           (lambda () (call-xml-rpc-proc call-sxml procedures))
         (lambda values
           `(params
             ,@(map (lambda (p)
                      `(param (value ,(value->xml-rpc-fragment p))))
                    values)))))))

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

(define (read-request-data request)
  (let ((len (header-value 'content-length (request-headers request))))
    ;; If the header is not available, this will read until EOF
    (read-string len (request-port request))))

(define (make-xml-rpc-request-handler procedures)
  (lambda (req resp)
    (if (not (eq? (request-method req) 'POST))
        (let* ((err "XML-RPC requests must use the POST method!\n")
               (_ (read-request-data req))
               (resp (write-response
                      (update-response
                       resp
                       code: 405 message: "Method not allowed"
                       headers: (headers
                                 `((allow POST)
                                   (content-type text/plain)
                                   (content-length ,(string-length err)))
                                 (response-headers resp))))))
          (unless (eq? (request-method req) 'HEAD)
            (display err (response-port resp)))
          resp)
        (let* ((sxml-response
                 (handle-exceptions exn
                   `(methodResponse
                     (fault
                      (value (struct
                              (member (name "faultCode")
                                      (value (i4 "3")))
                              (member (name "faultString")
                                      (value (string "Invalid request XML")))))))
                   (xml-rpc-call->xml-rpc-response
                    (ssax:xml->sxml (request-port req) '())
                    procedures)))
               (xml-string (string-append
                            "<?xml version=\"1.0\"?>\n"
                            (sxml->string sxml-response)))
               (resp (write-response
                      (update-response
                       resp
                       headers:
                       (headers
                        `((content-type text/xml)
                          (content-length ,(string-length xml-string)))
                        (response-headers resp))))))
          (display xml-string (response-port resp))
          resp))))

(define (start-simple-xml-rpc-server procedures #!optional (port 8080))
  (let ((listener (tcp-listen port))
        (handler (make-xml-rpc-request-handler procedures)))
    (let accept-next-connection ()
      (receive (in out)
        (tcp-accept listener)
        (thread-start!
         (lambda ()
           (handle-exceptions e
             (void)
             (let ((req (read-request in))
                   (resp (make-response port: out
                                        headers: (headers
                                                  `((connection close))))))
               (handler req resp)))
           (close-input-port in)
           (close-output-port out)))
        (accept-next-connection)))))

)