1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel xml arrays math generic http.client combinators
4 hashtables namespaces io base64 sequences strings calendar
5 xml.data xml.writer xml.utilities assocs math.parser debugger
6 calendar.format math.order ;
9 ! * Sending RPC requests
11 ! The word for what this does is "serialization"! Wow!
13 GENERIC: item>xml ( object -- xml )
16 dup 31 2^ neg 31 2^ 1 - between?
17 [ "Integers must fit in 32 bits" throw ] unless
18 number>string "i4" build-tag ;
20 PREDICATE: boolean < object { t f } member? ;
23 "1" "0" ? "boolean" build-tag ;
26 number>string "double" build-tag ;
28 M: string item>xml ! This should change < and &
31 : struct-member ( name value -- tag )
33 [ "Struct member name must be string" throw ] unless
35 item>xml "value" build-tag
36 2array "member" build-tag* ;
39 [ struct-member ] { } assoc>map
43 [ item>xml "value" build-tag ] map
44 "data" build-tag* "array" build-tag ;
46 TUPLE: base64 string ;
51 base64-string >base64 "base64" build-tag ;
53 : params ( seq -- xml )
54 [ item>xml "value" build-tag "param" build-tag ] map
57 : method-call ( name seq -- xml )
58 params >r "methodName" build-tag r>
59 2array "methodCall" build-tag* build-xml ;
61 : return-params ( seq -- xml )
62 params "methodResponse" build-tag build-xml ;
64 : return-fault ( fault-code fault-string -- xml )
65 [ "faultString" set "faultCode" set ] H{ } make-assoc item>xml
66 "value" build-tag "fault" build-tag "methodResponse" build-tag
69 TUPLE: rpc-method name params ;
71 C: <rpc-method> rpc-method
73 TUPLE: rpc-response params ;
75 C: <rpc-response> rpc-response
77 TUPLE: rpc-fault code string ;
79 C: <rpc-fault> rpc-fault
81 GENERIC: send-rpc ( rpc -- xml )
82 M: rpc-method send-rpc
83 [ rpc-method-name ] keep rpc-method-params method-call ;
84 M: rpc-response send-rpc
85 rpc-response-params return-params ;
87 [ rpc-fault-code ] keep rpc-fault-string return-fault ;
89 ! * Recieving RPC requests
90 ! this needs to have much better error checking
92 TUPLE: server-error tag message ;
94 : server-error ( tag message -- * )
95 \ server-error boa throw ;
97 M: server-error error.
98 "Error in XML supplied to server" print
99 "Description: " write dup server-error-message print
100 "Tag: " write server-error-tag xml>string print ;
102 PROCESS: xml>item ( tag -- object )
107 TAG: i4/int/double xml>item
108 children>string string>number ;
110 TAG: boolean xml>item
111 dup children>string {
112 { [ dup "1" = ] [ 2drop t ] }
113 { [ "0" = ] [ drop f ] }
114 [ "Bad boolean" server-error ]
117 : unstruct-member ( tag -- )
119 first-child-tag xml>item
120 >r children>string r> swap set ;
124 children-tags [ unstruct-member ] each
128 children>string base64> <base64> ;
131 first-child-tag children-tags
132 [ first-child-tag xml>item ] map ;
134 : params>array ( tag -- array )
136 [ first-child-tag first-child-tag xml>item ] map ;
138 : parse-rpc-response ( xml -- array )
139 first-child-tag params>array ;
141 : parse-method ( xml -- string array )
142 children-tags dup first children>string
143 swap second params>array ;
145 : parse-fault ( xml -- fault-code fault-string )
146 first-child-tag first-child-tag first-child-tag
147 xml>item [ "faultCode" get "faultString" get ] bind ;
149 : receive-rpc ( xml -- rpc )
150 dup name-tag dup "methodCall" =
151 [ drop parse-method <rpc-method> ] [
153 dup first-child-tag name-tag "fault" =
154 [ parse-fault <rpc-fault> ]
155 [ parse-rpc-response <rpc-response> ] if
156 ] [ "Bad main tag name" server-error ] if
159 : post-rpc ( rpc url -- rpc )
160 ! This needs to do something in the event of an error
161 >r send-rpc r> http-post nip string>xml receive-rpc ;
163 : invoke-method ( params method url -- )
164 >r swap <rpc-method> r> post-rpc ;
166 : put-http-response ( string -- )
167 "HTTP/1.1 200 OK\nConnection: close\nContent-Length: " write
168 dup length number>string write
169 "\nContent-Type: text/xml\nDate: " write
170 now timestamp>http-string write "\n\n" write