blob: ecd9073b3e297031b71ca042dfb04a9f4cba25f0 (
plain)
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
|
;;;; -*- mode: lisp -*-
;;;;
;;;; $Id: aserve.lisp,v 1.1.1.1 2004-06-09 09:02:39 scaekenberghe Exp $
;;;;
;;;; This file implements XML-RPC client and server networking based
;;;; on (Portable) AllegroServe (see http://opensource.franz.com/aserve/
;;;; or http://sourceforge.net/projects/portableaserve/), which you have
;;;; to install first.
;;;;
;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe.
;;;;
;;;; You are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
(defpackage xml-rpc-aserve
(:use common-lisp net.aserve.client net.aserve xml-rpc)
(:export
"XML-RPC-CALL"
"START-XML-RPC-ASERVE"
"PUBLISH-ASERVE-XML-RPC-HANDLER"))
(in-package :xml-rpc-aserve)
(defun xml-rpc-call-aserve (encoded &key
(url *xml-rpc-url*)
(agent *xml-rpc-agent*)
(host *xml-rpc-host*)
(port *xml-rpc-port*)
(basic-autorization *xml-rpc-authorization*)
(proxy))
(let ((xml (print-xml-string encoded)))
(multiple-value-bind (response response-code headers uri)
(do-http-request
(format nil "http://~a:~d~a" host port url)
:method :post
:protocol :http/1.0
:user-agent agent
:content-type "text/xml"
:basic-authorization basic-autorization
:content xml
:proxy proxy)
(declare (ignore headers uri))
(if (= response-code 200)
(let ((result (decode-xml-rpc (make-string-input-stream response))))
(if (typep result 'xml-rpc-fault)
(error result)
(car result)))
(error "http-error:~d" response-code)))))
(defun start-xml-rpc-aserve (&key (port *xml-rpc-port*))
(process-run-function "aserve-xml-rpc"
#'(lambda ()
(start :port port
:listeners 4
:chunking nil
:keep-alive nil))))
(defun publish-aserve-xml-rpc-handler (&key (url *xml-rpc-url*) (agent *xml-rpc-agent*))
(declare (ignore agent))
(publish :path url
:content-type "text/xml"
:function #'aserve-xml-rpc-handler))
(defun aserve-xml-rpc-handler (request entity)
(with-http-response (request
entity
:response (if (eq :post (request-method request))
*response-ok*
*response-bad-request*))
(with-http-body (request entity)
(let ((body (get-request-body request))
(id (process-name *current-process*)))
(with-input-from-string (in body)
(let ((xml (handle-xml-rpc-call in id)))
(format-debug t "~d sending ~a~%" id xml)
(princ xml *html-stream*)))))))
;;;; eof
|
