extra/xml-rpc/xml-rpc.factor

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