Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 118 lines (108 sloc) 4.106 kb
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
1 (in-package :cxml-rpc)
2
3
4 ;; for debugging:
5 (defun encoded-request (function-name &rest args)
6 (with-output-to-string (s)
7 (funcall (apply #'encoder function-name args) s)))
8
9 ;;; encoding
10
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
11 (defmacro do-tagged-sequence ((type value list) &body body)
12 (let ((seq (gensym))
13 (index (gensym)))
14 `(let ((,seq ,list))
15 (etypecase ,seq
16 (list (loop for (,type ,value . nil) on ,list by #'cddr
17 do (progn ,@body)))
18 (sequence
19 (assert (zerop (rem (length ,seq) 2)))
20 (loop for ,index from 0 below (length ,seq) by 2
21 for ,type = (elt ,seq ,index)
22 for ,value = (elt ,seq (1+ ,index))
23 do (progn ,@body)))))))
24
25 (defun encode-param (type object)
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
26 (with-element "param"
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
27 (encode-value type object)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
28
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
29 (defun encode-value (type object)
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
30 (with-element "value"
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
31 (encode-object type object)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
32
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
33 (defun universal-time-to-xml-rpc-time-string (utime)
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
34 (multiple-value-bind (second minute hour date month year day)
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
35 (apply #'decode-universal-time utime
36 (when *print-timestamps-in-utc-p* (list 0)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
37 (declare (ignore day))
38 (format nil "~d~2,'0d~2,'0d~A~2,'0d:~2,'0d:~2,'0d"
39 year month date
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
40 (if *print-timestamps-in-utc-p* #\Z #\T)
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
41 hour minute second)))
42
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
43 (defun encode-time (utime)
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
44 (make-instance 'xml-rpc-date
45 :universal-time utime
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
46 :iso8601 (universal-time-to-xml-rpc-time-string utime)))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
47
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
48 (defun dwim-type-for (object)
49 (etypecase object
50 (boolean :boolean)
51 ((signed-byte 32) :integer)
52 (float :double)
53 (symbol :string)
54 (string :string)
55 (integer :time) ; this feels wrong, but value is a utime with a
56 ; very high probability (:
57 (xml-rpc-date :time)
58 (file-stream :base64)
59 ((vector (unsigned-byte 8)) :base64)
60 (cons :dwim-struct)
61 (sequence :dwim-array)))
62
63 (defgeneric encode-object (type object)
64 (:method ((type (eql :boolean)) o)
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
65 (with-element "boolean"
66 (text
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
67 (if o "1" "0"))))
68 (:method ((type (eql :integer)) (o integer))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
69 (with-element (etypecase o
70 ((signed-byte 32) "i4"))
71 (text (format nil "~D" o))))
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
72 (:method ((type (eql :double)) (o number))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
73 (with-element "double"
74 (text (format nil "~F" o))))
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
75 (:method ((type (eql :string)) o)
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
76 (with-element "string"
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
77 (text (string o))))
78 (:method ((type (eql :array)) (o sequence))
79 (with-element "array"
80 (with-element "data"
81 (do-tagged-sequence (type value o)
82 (encode-value type value)))))
83 (:method ((type (eql :dwim-array)) (o sequence))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
84 (with-element "array"
85 (with-element "data"
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
86 (map nil (lambda (value)
87 (encode-value (dwim-type-for value) value))
88 o))))
89 (:method ((type (eql :base64)) (o file-stream))
90 (let* ((length (file-length o))
91 (vector (make-array length
92 :element-type (stream-element-type o))))
93 (read-sequence vector o)
94 (encode-object :base64 vector)))
95 (:method ((type (eql :base64)) (o string))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
96 (with-element "base64"
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
97 (text (cl-base64:string-to-base64-string o))))
98 (:method ((type (eql :base64)) (o sequence))
99 (with-element "base64"
100 (text (cl-base64:usb8-array-to-base64-string o))))
101 (:method ((type (eql :time)) (o integer))
102 (with-element "dateTime.iso8601"
103 (text (universal-time-to-xml-rpc-time-string o))))
104 (:method ((type (eql :time)) (o xml-rpc-date))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
105 (with-element "dateTime.iso8601"
106 (text (iso8601-of o))))
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
107 (:method ((type (eql :struct)) (alist cons))
108 (with-element "struct"
109 (loop for (name value-type value) in alist
110 do (with-element "member"
111 (with-element "name" (text name))
112 (encode-value value-type value)))))
113 (:method ((type (eql :dwim-struct)) (alist cons))
5c1273b Can decode replies now; structures, arrays implemented.
Andreas Fuchs authored
114 (with-element "struct"
f982fd8 Refactor encoding to use explicitly tagged values.
Andreas Fuchs authored
115 (loop for (name value) in alist
116 do (with-element "member"
117 (with-element "name" (text name))
118 (encode-value (dwim-type-for value) value))))))
Something went wrong with that request. Please try again.