1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs base64 calendar calendar.format
4 combinators debugger generic hashtables http http.client
5 http.client.private io io.encodings.string io.encodings.utf8
6 kernel make math math.order math.parser namespaces sequences
7 strings xml xml.data xml.syntax xml.traversal xml.writer ;
10 ! * Sending RPC requests
12 ! The word for what this does is "serialization"! Wow!
14 GENERIC: item>xml ( object -- xml )
17 dup 31 2^ neg 31 2^ 1 - between?
18 [ "Integers must fit in 32 bits" throw ] unless
19 [XML <i4><-></i4> XML] ;
22 "1" "0" ? [XML <boolean><-></boolean> XML] ;
25 number>string [XML <double><-></double> XML] ;
28 [XML <string><-></string> XML] ;
30 : struct-member ( name value -- tag )
31 over string? [ "Struct member name must be string" throw ] unless
41 [ struct-member ] { } assoc>map
42 [XML <struct><-></struct> XML] ;
45 [ item>xml [XML <value><-></value> XML] ] map
46 [XML <array><data><-></data></array> XML] ;
48 TUPLE: base64 string ;
54 [XML <base64><-></base64> XML] ;
56 : params ( seq -- xml )
57 [ item>xml [XML <param><value><-></value></param> XML] ] map
58 [XML <params><-></params> XML] ;
60 : method-call ( name seq -- xml )
64 <methodName><-></methodName>
69 : return-params ( seq -- xml )
70 params <XML <methodResponse><-></methodResponse> XML> ;
72 : return-fault ( fault-code fault-string -- xml )
73 [ "faultString" ,, "faultCode" ,, ] H{ } make item>xml
82 TUPLE: rpc-method name params ;
84 C: <rpc-method> rpc-method
86 TUPLE: rpc-response params ;
88 C: <rpc-response> rpc-response
90 TUPLE: rpc-fault code string ;
92 C: <rpc-fault> rpc-fault
94 GENERIC: send-rpc ( rpc -- xml )
95 M: rpc-method send-rpc
96 [ name>> ] [ params>> ] bi method-call ;
97 M: rpc-response send-rpc
98 params>> return-params ;
100 [ code>> ] [ string>> ] bi return-fault ;
102 ! * Recieving RPC requests
103 ! this needs to have much better error checking
105 ERROR: server-error tag message ;
107 M: server-error error.
108 "Error in XML supplied to server" print
109 "Description: " write dup message>> print
110 "Tag: " write tag>> xml>string print ;
112 TAGS: xml>item ( tag -- object )
117 : children>number ( tag -- n )
118 children>string string>number ;
120 TAG: i4 xml>item children>number ;
121 TAG: int xml>item children>number ;
122 TAG: double xml>item children>number ;
124 TAG: boolean xml>item
128 [ "Bad boolean" throw-server-error ]
131 : unstruct-member ( tag -- )
133 first-child-tag xml>item
134 [ children>string ] dip swap ,, ;
138 children-tags [ unstruct-member ] each
142 children>string base64> <base64> ;
145 first-child-tag children-tags
146 [ first-child-tag xml>item ] map ;
148 : params>array ( tag -- array )
150 [ first-child-tag first-child-tag xml>item ] map ;
152 : parse-rpc-response ( xml -- array )
153 first-child-tag params>array ;
155 : parse-method ( xml -- string array )
157 [ children>string ] [ params>array ] bi* ;
159 : parse-fault ( xml -- fault-code fault-string )
160 first-child-tag first-child-tag first-child-tag
161 xml>item [ "faultCode" get "faultString" get ] with-variables ;
163 : receive-rpc ( xml -- rpc )
164 dup main>> dup "methodCall" =
165 [ drop parse-method <rpc-method> ] [
167 dup first-child-tag main>> "fault" =
168 [ parse-fault <rpc-fault> ]
169 [ parse-rpc-response <rpc-response> ] if
170 ] [ "Bad main tag name" throw-server-error ] if
175 : xml-post-data ( xml -- post-data )
176 xml>string utf8 encode "text/xml" <post-data> swap >>data ;
178 : rpc-post-request ( xml url -- request )
179 [ send-rpc xml-post-data ] [ "POST" <client-request> ] bi*
184 : post-rpc ( rpc url -- rpc' )
185 ! This needs to do something in the event of an error
186 rpc-post-request http-request nip string>xml receive-rpc ;
188 : invoke-method ( params method url -- response )
189 [ swap <rpc-method> ] dip post-rpc ;