source: project/release/4/xml-rpc/trunk/xml-rpc-lolevel.scm @ 15214

Last change on this file since 15214 was 15214, checked in by sjamaan, 11 years ago

Implement new, properly tested, version of xml-rpc based on http-client and sxpath. TODO: documentation and xml-rpc-server module

File size: 7.2 KB
Line 
1;;;; xml-rpc-lolevel.scm
2;
3;; An implementation of the XML-RPC protocol
4;;
5;; This file contains the plumbing for XML RPC value marshaling/unmarshaling.
6;
7; Copyright (c) 2009, Peter Bex
8; Parts Copyright (c) Felix Winkelmann
9; All rights reserved.
10;
11; Redistribution and use in source and binary forms, with or without
12; modification, are permitted provided that the following conditions
13; are met:
14;
15; 1. Redistributions of source code must retain the above copyright
16;    notice, this list of conditions and the following disclaimer.
17; 2. Redistributions in binary form must reproduce the above copyright
18;    notice, this list of conditions and the following disclaimer in the
19;    documentation and/or other materials provided with the distribution.
20; 3. Neither the name of the author nor the names of its
21;    contributors may be used to endorse or promote products derived
22;    from this software without specific prior written permission.
23;
24; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
25; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
26; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
27; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
28; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
29; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
30; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
31; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
32; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
33; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
34; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
35; OF THE POSSIBILITY OF SUCH DAMAGE.
36;
37; Please report bugs, suggestions and ideas to the Chicken Trac
38; ticket tracking system (assign tickets to user 'sjamaan'):
39; http://trac.callcc.org
40
41(provide 'xml-rpc-lolevel)
42
43(module xml-rpc-lolevel
44  (signal-xml-rpc-error
45   xml-rpc-unparsers value->xml-rpc-fragment
46   list->xml-rpc-array vector->xml-rpc-array
47   number->xml-rpc-int number->xml-rpc-double
48   boolean->xml-rpc-boolean ->xml-rpc-string
49   u8vector->xml-rpc-base64 blob->xml-rpc-base64
50   alist->xml-rpc-struct hash-table->xml-rpc-struct
51   vector->xml-rpc-iso8601
52   nonempty-symbol-keyed-alist?
53
54   xml-rpc-parsers xml-rpc-fragment->value
55   xml-rpc-int->number xml-rpc-double->number
56   xml-rpc-boolean->number xml-rpc-string->string
57   xml-rpc-array->vector xml-rpc-array->list
58   xml-rpc-struct->alist xml-rpc-struct->hash-table
59   xml-rpc-base64->string xml-rpc-base64->u8vector xml-rpc-base64->blob
60   xml-rpc-datetime->vector)
61
62(import chicken scheme)
63(use data-structures posix srfi-1 srfi-4 srfi-69 base64 sxpath-lolevel)
64
65(define (signal-xml-rpc-error code msg . args)
66  (signal
67   (make-composite-condition
68    (make-property-condition 'exn 'message msg 'arguments args)
69    (make-property-condition 'xml-rpc 'code code))))
70
71(define (list->xml-rpc-array v)
72  `(array (data ,@(map (lambda (el)
73                         `(value ,(value->xml-rpc-fragment el)))
74                       v))))
75
76(define (vector->xml-rpc-array v)
77  (list->xml-rpc-array (vector->list v)))
78
79(define (number->xml-rpc-int v)
80  `(i4 ,(number->string (inexact->exact (round v)))))
81
82(define (number->xml-rpc-double v)
83  `(double ,(number->string (exact->inexact v))))
84
85(define (boolean->xml-rpc-boolean v)
86  `(boolean ,(if v "1" "0")))
87
88(define (->xml-rpc-string v)
89  `(string ,(->string v)))
90
91(define (u8vector->xml-rpc-base64 v)
92  (blob->xml-rpc-base64 (u8vector->blob/shared v)))
93
94(define (blob->xml-rpc-base64 v)
95  `(base64 ,(base64-encode (blob->string v))))
96
97(define (alist->xml-rpc-struct v)
98  `(struct ,@(map (lambda (p)
99                    `(member
100                      (name ,(->string (car p)))
101                      (value ,(value->xml-rpc-fragment (cdr p)))))
102                  v)))
103
104(define (hash-table->xml-rpc-struct v)
105  (alist->xml-rpc-struct (hash-table->alist v)))
106
107(define (vector->xml-rpc-iso8601 v)
108  `(dateTime.iso8601 ,(time->string v "%Y%m%dT%H:%M:%S")))
109
110(define (nonempty-symbol-keyed-alist? v)
111  (and (not (null? v))
112       (list? v)
113       (every (lambda (p)
114                (and (pair? p) (symbol? (car p))))
115              v)))
116
117(define xml-rpc-unparsers
118  (make-parameter `((,vector? . ,vector->xml-rpc-array)
119                    (,(conjoin number? exact?) . ,number->xml-rpc-int)
120                    (,number? . ,number->xml-rpc-double)
121                    (,boolean? . ,boolean->xml-rpc-boolean)
122                    (,string? . ,->xml-rpc-string)
123                    (,symbol? . ,->xml-rpc-string)
124                    (,u8vector? . ,u8vector->xml-rpc-base64)
125                    (,blob? . ,blob->xml-rpc-base64)
126                    (,hash-table? . ,hash-table->xml-rpc-struct)
127                    (,nonempty-symbol-keyed-alist? . ,alist->xml-rpc-struct)
128                    (,list? . ,list->xml-rpc-array))))
129
130(define (value->xml-rpc-fragment value)
131  ((alist-ref value (xml-rpc-unparsers)
132              (lambda (pred? v) (pred? v))
133              (lambda _ (error "No parser for value " value)))
134   value))
135
136(define (xml-rpc-int->number fragment)
137  (string->number (sxml:text fragment)))
138
139(define (xml-rpc-double->number fragment)
140  (string->number (sxml:text fragment)))
141
142(define (xml-rpc-boolean->number fragment)
143  (not (= (string->number (sxml:text fragment)) 0)))
144
145(define xml-rpc-string->string sxml:text)
146
147(define (xml-rpc-base64->string fragment)
148  (base64-decode (sxml:text fragment)))
149
150(define (xml-rpc-base64->u8vector fragment)
151  (blob->u8vector/shared (string->blob (base64-decode (sxml:text fragment)))))
152
153(define (xml-rpc-array->vector fragment)
154  (list->vector (xml-rpc-array->list fragment)))
155
156(define (xml-rpc-array->list fragment)
157  (map (lambda (v)
158         (xml-rpc-fragment->value v))
159       ((node-join (select-first-kid (ntype?? 'data))
160                   (select-kids (ntype?? 'value))
161                   sxml:content)
162        fragment)))
163
164(define (xml-rpc-struct->alist fragment)
165  (map (lambda (v)
166         (cons (string->symbol
167                (sxml:text ((select-first-kid (ntype?? 'name)) v)))
168               (xml-rpc-fragment->value
169                (car (sxml:content ((select-first-kid (ntype?? 'value)) v))))))
170       (sxml:content fragment)))
171
172(define (xml-rpc-struct->hash-table fragment)
173  (alist->hash-table (xml-rpc-struct->alist fragment)))
174
175(define (xml-rpc-base64->blob fragment)
176  (u8vector->blob/shared (base64-decode (cadr fragment))))
177
178(define (xml-rpc-datetime->vector fragment)
179  (string->time (cadr fragment) "%Y%m%dT%H:%M:%S"))
180
181(define xml-rpc-parsers
182  (make-parameter `((i4 . ,xml-rpc-int->number)
183                    (int . ,xml-rpc-int->number)
184                    (double . ,xml-rpc-double->number)
185                    (boolean . ,xml-rpc-boolean->number)
186                    (string . ,xml-rpc-string->string)
187                    (base64 . ,xml-rpc-base64->u8vector)
188                    (dateTime.iso8601 . ,xml-rpc-datetime->vector)
189                    (array . ,xml-rpc-array->vector)
190                    (struct . ,xml-rpc-struct->hash-table))))
191
192(define (xml-rpc-fragment->value fragment)
193  ((alist-ref (sxml:element-name fragment) (xml-rpc-parsers) eq?
194              (lambda _ (error "No unparser for tag " (car fragment))))
195   fragment))
196
197)
Note: See TracBrowser for help on using the repository browser.