##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################

package require Tcl 8.4
package require WS::Utils 2.4 ; # dict, lassign, logsubst
package require tdom 0.8
package require http 2
package require log
package require uri

package provide WS::Client 2.5.1

}

package require uri
package require base64
package require html
package require log

# Emulate the log::logsubst command introduced in log 1.4
if {![llength [info command ::log::logsubst]]} {
	proc ::log::logsubst {level text} {
		if {[::log::lvIsSuppressed $level]} {
			return
		}
		::log::log $level [uplevel 1 [list subst $text]]
	}
}

package provide WS::Embeded 2.4.1

namespace eval ::WS::Embeded {

    array set portInfo {}

    set portList [list]
    set forever {}

            -ssl2 1 \
            -ssl3 1 \
            -tls1 0 \
            -require 0 \
            -request 0
        set handle [::tls::socket -server [list ::WS::Embeded::accept $port] $port]
    } else {
        ::log::logsubst debug {socket -server [list ::WS::Embeded::accept $port] $port}
        set handle [socket -server [list ::WS::Embeded::accept $port] $port]
    }

    return $handle
}



###########################################################################
proc ::WS::Embeded::checkauth {port sock ip auth} {
    variable portInfo

    if {[info exists portInfo($port,auths)] && [llength $portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} {
        set realm $portInfo($port,realm)
        respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n"
        ::log::logsubst warning {Unauthorized from $ip}
        return -code error
    }
}


###########################################################################
#

#
#
###########################################################################
proc ::WS::Embeded::accept {port sock ip clientport} {
    variable portInfo

    upvar #0 ::WS::Embeded::Httpd$sock query
    ::log::logsubst info {Receviced request on $port for $ip:$clientport}

    array unset query reply
    chan configure $sock -translation crlf
    if {1 == [catch {
        gets $sock line
        ::log::logsubst debug {Request is: $line}
        set auth {}
        set request {}
        while {[gets $sock temp] > 0 && ![eof $sock]} {
            if {[regexp {^([^:]*):(.*)$} $temp -> key data]} {
                dict set request header [string tolower $key] [string trim $data]
            }
        }
        if {[eof $sock]} {
            ::log::logsubst warning  {Connection closed from $ip}
            return
        }
        if {[dict exists $request header authorization]} {
            regexp -nocase {^basic +([^ ]+)$}\
                [dict get $request header authorization] -> auth
        }
        if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} {
            ::log::logsubst warning  {Wrong request: $line}
            return
        }
        switch -exact -- $method {
            POST {
                ##
                ## This is all broken and needs to be fixed
                ##

                #parray query
                handler $port $sock $ip [array get query] $auth
            }
            GET {
                handler $port $sock $ip [uri::split $url] $auth
            }
            default {
                ::log::logsubst warning {Unsupported method '$method' from $ip}
                respond $sock 501 "Method not implemented"
            }
        }
    } msg]} {
        ::log::log error "Error: $msg"
        # catch this against an eventual closed socket
        catch {respond $sock 500 "Server Error"}
    }

    catch {flush $sock}
    catch {close $sock}
    return
}

package require Tcl 8.4
package require WS::Utils 2.4 ; # provides dict
package require html
package require log
package require tdom

package provide WS::Server 2.4.1

namespace eval ::WS::Server {
    array set ::WS::Server::serviceArr {}
    set ::WS::Server::procInfo {}
    set ::WS::Server::mode {}
}

#
###########################################################################
proc ::WS::Server::Service {args} {
    variable serviceArr
    variable procInfo
    variable mode

    ::log::logsubst debug {Defining Service as $args}

    array set defaults {
        -description    {}
        -checkheader    {::WS::Server::ok}
        -inheaders      {}
        -outheaders     {}
        -intransform    {}

    set mode $defaults(-mode)

    ##
    ## Install wsdl doc
    ##
    interp alias {} ::WS::Server::generateInfo_${service} \
                 {} ::WS::Server::generateInfo ${service}
    ::log::logsubst debug {Installing Generate info for $service at $defaults(-prefix)}
    switch -exact -- $mode {
        embedded {
            package require WS::Embeded 2.1.3
            foreach port $defaults(-ports) {
                ::WS::Embeded::AddHandler $port $defaults(-prefix) ::WS::Server::generateInfo_${service}
            }
        }

    ##
    ## Install wsdl
    ##
    interp alias {} ::WS::Server::generateWsdl_${service} \
                 {} ::WS::Server::generateWsdl ${service}
    ::log::logsubst debug {Installing GenerateWsdl info for $service at $defaults(-prefix)/wsdl}
    switch -exact -- $mode {
        embedded {
            foreach port $defaults(-ports) {
                ::WS::Embeded::AddHandler $port $defaults(-prefix)/wsdl ::WS::Server::generateWsdl_${service}
            }
        }
        channel {

    }

    ##
    ## Install operations
    ##
    interp alias {} ::WS::Server::callOperation_${service} \
                 {} ::WS::Server::callOperation ${service}
    ::log::logsubst debug {Installing callOperation info for $service at $defaults(-prefix)/op}
    switch -exact -- $mode {
        embedded {
            foreach port $defaults(-ports) {
                ::WS::Embeded::AddHandler $port $defaults(-prefix)/op ::WS::Server::callOperation_${service}
            }
        }
        channel {

#
#
###########################################################################
proc ::WS::Server::ServiceProc {service nameInfo arglist documentation body} {
    variable procInfo

    set name [lindex $nameInfo 0]
    ::log::logsubst debug {Defining operation $name for $service}
    set argOrder {}
    ::log::logsubst debug {\targs are {$arglist}}
    foreach {arg data} $arglist {
        lappend argOrder $arg
    }
    if {![dict exists $procInfo $service op$name argList]} {
        set tmpList [dict get $procInfo $service operationList]
        lappend tmpList $name
        dict set procInfo $service operationList $tmpList

proc ::WS::Server::GetWsdl {serviceName {urlPrefix ""}} {
    variable serviceArr
    variable procInfo

    array set serviceData $serviceArr($serviceName)

    set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]]
    ::log::logsubst debug {Generating WSDL for $serviceName}
    if {![info exists serviceArr($serviceName)]} {
        set msg "Unknown service '$serviceName'"
        ::return \
            -code error \
            -errorCode [list WS SERVER UNKSERV $serviceName] \
            $msg
    }

    variable serviceArr
    variable procInfo
    variable mode

    array set serviceData $serviceArr($serviceName)

    set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]]
    ::log::logsubst debug {Generating WSDL for $serviceName on $sock with {$args}}
    if {![info exists serviceArr($serviceName)]} {
        set msg "Unknown service '$serviceName'"
        switch -exact -- $mode {
            tclhttpd {
                ::Httpd_ReturnData \
                    $sock \
                    "text/html; charset=UTF-8" \

###########################################################################
# NOTE: This proc only works with Rivet
# TODO: Update to handle jsonp?
proc ::WS::Server::generateJsonInfo { service sock args } {
    variable serviceArr
    variable procInfo

    ::log::logsubst debug {Generating JSON Documentation for $service on $sock with {$args}}
    set serviceInfo $serviceArr($service)
    array set serviceData $serviceInfo
    set doc [yajl create #auto -beautify $serviceData(-beautifyJson)]

    $doc map_open

    $doc string operations array_open

        $doc string description string $description

        # parameters
        if {[llength [dict get $procInfo $service op$oper argOrder]]} {
            $doc string inputs array_open
            
            foreach arg [dict get $procInfo $service op$oper argOrder] {
                ::log::logsubst debug {\t\t\tDisplaying '$arg'}
                if {[dict exists $procInfo $service op$oper argList $arg comment]} {
                    set comment [dict get $procInfo $service op$oper argList $arg comment]
                } else {
                    set comment {}
                }

                set type [dict get $procInfo $service op$oper argList $arg type]

    $doc array_close

    ::log::log debug "\tDisplay custom types"
    $doc string types array_open
    set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service]
    foreach type [lsort -dictionary [dict keys $localTypeInfo]] {
        ::log::logsubst debug {\t\tDisplaying '$type'}

        $doc map_open
        $doc string name string $type
        $doc string fields array_open
        
        set typeDetails [dict get $localTypeInfo $type definition]
        foreach part [lsort -dictionary [dict keys $typeDetails]] {
            ::log::logsubst debug {\t\t\tDisplaying '$part'}
            set subType [dict get $typeDetails $part type]
            set comment {}
            if {[dict exists $typeDetails $part comment]} {
                set comment [dict get $typeDetails $part comment]
            }
            $doc map_open string field string $part string type string $subType string comment string $comment map_close
        }

#
###########################################################################
proc ::WS::Server::generateInfo {service sock args} {
    variable serviceArr
    variable procInfo
    variable mode

    ::log::logsubst debug {Generating HTML Documentation for $service on $sock with {$args}}
    if {![info exists serviceArr($service)]} {
        set msg "Unknown service '$service'"
        switch -exact -- $mode {
            tclhttpd {
                ::Httpd_ReturnData \
                    $sock \
                    "text/html; charset=UTF-8" \

    # decide if SOAP or REST mode should be used.
    set flavor "soap"
    if {[lsearch -exact $args "-rest"] != -1} {
        set flavor "rest"
    }

    ::log::logsubst debug {In ::WS::Server::callOperation {$service $sock $args}}
    array set serviceInfo $serviceArr($service)
    ::log::logsubst debug {\tDocument is {$inXML}}

    set ::errorInfo {}
    set ::errorCode {}
    set ns $service

    set inTransform $serviceInfo(-intransform)
    set outTransform $serviceInfo(-outtransform)

            set first [string first {<} $inXML]
            if {$first > 0} {
                set inXML [string range $inXML $first end]
            }
            # parse the XML request
            dom parse $inXML doc
            $doc documentElement top
            ::log::logsubst debug {$doc selectNodesNamespaces \
                    [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
                    $service http://$serviceInfo(-host)$serviceInfo(-prefix)]}
            $doc selectNodesNamespaces \
                [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
                     $service http://$serviceInfo(-host)$serviceInfo(-prefix)]
            $doc documentElement rootNode
            
            # extract the name of the method
            set top [$rootNode selectNodes /ENV:Envelope/ENV:Body/*]
            catch {$top localName} requestMessage
            set legacyRpcMode 0
            if {$requestMessage == ""} {
                # older RPC/Encoded clients need to try nodeName instead.
                # Python pySoap needs this.
                catch {$top nodeName} requestMessage
                set legacyRpcMode 1
            }
            ::log::logsubst debug {requestMessage = {$requestMessage} legacyRpcMode=$legacyRpcMode}
            if {[string match {*Request} $requestMessage]} {
                set operation [string range $requestMessage 0 end-7]
            } else {
                # broken clients might not have sent the correct Document Wrapped name.
                # Python pySoap and Perl SOAP::Lite need this.
                set operation $requestMessage
                set legacyRpcMode 1
            }
            ::log::logsubst debug {operation = '$operation' legacyRpcMode=$legacyRpcMode}
            set contentType "text/xml"
        }
        default {
            if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} "UnknownMethod" $flavor }
            error "bad flavor"
        }
    }

                    CLIENT \
                    $msg \
                    [list "errorCode" $::errorCode "stackTrace" $::errorInfo] \
                    $flavor]
        catch {$doc delete}
        set httpStatus 404
        if {$errorCallback ne {}} { $errorCallback "UNKNOWN_METHOD $msg" httpStatus $operation $flavor }
        ::log::logsubst debug {Leaving @ error 1::WS::Server::callOperation $response}

        # wrap in JSONP
        if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
            set response "$rawargs(jsonp_callback)($response)"
        }

        switch -exact -- $mode {

            rest {
                set tclArgList {}
                foreach argName $methodArgs {
                    set argType [string trim [dict get $argInfo $argName type]]
                    set typeInfoList [::WS::Utils::TypeInfo Server $service $argType]

                    if {![info exists rawargs($argName)]} {
                        ::log::logsubst debug {did not find argument for $argName, leaving blank}
                        lappend tclArgList {}
                        continue
                    }

                    switch -exact -- $typeInfoList {
                        {0 0} {
                            ## Simple non-array

                        } else {
                            # legacyRpcMode only, access arguments by index
                            set path "legacy argument index $argIndex"
                            set node [lindex [$top childNodes] $argIndex]
                            incr argIndex
                        }
                        if {[string equal $node {}]} {
                            ::log::logsubst debug {did not find argument for $argName using $path, leaving blank (pass $pass)}
                            lappend tclArgList {}
                            continue
                        }
                        ::log::logsubst debug {found argument $argName using $path, processing $node}
                        set gotAnyArgs 1
                        switch -exact -- $typeInfoList {
                            {0 0} {
                                ## Simple non-array
                                lappend tclArgList [$node asText]
                            }
                            {0 1} {

                                lappend tclArgList $tmp
                            }
                            default {
                                ## Do nothing
                            }
                        }
                    }
                    ::log::logsubst debug {gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode}
                    if {$gotAnyArgs || !$legacyRpcMode} break
                }
            }
            default {
                if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} $operation $flavor }
                error "invalid flavor"
            }
        }
        ::log::logsubst debug {finalargs $tclArgList}
    } errMsg]} {
        ::log::log error $errMsg
        set localerrorCode $::errorCode
        set localerrorInfo $::errorInfo
        set response [generateError \
                    $serviceInfo(-traceEnabled) \
                    CLIENT \
                    "Error Parsing Arguments -- $errMsg" \
                    [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \
                    $flavor]
        catch {$doc delete}
        set httpStatus 400
        if {$errorCallback ne {}} { $errorCallback "INVALID_ARGUMENT $errMsg" httpStatus $operation $flavor }
        ::log::logsubst debug {Leaving @ error 3::WS::Server::callOperation $response}

        # wrap in JSONP
        if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
            set response "$rawargs(jsonp_callback)($response)"
        }

        switch -exact -- $mode {

        }
        if {[info exists serviceInfo(-postmonitor)] &&
            [string length $serviceInfo(-postmonitor)]} {
            set precmd $serviceInfo(-postmonitor)
            lappend precmd POST $service $operation OK $results
            catch $precmd
        }
        ::log::logsubst debug {Leaving ::WS::Server::callOperation $response}
        switch -exact -- $mode {
            tclhttpd {
                ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response 200
            }
            embedded {
                ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response 200
            }

                    CLIENT \
                    $msg \
                    [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \
                    $flavor]
        catch {$doc delete}
        set httpStatus 500
        if {$errorCallback ne {}} { $errorCallback $msg httpStatus $operation $flavor }
        ::log::logsubst debug {Leaving @ error 2::WS::Server::callOperation $response}

        # wrap in JSONP
        if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
            set response "$rawargs(jsonp_callback)($response)"
        }

        switch -exact -- $mode {

# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  07/06/2006  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Server::generateError {includeTrace faultcode faultstring detail flavor} {
    ::log::logsubst debug {Entering ::WS::Server::generateError $faultcode $faultstring {$detail}}
    set code [lindex $detail 1]
    switch -exact -- $code {
        "VersionMismatch" {
            set code "SOAP-ENV:VersionMismatch"
        }
        "MustUnderstand" {
            set code "SOAP-ENV:MustUnderstand"

                [$doc asXML -indent none -doctypeDeclaration 0]
            $doc delete
        }
        default {
            error "unsupported flavor"
        }
    }
    ::log::logsubst debug {Leaving (error) ::WS::Server::generateError $response}
    return $response
}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.

# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  07/06/2006  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Server::generateReply {serviceName operation results flavor} {
    ::log::logsubst debug {Entering ::WS::Server::generateReply $serviceName $operation {$results}}

    variable serviceArr

    array set serviceData $serviceArr($serviceName)


    switch -exact -- $flavor {

            $doc delete
        }
        default {
            error "Unsupported flavor"
        }
    }

    ::log::logsubst debug {Leaving ::WS::Server::generateReply $output}
    return $output

}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure

    foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] {
        lappend operList $oper "#op_$oper"
    }
    append msg [::html::h2 {<a id='OperDetails'>Operation Details</a>}]

    set docFormat [dict get $serviceInfo -docFormat]
    foreach {oper anchor} $operList {
        ::log::logsubst debug {\t\tDisplaying '$oper'}
        append msg [::html::h3 "<a id='op_$oper'>$oper</a>"]

        append msg [::html::h4 {Description}] "\n"

        append msg [::html::openTag div {style="margin-left: 40px;"}]
        switch -exact -- $docFormat {
            "html" {

        append msg [::html::openTag div {style="margin-left: 40px;"}]

        if {[llength [dict get $procInfo $service op$oper argOrder]]} {
            append msg [::html::openTag {table} {border="2"}]
            append msg [::html::hdrRow Name Type Description]
            foreach arg [dict get $procInfo $service op$oper argOrder] {
                ::log::logsubst debug {\t\t\tDisplaying '$arg'}
                if {[dict exists $procInfo $service op$oper argList $arg comment]} {
                    set comment [dict get $procInfo $service op$oper argList $arg comment]
                } else {
                    set comment {}
                }
                append msg [::html::row \
                                $arg \

    ##
    ::log::log debug "\tDisplay custom types"
    set service [dict get $serviceInfo -service]
    append msg [::html::h2 {<a id='CustomTypeDetails'>Custom Types</a>}]

    set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service]
    foreach type [lsort -dictionary [dict keys $localTypeInfo]] {
        ::log::logsubst debug {\t\tDisplaying '$type'}
        set href_type [lindex [split $type :] end]
        set typeOverloadArray($type) 1
        append msg [::html::h3 "<a id='type_${href_type}'>$type</a>"]
        set typeDetails [dict get $localTypeInfo $type definition]
        append msg [::html::openTag {table} {border="2"}]
        append msg [::html::hdrRow Field Type Comment]
        foreach part [lsort -dictionary [dict keys $typeDetails]] {
            ::log::logsubst debug {\t\t\tDisplaying '$part'}
            if {[dict exists $typeDetails $part comment]} {
                set comment [dict get $typeDetails $part comment]
            } else {
                set comment {}
            }
            append msg [::html::row \
                            $part \

    set service [dict get $serviceInfo -service]
    append msg [::html::h2 {<a id='SimpleTypeDetails'>Simple Types</a>}]

    append msg "\n<br/>\n<center>" [::html::minorMenu $menuList] "</center>"
    set localTypeInfo [::WS::Utils::GetServiceSimpleTypeDef Server $service]
    foreach typeDetails [lsort -dictionary -index 0 $localTypeInfo] {
        set type [lindex $typeDetails 0]
        ::log::logsubst debug {\t\tDisplaying '$type'}
        set typeOverloadArray($type) 1
        append msg [::html::h3 "<a id='type_$type'>$type</a>"]
        append msg [::html::openTag {table} {border="2"}]
        append msg [::html::hdrRow Attribute Value]
        foreach part [lsort -dictionary [dict keys [lindex $typeDetails 1]]] {
            ::log::logsubst debug {\t\t\tDisplaying '$part'}
            append msg [::html::row \
                            $part \
                            [dict get [lindex $typeDetails 1] $part]
                       ]
        }
        append msg [::html::closeTag]
    }
    append msg "\n<hr/>\n"

    return $msg
}

    }
}

package require log

# Emulate the log::logsubst command introduced in log 1.4
if {![llength [info command ::log::logsubst]]} {

	proc ::log::logsubst {level text} {
		if {[::log::lvIsSuppressed $level]} {
			return
		}
		::log::log $level [uplevel 1 [list subst $text]]
	}








}

package require tdom 0.8
package require struct::set

package provide WS::Utils 2.4.2

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded WS::AOLserver 2.4.0 [list source [file join $dir AOLserver.tcl]]
package ifneeded WS::Channel 2.4.0 [list source [file join $dir ChannelServer.tcl]]
package ifneeded WS::Client 2.5.1 [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Embeded 2.4.1 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::Server 2.4.1 [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.4.2 [list source [file join $dir Utilities.tcl]]
package ifneeded WS::Wub 2.4.0 [list source [file join $dir WubServer.tcl]]
package ifneeded Wsdl 2.4.0 [list source [file join $dir WubServer.tcl]]