XML-RPC in contrib
microdan
parent
56dae8f3b4
commit
3e83963fbd
|
|
@ -0,0 +1,13 @@
|
||||||
|
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
REQUIRES: contrib/xml contrib/base64 contrib/http-client
|
||||||
|
contrib/httpd ;
|
||||||
|
|
||||||
|
PROVIDE: contrib/xml-rpc
|
||||||
|
{ +files+ {
|
||||||
|
"xml-rpc.factor"
|
||||||
|
"xml-rpc.facts"
|
||||||
|
} }
|
||||||
|
{ +tests+ {
|
||||||
|
"test.factor"
|
||||||
|
} } ;
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
USING: xml-rpc test ;
|
||||||
|
|
||||||
|
[ T{ rpc-method f "blah" { 1 H{ { "2" 3 } { "5" "foobar" } } } } ]
|
||||||
|
[ "blah" { 1 H{ { "2" 3 } { "5" "foobar" } } }
|
||||||
|
<rpc-method> send-rpc receive-rpc ] unit-test
|
||||||
|
|
@ -0,0 +1,143 @@
|
||||||
|
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
IN: xml-rpc
|
||||||
|
USING: kernel xml arrays math errors errors generic http-client
|
||||||
|
hashtables namespaces io base64 sequences strings ;
|
||||||
|
|
||||||
|
! * Sending RPC requests
|
||||||
|
! TODO: time
|
||||||
|
! The word for what this does is "serialization"! Wow!
|
||||||
|
|
||||||
|
GENERIC: item>xml ( object -- xml )
|
||||||
|
|
||||||
|
M: integer item>xml
|
||||||
|
dup 2 31 ^ neg 2 31 ^ 1 - between?
|
||||||
|
[ "Integers must fit in 32 bits" throw ] unless
|
||||||
|
number>string "i4" build-tag ;
|
||||||
|
|
||||||
|
PREDICATE: object boolean { t f } member? ;
|
||||||
|
|
||||||
|
M: boolean item>xml
|
||||||
|
"1" "0" ? "boolean" build-tag ;
|
||||||
|
|
||||||
|
M: float item>xml
|
||||||
|
number>string "double" build-tag ;
|
||||||
|
|
||||||
|
M: string item>xml ! This should change < and &
|
||||||
|
"string" build-tag ;
|
||||||
|
|
||||||
|
: struct-member ( name value -- tag )
|
||||||
|
swap dup string?
|
||||||
|
[ "Struct member name must be string" throw ] unless
|
||||||
|
"name" build-tag swap
|
||||||
|
item>xml "value" build-tag
|
||||||
|
2array "member" build-tag* ;
|
||||||
|
|
||||||
|
M: hashtable item>xml
|
||||||
|
[ [ struct-member , ] hash-each ] { } make
|
||||||
|
"struct" build-tag* ;
|
||||||
|
|
||||||
|
M: array item>xml
|
||||||
|
[ item>xml "value" build-tag ] map
|
||||||
|
"data" build-tag* "array" build-tag ;
|
||||||
|
|
||||||
|
TUPLE: base64 string ;
|
||||||
|
|
||||||
|
M: base64 item>xml
|
||||||
|
base64-string >base64 "base64" build-tag ;
|
||||||
|
|
||||||
|
: params ( seq -- xml )
|
||||||
|
[ item>xml "value" build-tag "param" build-tag ] map
|
||||||
|
"params" build-tag* ;
|
||||||
|
|
||||||
|
: method-call ( name seq -- xml )
|
||||||
|
params >r "methodName" build-tag r>
|
||||||
|
2array "methodCall" build-tag* build-xml-doc ;
|
||||||
|
|
||||||
|
: return-params ( seq -- xml )
|
||||||
|
params "methodResponse" build-tag build-xml-doc ;
|
||||||
|
|
||||||
|
: return-fault ( fault-code fault-string -- xml )
|
||||||
|
[ "faultString" set "faultCode" set ] make-hash item>xml
|
||||||
|
"value" build-tag "fault" build-tag "methodResponse" build-tag
|
||||||
|
build-xml-doc ;
|
||||||
|
|
||||||
|
TUPLE: rpc-method name params ;
|
||||||
|
TUPLE: rpc-response params ;
|
||||||
|
TUPLE: rpc-fault code string ;
|
||||||
|
|
||||||
|
GENERIC: send-rpc ( rpc -- xml )
|
||||||
|
M: rpc-method send-rpc
|
||||||
|
[ rpc-method-name ] keep rpc-method-params method-call ;
|
||||||
|
M: rpc-response send-rpc
|
||||||
|
rpc-response-params return-params ;
|
||||||
|
M: rpc-fault send-rpc
|
||||||
|
[ rpc-fault-code ] keep rpc-fault-string return-fault ;
|
||||||
|
|
||||||
|
! * Recieving RPC requests
|
||||||
|
! this needs to have much better error checking
|
||||||
|
|
||||||
|
TUPLE: server-error tag message ;
|
||||||
|
M: server-error error.
|
||||||
|
"Error in XML supplied to server" print
|
||||||
|
"Description: " write dup server-error-message print
|
||||||
|
"Tag: " write server-error-tag xml>string print ;
|
||||||
|
|
||||||
|
PROCESS: xml>item ( tag -- object )
|
||||||
|
|
||||||
|
TAG: string xml>item
|
||||||
|
children>string ;
|
||||||
|
|
||||||
|
TAG: i4/int/double xml>item
|
||||||
|
children>string string>number ;
|
||||||
|
|
||||||
|
TAG: boolean xml>item
|
||||||
|
dup children>string {
|
||||||
|
{ [ dup "1" = ] [ 2drop t ] }
|
||||||
|
{ [ "0" = ] [ drop f ] }
|
||||||
|
{ [ t ] [ "Bad boolean" <server-error> throw ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: unstruct-member ( tag -- )
|
||||||
|
children-tags first2
|
||||||
|
first-child-tag xml>item
|
||||||
|
>r children>string r> swap set ;
|
||||||
|
|
||||||
|
TAG: struct xml>item
|
||||||
|
[
|
||||||
|
children-tags [ unstruct-member ] each
|
||||||
|
] make-hash ;
|
||||||
|
|
||||||
|
TAG: base64 xml>item
|
||||||
|
children>string base64> <base64> ;
|
||||||
|
|
||||||
|
: params>array ( tag -- array )
|
||||||
|
children-tags
|
||||||
|
[ first-child-tag first-child-tag xml>item ] map ;
|
||||||
|
|
||||||
|
: parse-rpc-response ( xml-doc -- array )
|
||||||
|
first-child-tag params>array ;
|
||||||
|
|
||||||
|
: parse-method ( xml-doc -- string array )
|
||||||
|
children-tags dup first children>string
|
||||||
|
swap second params>array ;
|
||||||
|
|
||||||
|
: parse-fault ( xml-doc -- fault-code fault-string )
|
||||||
|
first-child-tag first-child-tag first-child-tag
|
||||||
|
xml>item [ "faultCode" get "faultString" get ] bind ;
|
||||||
|
|
||||||
|
: receive-rpc ( xml-doc -- rpc )
|
||||||
|
dup name-tag dup "methodCall" =
|
||||||
|
[ drop parse-method <rpc-method> ] [
|
||||||
|
"methodResponse" = [
|
||||||
|
dup first-child-tag name-tag "fault" =
|
||||||
|
[ parse-fault <rpc-fault> ]
|
||||||
|
[ parse-rpc-response <rpc-response> ] if
|
||||||
|
] [ "Bad main tag name" <server-error> throw ] if
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: post-rpc ( rpc url -- rpc )
|
||||||
|
! This needs to do something in the event of an error
|
||||||
|
>r "text/xml" swap send-rpc xml>string r> http-post
|
||||||
|
2nip string>xml receive-rpc ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,71 @@
|
||||||
|
USING: xml-rpc help ;
|
||||||
|
|
||||||
|
HELP: send-rpc
|
||||||
|
{ $values { "rpc" "an RPC data type" } { "xml" "an XML document" } }
|
||||||
|
{ $description "converts an RPC data type into an XML document which can be sent to another computer" }
|
||||||
|
{ $see-also receive-rpc } ;
|
||||||
|
|
||||||
|
HELP: receive-rpc
|
||||||
|
{ $values { "xml" "an XML document" } { "rpc" "an RPC data type" } }
|
||||||
|
{ $description "parses an XML document into an RPC data type, for further local processing" }
|
||||||
|
{ $see-also send-rpc } ;
|
||||||
|
|
||||||
|
HELP: <base64>
|
||||||
|
{ $values { "string" "a string" } { "base64" "a base64 tuple" } }
|
||||||
|
{ $description "creates a base64 tuple using the data in the string. This marks the data for encoding in the base64 format" }
|
||||||
|
{ $see-also base64 } ;
|
||||||
|
|
||||||
|
HELP: base64
|
||||||
|
{ $class-description "a piece of data marked for encoding as base64 in an XML-RPC message" }
|
||||||
|
{ $see-also <base64> } ;
|
||||||
|
|
||||||
|
HELP: <rpc-method>
|
||||||
|
{ $values { "name" "a string" } { "params" "a sequence" } }
|
||||||
|
{ $description "creates a tuple reprsenting a method call which can be translated using" { $code send-rpc } "into an XML-RPC document" }
|
||||||
|
{ $see-also rpc-method <rpc-response> <rpc-fault> } ;
|
||||||
|
|
||||||
|
HELP: rpc-method
|
||||||
|
{ $class-description "a tuple which is equivalent to an XML-RPC method send. Contains two fields, name and params" }
|
||||||
|
{ $see-also <rpc-method> rpc-response rpc-fault } ;
|
||||||
|
|
||||||
|
HELP: <rpc-response>
|
||||||
|
{ $values { "params" "a sequence" } }
|
||||||
|
{ $description "creates a tuple representing a data response in XML-RPC" }
|
||||||
|
{ $see-also rpc-response <rpc-method> <rpc-fault> } ;
|
||||||
|
|
||||||
|
HELP: rpc-response
|
||||||
|
{ $class-description "represents an XML-RPC method response, with a number of paramters holding data. Contains one field, params, a sequence" }
|
||||||
|
{ $see-also <rpc-response> rpc-method rpc-fault } ;
|
||||||
|
|
||||||
|
HELP: <rpc-fault>
|
||||||
|
{ $values { "code" "an integer" } { "string" "a string" } }
|
||||||
|
{ $description "creates a tuple representing an exception in RPC, to be returned to the caller. The code is a number representing what type of error it is, and the string is a description" }
|
||||||
|
{ $see-also rpc-fault <rpc-method> <rpc-response> } ;
|
||||||
|
|
||||||
|
HELP: rpc-fault
|
||||||
|
{ $class-description "represents an XML-RPC fault" }
|
||||||
|
{ $see-also <rpc-fault> rpc-method rpc-response } ;
|
||||||
|
|
||||||
|
HELP: post-rpc
|
||||||
|
{ $values { "rpc" "an XML-RPC input tuple" } { "url" "a URL" }
|
||||||
|
{ "rpc" "an XML-RPC output tuple" } }
|
||||||
|
{ $description "posts an XML-RPC document to the specified URL, receives the response and parses it as XML-RPC, returning the tuple" } ;
|
||||||
|
|
||||||
|
ARTICLE: { "xml-rpc" "intro" } "XML-RPC"
|
||||||
|
"This is the XML-RPC library. XML-RPC is used instead of SOAP because it is far simpler and easier to use for most tasks. The library was implemented by Daniel Ehrenberg."
|
||||||
|
$terpri
|
||||||
|
"The most important words that this library implements are:"
|
||||||
|
{ $subsection send-rpc }
|
||||||
|
{ $subsection receive-rpc }
|
||||||
|
"data types in XML-RPC"
|
||||||
|
{ $subsection base64 }
|
||||||
|
{ $subsection rpc-method }
|
||||||
|
{ $subsection rpc-response }
|
||||||
|
{ $subsection rpc-fault }
|
||||||
|
"the constructors for these are"
|
||||||
|
{ $subsection <base64> }
|
||||||
|
{ $subsection <rpc-method> }
|
||||||
|
{ $subsection <rpc-response> }
|
||||||
|
{ $subsection <rpc-fault> }
|
||||||
|
"other words include"
|
||||||
|
{ $subsection post-rpc } ;
|
||||||
Loading…
Reference in New Issue