;;;
;;; Time-stamp: <06/01/04 15:14:35 nhw>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;

;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.

;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;; License for more details.

;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA

;;; Author: Noel Welsh <[email protected]>
;;
;;
;; Commentary:

(module protocol mzscheme

  (require (planet "xml.ss" ("jim" "webit.plt" 1 3))
           (planet "xxexpr.ss" ("lshift" "xxexpr.plt" 1))
           (lib "url.ss" "net")
           (lib "ssax.ss" "ssax")
           "base.ss"
           "serialise.ss")
  
  (provide encode-xmlrpc-call
           write-xmlrpc-call
           make-xmlrpc-call
           read-xmlrpc-response
           decode-xmlrpc-response)

  ;; http-200? : string -> (U #t #f)
  (define (http-200? headers)
    (if (regexp-match #rx"^HTTP/[0-9]*\\.[0-9]* 200" headers)
        #t
        #f))
  
  ;; encode-xmlrpc-call : string any ... -> sxml
  (define (encode-xmlrpc-call method-name . args)
    `(methodCall
      (methodName ,method-name)
      (params
       ,@(map (lambda (val)
                `(param ,(serialise val)))
              args))))

  ;; write-xmlrpc-call-headers : sxml output-port -> #t
  (define (write-xmlrpc-call call op)
    (parameterize
      ((xml-double-quotes-mode #t))
      (pretty-print-xxexpr (list '(*pi* xml (version "1.0"))
                                 call) op)))

  ;; make-xmlrpc-call : url sxml -> impure-port
  (define (make-xmlrpc-call url call)
    (let ((op (open-output-bytes)))
      (write-xmlrpc-call call op)
      (post-impure-port url
                        (get-output-bytes op)
                        '("Content-Type: text/xml"
                          "User-Agent: PLT Scheme"))))

  ;; read-xmlrpc-response : input-port -> sxml
  (define (read-xmlrpc-response ip)
    (let ((headers (purify-port ip)))
      (unless (http-200? headers)
        (raise-exn:xmlrpc "Server did not respond with an HTTP 200"))
      (ssax:xml->sxml ip '())))

  ;; decode-xmlrpc-response : input-port -> any
  (define (decode-xmlrpc-response ip)
    (let ((resp (read-xmlrpc-response ip)))
      (xml-match (xml-document-content resp)
        [(methodResponse (params (param ,value)))
         (deserialise value)]
        [(methodResponse (fault ,value))
         (let ((h (deserialise value)))
           (raise
            (make-exn:xmlrpc:fault
             (string->immutable-string
              (hash-table-get h 'faultString))
             (current-continuation-marks)
             (hash-table-get h 'faultCode))))]
        [,else
         (raise-exn:xmlrpc
          (format "Received invalid XMLRPC response ~a\n" else))])))
        

  )