basis/xml-rpc/xml-rpc.factor

   1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel xml arrays math generic http.client
   4 combinators hashtables namespaces io base64 sequences strings
   5 calendar xml.data xml.writer xml.utilities assocs math.parser
   6 debugger calendar.format math.order xml.interpolate ;
   7 IN: xml-rpc
   8
   9 ! * Sending RPC requests
  10 ! TODO: time
  11 ! The word for what this does is "serialization"! Wow!
  12
  13 GENERIC: item>xml ( object -- xml )
  14
  15 M: integer item>xml
  16     dup 31 2^ neg 31 2^ 1 - between?
  17     [ "Integers must fit in 32 bits" throw ] unless
  18     number>string [XML <i4><-></i4> XML] ;
  19
  20 UNION: boolean t POSTPONE: f ;
  21
  22 M: boolean item>xml
  23     "1" "0" ? [XML <boolean><-></boolean> XML] ;
  24
  25 M: float item>xml
  26     number>string [XML <double><-></double> XML] ;
  27
  28 M: string item>xml
  29     [XML <string><-></string> XML] ;
  30
  31 : struct-member ( name value -- tag )
  32     over string? [ "Struct member name must be string" throw ] unless
  33     item>xml
  34     [XML
  35         <member>
  36             <name><-></name>
  37             <value><-></value>
  38         </member>
  39     XML] ;
  40
  41 M: hashtable item>xml
  42     [ struct-member ] { } assoc>map
  43     [XML <struct><-></struct> XML] ;
  44
  45 M: array item>xml
  46     [ item>xml [XML <value><-></value> XML] ] map
  47     [XML <array><data><-></data></array> XML] ;
  48
  49 TUPLE: base64 string ;
  50
  51 C: <base64> base64
  52
  53 M: base64 item>xml
  54     string>> >base64
  55     [XML <base64><-></base64> XML] ;
  56
  57 : params ( seq -- xml )
  58     [ item>xml [XML <param><value><-></value></param> XML] ] map
  59     [XML <params><-></params> XML] ;
  60
  61 : method-call ( name seq -- xml )
  62     params
  63     <XML
  64         <methodCall>
  65             <methodName><-></methodName>
  66             <->
  67         </methodCall>
  68     XML> ;
  69
  70 : return-params ( seq -- xml )
  71     params <XML <methodResponse><-></methodResponse> XML> ;
  72
  73 : return-fault ( fault-code fault-string -- xml )
  74     [ "faultString" set "faultCode" set ] H{ } make-assoc item>xml
  75     <XML
  76         <methodResponse>
  77             <fault>
  78                 <value><-></value>
  79             </fault>
  80         </methodResponse>
  81     XML> ;
  82
  83 TUPLE: rpc-method name params ;
  84
  85 C: <rpc-method> rpc-method
  86
  87 TUPLE: rpc-response params ;
  88
  89 C: <rpc-response> rpc-response
  90
  91 TUPLE: rpc-fault code string ;
  92
  93 C: <rpc-fault> rpc-fault
  94
  95 GENERIC: send-rpc ( rpc -- xml )
  96 M: rpc-method send-rpc
  97     [ name>> ] [ params>> ] bi method-call ;
  98 M: rpc-response send-rpc
  99     params>> return-params ;
 100 M: rpc-fault send-rpc
 101     [ code>> ] [ string>> ] bi return-fault ;
 102
 103 ! * Recieving RPC requests
 104 ! this needs to have much better error checking
 105
 106 TUPLE: server-error tag message ;
 107
 108 : server-error ( tag message -- * )
 109     \ server-error boa throw ;
 110
 111 M: server-error error.
 112     "Error in XML supplied to server" print
 113     "Description: " write dup message>> print
 114     "Tag: " write tag>> xml>string print ;
 115
 116 PROCESS: xml>item ( tag -- object )
 117
 118 TAG: string xml>item
 119     children>string ;
 120
 121 TAG: i4/int/double xml>item
 122     children>string string>number ;
 123
 124 TAG: boolean xml>item
 125     dup children>string {
 126         { [ dup "1" = ] [ 2drop t ] }
 127         { [ "0" = ] [ drop f ] }
 128         [ "Bad boolean" server-error ]
 129     } cond ;
 130
 131 : unstruct-member ( tag -- )
 132     children-tags first2
 133     first-child-tag xml>item
 134     [ children>string ] dip swap set ;
 135
 136 TAG: struct xml>item
 137     [
 138         children-tags [ unstruct-member ] each
 139     ] H{ } make-assoc ;
 140
 141 TAG: base64 xml>item
 142     children>string base64> <base64> ;
 143
 144 TAG: array xml>item
 145     first-child-tag children-tags
 146     [ first-child-tag xml>item ] map ;
 147
 148 : params>array ( tag -- array )
 149     children-tags
 150     [ first-child-tag first-child-tag xml>item ] map ;
 151
 152 : parse-rpc-response ( xml -- array )
 153     first-child-tag params>array ;
 154
 155 : parse-method ( xml -- string array )
 156     children-tags first2
 157     [ children>string ] [ params>array ] bi* ;
 158
 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 ] bind ;
 162
 163 : receive-rpc ( xml -- rpc )
 164     dup main>> dup "methodCall" =
 165     [ drop parse-method <rpc-method> ] [
 166         "methodResponse" = [
 167             dup first-child-tag main>> "fault" =
 168             [ parse-fault <rpc-fault> ]
 169             [ parse-rpc-response <rpc-response> ] if
 170         ] [ "Bad main tag name" server-error ] if
 171     ] if ;
 172
 173 : post-rpc ( rpc url -- rpc )
 174     ! This needs to do something in the event of an error
 175     [ send-rpc ] dip http-post nip string>xml receive-rpc ;
 176
 177 : invoke-method ( params method url -- )
 178     [ swap <rpc-method> ] dip post-rpc ;
 179
 180 : put-http-response ( string -- )
 181     "HTTP/1.1 200 OK\nConnection: close\nContent-Length: " write
 182     dup length number>string write
 183     "\nContent-Type: text/xml\nDate: " write
 184     now timestamp>http-string write "\n\n" write
 185     write ;