1# JSONRPC.tcl
2# Copyright (C) 2005 Ashok P. Nadkarnis <apnadkarni@users.sourceforge.net>
3#
4# Provide Tcl access to JSON-RPC methods.
5# Based on XMLRPC.tcl in the TclSOAP package, this package uses
6# much of the common communication transport code from the TclSOAP
7# package.
8
9#
10# -------------------------------------------------------------------------
11# This software is distributed in the hope that it will be useful, but
12# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
13# or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
14# for more details.
15# -------------------------------------------------------------------------
16
17package require SOAP::Utils
18package require SOAP 1.4
19package require rpcvar
20package require json
21
22namespace eval ::JSONRPC {
23    variable version 0.1.0;     # Software version
24    variable rcs_version { $Id: jsonrpc.tcl,v 1.4 2008/10/09 11:02:30 apnadkarni Exp $ }
25
26    variable jsonrpc_state;           # Array to hold global stuff
27    set jsonrpc_state(request_id) 0;         # Used to identify requests
28
29    namespace export create cget dump configure proxyconfig export
30    # catch {namespace import -force [uplevel {namespace current}]::rpcvar::*}
31    # catch {namespace import -force ::SOAP::Utils::*}
32
33    # Create the typedefs for a jsonrequest and jsonresponse.
34    # Note: Some servers (for example the test server at
35    # http://jsolait.net/wiki/examples/jsonrpc/tester) seem to insist
36    # that the id field be a formatted as a string and not an integer
37    ::rpcvar::typedef {
38        jsonrpc string
39        id      string
40        params  array
41        method  string
42    } jsonrequest
43
44    ::rpcvar::typedef {
45        jsonrpc string
46        id      string
47        params  object
48        method  string
49    } jsonrequest_namedparams
50
51    ::rpcvar::typedef {
52        code    int
53        message string
54        data    any
55    } jsonerror
56
57    ::rpcvar::typedef {
58        jsonrpc string
59        id      string
60        result  any
61        error   jsonerror
62    } jsonresponse
63
64}
65
66# -------------------------------------------------------------------------
67
68# Delegate all these methods to the SOAP package. This does not mean
69# all the options for SOAP are supported or meaningful for JSON-RPC but
70# the irrelevant ones will be ignored. We do need to override the
71# SOAP method call wrapper and unwrapper functions.
72proc ::JSONRPC::create {args} {
73    set args [linsert $args 1 \
74                  -rpcprotocol JSONRPC \
75                  -contenttype "application/json-rpc" \
76                  -wrapProc [namespace origin \
77                                 [namespace parent]::JSONRPC::request] \
78                  -parseProc [namespace origin \
79                                  [namespace parent]::JSONRPC::parse_response]]
80    return [uplevel 1 "SOAP::create $args"]
81}
82
83proc ::JSONRPC::configure { args } {
84    return [uplevel 1 "SOAP::configure $args"]
85}
86
87proc ::JSONRPC::cget { args } {
88    return [uplevel 1 "SOAP::cget $args"]
89}
90
91proc ::JSONRPC::dump { args } {
92    return [uplevel 1 "SOAP::dump $args"]
93}
94
95proc ::JSONRPC::proxyconfig { args } {
96    return [uplevel 1 "SOAP::proxyconfig $args"]
97}
98
99proc ::JSONRPC::export {args} {
100    foreach item $args {
101        uplevel "set \[namespace current\]::__jsonrpc_exports($item)\
102                \[namespace code $item\]"
103    }
104    return
105}
106
107# -------------------------------------------------------------------------
108
109# Description:
110#   Prepare an JSON-RPC fault (error) response
111# Parameters:
112#   faultcode   the JSON-RPC fault code (numeric)
113#   faultstring summary of the fault
114#   detail      list of {detailName detailInfo}
115# Result:
116#   Returns the JSON text of the error packet.
117#
118proc ::JSONRPC::fault {jsonver reqid faultcode faultstring {detail {}}} {
119    if {[llength $detail] == 0} {
120        set err [list code $faultcode message $faultstring]
121    } else {
122        set err [list \
123                     code $faultcode \
124                     message $faultstring \
125                     data  [rpcvar::rpcvar struct $detail]]
126    }
127    return [jsonresponse $jsonver $reqid $err error]
128}
129
130proc ::JSONRPC::encode_value {value} {
131    set type      [rpcvar::rpctype $value]
132    set value     [rpcvar::rpcvalue $value]
133    set typeinfo  [rpcvar::typedef -info $type]
134
135    if {[string match {*()} $type] || [string match array $type]} {
136        # Arrays have a type suffix of "()"
137        set itemtype [string trimright $type ()]
138        if {$itemtype == "array"} {
139            set itemtype "any"
140        }
141        set acc {}
142        foreach elt $value {
143            if {[string match $itemtype "any"]} {
144                lappend acc [JSONRPC::encode_value $elt]
145            } else {
146                lappend acc [JSONRPC::encode_value [rpcvar::rpcvar $itemtype $elt]]
147            }
148        }
149        return "\[[join $acc ,]\]"
150    } elseif {[llength $typeinfo] > 1} {
151        # a typedef'd struct (object in json)
152        array set ti $typeinfo
153        set acc {}
154        foreach {eltname eltvalue} $value {
155
156            if {![info exists ti($eltname)]} {
157                error "Invalid member name: \"$eltname\" is not a member of the $type object typedef." \
158                    "" [list JSONRPC local "Invalid object member name"]
159            }
160            if {$ti($eltname) eq "any"} {
161                lappend acc "\"$eltname\":[JSONRPC::encode_value $eltvalue]"
162            } else {
163                lappend acc "\"$eltname\":[JSONRPC::encode_value [rpcvar::rpcvar $ti($eltname) $eltvalue]]"
164            }
165        }
166        return "{[join $acc ,]}"
167    } elseif {[string equal struct $type] || [string equal object $type]} {
168        # an undefined struct (json object)
169        set acc {}
170        foreach {eltname eltvalue} $value {
171            lappend acc "\"$eltname\":[JSONRPC::encode_value $eltvalue]"
172        }
173        return "{[join $acc ,]}"
174    } elseif {[string equal $type "string"]} {
175        return "\"[JSONRPC::escape $value]\""
176    } elseif {$type eq "number" || $type eq "int" || $type eq "float" || $type eq "double"} {
177        # Convert hex and octal to standard decimal. Also
178        # canonicalizes floating point
179        return [expr $value]
180    } elseif {[string match bool* $type]} {
181        return [expr {$value ? true : false}]
182    } else {
183        # All other simple types
184        return $value
185    }
186}
187
188#
189# Escapes a JSON string
190proc ::JSONRPC::escape {s} {
191    # Initialize the map for escaping special characters
192
193    # First do control characters as \u00xx sequences
194    for {set i 0} {$i < 32} {incr i} {
195        set map([format %c $i]) \\u[format %04x $i]
196    }
197
198    # Replace certain well known control characters with \ sequences
199    set map([format %c 8]) \\b; # backspace
200    set map([format %c 9]) \\t; # tab
201    set map([format %c 10]) \\n; # lf
202    set map([format %c 12]) \\f; # ff
203    set map([format %c 13]) \\r; # cr
204
205    # Other special sequences
206    set map(\") {\"}
207    set map(\\) {\\}
208    set map(/)  {\/}
209
210    set [namespace current]::json_escape_map [array get map]
211
212    # Redefine ourselves so we do not initialize every time
213    proc ::JSONRPC::escape s {
214        variable json_escape_map
215        return [string map $json_escape_map $s]
216    }
217
218    # Call the redefined proc from the caller's level
219    return [uplevel 1 [info level 0]]
220}
221
222
223#
224# Description:
225#   Procedure to generate the JSON data for a configured JSONRPC procedure.
226# Parameters:
227#   procVarName - the name of the JSONRPC method variable
228#   args        - the arguments for this RPC method
229# Result:
230#   Payload data containing the JSONRPC method call.
231#
232proc ::JSONRPC::request {procVarName args} {
233    variable jsonrpc_state
234
235    upvar $procVarName procvar
236
237    set procName [lindex [split $procVarName {_}] end]
238    set params $procvar(params)
239    set name   $procvar(name)
240
241    if { [llength $args] != [expr { [llength $params] / 2 } ]} {
242        set msg "wrong # args: should be \"$procName"
243        foreach { id type } $params {
244            append msg " " $id
245        }
246        append msg "\""
247        return -code error -errorcode [list JSONRPC local "Wrong number of arguments."] $msg
248    }
249
250    # Construct the typed parameter list. The parameter
251    # list is constructed as an array (by position) unless specified
252    # otherwise by that caller as an object (by name)
253    set plist [list ]
254    if { [llength $params] != 0 } {
255        if {$procvar(namedparams)} {
256            foreach {pname ptype} $params val $args {
257                lappend plist $pname [rpcvar::rpcvar $ptype $val]
258            }
259        } else {
260            foreach {pname ptype} $params val $args {
261                lappend plist [rpcvar::rpcvar $ptype $val]
262            }
263        }
264    }
265
266    # Sent as a JSON object
267    # { "jsonrpc" : VERSIONSTRING, "method" : METHODNAMESTRING, "params" : [ PARAMARRAYLIST ], "id" : ID }
268    # The params element may be left out if no params according to the spec but
269    # some servers object to this so always fill it in.
270    # The id element is filled in, but not currently used as the
271    # TclSOAP interface has no way to
272    # have the caller associated requests with responses
273
274    # Version 1 JSON has no version field
275    set reqflds [list id [incr jsonrpc_state(request_id)] method $name]
276    if {$procvar(version) ne "" &&
277        ! [string match "1.*" $procvar(version)]} {
278        lappend reqflds jsonrpc $procvar(version)
279    }
280
281    lappend reqflds params $plist
282
283    if {$procvar(namedparams)} {
284        return [encode_value [rpcvar::rpcvar jsonrequest_namedparams $reqflds]]
285    } else {
286        return [encode_value [rpcvar::rpcvar jsonrequest $reqflds]]
287    }
288}
289
290
291# Description:
292#   Parse an JSON-RPC response payload. Check for fault response otherwise
293#   extract the value data.
294# Parameters:
295#   procVarName  - the name of the JSON-RPC method configuration variable
296#   payload          - the payload of the response
297# Result:
298#   The extracted value(s). Array types are converted into lists and struct/object
299#   types are turned into lists of name/value pairs suitable for array set
300# Notes:
301#   The XML-RPC fault response doesn't allow us to add in extra values
302#   to the fault struct. So where to put the servers errorInfo?
303#
304proc ::JSONRPC::parse_response { procVarName payload } {
305    upvar $procVarName procvar
306
307    set result {}
308    if {$payload == {} && ![string match "http*" $procvar(proxy)]} {
309        # This is probably not an error. SMTP and FTP won't return anything
310        # HTTP should always return though (I think).
311        return {}
312    } else {
313        if {[catch {set response [::json::json2dict $payload]}]} {
314            return -code error \
315                -errorcode [list JSONRPC local \
316                                "Server response is not well-formed JSON. The response was '$payload'"]
317        }
318    }
319
320    # The response will have the following fields:
321    #  jsonrpc - protocol version, may be missing for V1.0 servers
322    #            (ignored)
323    #  result - the result value - only if no errors
324    #  error - error value on faults
325    #  id - the id from the original request (currently ignored
326
327    # Both error and result fields should not be simultaneously present.
328    # But older servers may return various combinations.
329    # TBD - check handling of JSON null values
330    if {[dict exists $response error] &&
331        [dict get $response error] ne "null"} {
332        set err [dict get $response error]
333        if {[dict exists $err message]} {
334            set ermsg "Error response from server: [dict get $err message]"
335        } else {
336            set ermsg "Server returned an error."
337        }
338        return -code error -errorcode [list JSONRPC remote [dict get $response error]] $ermsg
339    }
340
341    if {![dict exists $response result]} {
342        return -code error -errorcode [list JSONRPC local \
343            "Server response is not well-formed JSON-RPC response. The response was '$payload'"]
344    }
345
346    return [dict get $response result]
347}
348
349
350# -------------------------------------------------------------------------
351# Description:
352#   Parse an JSON-RPC call payload. Extracts method name and parameters.
353# Parameters:
354#   procVarName  - the name of the JSON-RPC method configuration variable
355#   payload      - the payload of the response
356# Result:
357#   A list containing the context of the request as the first element,
358#   the name of the called method as second element,
359#   and the extracted parameter(s) as third element. Array types are
360#   converted into lists and struct types are turned into lists of
361#   name/value pairs suitable for array set
362# Notes:
363#
364proc ::JSONRPC::parse_request { payload } {
365    set result {}
366    if {[catch {set request [::json::json2dict $payload]}]} {
367        return -code error -errorcode [list JSONRPC local "JSON request received with invalid format"] \
368            "Client request is not well-formed JSON.\n\
369            Call was '$payload'"
370    }
371
372    if {! ([dict exists $request method] && [dict exists $request id])} {
373        return -code error -errorinfo Server \
374            "Client request is not well-formed JSON-RPC request.\n\
375            Call was '$payload'"
376    }
377
378    set jsonrpcver "1.0"
379    if {[dict exists $request jsonrpc]} {
380        set jsonrpcver [dict get $request jsonrpc]
381    }
382    set id     [dict get $request id]
383    set method [dict get $request method]
384    set params {}
385    if {[dict exists $request params]} {
386        set params [dict get $request params]
387    }
388
389    return [list [list $jsonrpcver $id] $method $params]
390}
391
392# ----------------------------------------------------------------
393# Description:
394#   Build a JSON-RPC response
395# Parameters:
396#   jsonver - what version to use for formatting
397#   reqid   - the request id to which this is the response
398#   value   - result to be returned
399#   type    - "error" if error. Anything else is a result
400# Result:
401#   A JSON formatted string
402proc ::JSONRPC::jsonresponse {jsonver reqid value {type result}} {
403    if {$type eq "error"} {
404        set respflds [list error $value id $reqid]
405    } else {
406        set respflds [list result $value id $reqid]
407    }
408
409    if {![string match "1.*" $jsonver]} {
410        lappend respflds jsonrpc $jsonver
411    }
412
413    return [::JSONRPC::encode_value [rpcvar::rpcvar jsonresponse $respflds]]
414}
415
416# Description:
417#   Dummy JSONRPC transports to examine the JSONRPC requests generated for use
418#   with the test package and for debugging.
419# Parameters:
420#   procVarName  - JSONRPC method name configuration variable
421#   url          - URL of the remote server method implementation
422#   soap         - the XML payload for this JSONRPC method call
423#
424namespace eval JSONRPC::Transport::print {
425    variable method:options {}
426    proc configure {args} {
427        return
428    }
429    proc xfer { procVarName url payload } {
430        puts url:$url
431        puts "$payload"
432    }
433    SOAP::register urn:print [namespace current]
434}
435
436namespace eval JSONRPC::Transport::reflect {
437    variable method:options {
438        contenttype
439    }
440    proc method:configure args {
441        return
442    }
443    proc configure {args} {
444        return
445    }
446    proc xfer {procVarName url payload} {
447        if {[catch {
448            foreach {jsoncontext method params} [::JSONRPC::parse_request $payload] break
449            foreach {jsonrpcver id} $jsoncontext break
450            if {$jsonrpcver eq ""} {
451                set jsonrpcver "1.0"
452            }
453        } msg]} {
454            # Could not even parse request - do not return error response
455            error msg $::errorInfo $::errorCode
456        }
457
458        # Request was parsed, not eval it if supported method
459        if {$method eq "calc"} {
460            if {[catch {
461                set result [eval expr $params]
462            } msg]} {
463                return [::JSONRPC::fault $jsonrpcver $id 1 $msg [list errorCode $::errorCode errorMessage $msg]]
464            }
465        } else {
466            return [::JSONRPC::fault $jsonrpcver $id -32601 "Method not found."]
467        }
468
469        return [::JSONRPC::jsonresponse $jsonrpcver $id [rpcvar::rpcvar string $result]]
470    }
471    SOAP::register urn:jsonreflect [namespace current]
472}
473
474# -------------------------------------------------------------------------
475
476package provide JSONRPC $JSONRPC::version
477
478# -------------------------------------------------------------------------
479
480# Local variables:
481#    indent-tabs-mode: nil
482# End:
483