;; -*- mode: common-lisp; package: user -*-
;;
;; See the file LICENSE for the full license governing this code.



(in-package :user)

(eval-when (compile load eval)

  (require :xml-rpc "xml-rpc")
  (require :tester)
  )

(defpackage :user
  (:use :net.xml-rpc :util.test :net.xml.sax)
  (:import-from :net.xml-rpc :decode-xml-parse :decode-xml-rpc-value)
  (:import-from :util.test util.test::*do-test*)
  )

;; This file can run with or without the internal test module.
(or (boundp '*do-test*) (set '*do-test* t))

(defun test-xml-rpc (&aux (unex *test-unexpected-failures*))
  (with-tests
      (:name "XML-RPC")
    (test-no-error (test1))
    (test-no-error (test2))
    (test-no-error (test3))
    (test :ok (test4))
    (test :ok (test5))
    (test :ok (test6))
    (test :ok (test7))
    (test :ok (values (test8)))
    (test :ok (test9))
    (test-no-error (load "xml-rpc-examples"))
    (test-no-error (try10))
    (test-no-error (try11))
    (test-no-error (try12))
    (test-no-error (try13))
    (test-no-error (try14))
    (test-no-error (try15))
    (test-error (try15client) :condition-type 'xml-rpc-fault :announce t)
    (test-bug25503)
    (eql unex *test-unexpected-failures*)))

;;;
;;; Some test cases for the parsers and decoders

(defun test1 ()
  (decode-xml-parse '(array (data (value (int 1)) (value (int 2)) (value (int 3))))
		    '("array" ("data" (:* :elements :value)))))

(defun test2 ()
  (decode-xml-parse '(array ("   " data "   " 
			     (value "   " (int 1)) 
			     "   "
			     ("   " value (int 2)) 
			     (value (int 3))))
		    '("array" ("data" (:* :elements :value)))
		    nil :ignore-whitespace
		    ))

(defun test3 ()
  (list (encode-xml-rpc-value (encode-universal-time 1 1 1 1 1 1) :date)
	(encode-xml-rpc-value (list 1 1 1 1 1 1) :date)
	(encode-xml-rpc-value (list 1 1 1 1 1 -1) :date)
	(encode-xml-rpc-value 0e1)
	(encode-xml-rpc-value 0d1)
	))

(defun test4 ()
  (let ((in
	 "<value><base64>R0lGODlhFgASAJEAAP/////OnM7O/wAAACH5BAEAAAAALAAAAAAWABIAAAJAhI+py40zDIzujEDBzW0n74AaFGChqZUYylyYq7ILXJJ1BU95l6r23RrRYhyL5jiJAT/Ink8WTPoqHx31im0UAAA7</base64></value>"
	 )
	out)
    (multiple-value-bind (val type)
	(decode-xml-rpc-value (first (parse-to-lxml in :content-only t)))
      (if* (and (stringp val) (eq :base64 type))
	   then
	   (setf out (encode-xml-rpc-value val type))
	   (if (equal in out)
	       :ok
	     (list in out))
	   else
	   (list type val)))))



(defun test5 ()
  (let ((in
	 "<value><string></string></value>"
	 )
	out)
    (multiple-value-bind (val type)
	(decode-xml-rpc-value (first (parse-to-lxml in :content-only t)))
      (if* (and (stringp val) (eq :string type))
	   then
	   (setf out (encode-xml-rpc-value val type))
	   (if (equal in out)
	       :ok
	     (list in out))
	   else
	   (list type val)))))

(defun test6 ()
  (let ((in
	 "<value><base64></base64></value>"
	 )
	out)
    (multiple-value-bind (val type)
	(decode-xml-rpc-value (first (parse-to-lxml in :content-only t)))
      (if* (and (stringp val) (eq :base64 type))
	   then
	   (setf out (encode-xml-rpc-value val type))
	   (if (equal in out)
	       :ok
	     (list in out))
	   else
	   (list type val)))))

(defun test7 ()
  (let ((in "<value></value>"))
    (multiple-value-bind (val type)
	(decode-xml-rpc-value (first (parse-to-lxml in :content-only t)))
      (if* (and (stringp val) (eq :string type))
	   then
	   :ok
	   else
	   (list type val)))))

(defun test8 ()
  (let ((in "<value>foo</value>"))
    (multiple-value-bind (val type)
	(decode-xml-rpc-value (first (parse-to-lxml in :content-only t)))
      (if* (and (stringp val) (eq :string type))
	   then
	   (values :ok val)
	   else
	   (list type val)))))

(defun test9 ()
  (let ((in
	 "<value><string>   </string></value>"
	 )
	out)
    (multiple-value-bind (val type)
	(decode-xml-rpc-value (first (parse-to-lxml in :content-only t)))
      (if* (and (stringp val) (eq :string type))
	   then
	   (setf out (encode-xml-rpc-value val type))
	   (if (equal in out)
	       :ok
	     (list in out))
	   else
	   (list type val)))))

;; test10 and test11 are manual tests.
(defun test10 ()
  (unwind-protect
      (let ()
	(trace (do-http-request :break-before t))
	(xml-rpc-call :encoded :url "http://test" 
		      :redirect 17
		      :proxy "http:/proxy")
	)
    (untrace do-http-request)))

(defun test11 ()
  (unwind-protect
      (let ()
	(trace (do-http-request :break-before t))
	(multiple-value-bind (v e)
	    (ignore-errors
	      (xml-rpc-call :encoded :url "http://test" 
			    :content "abc"
			    :proxy "http:/proxy"))
	  (if (search "not allowed in xml-rpc-call"
		      (format nil "~A" e))
	      :ok
	    (values nil v e)))
	)
    (untrace do-http-request)))

(defun test-bug25503 ()
  (let ((*rpc-server* (make-xml-rpc-server
                       :start (list :port nil :listeners 3) :enable t
                       :publish '(:path "/rpc")
                       ))
	port)
    (unwind-protect
	(let ()
	  (export-xml-rpc-method *rpc-server* '("test.testString" rpc-test-string) :int :string)
    
	  (setq port (socket:local-port (net.aserve:wserver-socket net.aserve:*wserver*)))
    
	  (test 33 (values (xml-rpc-call
			    (encode-xml-rpc-call "test.testString" "<my><test><doc></doc></test></my>")
			    :url (format nil "http://localhost:~A/rpc" port))))
	  )
      (disable-xml-rpc-server *rpc-server*)
      (net.aserve:shutdown))))

(defun rpc-test-string (string)
  (format t "Argument string = ~s~%" string) ;; display it on the server
  (length string))




(when (eval '*do-test*) (test-xml-rpc))
