Use xml.interpolate for xml-rpc
parent
02b09fdca4
commit
dd553440dc
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors kernel xml arrays math generic http.client
|
USING: accessors kernel xml arrays math generic http.client
|
||||||
combinators hashtables namespaces io base64 sequences strings
|
combinators hashtables namespaces io base64 sequences strings
|
||||||
calendar xml.data xml.writer xml.utilities assocs math.parser
|
calendar xml.data xml.writer xml.utilities assocs math.parser
|
||||||
debugger calendar.format math.order ;
|
debugger calendar.format math.order xml.interpolate ;
|
||||||
IN: xml-rpc
|
IN: xml-rpc
|
||||||
|
|
||||||
! * Sending RPC requests
|
! * Sending RPC requests
|
||||||
|
@ -15,56 +15,70 @@ GENERIC: item>xml ( object -- xml )
|
||||||
M: integer item>xml
|
M: integer item>xml
|
||||||
dup 31 2^ neg 31 2^ 1 - between?
|
dup 31 2^ neg 31 2^ 1 - between?
|
||||||
[ "Integers must fit in 32 bits" throw ] unless
|
[ "Integers must fit in 32 bits" throw ] unless
|
||||||
number>string "i4" build-tag ;
|
number>string [XML <i4><-></i4> XML] ;
|
||||||
|
|
||||||
UNION: boolean t POSTPONE: f ;
|
UNION: boolean t POSTPONE: f ;
|
||||||
|
|
||||||
M: boolean item>xml
|
M: boolean item>xml
|
||||||
"1" "0" ? "boolean" build-tag ;
|
"1" "0" ? [XML <boolean><-></boolean> XML] ;
|
||||||
|
|
||||||
M: float item>xml
|
M: float item>xml
|
||||||
number>string "double" build-tag ;
|
number>string [XML <double><-></double> XML] ;
|
||||||
|
|
||||||
M: string item>xml ! This should change < and &
|
M: string item>xml
|
||||||
"string" build-tag ;
|
[XML <string><-></string> XML] ;
|
||||||
|
|
||||||
: struct-member ( name value -- tag )
|
: struct-member ( name value -- tag )
|
||||||
swap dup string?
|
over string? [ "Struct member name must be string" throw ] unless
|
||||||
[ "Struct member name must be string" throw ] unless
|
item>xml
|
||||||
"name" build-tag swap
|
[XML
|
||||||
item>xml "value" build-tag
|
<member>
|
||||||
2array "member" build-tag* ;
|
<name><-></name>
|
||||||
|
<value><-></value>
|
||||||
|
</member>
|
||||||
|
XML] ;
|
||||||
|
|
||||||
M: hashtable item>xml
|
M: hashtable item>xml
|
||||||
[ struct-member ] { } assoc>map
|
[ struct-member ] { } assoc>map
|
||||||
"struct" build-tag* ;
|
[XML <struct><-></struct> XML] ;
|
||||||
|
|
||||||
M: array item>xml
|
M: array item>xml
|
||||||
[ item>xml "value" build-tag ] map
|
[ item>xml [XML <value><-></value> XML] ] map
|
||||||
"data" build-tag* "array" build-tag ;
|
[XML <array><data><-></data></array> XML] ;
|
||||||
|
|
||||||
TUPLE: base64 string ;
|
TUPLE: base64 string ;
|
||||||
|
|
||||||
C: <base64> base64
|
C: <base64> base64
|
||||||
|
|
||||||
M: base64 item>xml
|
M: base64 item>xml
|
||||||
string>> >base64 "base64" build-tag ;
|
string>> >base64
|
||||||
|
[XML <base64><-></base64> XML] ;
|
||||||
|
|
||||||
: params ( seq -- xml )
|
: params ( seq -- xml )
|
||||||
[ item>xml "value" build-tag "param" build-tag ] map
|
[ item>xml [XML <param><value><-></value></param> XML] ] map
|
||||||
"params" build-tag* ;
|
[XML <params><-></params> XML] ;
|
||||||
|
|
||||||
: method-call ( name seq -- xml )
|
: method-call ( name seq -- xml )
|
||||||
params [ "methodName" build-tag ] dip
|
params
|
||||||
2array "methodCall" build-tag* build-xml ;
|
<XML
|
||||||
|
<methodCall>
|
||||||
|
<methodName><-></methodName>
|
||||||
|
<->
|
||||||
|
</methodCall>
|
||||||
|
XML> ;
|
||||||
|
|
||||||
: return-params ( seq -- xml )
|
: return-params ( seq -- xml )
|
||||||
params "methodResponse" build-tag build-xml ;
|
params <XML <methodResponse><-></methodResponse> XML> ;
|
||||||
|
|
||||||
: return-fault ( fault-code fault-string -- xml )
|
: return-fault ( fault-code fault-string -- xml )
|
||||||
[ "faultString" set "faultCode" set ] H{ } make-assoc item>xml
|
[ "faultString" set "faultCode" set ] H{ } make-assoc item>xml
|
||||||
"value" build-tag "fault" build-tag "methodResponse" build-tag
|
<XML
|
||||||
build-xml ;
|
<methodResponse>
|
||||||
|
<fault>
|
||||||
|
<value><-></value>
|
||||||
|
</fault>
|
||||||
|
</methodResponse>
|
||||||
|
XML> ;
|
||||||
|
|
||||||
TUPLE: rpc-method name params ;
|
TUPLE: rpc-method name params ;
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: xml xml.state kernel sequences fry assocs xml.data
|
USING: xml xml.state kernel sequences fry assocs xml.data
|
||||||
accessors strings make multiline parser namespaces macros
|
accessors strings make multiline parser namespaces macros
|
||||||
sequences.deep generalizations locals words combinators
|
sequences.deep generalizations locals words combinators
|
||||||
math present ;
|
math present arrays ;
|
||||||
IN: xml.interpolate
|
IN: xml.interpolate
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
@ -31,7 +31,8 @@ DEFER: interpolate-sequence
|
||||||
GENERIC: push-item ( item -- )
|
GENERIC: push-item ( item -- )
|
||||||
M: string push-item , ;
|
M: string push-item , ;
|
||||||
M: object push-item , ;
|
M: object push-item , ;
|
||||||
M: sequence push-item % ;
|
M: sequence push-item
|
||||||
|
[ dup array? [ % ] [ , ] if ] each ;
|
||||||
|
|
||||||
GENERIC: interpolate-item ( table item -- )
|
GENERIC: interpolate-item ( table item -- )
|
||||||
M: object interpolate-item nip , ;
|
M: object interpolate-item nip , ;
|
||||||
|
|
Loading…
Reference in New Issue