Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 209 lines (190 sloc) 9.005 kb
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
1 (in-package :cxml-rpc)
2
3 (defun skip-characters (source)
af41687 @antifuchs Refactor decoding macros and fix escaped-entity decoding bug.
authored
4 (apply #'concatenate 'string
5 (loop while (eql :characters (klacks:peek source))
6 collect (nth-value 1 (klacks:skip source :characters)))))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
7
8 (defun skip* (source &rest args)
9 (skip-characters source)
10 (apply #'klacks:skip source args)
11 (skip-characters source))
12
af41687 @antifuchs Refactor decoding macros and fix escaped-entity decoding bug.
authored
13 (defun invoke-expecting-element/consuming (source element continuation)
14 (klacks:expecting-element (source element)
15 (skip* source :start-element nil element)
16 (multiple-value-prog1 (progn (funcall continuation source))
17 (skip-characters source))))
18
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
19 (defmacro expecting-element/consuming ((source lname) &body body)
af41687 @antifuchs Refactor decoding macros and fix escaped-entity decoding bug.
authored
20 `(flet ((expecting-element-continuation (,source)
21 ,@body))
22 (invoke-expecting-element/consuming ,source ,lname
23 #'expecting-element-continuation)))
24
25 (defun invoke-expecting-element/characters (source element continuation)
26 (klacks:expecting-element (source element)
27 (klacks:skip source :start-element nil element)
28 (let ((characters (skip-characters source)))
29 (funcall continuation source characters))))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
30
31 (defmacro expecting-element/characters ((source lname character-var) &body body)
af41687 @antifuchs Refactor decoding macros and fix escaped-entity decoding bug.
authored
32 `(flet ((expecting-element/characters-continuation
33 (,source ,character-var)
34 (declare (ignorable source))
35 ,@body))
36 (invoke-expecting-element/characters
37 ,source ,lname
38 #'expecting-element/characters-continuation)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
39
4c11456 Add a rudimentary server implementation.
Andreas Fuchs authored
40 (defun decode-method-call (stream)
41 (klacks:with-open-source (source (cxml:make-source stream))
42 (klacks:find-element source "methodCall")
43 (skip* source :start-element nil "methodCall")
44 (let ((method-name (decode-method-name source)))
45 (if (eql :end-element (klacks:peek source))
46 method-name
47 (expecting-element/consuming (source "params")
9527732 Add user-defined methods, integrate them with the rest of the system.
Andreas Fuchs authored
48 (apply #'values
49 method-name
50 (loop while (eql :start-element (klacks:peek source))
51 for (value type) = (multiple-value-list
52 (decode-parameter source))
53 collect value into params
54 collect type into param-types
55 do (skip-characters source)
56 finally (return (list param-types params)))))))))
4c11456 Add a rudimentary server implementation.
Andreas Fuchs authored
57
aef517f xrpc-struct constructor, reorder things to reduce warnings
Andreas Fuchs authored
58 (defun decode-response (stream)
4c11456 Add a rudimentary server implementation.
Andreas Fuchs authored
59 (klacks:with-open-source (source (cxml:make-source stream))
60 (let (response-type)
61 (klacks:find-element source "methodResponse")
62 (klacks:consume source)
63 (setf response-type (nth-value 2 (klacks:find-element source)))
64 (when (equal response-type "fault")
65 (expecting-element/consuming (source "fault")
66 (let ((fault (decode-value source)))
67 (error 'cxml-rpc-fault
9527732 Add user-defined methods, integrate them with the rest of the system.
Andreas Fuchs authored
68 :fault-code (third (assoc "faultCode" fault :test #'equal))
69 :fault-phrase (third (assoc "faultString" fault
70 :test #'equal))))))
4c11456 Add a rudimentary server implementation.
Andreas Fuchs authored
71 (expecting-element/consuming (source "params")
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
72 (decode-parameter source)))))
aef517f xrpc-struct constructor, reorder things to reduce warnings
Andreas Fuchs authored
73
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
74 (defun decode-parameter (source)
75 (expecting-element/consuming (source "param")
76 (decode-value source)))
77
4c11456 Add a rudimentary server implementation.
Andreas Fuchs authored
78 (defun decode-method-name (source)
79 (multiple-value-prog1 (expecting-element/characters (source "methodName" name)
80 name)
81 (skip-characters source)))
82
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
83 (defun decode-name (source)
4c11456 Add a rudimentary server implementation.
Andreas Fuchs authored
84 (multiple-value-prog1 (expecting-element/characters (source "name" name)
85 name)
86 (skip-characters source)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
87
88 (defun decode-value (source)
89 (klacks:expecting-element (source "value")
90 (klacks:consume source)
91 (multiple-value-bind (type val1 val2) (klacks:peek source)
92 (declare (ignore val1))
93 (ecase type
a211149 Export the right member-* functions
Andreas Fuchs authored
94 (:characters ; Stupid: if no type is specified, it's a string...
4c11456 Add a rudimentary server implementation.
Andreas Fuchs authored
95 (multiple-value-prog1
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
96 (multiple-value-bind (value type) (decode-object :lazy-string source)
97 ;; ...but some impls insist on indenting the contents of
98 ;; <values>:
99 (if value
100 (values value type)
101 (multiple-value-prog1
102 (decode-object
103 (type-tag-for (nth-value 2 (klacks:peek source)))
104 source)
105 (skip-characters source))))))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
106 (:start-element
4c11456 Add a rudimentary server implementation.
Andreas Fuchs authored
107 (multiple-value-prog1 (decode-object (type-tag-for val2) source)
86196b8 Fix decoder for <value/> and <string/> tags
Andreas Fuchs authored
108 (skip-characters source)))
109 (:end-element (values "" :string))))))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
110
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
111 (defvar *xml-rpc-type-alist* '(("dateTime.iso8601" . :time)
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
112 ("string" . :string)
113 ("i4" . :integer)
114 ("int" . :integer)
115 ("double" . :double)
116 ("boolean" . :boolean)
117 ("base64" . :base64)
118 ("struct" . :struct)
119 ("array" . :array)))
120
121 (defun type-tag-for (tag)
122 (cdr (assoc tag *xml-rpc-type-alist* :test #'equal)))
123
9527732 Add user-defined methods, integrate them with the rest of the system.
Andreas Fuchs authored
124 (defun xmlrpc-type-tag (lisp-tag)
125 (car (find lisp-tag *xml-rpc-type-alist* :key 'cdr)))
126
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
127 (defun first-invalid-integer-position (string)
128 (position-if-not (lambda (c) (or (eql c #\-) (eql c #\+) (digit-char-p c)))
129 string))
130
131 (defun decode-time (string)
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
132 (let ((year (subseq string 0 4))
133 (month (subseq string 4 6))
134 (date (subseq string 6 8))
135 (utc-marker (subseq string 8 9))
136 (hour (subseq string 9 11))
137 (minute (subseq string 12 14))
138 (second (subseq string 15 17)))
139 (apply #'encode-universal-time
140 (mapcar #'parse-integer
141 `(,second ,minute ,hour ,date ,month ,year
142 ,@(when (equal utc-marker "Z")
143 (list "0")))))))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
144
145 (defgeneric decode-object (type source)
146 (:method ((type (eql :lazy-string)) source)
3444c75 @antifuchs Fix decoding of implicit <string> values.
authored
147 (let ((string (skip-characters source)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
148 (when (eql :end-element (klacks:peek source))
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
149 (values string :string))))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
150 (:method ((type (eql :string)) source)
151 (expecting-element/characters (source "string" chars)
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
152 (values chars :string)))
153 (:method ((type (eql :time)) source)
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
154 (expecting-element/characters (source "dateTime.iso8601" chars)
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
155 (values (decode-time chars) :time)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
156 (:method ((type (eql :integer)) source)
157 (let ((integer-spec (nth-value 2 (klacks:peek source))))
158 (expecting-element/characters (source integer-spec chars)
159 (let ((value (parse-integer chars :junk-allowed t)))
160 (when (first-invalid-integer-position chars)
161 (error 'malformed-value-content
162 :type integer-spec :content chars))
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
163 (values value :integer)))))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
164 (:method ((type (eql :boolean)) source)
165 (expecting-element/characters (source "boolean" chars)
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
166 (values (cond ((string= chars "1") t)
167 ((string= chars "0") nil)
168 (t (error 'malformed-value-content
169 :type "boolean" :content chars)))
170 :boolean)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
171 (:method ((type (eql :array)) source)
172 (expecting-element/consuming (source "array")
173 (expecting-element/consuming (source "data")
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
174 (values
175 (loop while (eql :start-element (klacks:peek source))
176 for (value type) = (multiple-value-list (decode-value source))
177 collect type
178 collect value
179 do (skip-characters source))
180 :array))))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
181 (:method ((type (eql :struct)) source)
182 (expecting-element/consuming (source "struct")
9527732 Add user-defined methods, integrate them with the rest of the system.
Andreas Fuchs authored
183 (values
184 (loop while (eql :start-element (klacks:peek source))
185 collect (expecting-element/consuming (source "member")
186 (let ((name (decode-name source)))
187 (multiple-value-bind (value type)
188 (decode-value source)
189 (list name type value))))
190 do (skip-characters source))
191 :struct)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
192 (:method ((type (eql :base64)) source)
193 (expecting-element/characters (source "base64" chars)
b75a312 Make the decoder return type tags that the encoder can use.
Andreas Fuchs authored
194 (values (cl-base64:base64-string-to-usb8-array chars) :base64)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
195 (:method ((type (eql :double)) source)
196 (expecting-element/characters (source "double" chars)
3bb403e @antifuchs Fix float decoding failure by using parse-number for doubles.
authored
197 (when (find-if-not (lambda (c)
198 (or (digit-char-p c)
199 (member c '(#\. #\-))))
200 chars)
201 (error 'malformed-value-content :type "double" :content chars))
fb94323 @antifuchs Fix a stupid error in double decoding: Return the type tag, as well.
authored
202 (handler-case (values (parse-number:parse-real-number chars) :double)
3bb403e @antifuchs Fix float decoding failure by using parse-number for doubles.
authored
203 (parse-error ()
204 (error 'malformed-value-content :type "double" :content chars)))))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
205 (:method (type source)
4c11456 Add a rudimentary server implementation.
Andreas Fuchs authored
206 (error 'bad-type-specifier
207 :element (nth-value 2 (klacks:peek source))
3444c75 @antifuchs Fix decoding of implicit <string> values.
authored
208 :type-alist *xml-rpc-type-alist*)))
Something went wrong with that request. Please try again.