basis/xml-rpc/xml-rpc.factor

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