;;; 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 <>
;;          Matt Jadud <>
;; Commentary:

(module protocol scheme

  (require (planet "" ("jim" "webit.plt" 1 4))
           (planet "" ("lshift" "xxexpr.plt" 1))
           (lib "" "net")
           ;; 20060711 MCJ
           ;; It would appear that a PLaneT require would be
           ;; more appropriate here
           ;;(lib "" "ssax")
           (prefix-in ssax: (planet "" ("lizorkin" "ssax.plt" 2 0)))
  (provide encode-xmlrpc-call
           ;; Server-side
           (struct-out rpc-call))

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

  ;; write-xmlrpc-call-headers : sxml output-port -> #t
  (define (write-xmlrpc-call call op)
      ((xml-double-quotes-mode #t))
      (let ([result
             (pretty-print-xxexpr (list '(*pi* xml (version "1.0"))
                                        call) op)])
        ;; We don't need to close this port; it's an
        ;; 'ouput-bytes' port. Oops. Closing this breaks things.
        ;;(close-output-port op)

  ;; WARNING 20060711 MCJ
  ;; Given a bad hostname, make-xmlrpc-call could fail. Should we
  ;; catch that and pass it on as an XML-RPC exception,
  ;; or leave it to the developer?
../../../../Library/PLT Scheme/350/collects/xmlrpc/ tcp-connect: connection to locahost, port 8080 failed; host not found (at step 1: No address associated with nodename; errno=7)
  ;; 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)))
      ;; Expanding the quality of error message supplied to the
      ;; programmer developing with the XML-RPC library.
        [(http-404? headers)
         (raise-exn:xmlrpc "Server responded with a 404: File not found")]
        [(not (http-200? headers))
          (format "Server did not respond with an HTTP 200~nHeaders:~n~a~n"
      ;; 20060731 MCJ
      ;; This input port doesn't seem to get closed. Or,
      ;; if it does, I don't know where. We'll find out.
      (let ([response (ssax:ssax:xml->sxml ip '())])
        (close-input-port ip)
        response) ))

  ;; 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)))
              (hash-ref h 'faultString))
             (hash-ref h 'faultCode))))]
          (format "Received invalid XMLRPC response ~a\n" else))])))
  ;; Server-side
  ;; extract-parameter-values : (list-of `(param ,v)) -> any
  (define (extract-parameter-values param*)
    (map (lambda (p)
           (xml-match p
             [(param ,value) (deserialise value)]
                (format "Bad parameter in methodCall: ~a~n" p))]))
  ;; read-xmlrpc-response : string -> sxml
  (define (read-xmlrpc-call str)
    (let* ([call-ip (open-input-string str)]
           [result (ssax:ssax:xml->sxml call-ip '())])
      (close-input-port call-ip)
  ;; decode-xmlrpc-call : string -> any
  (define-struct rpc-call (name args))
  (define (decode-xmlrpc-call str)
    (let ([docu (read-xmlrpc-call str)])
      (xml-match (xml-document-content docu)
        [(methodCall (methodName ,name) (params ,param* ...))
         (let ([value* (extract-parameter-values param*)])
           (make-rpc-call (string->symbol name) value*))]
           (format "Cannot parse methodCall: ~a~n" else))])))