From 3e83963fbd00455b3310f01a6673615642bf4c7b Mon Sep 17 00:00:00 2001 From: microdan Date: Fri, 24 Nov 2006 01:21:42 +0000 Subject: [PATCH] XML-RPC in contrib --- contrib/xml-rpc/load.factor | 13 +++ contrib/xml-rpc/test.factor | 5 ++ contrib/xml-rpc/xml-rpc.factor | 143 +++++++++++++++++++++++++++++++++ contrib/xml-rpc/xml-rpc.facts | 71 ++++++++++++++++ 4 files changed, 232 insertions(+) create mode 100644 contrib/xml-rpc/load.factor create mode 100644 contrib/xml-rpc/test.factor create mode 100644 contrib/xml-rpc/xml-rpc.factor create mode 100644 contrib/xml-rpc/xml-rpc.facts diff --git a/contrib/xml-rpc/load.factor b/contrib/xml-rpc/load.factor new file mode 100644 index 0000000000..5cad9c3f24 --- /dev/null +++ b/contrib/xml-rpc/load.factor @@ -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" +} } ; diff --git a/contrib/xml-rpc/test.factor b/contrib/xml-rpc/test.factor new file mode 100644 index 0000000000..de5ce3cb6d --- /dev/null +++ b/contrib/xml-rpc/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" } } } + send-rpc receive-rpc ] unit-test diff --git a/contrib/xml-rpc/xml-rpc.factor b/contrib/xml-rpc/xml-rpc.factor new file mode 100644 index 0000000000..e464539471 --- /dev/null +++ b/contrib/xml-rpc/xml-rpc.factor @@ -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" 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> ; + +: 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 ] [ + "methodResponse" = [ + dup first-child-tag name-tag "fault" = + [ parse-fault ] + [ parse-rpc-response ] if + ] [ "Bad main tag name" 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 ; + diff --git a/contrib/xml-rpc/xml-rpc.facts b/contrib/xml-rpc/xml-rpc.facts new file mode 100644 index 0000000000..d828849281 --- /dev/null +++ b/contrib/xml-rpc/xml-rpc.facts @@ -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: +{ $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 } ; + +HELP: +{ $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 } ; + +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-response rpc-fault } ; + +HELP: +{ $values { "params" "a sequence" } } +{ $description "creates a tuple representing a data response in XML-RPC" } +{ $see-also rpc-response } ; + +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-method rpc-fault } ; + +HELP: +{ $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 } ; + +HELP: rpc-fault +{ $class-description "represents an XML-RPC fault" } +{ $see-also 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 } + { $subsection } + { $subsection } + { $subsection } + "other words include" + { $subsection post-rpc } ;