#
# The contents of this file are subject to the AOLserver Public License
# Version 1.1 (the "License"); you may not use this file except in
# compliance with the License. You may obtain a copy of the License at
# http://aolserver.com/.
#
# Software distributed under the License is distributed on an "AS IS"
# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
# the License for the specific language governing rights and limitations
# under the License.
#
# The Original Code is AOLserver Code and related documentation
# distributed by AOL.
#
# The Initial Developer of the Original Code is America Online,
# Inc. Portions created by AOL are Copyright (C) 1999 America Online,
# Inc. All Rights Reserved.
#
# Alternatively, the contents of this file may be used under the terms
# of the GNU General Public License (the "GPL"), in which case the
# provisions of GPL are applicable instead of those above.  If you wish
# to allow use of your version of this file only under the terms of the
# GPL and not to allow others to use your version of this file under the
# License, indicate your decision by deleting the provisions above and
# replace them with the notice and other provisions required by the GPL.
# If you do not delete the provisions above, a recipient may use your
# version of this file under either the License or the GPL.
#

#
# $Header$
#

#
# xmlrpc.tcl --
#
#       Implementation of an XML-RPC client and server mechanism.
#

package require tdom 0.8

proc ns_xmlrpc {option args} {
    switch -glob -- $option {
        b* - bind {
            if {[llength $args] != 3} {
                error "wrong # args: should be \"ns_xmlrpc bind url method proc\""
            }

            error "not yet implemented"
        }

        c* - call {
            if {[llength $args] < 2} {
                error "wrong # args: should be \"ns_xmlrpc call ?-timeout timeout? url method ?arg arg ...?\""
            }
            set timeout 1   ;# default timeout = 1 sec
            if {[lindex $args 0] eq "-timeout"} {
                set timeout [lindex $args 1]
                set args [lrange $args 2 end]
            }
            
            set id [eval ns_xmlrpc queue $args]
            return [ns_xmlrpc wait $id $timeout]
        }

        fa* - fault {
            if {[llength $args] != 2 && [llength $args] != 4} {
                error "wrong # args: should be \"ns_xmlrpc fault ?-indent indent? code string\""
            }
            set indent none
            if {[lindex $args 0] eq "-indent"} {
                set indent [lindex $args 1]
                set args [lrange $args 2 end]
            }
            foreach {code string} $args break

            set xml {}
            dom createDocument methodResponse doc
            if {[set res [catch {
                $doc documentElement root
                $root appendXML {
                    <fault>
                        <value>
                            <struct>
                                <member>
                                    <name>faultCode</name>
                                    <value><int></int></value>
                                </member>
                                <member>
                                    <name>faultString</name>
                                    <value><string></string></value>
                                </member>
                            </struct>
                        </value>
                    </fault>
                }
                set node [$root selectNodes "//methodResponse/fault/value/struct/member/value/int"]
                $doc createTextNode $code child
                $node appendChild $child
                set node [$root selectNodes "//methodResponse/fault/value/struct/member/value/string"]
                $doc createTextNode $string child
                $node appendChild $child
                set xml "<?xml version=\"1.0\"?>\n[$doc asXML -indent $indent]"
                if {$indent eq "none"} {
                    append xml "\n"
                }
            } err]]} {
                set savedInfo $::errorInfo
            }
            $doc delete
            if {$res} {
                error $err
            }
            return $xml
        }

        fo* - format {
            set indent none
            set types yes
            while {[llength $args]} {
                if {[lindex $args 0] eq "-indent"} {
                    set indent [lindex $args 1]
                    set args [lrange $args 2 end]
                    continue
                }
                if {[lindex $args 0] eq "-types"} {
                    set types [lindex $args 1]
                    set args [lrange $args 2 end]
                    continue
                }
                break
            }

            set xml {}
            dom createDocument methodResponse doc
            if {[set res [catch {
                $doc documentElement root
                $doc createElement params params
                $root appendChild $params
                foreach arg $args {
                    foreach {type value} $arg {
                        $doc createElement param paramNode
                        set node [ns_xmlrpc _format $doc $type $value $types]
                        $paramNode appendChild $node
                        $params appendChild $paramNode
                    }
                }
                set xml "<?xml version=\"1.0\"?>\n[$doc asXML -indent $indent]"
                if {$indent eq "none"} {
                    append xml "\n"
                }
            } err]]} {
                set savedInfo $::errorInfo
            }
            $doc delete
            if {$res} {
                error $err
            }
            return $xml
        }

        _f* - _format {
            if {[llength $args] != 4} {
                error "wrong # args: should be \"ns_xmlrpc _format doc type value types\""
            }
            foreach {doc type value types} $args break

            $doc createElement value valueNode
            set childNode $valueNode
            if {$types || $type eq "array" || $type eq "struct"} {
                $doc createElement $type typeNode
                $valueNode appendChild $typeNode
                set childNode $typeNode
            }
            switch -exact -- $type {
                array {
                    $doc createElement data dataNode
                    $childNode appendChild $dataNode
                    foreach arg $value {
                        foreach {_type _value} $arg {
                            set node [ns_xmlrpc _format $doc $_type $_value $types]
                            $dataNode appendChild $node
                        }
                    }
                }

                struct {
                    foreach {name arg} $value {
                        $doc createElement member memberNode
                        $childNode appendChild $memberNode
                        $doc createElement name nameNode
                        $memberNode appendChild $nameNode
                        $nameNode appendChild [$doc createTextNode $name]
                        foreach {_type _value} $arg {
                            set node [ns_xmlrpc _format $doc $_type $_value $types]
                            $memberNode appendChild $node
                        }
                    }
                }

                string -
                i4 -
                int -
                double -
                base64 -
                boolean -
                datetime.iso8601 -
                default {
                    $childNode appendChild [$doc createTextNode $value]
                }
            }
            return $valueNode
        }

        l* - listen {
            if {[llength $args] != 1} {
                error "wrong # args: should be \"ns_xmlrpc listen xml\""
            }
            set xml [lindex $args 0]

            set method {}
            set params {}

            dom parse $xml doc
            if {[set res [catch {
                $doc documentElement root
                set method [$root selectNodes "string(//methodCall/methodName)"]
                foreach node [$root selectNodes "//methodCall/params/param/value"] {
                    set child [$node child 1]
                    if {[llength $child]} {
                        set node $child
                    }
                    lappend params [ns_xmlrpc _parse $node]
                }
            } err]]} {
                set savedInfo $::errorInfo
            }
            $doc delete
            if {$res} {
                error $err
            }
            return [concat $method $params]
        }

        q* - queue {
            if {[llength $args] < 2} {
                error "wrong # args: should be \"ns_xmlrpc queue url method ?arg arg ...?\""
            }
            foreach {url method} $args break

            set headers [ns_set create]
            ns_set put $headers Content-Type "text/xml"
            set body "<?xml version=\"1.0\"?>\n"
            ## TODO: Escape $method for XML properly.  CDATA?
            append body "<methodCall><methodName>$method</methodName>"
            append body "<params>"
            foreach arg [lrange $args 2 end] {
                ## TODO: Escape $arg for XML properly.  CDATA?
                append body "<param><value>$arg</value></param>"
            }
            append body "</params></methodCall>\n"
            ns_log notice "body = [list $body]"
            return [ns_http queue POST $url $body $headers]
        }

        w* - wait {
            if {[llength $args] != 1 && [llength $args] != 2} {
                error "wrong # args: should be \"ns_xmlrpc wait id ?timeout?\""
            }
            foreach {id timeout} $args break
            if {![string length $timeout]} {
                set timeout 1   ;# default timeout = 1 sec
            }

            set code [ns_http wait $id xml $timeout]
            ns_log notice "code = $code, xml = [list $xml]"
            if {$code != 1} {
                return
            }
            set data [list]
            dom parse $xml doc
            if {[set res [catch {
                $doc documentElement root
                foreach node [$root selectNodes "//methodResponse/params/param/value"] {
                    set child [$node child 1]
                    if {[llength $child]} {
                        set node $child
                    }
                    lappend data [ns_xmlrpc _parse $node]
                }
            } err]]} {
                set savedInfo $::errorInfo
            }
            $doc delete
            if {$res} {
                error $err
            }
            return $data
        }

        _p* - _parse {
            set node [lindex $args 0]
            set type [$node nodeName]
            set value [$node text]
            # puts "*!* type = $type, value = [list $value], [list [$node asXML]]"
            switch -exact -- $type {
                array {
                    set data [list]
                    foreach node [$node selectNodes "data/value"] {
                        set child [$node child 1]
                        if {[llength $child]} {
                            set node $child
                        }
                        lappend data [ns_xmlrpc _parse $node]
                    }
                    return $data
                }

                struct {
                    set data [list]
                    foreach node [$node selectNodes "member"] {
                        set name [ns_xmlrpc _parse [$node child 1]]
                        set child [$node child 2]
                        if {[llength [$child childNodes]]} {
                            set child [$child child 1]
                        }
                        set value [ns_xmlrpc _parse $child]
                        lappend data [list $name $value]
                    }
                    return $data
                }

                string -
                i4 -
                int -
                double -
                base64 -
                boolean -
                datetime.iso8601 -
                default {
                    return $value
                }
            }
        }

        default {
            error "bad option \"$option\": must be bind, call, fault, format, queue, or wait"
        }
    }
}