cxml-rpc/decoding.lisp at master · antifuchs/cxml-rpc · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
(in-package :cxml-rpc)

(defun skip-characters (source)
  (apply #'concatenate 'string
         (loop while (eql :characters (klacks:peek source))
               collect (nth-value 1 (klacks:skip source :characters)))))

(defun skip* (source &rest args)
  (skip-characters source)
  (apply #'klacks:skip source args)
  (skip-characters source))

(defun invoke-expecting-element/consuming (source element continuation)
  (klacks:expecting-element (source element)
    (skip* source :start-element nil element)
    (multiple-value-prog1 (progn (funcall continuation source))
                          (skip-characters source))))

(defmacro expecting-element/consuming ((source lname) &body body)
  `(flet ((expecting-element-continuation (,source)
            ,@body))
     (invoke-expecting-element/consuming ,source ,lname
                                         #'expecting-element-continuation)))

(defun invoke-expecting-element/characters (source element continuation)
  (klacks:expecting-element (source element)
    (klacks:skip source :start-element nil element)
    (let ((characters (skip-characters source)))
      (funcall continuation source characters))))

(defmacro expecting-element/characters ((source lname character-var) &body body)
  `(flet ((expecting-element/characters-continuation
              (,source ,character-var)
            (declare (ignorable source))
            ,@body))
     (invoke-expecting-element/characters
      ,source ,lname
      #'expecting-element/characters-continuation)))

(defun decode-method-call (stream)
  (klacks:with-open-source (source (cxml:make-source stream))
    (klacks:find-element source "methodCall")
    (skip* source :start-element nil "methodCall")
    (let ((method-name (decode-method-name source)))
      (if (eql :end-element (klacks:peek source))
          method-name
          (expecting-element/consuming (source "params")
            (apply #'values
                   method-name
                   (loop while (eql :start-element (klacks:peek source))
                         for (value type) = (multiple-value-list
                                             (decode-parameter source))
                         collect value into params
                         collect type into param-types
                         do (skip-characters source)
                         finally (return (list param-types params)))))))))

(defun decode-response (stream)
  (klacks:with-open-source (source (cxml:make-source stream))
    (let (response-type)
      (klacks:find-element source "methodResponse")
      (klacks:consume source)
      (setf response-type (nth-value 2 (klacks:find-element source)))
      (when (equal response-type "fault")
        (expecting-element/consuming (source "fault")
          (let ((fault (decode-value source)))
            (error 'cxml-rpc-fault
                   :fault-code (third (assoc "faultCode" fault :test #'equal))
                   :fault-phrase (third (assoc "faultString" fault
                                               :test #'equal))))))
      (expecting-element/consuming (source "params")
        (decode-parameter source)))))

(defun decode-parameter (source)
  (expecting-element/consuming (source "param")
    (decode-value source)))

(defun decode-method-name (source)
  (multiple-value-prog1 (expecting-element/characters (source "methodName" name)
                          name)
                        (skip-characters source)))

(defun decode-name (source)
  (multiple-value-prog1 (expecting-element/characters (source "name" name)
                          name)
                        (skip-characters source)))

(defun decode-value (source)
  (klacks:expecting-element (source "value")
    (klacks:consume source)
    (multiple-value-bind (type val1 val2) (klacks:peek source)
      (declare (ignore val1))
      (ecase type
        (:characters ; Stupid: if no type is specified, it's a string...
         (multiple-value-prog1
           (multiple-value-bind (value type) (decode-object :lazy-string source)
             ;; ...but some impls insist on indenting the contents of
             ;; <values>:
             (if value
                 (values value type)
                 (multiple-value-prog1
                   (decode-object
                    (type-tag-for (nth-value 2 (klacks:peek source)))
                    source)
                   (skip-characters source))))))
        (:start-element
         (multiple-value-prog1 (decode-object (type-tag-for val2) source)
                               (skip-characters source)))
        (:end-element (values "" :string))))))

(defvar *xml-rpc-type-alist* '(("dateTime.iso8601" . :time)
                               ("string" . :string)
                               ("i4" . :integer)
                               ("int" . :integer)
                               ("double" . :double)
                               ("boolean" . :boolean)
                               ("base64" . :base64)
                               ("struct" . :struct)
                               ("array" . :array)))

(defun type-tag-for (tag)
  (cdr (assoc tag *xml-rpc-type-alist* :test #'equal)))

(defun xmlrpc-type-tag (lisp-tag)
  (car (find lisp-tag *xml-rpc-type-alist* :key 'cdr)))

(defun first-invalid-integer-position (string)
  (position-if-not (lambda (c) (or (eql c #\-) (eql c #\+) (digit-char-p c)))
                   string))

(defun decode-time (string)
  (let ((year (subseq string 0 4))
        (month (subseq string 4 6))
        (date (subseq string 6 8))
        (utc-marker (subseq string 8 9))
        (hour (subseq string 9 11))
        (minute (subseq string 12 14))
        (second (subseq string 15 17)))
    (apply #'encode-universal-time
           (mapcar #'parse-integer
                   `(,second ,minute ,hour ,date ,month ,year
                             ,@(when (equal utc-marker "Z")
                                 (list "0")))))))

(defgeneric decode-object (type source)
  (:method ((type (eql :lazy-string)) source)
    (let ((string (skip-characters source)))
      (when (eql :end-element (klacks:peek source))
        (values string :string))))
  (:method ((type (eql :string)) source)
    (expecting-element/characters (source "string" chars)
      (values chars :string)))
  (:method ((type (eql :time)) source)
    (expecting-element/characters (source "dateTime.iso8601" chars)
      (values (decode-time chars) :time)))
  (:method ((type (eql :integer)) source)
    (let ((integer-spec (nth-value 2 (klacks:peek source))))
      (expecting-element/characters (source integer-spec chars)
        (let ((value (parse-integer chars :junk-allowed t)))
          (when (first-invalid-integer-position chars)
            (error 'malformed-value-content
                   :type integer-spec :content chars))
          (values value :integer)))))
  (:method ((type (eql :boolean)) source)
    (expecting-element/characters (source "boolean" chars)
      (values (cond ((string= chars "1") t)
                    ((string= chars "0") nil)
                    (t (error 'malformed-value-content
                              :type "boolean" :content chars)))
              :boolean)))
  (:method ((type (eql :array)) source)
    (expecting-element/consuming (source "array")
      (expecting-element/consuming (source "data")
        (values
         (loop while (eql :start-element (klacks:peek source))
               for (value type) =  (multiple-value-list (decode-value source))
               collect type
               collect value
               do (skip-characters source))
         :array))))
  (:method ((type (eql :struct)) source)
    (expecting-element/consuming (source "struct")
      (values
       (loop while (eql :start-element (klacks:peek source))
             collect (expecting-element/consuming (source "member")
                       (let ((name (decode-name source)))
                         (multiple-value-bind (value type)
                             (decode-value source)
                           (list name type value))))
             do (skip-characters source))
       :struct)))
  (:method ((type (eql :base64)) source)
    (expecting-element/characters (source "base64" chars)
      (values (cl-base64:base64-string-to-usb8-array chars) :base64)))
  (:method ((type (eql :double)) source)
    (expecting-element/characters (source "double" chars)
      (when (find-if-not (lambda (c)
                           (or (digit-char-p c)
                               (member c '(#\. #\-))))
                         chars)
        (error 'malformed-value-content :type "double" :content chars))
      (handler-case (values (parse-number:parse-real-number chars) :double)
        (parse-error ()
          (error 'malformed-value-content :type "double" :content chars)))))
  (:method (type source)
    (error 'bad-type-specifier
           :element (nth-value 2 (klacks:peek source))
           :type-alist *xml-rpc-type-alist*)))