Hi,
two weeks ago I decided to start my path to practical Scheme by adding
new features to an existing project. This would help me seeing how
experimented Scheme programmers work and also safe me from finding a new
idea and start from scratch, which sometimes is a bit discouraging.
I took tekuti, Andy Wingo's blog software, and I'm having lots of fun
with it. One of the features I added was the support of the Movable
Type XMLRPC API, so I could post and edit articles from a desktop
client.
After a few tries I thought I could create a generic XMLRPC library for
Guile, and this is what's this post about, the (tekuti xmlrpc) module.
I would be very happy to receive your inputs so I can improve it in all
senses. Note that the library does not support error handling yet.
(tekuti xmlrpc) attached and basic documentation below.
Best regards and thanks in advance.
Aleix
---------
*** XMLRPC requests ***
- xml->sxmlrpc-request str
Given an XML string return an association list representing an
XMLRPC request with two pairs:
'((method . methodName)
(params . (param1 param2 ... paramN)))
param is the ordered list of the XMLRPC function call
parameters. XMLRPC parameters are mapped to Scheme types as follows:
boolean -> boolean
i4 / int -> number
double -> number
string -> string
base64 -> string (base64 kept)
structure -> association list
array -> list
dateTime.iso8601 -> date
- sxmlrpc-request-method req
Return the method of an XMLRPC request.
- sxmlrpc-request-params req
Return the parameters of an XMLRPC request.
*** XMLRPC responses ***
- sxmlrpc-integer v
Create an XMLRPC integer.
(sxmlrpc-integer 34) -> <int>34</int>
- sxmlrpc-boolean b
Create an XMLRPC boolean.
(sxmlrpc-boolean #t) -> <boolean>1</boolean>
- sxmlrpc-string s
Create an XMLRPC string.
(sxmlrpc-string "Hello!") -> <string>Hello!</string>
- sxmlrpc-base64 b64
Create an XMLRPC Base64 string.
(sxmlrpc-base64 "eWHJlYWQgdGhpcyE=") ->
<base64>eWHJlYWQgdGhpcyE=</base64>
- sxmlrpc-date d
Create an XMLRPC date.
(sxmlrpc-date (current-date)) ->
<dateTime.iso8601>20100114T00:01:02</dateTime.iso8601>
- sxmlrpc-array data f-type
Create an XMLRPC array for the given data list. Each item in the list
will be of the XMLRPC type obtained from the f-type procedure.
(sxmlrpc-array '(1 2 3) sxmlrpc-integer)
->
<array>
<data>
<value><int>1</int></value>
<value><int>2</int></value>
<value><int>3</int></value>
</data>
</array>
- sxmlrpc-struct members
Create an XMLRPC structure where each entry is a pair from the given
members.
(sxmlrpc-struct `((blogId . ,(sxmlrpc-integer 14))
(blogName . ,(sxmlrpc-string "Just another blog")))
->
<struct>
<member>
<name>blogId</name>
<value><int>14</int></value>
</member>
<member>
<name>blogName</name>
<value><string>Just another blog</string></value>
</member>
</struct>
- sxmlrpc-fault code message
Create an XMLRPC fault message.
(sxmlrpc-fault 23 "Authorization required")
->
<fault>
<value>
<struct>
<member>
<name>faultCode</name>
<value>23</value>
</member>
<member>
<name>faultString</name>
<value>Authorization required</value>
</member>
</struct
</value>
- sxmlrpc-fault->xml fault port
Create an XMLRPC response fault string with the given fault (obtained
with sxmlrpc-fault) and write it to the given port.
- sxmlrpc-response->xml param port
Create an XMLRPC response string with the given XMLRPC parameter and
write it to the specified port.
XMLRPC parameter is one obtained from: sxmlrpc-string, sxmlrpc-struct,
sxmlrpc-array...
;; Tekuti
;; Copyright (C) 2011 Aleix Conchillo Flaque <aconchillo at gmail dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA [email protected]
;;; Commentary:
;;
;; Tekuti generic XMLRPC support.
;;
;;; Code:
(define-module (tekuti xmlrpc)
#:use-module (rnrs bytevectors)
#:use-module (sxml simple)
#:use-module (sxml xpath)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:export (sxmlrpc-request-method
sxmlrpc-request-params
sxmlrpc-struct sxmlrpc-array
sxmlrpc-string sxmlrpc-integer
sxmlrpc-boolean sxmlrpc-date
sxmlrpc-fault
xml->sxmlrpc-request
sxml->sxmlrpc-request
sxmlrpc-fault->xml
sxmlrpc-response->xml))
(define (sxml->sxmlrpc-request x)
(define (native-type t)
(let-values (((type value) (car+cdr t)))
(case type
((i4) (if (null? value) 0 (string->number (car value))))
((int) (if (null? value) 0 (string->number (car value))))
((double) (if (null? value) 0.0 (string->number (car value))))
((string) (if (null? value) "" (car value)))
((base64) (if (null? value) "" (car value)))
((boolean) (if (null? value)
#f
(not (zero? (string->number (car value))))))
((dateTime.iso8601) (if (null? value)
(current-date)
(string->date (car value)
"~Y~m~dT~H:~M:~S")))
((struct)
(map
(lambda (n v) (cons (string->symbol (second n))
(native-type (second v))))
((sxpath '(name)) value)
((sxpath '(value)) value)))
((array)
(list->vector
(map
(lambda (v) (native-type (second v)))
((sxpath '(value)) value)))))))
(list (cons 'method
(string->symbol (cadar ((sxpath '(methodCall methodName)) x))))
(cons 'params
(map
(lambda (v) (native-type (second v)))
((sxpath '(// params param value)) x)))))
(define (sxmlrpc-request-method request)
(assq-ref request 'method))
(define (sxmlrpc-request-params request)
(assq-ref request 'params))
(define (sxmlrpc-struct members)
`(struct ,(map (lambda (m) `(member (name ,(first m))
(value ,(cdr m)))) members)))
(define (sxmlrpc-array data f-type)
`(array (data ,(map (lambda (v) `(value ,(f-type v))) data))))
(define (sxmlrpc-string s)
`(string ,s))
(define (sxmlrpc-base64 s)
`(base64 ,s))
(define (sxmlrpc-integer v)
`(int ,v))
(define (sxmlrpc-boolean b)
`(boolean ,(if b 1 0)))
(define (sxmlrpc-date d)
`(dateTime.iso8601 ,(date->string d "~Y~m~dT~H:~M:~S")))
(define (sxmlrpc-fault code message)
`(fault (value ,(sxmlrpc-struct `((faultCode . ,code)
(faultString . ,message))))))
(define (sxmlrpc-fault->xml fault port)
(sxml->xml `(methodResponse ,fault) port))
(define (sxmlrpc-response->xml param port)
(sxml->xml `(methodResponse (params (param (value ,param)))) port))
(define (xml->sxmlrpc-request s)
(define (remove-whitespace-nodes sxml)
(define (node-fix node)
(cond ((symbol? node) node)
((string? node) (if (string-null? (string-trim node))
#nil
node))
(else (remove-whitespace-nodes node))))
(delete #nil (map node-fix sxml)))
(let* ((xml (utf8->string s))
(sxml (with-input-from-string xml xml->sxml)))
(sxml->sxmlrpc-request (remove-whitespace-nodes sxml))))
