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 ;
   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 "i4" build-tag ;
  19
  20 UNION: boolean t POSTPONE: f ;
  21
  22 M: boolean item>xml
  23     "1" "0" ? "boolean" build-tag ;
  24
  25 M: float item>xml
  26     number>string "double" build-tag ;
  27
  28 M: string item>xml ! This should change < and &
  29     "string" build-tag ;
  30
  31 : struct-member ( name value -- tag )
  32     swap dup string?
  33     [ "Struct member name must be string" throw ] unless
  34     "name" build-tag swap
  35     item>xml "value" build-tag
  36     2array "member" build-tag* ;
  37
  38 M: hashtable item>xml
  39     [ struct-member ] { } assoc>map
  40     "struct" build-tag* ;
  41
  42 M: array item>xml
  43     [ item>xml "value" build-tag ] map
  44     "data" build-tag* "array" build-tag ;
  45
  46 TUPLE: base64 string ;
  47
  48 C: <base64> base64
  49
  50 M: base64 item>xml
  51     string>> >base64 "base64" build-tag ;
  52
  53 : params ( seq -- xml )
  54     [ item>xml "value" build-tag "param" build-tag ] map
  55     "params" build-tag* ;
  56
  57 : method-call ( name seq -- xml )
  58     params [ "methodName" build-tag ] dip
  59     2array "methodCall" build-tag* build-xml ;
  60
  61 : return-params ( seq -- xml )
  62     params "methodResponse" build-tag build-xml ;
  63
  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
  67     build-xml ;
  68
  69 TUPLE: rpc-method name params ;
  70
  71 C: <rpc-method> rpc-method
  72
  73 TUPLE: rpc-response params ;
  74
  75 C: <rpc-response> rpc-response
  76
  77 TUPLE: rpc-fault code string ;
  78
  79 C: <rpc-fault> rpc-fault
  80
  81 GENERIC: send-rpc ( rpc -- xml )
  82 M: rpc-method send-rpc
  83     [ name>> ] [ params>> ] bi method-call ;
  84 M: rpc-response send-rpc
  85     params>> return-params ;
  86 M: rpc-fault send-rpc
  87     [ code>> ] [ string>> ] bi return-fault ;
  88
  89 ! * Recieving RPC requests
  90 ! this needs to have much better error checking
  91
  92 TUPLE: server-error tag message ;
  93
  94 : server-error ( tag message -- * )
  95     \ server-error boa throw ;
  96
  97 M: server-error error.
  98     "Error in XML supplied to server" print
  99     "Description: " write dup message>> print
 100     "Tag: " write tag>> xml>string print ;
 101
 102 PROCESS: xml>item ( tag -- object )
 103
 104 TAG: string xml>item
 105     children>string ;
 106
 107 TAG: i4/int/double xml>item
 108     children>string string>number ;
 109
 110 TAG: boolean xml>item
 111     dup children>string {
 112         { [ dup "1" = ] [ 2drop t ] }
 113         { [ "0" = ] [ drop f ] }
 114         [ "Bad boolean" server-error ]
 115     } cond ;
 116
 117 : unstruct-member ( tag -- )
 118     children-tags first2
 119     first-child-tag xml>item
 120     [ children>string ] dip swap set ;
 121
 122 TAG: struct xml>item
 123     [
 124         children-tags [ unstruct-member ] each
 125     ] H{ } make-assoc ;
 126
 127 TAG: base64 xml>item
 128     children>string base64> <base64> ;
 129
 130 TAG: array xml>item
 131     first-child-tag children-tags
 132     [ first-child-tag xml>item ] map ;
 133
 134 : params>array ( tag -- array )
 135     children-tags
 136     [ first-child-tag first-child-tag xml>item ] map ;
 137
 138 : parse-rpc-response ( xml -- array )
 139     first-child-tag params>array ;
 140
 141 : parse-method ( xml -- string array )
 142     children-tags first2
 143     [ children>string ] [ params>array ] bi* ;
 144
 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 ;
 148
 149 : receive-rpc ( xml -- rpc )
 150     dup main>> dup "methodCall" =
 151     [ drop parse-method <rpc-method> ] [
 152         "methodResponse" = [
 153             dup first-child-tag main>> "fault" =
 154             [ parse-fault <rpc-fault> ]
 155             [ parse-rpc-response <rpc-response> ] if
 156         ] [ "Bad main tag name" server-error ] if
 157     ] if ;
 158
 159 : post-rpc ( rpc url -- rpc )
 160     ! This needs to do something in the event of an error
 161     [ send-rpc ] dip http-post nip string>xml receive-rpc ;
 162
 163 : invoke-method ( params method url -- )
 164     [ swap <rpc-method> ] dip post-rpc ;
 165
 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
 171     write ;