(import (chicken blob) (chicken port) test ssax intarweb sxpath-lolevel  xml-rpc-client xml-rpc-lolevel xml-rpc-server srfi-4 srfi-13 srfi-69)

(test-begin "xml-rpc")

(test-group "Marshaling"
  (test "integer"
        `(i4 "1")
        (value->xml-rpc-fragment 1))
  (test "double"
        `(double "1.2345")
        (value->xml-rpc-fragment 1.2345))
  (test "double exact->inexact"
        `(double ,(number->string (exact->inexact 1/3)))
        (value->xml-rpc-fragment 1/3))
  (test "empty string" 
        `(string "") ;; Or (string) ?
        (value->xml-rpc-fragment ""))
  (test "string"
        `(string "fubar")
        (value->xml-rpc-fragment "fubar"))
  (test "empty symbol"
        `(string "") ;; Or (string) ?
        (value->xml-rpc-fragment '||))
  (test "symbol"
        `(string "fubar")
        (value->xml-rpc-fragment 'fubar))
  (test "empty u8vector"
        `(base64 "")
        (value->xml-rpc-fragment (u8vector)))
  (test "u8vector"
        `(base64 "YWJj")
        (value->xml-rpc-fragment (u8vector 97 98 99)))
  (test "empty blob"
        `(base64 "")
        (value->xml-rpc-fragment (string->blob "")))
  (test "blob"
        `(base64 "YWJj")
        (value->xml-rpc-fragment (string->blob "abc")))
  (test "empty vector"
        `(array (data))
        (value->xml-rpc-fragment (vector)))
  (test "vector"
        `(array (data
                 (value (string "one"))
                 (value (i4 "2"))))
        (value->xml-rpc-fragment (vector "one" 2)))
  (test "nested vector"
        `(array (data
                 (value (array (data (value (string "one")))))))
        (value->xml-rpc-fragment (vector (vector "one"))))
  (test "empty list"
        `(array (data))
        (value->xml-rpc-fragment '()))
  (test "list"
        `(array (data
                 (value (string "one"))
                 (value (i4 "2"))))
        (value->xml-rpc-fragment '("one" 2)))
  (test "nested list"
        `(array (data
                 (value (array (data (value (string "one")))))))
        (value->xml-rpc-fragment '(("one"))))  
  (test "empty hash table"
        `(struct)
        (value->xml-rpc-fragment (alist->hash-table `())))
  (test-assert
   "simple hash table"
   (let ((fragment (value->xml-rpc-fragment
                    (alist->hash-table `((qux . 1) (foo . "bar"))))))
     (or (equal? fragment
                 `(struct (member
                           (name "qux")
                           (value (i4 "1")))
                          (member
                           (name "foo")
                           (value (string "bar")))))
         (equal? fragment
                 `(struct (member
                           (name "foo")
                           (value (string "bar")))
                          (member
                           (name "qux")
                           (value (i4 "1"))))))))
  (test "nested hash table"
        `(struct
          (member
           (name "foo")
           (value (struct
                   (member
                    (name "bar")
                    (value (string "qux")))))))
        (value->xml-rpc-fragment
         (alist->hash-table `((foo . ,(alist->hash-table `((bar . "qux"))))))))
  (test "hash table with vector array"
        `(struct
          (member
           (name "foo")
           (value (array
                   (data
                    (value (string "bar"))
                    (value (string "qux")))))))
        (value->xml-rpc-fragment
         (alist->hash-table `((foo . ,(vector "bar" "qux"))))))
  (test "vector array with hash tables"
        `(array
          (data
           (value
            (struct
             (member
              (name "foo")
              (value (string "bar")))))
           (value
            (struct
             (member
              (name "qux")
              (value (string "mooh")))))))
        (value->xml-rpc-fragment
         (vector (alist->hash-table `((foo . "bar")))
                 (alist->hash-table `((qux . "mooh"))))))
  (test "simple alist"
        `(struct
          (member
           (name "qux")
           (value (i4 "1")))
          (member
           (name "foo")
           (value (string "bar"))))
        (value->xml-rpc-fragment `((qux . 1) (foo . "bar"))))
  (test "nested alist"
        `(struct
          (member
           (name "foo")
           (value (struct
                   (member
                    (name "bar")
                    (value (string "qux")))))))
        (value->xml-rpc-fragment `((foo . ((bar . "qux"))))))
  (test "alist with vector array"
        `(struct
          (member
           (name "foo")
           (value (array
                   (data
                    (value (string "bar"))
                    (value (string "qux")))))))
        (value->xml-rpc-fragment `((foo . ,(vector "bar" "qux")))))
  (test "vector array with alist"
        `(array
          (data
           (value
            (struct
             (member
              (name "foo")
              (value (string "bar")))))
           (value
            (struct
             (member
              (name "qux")
              (value (string "mooh")))))))
        (value->xml-rpc-fragment
         (vector '((foo . "bar")) '((qux . "mooh")))))
  (test "ISO8601"
        `(dateTime.iso8601 "19980717T14:08:55")
        (parameterize ((xml-rpc-unparsers
                        `((,vector? . ,vector->xml-rpc-iso8601))))
          (value->xml-rpc-fragment (vector 55 8 14 17 6 98 0 0 #f 0))))
  (test-error "complex number gives error"
              (value->xml-rpc-fragment 2+3i))
  (test-error "procedure gives error"
              (value->xml-rpc-fragment string?))
  (test-error "unknown type gives error"
              (value->xml-rpc-fragment (make-foo 1))))

(test-group "Unmarshaling"
  (test "integer (i4)"
        123
        (xml-rpc-fragment->value `(i4 "123")))
  (test "integer (int)"
        123
        (xml-rpc-fragment->value `(int "123")))
  (test "double"
        123.456
        (xml-rpc-fragment->value `(double "123.456")))
  (test "boolean false"
        #f
        (xml-rpc-fragment->value `(boolean "0")))
  (test "boolean true (correct)"
        #t
        (xml-rpc-fragment->value `(boolean "1")))
  (test "boolean true (liberal)"
        #t
        (xml-rpc-fragment->value `(boolean "2")))
  (test "empty string"
        ""
        (xml-rpc-fragment->value `(string)))
  (test "empty string (explicit data)"
        ""
        (xml-rpc-fragment->value `(string "")))
  (test "base64"
        (u8vector 97 98 99)
        (xml-rpc-fragment->value `(base64 "YWJj")))
  (test "empty array"
        (vector)
        (xml-rpc-fragment->value `(array (data))))
  (test "simple array"
        (vector 1 "abc")
        (xml-rpc-fragment->value `(array (data (value (int "1"))
                                               (value (string "abc"))))))
  (test "nested array"
        (vector (vector 1 2) (vector "abc" "def") "ghi")
        (xml-rpc-fragment->value `(array (data
                                          (value (array
                                                  (data
                                                   (value (int "1"))
                                                   (value (int "2")))))
                                          (value (array
                                                  (data
                                                   (value (string "abc"))
                                                   (value (string "def")))))
                                          (value (string "ghi"))))))
  (test "nasty nested array with attrs"
        (vector (vector 1 2) (vector "abc" "def") "ghi")
        (xml-rpc-fragment->value `(array (@ (type "list"))
                                         (data (@ (type "nested"))
                                          (value (array
                                                  (data (@ (type "flat"))
                                                   (value (int
                                                           (@ (bit "signed"))
                                                           "1"))
                                                   (value (int "2")))))
                                          (value (array
                                                  (data
                                                   (value (string "abc"))
                                                   (value (string "def")))))
                                          (value (string "ghi"))))))
  (test "empty struct"
        '()
        (hash-table->alist (xml-rpc-fragment->value `(struct))))
  (test "simple struct"
        '((foo . "bar"))
        (hash-table->alist
         (xml-rpc-fragment->value `(struct (member (name "foo")
                                                   (value (string "bar")))))))
  (test "simple struct - rearranged name/value"
        '((foo . "bar"))
        (hash-table->alist
         (xml-rpc-fragment->value `(struct (member (value (string "bar"))
                                                   (name "foo"))))))
  (test "nested struct"
        `((foo . ((bar . "qux"))))
        (map (lambda (x) (cons (car x) (hash-table->alist (cdr x))))
             (hash-table->alist
              (xml-rpc-fragment->value
               `(struct (member
                         (name "foo")
                         (value (struct
                                 (member
                                  (name "bar")
                                  (value (string "qux")))))))))))
  (test "nasty nested struct with attrs"
        `((foo . ((bar . "qux"))))
        (map (lambda (x) (cons (car x) (hash-table->alist (cdr x))))
             (hash-table->alist
              (xml-rpc-fragment->value
               `(struct (@ (lang "en"))
                        (member
                         (name (@ (dir "rtl")) "foo")
                         (value (@ (type "dictionary"))
                                (struct
                                 (member
                                  (name "bar")
                                  (value (string "qux")))))))))))
  ;; Try other different notations (ISO8601 has a variety of notations)
  (test "datetime"
        (vector 55 8 14 17 6 98 'FUBAR 'FUBAR #f 0)
        (let ((v (xml-rpc-fragment->value
                  `(dateTime.iso8601 "19980717T14:08:55"))))
          ;; Nasty workaround to account for differences in POSIX
          ;; strptime() implementations: some fill in missing numbers,
          ;; others don't.  This causes the returned vector to differ
          ;; on day of week and day of year, because that info is
          ;; not in the parsed string.
          (vector-set! v 6 'FUBAR)
          (vector-set! v 7 'FUBAR)
          v)))

(test-group "response handling"
  (test "simple response"
        '("test")
        (receive params
          (xml-rpc-response->values
          `(*TOP*
            (*PI* xml "version=\"1.0\"")
            (methodResponse
             (params
              (param (value (string "test")))))))
          params))
  (test "multi-param response (chicken extension)"
        '("test" 1 2 3)
        (receive params
          (xml-rpc-response->values
           `(*TOP*
             (*PI* xml "version=\"1.0\"")
             (methodResponse
              (params
               (param (value (string "test")))
               (param (value (i4 "1")))
               (param (value (int "2")))
               (param (value (int "3")))))))
          params))
  (test-error "fault code throws exception"
              (receive params
                (xml-rpc-response->values
                 `(*TOP*
                   (*PI* xml "version=\"1.0\"")
                   (methodResponse
                    (fault
                     (value (struct
                             (member
                              (name "faultCode")
                              (value (int "10")))
                             (member
                              (name "faultString")
                              (value (string "there was an error")))))))))
                params)))

(test-group "xml call handling"
  (test "simple call"
        '(1 2 3)
        (call-xml-rpc-proc
         `(*TOP*
           (*PI* xml "version=\"1.0\"")
           (methodCall
            (methodName "scheme.List")
            (params
             (param (value (int "1")))
             (param (value (int "2")))
             (param (value (int "3"))))))
         `((scheme.List . ,list))))
  (test "empty params"
        '1
        (call-xml-rpc-proc
         `(*TOP*
           (*PI* xml "version=\"1.0\"")
           (methodCall
            (methodName "always-one")
            (params)))
         `((always-one . ,(constantly 1)))))
  (test-error "unknown method"
              (call-xml-rpc-proc
               `(*TOP*
                 (*PI* xml "version=\"1.0\"")
                 (methodCall
                  (methodName "scheme.unknown")
                  (params
                   (param (value (int "1")))
                   (param (value (int "2")))
                   (param (value (int "3"))))))
               `((scheme.List . ,list))))
  (test-error "malformed xml error"
              (call-xml-rpc-proc
               `(*TOP*
                 (*PI* xml "version=\"1.0\"")
                 (methodCall
                  (params
                   (param (value (int "1")))
                   (param (value (int "2")))
                   (param (value (int "3"))))))
               `((scheme.List . ,list)))))

(test-group "call to xml conversion"
  (test "simple call"
        `(methodResponse
          (params
           (param (value (array (data (value (i4 "1"))
                                      (value (i4 "2"))
                                      (value (i4 "3"))))))))
        (xml-rpc-call->xml-rpc-response
         `(*TOP*
           (*PI* xml "version=\"1.0\"")
           (methodCall
            (methodName "scheme.List")
            (params
             (param (value (int "1")))
             (param (value (int "2")))
             (param (value (int "3"))))))
         `((scheme.List . ,list))))
  (test "unknown procedure"
        `(methodResponse
          (fault
           (value (struct
                   (member
                    (name "faultCode")
                    (value (i4 "1")))
                   (member
                    (name "faultString")
                    (value (string "Unknown procedure \"doesnotexist\"")))))))
        (xml-rpc-call->xml-rpc-response
         `(*TOP*
           (*PI* xml "version=\"1.0\"")
           (methodCall
            (methodName "doesnotexist")
            (params
             (param (value (int "1")))
             (param (value (int "2")))
             (param (value (int "3"))))))
         `((scheme.List . ,list))))
  (test "malformed xml"
        `(methodResponse
          (fault
           (value (struct
                   (member
                    (name "faultCode")
                    (value (i4 "2")))
                   (member
                    (name "faultString")
                    (value (string "Bad request XML")))))))
        (xml-rpc-call->xml-rpc-response
         `(*TOP*
           (*PI* xml "version=\"1.0\"")
           (somethingFubar
            (methodName "scheme.List")
            (params
             (param (value (int "1")))
             (param (value (int "2")))
             (param (value (int "3"))))))
         `((scheme.List . ,list))))
  (test "procedure error"
        `(methodResponse
          (fault
           (value (struct
                   (member
                    (name "faultCode")
                    (value (i4 "-1")))
                   (member
                    (name "faultString")
                    (value (string "Error in procedure")))))))
        (xml-rpc-call->xml-rpc-response
         `(*TOP*
           (*PI* xml "version=\"1.0\"")
           (methodCall
            (methodName "scheme.List")
            (params
             (param (value (int "1")))
             (param (value (int "2")))
             (param (value (int "3"))))))
         `((scheme.List . ,(lambda _ (error "Error in procedure")))))))

(define handler (make-xml-rpc-request-handler `((scheme.List . ,list))))

(test-group "request handling"
  (call-with-input-string "doesn't matter"
    (lambda (in)
      (let* ((resp #f)
             (out (call-with-output-string
                    (lambda (out)
                      (set! resp
                            (handler
                             (make-request port: in method: 'GET)
                             (make-response port: out)))))))
        (test 405 (response-code resp)))))
  (call-with-input-string "invalid XML"
    (lambda (in)
      (let* ((resp #f)
             (out (call-with-output-string
                    (lambda (out)
                      (set! resp
                            (handler
                             (make-request port: in method: 'POST)
                             (make-response port: out)))))))
        (test 200 (response-code resp))
        (test "Invalid XML"
              `(*TOP*
                (*PI* xml "version=\"1.0\"")
                (methodResponse
                 (fault
                  (value
                   (struct (member (name "faultCode")
                                   (value (i4 "3")))
                           (member (name "faultString")
                                   (value (string "Invalid request XML"))))))))
              (call-with-input-string out
                (lambda (in)
                  (let ((resp (read-response in)))
                    (ssax:xml->sxml (response-port resp) '()))))))))
  (define (sxml->string sxml)
    (string-concatenate (flatten (sxml:sxml->xml sxml))))
  (call-with-input-string (sxml->string `(methodCall
                                          (methodName "scheme.List")
                                          (params
                                           (param (value (int "1")))
                                           (param (value (int "2")))
                                           (param (value (int "3"))))))
    (lambda (in)
      (let* ((resp #f)
             (out (call-with-output-string
                    (lambda (out)
                      (set! resp
                            (handler
                             (make-request port: in method: 'POST)
                             (make-response port: out)))))))
        (test 200 (response-code resp))
        (test "Correct response to valid request"
              `(*TOP*
                (*PI* xml "version=\"1.0\"")
                (methodResponse
                 (params
                  (param (value (array (data (value (i4 "1"))
                                             (value (i4 "2"))
                                             (value (i4 "3")))))))))
              (call-with-input-string out
                (lambda (in)
                  (let ((resp (read-response in)))
                    (ssax:xml->sxml (response-port resp) '())))))))))

(test-end)

(unless (zero? (test-failure-count)) (exit 1))