Index: AOLserver.tcl ================================================================== --- AOLserver.tcl +++ AOLserver.tcl @@ -1,5 +1,6 @@ +package require Tcl 8.6- namespace eval ::WS::AOLserver { if {![info exists logVersion]} { variable logVersion [package require log] @@ -109,6 +110,6 @@ } } } } -package provide WS::AOLserver 1.4.0 +package provide WS::AOLserver 2.4.0 Index: ChannelServer.tcl ================================================================== --- ChannelServer.tcl +++ ChannelServer.tcl @@ -30,16 +30,33 @@ ## 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.6- +# XXX WS::Utils usable here? (provide dict, lassign) +if {![llength [info command dict]]} { + package require dict +} +if {![llength [info command lassign]]} { + proc lassign {inList args} { + set numArgs [llength $args] + set i -1 + foreach var $args { + incr i + uplevel 1 [list set $var [lindex $inList $i]] + } + return [lrange $inList $numArgs end] + } +} package require uri package require base64 package require html -package provide WS::Channel 1.4.0 +package provide WS::Channel 2.4.0 namespace eval ::WS::Channel { array set portInfo {} array set dataArray {} @@ -57,12 +74,12 @@ # # Description : Register a handler for a url on a port. # # Arguments : # ports -- The port to register the callback on -# operation -- {} for WSDL callback, otherwise opeartion callback -# callback -- The callback prefix, two additionally argumens are lappended +# operation -- {} for WSDL callback, otherwise operation callback +# callback -- The callback prefix, two additionally arguments are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : DELETED CheckAndBuild.tcl Index: CheckAndBuild.tcl ================================================================== --- CheckAndBuild.tcl +++ /dev/null @@ -1,584 +0,0 @@ -############################################################################### -## ## -## Copyright (c) 2006, Arnulf Wiedemann -## All rights reserved. ## -## ## -## Redistribution and use in source and binary forms, with or without ## -## modification, are permitted provided that the following conditions ## -## are met: ## -## ## -## * Redistributions of source code must retain the above copyright ## -## notice, this list of conditions and the following disclaimer. ## -## * Redistributions in binary form must reproduce the above ## -## copyright notice, this list of conditions and the following ## -## disclaimer in the documentation and/or other materials provided ## -## with the distribution. ## -## ## -## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## -## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## -## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## -## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## -## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## -## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## -## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## -## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## -## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## -## 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 WS::Utils - -package provide WS::CheckAndBuild 0.0.3 - -if {![llength [info command dict]]} { - package require dict -} -package require tdom -package require log - -namespace eval ::WS::CheckAndBuild { - variable resultTree - variable currNode -} - - -########################################################################### -# -# Public Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PUBLIC<< -# -# Procedure Name : ::WS::CheckAndBuild::ValidateRequest -# -# Description : Given a schema validate a XML string given as parameter -# using a XML schema description (in WS:: form) for -# validation -# -# Arguments : -# mode - Client/Server -# serviceName - The service name -# tagName - The name of the starting tag -# xmlString - The XML string to validate -# typeInfos - The types infos -# -# Returns : 1 if valition ok, 0 if not -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Arnulf Wiedemann -# -#>>END PUBLIC<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 08/14/2006 A.Wiedemann Initial version -# -# -########################################################################### -proc ::WS::CheckAndBuild::Validate {mode serviceName tagName xmlString typeInfos} { - variable resultTree - variable currNode - - set startInfos [dict get $typeInfos types $tagName] - dom parse $xmlString resultTree - $resultTree documentElement currNode - set nodeName [$currNode nodeName] - if {![string equal $nodeName $tagName]} { - return \ - -code error \ - -errorcode [list WS CHECK START_NODE_DIFFERS [list $tagName $nodeName]] \ - "start node differs expected: $tagName found: $nodeName" - } - return [checkTags $mode $serviceName $startInfos $typeInfos] -} - - -########################################################################### -# -# Public Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PUBLIC<< -# -# Procedure Name : ::WS::CheckAndBuild::BuildRequest -# -# Description : Given a schema check the body of a request handed in -# as a XML string using a XML schema description (in WS:: form) -# for validation -# -# Arguments : -# mode - Client/Server -# serviceName - The service name -# tagName - The name of the starting tag -# typeInfos - The types infos -# -# Returns : The body of the request as xml -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Arnulf Wiedemann -# -#>>END PUBLIC<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 08/13/2006 A.Wiedemann Initial version -# -# -########################################################################### -proc ::WS::CheckAndBuild::BuildRequest {mode serviceName tagName typeInfos valueInfos} { - upvar $valueInfos values - variable resultTree - variable currNode - - set startInfos [dict get $typeInfos types $tagName] - set resultTree [::dom createDocument $tagName] - $resultTree documentElement currNode - buildTags $mode $serviceName $startInfos $typeInfos $valueInfos - return [$resultTree asXML] -} - - -########################################################################### -# -# Private Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PRIVATE<< -# -# Procedure Name : ::WS::CheckAndBuild::buildValue -# -# Description : Check a Value to be put into a tag pair according to the -# XML schema description -# -# Arguments : -# mode - Client/Server -# serviceName - The name of the service -# key - The element to handle -# typeInfo - The type info for the element to handle -# valueInfos - The name of the array with the values -# -# Returns : The value or an error if checking not ok -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Arnulf Wiedemann -# -#>>END PRIVATE<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 08/13/2006 A.Wiedemann Initial version -# -# -########################################################################### -proc ::WS::CheckAndBuild::buildValue {mode serviceName key typeInfo valueInfos} { - upvar $valueInfos values - - catch {unset typeInfos} - array set typeInfos [list \ - minLength 0 \ - maxLength -1 \ - minOccurs 0 \ - maxOccurs -1 \ - fixed false \ - length -1 \ - ] - array set typeInfos $typeInfo - - set val "" - set gotVal 0 - if {[info exists values($key)]} { - set val $values($key) - set gotVal 0 - } - set minLength $typeInfos(minLength) - set maxLength $typeInfos(maxLength) - set minOccurs $typeInfos(minOccurs) - set maxOccurs $typeInfos(maxOccurs) - set fixed $typeInfos(fixed) - if {$minOccurs > 0} { - if {!$gotVal} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $val $pattern]] \ - "No value for '$key' which is mandatory typeInfo:$typeInfo:" - } - } - if {$minLength >= 0} { - if {[string length $val] < $minLength} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_TO_SHORT [list $key $val $minLength $typeInfo]] \ - "Value for $key: '$val' is too short, minLength: $minLength:" - } - } - if {$maxLength >= 0} { - if {[string length $val] > $maxLength} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_TO_LONG [list $key $val $maxLength $typeInfo]] \ - "Value for $key: '$val' is too long, maxLength: $maxLength:" - } - } - set haveEnumeration 0 - set isOk 0 - set enumerationVals [list] - set enumerationInfos [dict get $typeInfo enumeration] - foreach {typeKey typeVal} $enumerationInfos { - set haveEnumeration 1 - lappend enumerationVals $typeVal - if {[string equal $val $typeVal]} { - set isOk 1 - } - } - if {$haveEnumeration && $fixed} { - return [lindex $enumerationVals 0] - } - if {$haveEnumeration && ! $isOk} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $key $val $enumerationVals $typeInfo]] \ - "Value for $key: '$val' is not in enumeration values: '$enumerationVals':" - } - if {[info exists typeInfos(pattern)]} { - set pattern $typeInfos(pattern) - if {! [regexp $pattern $val]} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $val $pattern $typeInfo]] \ - "Value for $key: '$val' does not match pattern: '$pattern':" - } - } - return $val -} - - -########################################################################### -# -# Private Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PRIVATE<< -# -# Procedure Name : ::WS::CheckAndBuild::buildTags -# -# Description : Recursivly build the tags by checking the values to put -# inside the tags and append to the dom tree resultTree -# -# Arguments : -# mode - Client/Server -# serviceName - The service name -# startInfos - The infos for the current tag -# typeInfos - The types infos -# valueInfos - The name of the array with the values -# -# Returns : nothing -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Arnulf Wiedemann -# -#>>END PRIVATE<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 08/13/2006 A.Wiedemann Initial version -# -# -########################################################################### -proc ::WS::CheckAndBuild::buildTags {mode serviceName startInfos typeInfos valueInfos} { - upvar $valueInfos values - variable resultTree - variable currNode - - foreach {key value} $startInfos { - lappend keyList $key - } - foreach entry $keyList { - foreach {key dummy} $entry break - if {[dict exists $startInfos $key type]} { - set allDone 0 - if {[info exists ::WS::Parse::simpleTypes($key)]} { - if {![info exists ::WS::Parse::simpleTypes($mode,$serviceName,$key)]} { - set typeInfo [list type $key] - set val [buildValue $mode $serviceName $key $typeInfo $valueInfos] - $currNode appendChild [$resultTree createElement $key node] - $node appendChild [$resultTree createTextNode $val] - set all_done 1 - } - } - if {!$allDone} { - set typeName [dict get $startInfos $key type] - set typeName [string trimright $typeName "()"] - if {[dict exists $typeInfos types $typeName]} { - set subStartInfos [dict get $typeInfos types $typeName] - set saveNode $currNode - $currNode appendChild [$resultTree createElement $key currNode] - buildTags $mode $serviceName $subStartInfos $typeInfos $valueInfos - set currNode $saveNode - } else { - set simpleTypeInfos [::WS::Utils::GetServiceSimpleTypeDef $mode $serviceName $typeName] - set val [buildValue $mode $serviceName $key $simpleTypeInfos $valueInfos] - $currNode appendChild [$resultTree createElement $key node] - $node appendChild [$resultTree createTextNode $val] - } - } - } else { - return \ - -code error \ - -errorcode [list WS CHECK SIMPLE_TYPES2_NOT_IMPLEMENTED [list $key $startInfos]] \ - "simple type 2 part not yet implemented (in handling key: $key startInfos: $startInfos:" - } - } -} - - -########################################################################### -# -# Private Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PRIVATE<< -# -# Procedure Name : ::WS::CheckAndBuild::checkValue -# -# Description : Check a Value between tags of a XML document against the -# type in the XML schema description -# -# Arguments : -# mode - Client/Server -# serviceName - The name of the service -# key - The element to handle -# value - The value to check -# typeInfo - The type info for the element to handle -# -# Returns : 1 if ok or 0 if checking not ok -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Arnulf Wiedemann -# -#>>END PRIVATE<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 08/14/2006 A.Wiedemann Initial version -# -# -########################################################################### -proc ::WS::CheckAndBuild::checkValue {mode serviceName key value typeInfo} { - - catch {unset typeInfos} - array set typeInfos [list \ - minLength 0 \ - maxLength -1 \ - minOccurs 0 \ - maxOccurs -1 \ - fixed false \ - length -1 \ - ] - array set typeInfos $typeInfo - set minLength $typeInfos(minLength) - set maxLength $typeInfos(maxLength) - set minOccurs $typeInfos(minOccurs) - set maxOccurs $typeInfos(maxOccurs) - set fixed $typeInfos(fixed) - if {$minOccurs > 0} { - if {[string length $value] == 0} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $value $pattern]] \ - "No value for $key which is mandatory typeInfo:$typeInfo:" - } - } - if {$minLength >= 0} { - if {[string length $value] < $minLength} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_TO_SHORT [list $key $value $minLength $typeInfo]] \ - "Value for $key: '$value' is too short, minLength: $minLength:" - } - } - if {$maxLength >= 0} { - if {[string length $value] > $maxLength} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_TO_LONG [list $key $value $maxLength $typeInfo]] \ - "Value for $key: '$value' is too long, maxLength: $maxLength:" - } - } - set haveEnumeration 0 - set isOk 0 - set enumerationVals [list] - set enumerationInfos [dict get $typeInfo enumeration] - foreach {typeKey typeVal} $enumerationInfos { - set haveEnumeration 1 - lappend enumerationVals $typeVal - if {[string equal $value $typeVal]} { - set isOk 1 - } - } - if {$haveEnumeration && ! $isOk} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $key $value $enumerationVals $typeInfo]] \ - "Value for $key: '$value' is not in enumeration values: '$enumerationVals':" - } - if {[info exists typeInfos(pattern)]} { - set pattern $typeInfos(pattern) - if {! [regexp $pattern $value]} { - return \ - -code error \ - -errorcode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $value $pattern $typeInfo]] \ - "Value for $key: '$value' does not match pattern: '$pattern':" - } - } - return 1 -} - - - -########################################################################### -# -# Private Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PRIVATE<< -# -# Procedure Name : ::WS::CheckAndBuild::checkTags -# -# Description : Recursivly check the tags and values inside the tags -# -# Arguments : -# mode - Client/Server -# serviceName - The service name -# startInfos - The infos for the current tag -# typeInfos - The types infos -# -# Returns : 1 if ok, 0 otherwise -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Arnulf Wiedemann -# -#>>END PRIVATE<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 08/13/2006 A.Wiedemann Initial version -# -# -########################################################################### -proc ::WS::CheckAndBuild::checkTags {mode serviceName startInfos typeInfos} { - variable resultTree - variable currNode - - foreach {key value} $startInfos { - lappend keyList $key - } - set node [$currNode firstChild] - set lastNode [$currNode lastChild] - foreach entry $keyList { - foreach {key dummy} $entry break - if {[dict exists $startInfos $key type]} { - set allDone 0 - if {[info exists ::WS::Parse::simpleTypes($key)]} { - if {![info exists ::WS::Parse::simpleTypes($mode,$serviceName,$key)]} { - set typeInfo [list type $key] - if {[$node hasChildNodes]} { - set textNode [$node firstChild] - set value [$textNode nodeValue] - } else { - # there is no text node so set value to empty - set value "" - } - checkValue $mode $serviceName $key $value $typeInfo - set all_done 1 - } - } - if {!$allDone} { - set typeName [dict get $startInfos $key type] - set typeName [string trimright $typeName "()"] - if {[dict exists $typeInfos types $typeName]} { - set subStartInfos [dict get $typeInfos types $typeName] - set currNode $node - checkTags $mode $serviceName $subStartInfos $typeInfos - set node $currNode - } else { - set simpleTypeInfos [::WS::Utils::GetServiceSimpleTypeDef $mode $serviceName $typeName] - if {[$node hasChildNodes]} { - set textNode [$node firstChild] - set value [$textNode nodeValue] - } else { - # there is no text node so set value to empty - set value "" - } - checkValue $mode $serviceName $key $value $simpleTypeInfos - } - } - } else { - return \ - -code error \ - -errorcode [list WS CHECK SIMPLE_TYPES2_NOT_IMPLEMENTED [list $key $startInfos]] \ - "simple type 2 part not yet implemented (in handling key: $key startInfos: $startInfos:" - } - if {$node != $lastNode} { - set node [$node nextSibling] - } - } - return 1 -} - Index: ClientSide.tcl ================================================================== --- ClientSide.tcl +++ ClientSide.tcl @@ -1,8 +1,9 @@ ############################################################################### ## ## -## Copyright (c) 2006-2008, Gerald W. Lester ## +## Copyright (c) 2016-2019, Harald Oehlmann ## +## Copyright (c) 2006-2013, Gerald W. Lester ## ## Copyright (c) 2008, Georgios Petasis ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## Copyright (c) 2006, Arnulf Wiedemann ## ## Copyright (c) 2006, Colin McCormack ## ## Copyright (c) 2006, Rolf Ade ## @@ -37,28 +38,42 @@ ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### -package require WS::Utils -#package require Tcl 8.5 -if {![llength [info command dict]]} { - package require dict -} +package require Tcl 8.6- +package require WS::Utils ; # logsubst package require tdom 0.8 package require http 2 package require log package require uri -catch { - package require tls - http::register https 443 ::tls::socket -} - -package provide WS::Client 1.4.1 +package provide WS::Client 3.0.1 namespace eval ::WS::Client { + # register https only if not yet registered + if {[catch { http::unregister https } lPortCmd]} { + # not registered -> register on my own + if {[catch { + package require tls + http::register https 443 ::tls::socket + } err]} { + log::log warning "No TLS package: $err" + if { [catch { + package require twapi_crypto + http::register https 443 ::twapi::tls_socket + + } Err] } { + log::log warning "No https support. No TWAPI package: $err" + } + } + } else { + # Ok, was registered - reregister + http::register https {*}$lPortCmd + } + unset -nocomplain err lPortCmd + ## ## serviceArr is indexed by service name and contains a dictionary that ## defines the service. The dictionary has the following structure: ## targetNamespace - the target namespace ## operList - list of operations @@ -89,15 +104,188 @@ ## outputs --- return type ## ## Note -- all type information is formated suitable to be passed ## to ::WS::Utils::ServiceTypeDef ## - array set serviceArr {} - set currentBaseUrl {} + array set ::WS::Client::serviceArr {} + set ::WS::Client::currentBaseUrl {} + array set ::WS::Client::options { + skipLevelWhenActionPresent 0 + skipLevelOnReply 0 + skipHeaderLevel 0 + suppressTargetNS 0 + allowOperOverloading 1 + contentType {text/xml;charset=utf-8} + UseNS {} + parseInAttr {} + genOutAttr {} + valueAttrCompatiblityMode 1 + suppressNS {} + useTypeNs {} + nsOnChangeOnly {} + noTargetNs 0 + errorOnRedefine 0 + inlineElementNS 1 + queryTimeout 60000 + } + ## + ## List of options which are copied to the service array + ## + set ::WS::Client::serviceLocalOptionsList { + skipLevelWhenActionPresent + skipLevelOnReply + skipHeaderLevel + suppressTargetNS + allowOperOverloading + contentType + UseNS + parseInAttr + genOutAttr + valueAttrCompatiblityMode + suppressNS + useTypeNs + nsOnChangeOnly + noTargetNs + queryTimeout + } + + ## + ## List of options which are set and restored in the Utilities module + ## when we do a call into the module + ## + set ::WS::Client::utilsOptionsList { + UseNS + parseInAttr + genOutAttr + valueAttrCompatiblityMode + suppressNS + useTypeNs + nsOnChangeOnly + } } +########################################################################### +# +# Public Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PUBLIC<< +# +# Procedure Name : ::WS::Client::SetOption +# +# Description : Set or get file global or default option. +# Global option control the service creation process. +# Default options are takren as defaults to new created services. +# +# Arguments : +# -globalonly +# - Return list of global options/values +# -defaultonly +# - Return list of default options/values +# -- +# option - Option to be set/retrieved +# Return all option/values if omitted +# args - Value to set the option to +# Return the value if not given +# +# Returns : The value of the option +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PUBLIC<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 04/272009 G.Lester Initial version +# 2.4.5 2017-12-04 H.Oehlmann Return all current options if no argument +# given. Options -globalonly or -defaultonly +# limit this to options which are (not) +# copied to the service. +# +########################################################################### +proc ::WS::Client::SetOption {args} { + variable options + variable serviceLocalOptionsList + if {0 == [llength $args]} { + return [array get options] + } + set args [lassign $args option] + + switch -exact -- $option { + -globalonly { + ## + ## Return list of global options + ## + # A list convertible to a dict is build for performance reasons: + # - lappend does not test existence for each element + # - if a list is needed, dict build burden is avoided + set res {} + foreach option [array names options] { + if {$option ni $serviceLocalOptionsList} { + lappend res $option $options($option) + } + } + return $res + } + -defaultonly { + ## + ## Return list of default options + ## + set res {} + foreach option [array names options] { + if {$option in $serviceLocalOptionsList} { + lappend res $option $options($option) + } + } + return $res + } + -- { + ## + ## End of options + ## + set args [lassign $args option] + } + } + ## + ## Check if given option exists + ## + if {![info exists options($option)]} { + return -code error \ + -errorcode [list WS CLIENT UNKOPT $option] \ + "Unknown option: '$option'" + } + ## + ## Check if value is given + ## + switch -exact -- [llength $args] { + 0 { + return $options($option) + } + 1 { + set value [lindex $args 0] + set options($option) $value + return $value + } + default { + return -code error \ + -errorcode [list WS CLIENT INVALDCNT $args] \ + "To many parameters: '$args'" + } + } +} + ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # @@ -131,35 +319,152 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 04/14/2009 G.Lester Initial version -# +# 2.4.5 2017-12-04 H.Oehlmann Use distinct list of option items, which are +# copied to the service array. Not all options +# are used in the service array. # ########################################################################### -proc ::WS::Client::CreateService {serviceName type url args} { +proc ::WS::Client::CreateService {serviceName type url target args} { variable serviceArr + variable options + variable serviceLocalOptionsList + + if {$options(errorOnRedefine) && [info exists serviceArr($serviceName)]} { + return -code error "Service '$serviceName' already exists" + } elseif {[info exists serviceArr($serviceName)]} { + unset serviceArr($serviceName) + } dict set serviceArr($serviceName) types {} dict set serviceArr($serviceName) operList {} dict set serviceArr($serviceName) objList {} dict set serviceArr($serviceName) headers {} - dict set serviceArr($serviceName) targetNamespace [list [list tns1 $url]] + dict set serviceArr($serviceName) targetNamespace tns1 $target dict set serviceArr($serviceName) name $serviceName dict set serviceArr($serviceName) location $url dict set serviceArr($serviceName) style $type + dict set serviceArr($serviceName) imports {} dict set serviceArr($serviceName) inTransform {} dict set serviceArr($serviceName) outTransform {} + foreach item $serviceLocalOptionsList { + dict set serviceArr($serviceName) $item $options($item) + } foreach {name value} $args { set name [string trimleft $name {-}] dict set serviceArr($serviceName) $name $value } + ::log::logsubst debug {Setting Target Namespace tns1 as $target} if {[dict exists $serviceArr($serviceName) xns]} { - set xns [dict get $serviceArr($serviceName) xns] - ::log::log debug [list Setting targetNamespae to $xns] - dict set serviceArr($serviceName) targetNamespace [list $xns] + foreach xnsItem [dict get $serviceArr($serviceName) xns] { + lassign $xnsItem tns xns + ::log::logsubst debug {Setting targetNamespace $tns for $xns} + dict set serviceArr($serviceName) targetNamespace $tns $xns + } + } +} + +########################################################################### +# +# Public Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PUBLIC<< +# +# Procedure Name : ::WS::Client::Config +# +# Description : Configure a service information +# +# Arguments : +# serviceName - Service name to add namespace to. +# Return a list of items/values of default options if not +# given. +# item - The item to configure. Return a list of all items/values +# if not given. +# value - Optional, the new value. Return the value, if not given. +# +# Returns : The value of the option or a list of item/value pairs. +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PUBLIC<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 04/14/2009 G.Lester Initial version +# 2.4.5 2017-12-04 H.Oehlmann Allow to set an option to the empty string. +# Return all option/values, if called without +# item. Return default items/values if no +# service given. +# +########################################################################### +proc ::WS::Client::Config {args} { + variable serviceArr + variable options + variable serviceLocalOptionsList + + set validOptionList $serviceLocalOptionsList + lappend validOptionList location targetNamespace + + if {0 == [llength $args]} { + # A list convertible to a dict is build for performance reasons: + # - lappend does not test existence for each element + # - if a list is needed, dict build burden is avoided + set res {} + foreach item $validOptionList { + lappend res $item + if {[info exists options($item)]} { + lappend res $options($item) + } else { + lappend res {} + } + } + return $res + } + set args [lassign $args serviceName] + if {0 == [llength $args]} { + set res {} + foreach item $validOptionList { + lappend res $item [dict get $serviceArr($serviceName) $item] + } + return $res + } + + set args [lassign $args item] + if { $item ni $validOptionList } { + return -code error "Uknown option '$item' -- must be one of: [join $validOptionList {, }]" + } + + switch -exact -- [llength $args] { + 0 { + return [dict get $serviceArr($serviceName) $item] + } + 1 { + set value [lindex $args 0] + dict set serviceArr($serviceName) $item $value + return $value + } + default { + ::log::log debug "To many arguments arguments {$args}" + return \ + -code error \ + -errorcode [list WS CLIENT INVARGCNT $args] \ + "To many arguments '$args'" + } } } ########################################################################### # @@ -207,11 +512,11 @@ variable serviceArr dict set serviceArr($serviceName) inTransform $inTransform dict set serviceArr($serviceName) outTransform $outTransform - return; + return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure @@ -267,15 +572,16 @@ # Procedure Name : ::WS::Client::DefineRestMethod # # Description : Define a method # # Arguments : -# serviceName - Service name to add namespace to -# methodName - The name of the method to add -# inputArgs - List of input argument definitions where each argument +# serviceName - Service name to add namespace to +# objectName - Name of the object +# operationName - The name of the method to add +# inputArgs - List of input argument definitions where each argument # definition is of the format: name typeInfo -# returnType - The type, if any returned by the procedure. Format is: +# returnType - The type, if any returned by the procedure. Format is: # xmlTag typeInfo # # where, typeInfo is of the format {type typeName comment commentString} # # Returns : The current service definition @@ -302,23 +608,23 @@ ########################################################################### proc ::WS::Client::DefineRestMethod {serviceName objectName operationName inputArgs returnType {location {}}} { variable serviceArr if {[lsearch -exact [dict get $serviceArr($serviceName) objList] $objectName] == -1} { - dict lappend $serviceArr($serviceName) objList $objectName + dict lappend serviceArr($serviceName) objList $objectName } if {![llength $location]} { set location [dict get $serviceArr($serviceName) location] } - if {![string equal $inputArgs {}]} { + if {$inputArgs ne {}} { set inType $objectName.$operationName.Request ::WS::Utils::ServiceTypeDef Client $serviceName $inType $inputArgs } else { set inType {} } - if {![string equal $returnType {}]} { + if {$returnType ne {}} { set outType $objectName.$operationName.Results ::WS::Utils::ServiceTypeDef Client $serviceName $outType $returnType } else { set outType {} } @@ -361,50 +667,47 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 01/30/2009 G.Lester Initial version +# 2.4.1 2017-08-31 H.Oehlmann Use utility function +# ::WS::Utils::geturl_fetchbody for http call +# which also follows redirects. +# 3.0.0 2020-10-26 H.Oehlmann Add geturl timeout # # ########################################################################### proc ::WS::Client::ImportNamespace {serviceName url} { variable serviceArr - switch [dict get [::uri::split $url] scheme] { + set serviceInfo $serviceArr($serviceName) + switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token set xml $token(data) unset token } - http { - set token [::http::geturl $url] - ::http::wait $token - set ncode [::http::ncode $token] - set xml [::http::data $token] - ::http::cleanup $token - if {$ncode != 200} { - return \ - -code error \ - -errorcode [list WS CLIENT HTTPFAIL $url] \ - "HTTP get of import file failed '$url'" - } + http - + https { + set xml [::WS::Utils::geturl_fetchbody $url\ + -timeout [dict get $serviceInfo queryTimeout]] } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" } } - set tnsCount [llength [dict get $serviceArr($serviceName) targetNamespace]] - set serviceInfo $serviceArr($serviceName) + set tnsCount [expr {[llength [dict get $serviceArr($serviceName) targetNamespace]]/2}] + dict lappend serviceInfo imports $url ::WS::Utils::ProcessImportXml Client $url $xml $serviceName serviceInfo tnsCount set serviceArr($serviceName) $serviceInfo set result {} - foreach pair [dict get $serviceArr($serviceName) targetNamespace] { - if {[string equal [lindex $pair 1] $url]} { - set result [lindex $pair 0] + foreach {result target} [dict get $serviceArr($serviceName) targetNamespace] { + if {$target eq $url} { + break } } return $result } @@ -445,14 +748,14 @@ # ########################################################################### proc ::WS::Client::GetOperationList {serviceName {object {}}} { variable serviceArr - if {[string equal $object {}]} { + if {$object eq {}} { return [dict get $serviceArr($serviceName) operList] } else { - return [dict get $serviceArr($serviceName) operation $object inputs] + return [list $object [dict get $serviceArr($serviceName) operation $object inputs] [dict get $serviceArr($serviceName) operation $object outputs]] } } ########################################################################### @@ -465,11 +768,11 @@ # Procedure Name : ::WS::Client::AddInputHeader # # Description : Import and additional namespace into the service # # Arguments : -# serviceName - Service name to of the oepration +# serviceName - Service name to of the operation # operation - name of operation to add an input header to # headerType - the type name to add as a header # attrList - list of name value pairs of attributes and their # values to add to the XML # @@ -501,11 +804,11 @@ set serviceInfo $serviceArr($serviceName) set soapRequestHeader [dict get $serviceInfo operation $operationName soapRequestHeader] lappend soapRequestHeader [list $headerType $attrList] dict set serviceInfo operation $operationName soapRequestHeader $soapRequestHeader set serviceArr($serviceName) $serviceInfo - return ; + return } ########################################################################### # @@ -514,11 +817,11 @@ # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::AddOutputHeader # -# Description : Import and additional namespace into the service +# Description : Import any additional namespace into the service # # Arguments : # serviceName - Service name to of the oepration # operation - name of operation to add an output header to # headerType - the type name to add as a header @@ -549,18 +852,67 @@ ########################################################################### proc ::WS::Client::AddOutputHeader {serviceName operation headerType} { variable serviceArr set serviceInfo $serviceArr($serviceName) - set soapReplyHeader [dict get $serviceInfo operation $operationName soapReplyHeader] + set soapReplyHeader [dict get $serviceInfo operation $operation soapReplyHeader] lappend soapReplyHeader $headerType - dict set serviceInfo operation $operationName soapReplyHeader $soapReplyHeader + dict set serviceInfo operation $operation soapReplyHeader $soapReplyHeader set serviceArr($serviceName) $serviceInfo - return ; + return } + +########################################################################### +# +# Public Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PUBLIC<< +# +# Procedure Name : ::WS::Client::GetParsedWsdl +# +# Description : Get a service definition +# +# Arguments : +# serviceName - Name of the service. +# +# Returns : The parsed service information +# +# Side-Effects : None +# +# Exception Conditions : UNKSERVICE +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PUBLIC<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 07/06/2006 G.Lester Initial version +# +# +########################################################################### +proc ::WS::Client::GetParsedWsdl {serviceName} { + variable serviceArr + + if {![info exists serviceArr($serviceName)]} { + return \ + -code error "Unknown service '$serviceName'" \ + -errorcode [list UNKSERVICE $serviceName] + } + + return $serviceArr($serviceName) +} + ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # @@ -601,46 +953,70 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 3.0.0 2020-10-30 H.Oehlmann Smooth option migration. # # ########################################################################### proc ::WS::Client::LoadParsedWsdl {serviceInfo {headers {}} {serviceAlias {}}} { variable serviceArr + variable options + variable serviceLocalOptionsList if {[string length $serviceAlias]} { set serviceName $serviceAlias } else { set serviceName [dict get $serviceInfo name] } + if {$options(errorOnRedefine) && [info exists serviceArr($serviceName)]} { + return -code error "Service '$serviceName' already exists" + } elseif {[info exists serviceArr($serviceName)]} { + unset serviceArr($serviceName) + } + if {[llength $headers]} { dict set serviceInfo headers $headers } set serviceArr($serviceName) $serviceInfo + + ## + ## Copy any not present options from the default values + ## This allows smooth migration, if a new version of the package define + ## new options and the preparsed service of the old version was stored. + ## + + foreach item $serviceLocalOptionsList { + if {![dict exists $serviceArr($serviceName) $item]} { + dict set serviceArr($serviceName) $item $options($item) + } + } if {[dict exists $serviceInfo types]} { foreach {typeName partList} [dict get $serviceInfo types] { - if {[string equal [lindex [split $typeName {:}] 1] {}]} { - ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $partList tns1 + set definition [dict get $partList definition] + set xns [dict get $partList xns] + set isAbstarct [dict get $partList abstract] + if {[lindex [split $typeName {:}] 1] eq {}} { + ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition tns1 $isAbstarct } else { - set xns [lindex [split $typeName {:}] 0] - set typeName [lindex [split $typeName {:}] 1] - ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $partList $xns + #set typeName [lindex [split $typeName {:}] 1] + ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition $xns $isAbstarct } } } if {[dict exists $serviceInfo simpletypes]} { - foreach {typeName partList} [dict get $serviceInfo simpletypes] { - if {[string equal [lindex [split $typeName {:}] 1] {}]} { - ::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $partList tns1 + foreach partList [dict get $serviceInfo simpletypes] { + lassign $partList typeName definition + if {[lindex [split $typeName {:}] 1] eq {}} { + ::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $definition tns1 } else { set xns [lindex [split $typeName {:}] 0] - set typeName [lindex [split $typeName {:}] 1] - ::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $partList $xns + #set typeName [lindex [split $typeName {:}] 1] + ::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $definition $xns } } } return $serviceName @@ -656,21 +1032,24 @@ # Procedure Name : ::WS::Client::GetAndParseWsdl # # Description : # # Arguments : -# url - The url of the WSDL -# headers - Extra headers to add to the HTTP request. This +# url - The url of the WSDL +# headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. -# serviceAlias - Alias (unique) name for service. -# This is an optional argument and defaults to the name of the -# service in serviceInfo. +# serviceAlias - Alias (unique) name for service. +# This is an optional argument and defaults to the name +# of the service in serviceInfo. +# serviceNumber - Number of service within the WSDL to assign the +# serviceAlias to. Only usable with a serviceAlias. +# First service (default) is addressed by value "1". # # Returns : The parsed service definition # # Side-Effects : None # @@ -687,33 +1066,36 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version -# +# 2.4.1 2017-08-31 H.Oehlmann Use utility function +# ::WS::Utils::geturl_fetchbody for http call +# 2.4.6 2017-12-07 H.Oehlmann Added argument "serviceNumber". +# 3.0.0 2020-10-26 H.Oehlmann Added query timeout # ########################################################################### -proc ::WS::Client::GetAndParseWsdl {url {headers {}} {serviceAlias {}}} { +proc ::WS::Client::GetAndParseWsdl {url {headers {}} {serviceAlias {}} {serviceNumber 1}} { variable currentBaseUrl + variable options set currentBaseUrl $url - switch [dict get [::uri::split $url] scheme] { + switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token - set wsdlInfo [ParseWsdl $token(data) -headers $headers -serviceAlias $serviceAlias] + set wsdlInfo [ParseWsdl $token(data) -headers $headers -serviceAlias $serviceAlias -serviceNumber $serviceNumber] unset token } http - https { + set largs {} if {[llength $headers]} { - set token [::http::geturl $url -headers $headers] - } else { - set token [::http::geturl $url] + lappend largs -headers $headers } - ::http::wait $token - set wsdlInfo [ParseWsdl [::http::data $token] -headers $headers -serviceAlias $serviceAlias] - ::http::cleanup $token + set body [::WS::Utils::geturl_fetchbody $url\ + -timeout $options(queryTimeout) {*}$largs] + set wsdlInfo [ParseWsdl $body -headers $headers -serviceAlias $serviceAlias -serviceNumber $serviceNumber] } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ @@ -732,30 +1114,32 @@ # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::ParseWsdl # -# Description : Parse a WSDL +# Description : Parse a WSDL and create the service. Create stubs if specified. # # Arguments : # wsdlXML - XML of the WSDL # # Optional Arguments: # -createStubs 0|1 - create stub routines for the service -# NOTE -- Webservice arguments are position -# independent, thus the proc arguments -# will be defined in alphabetical order. # -headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. -# -serviceAlias - Alias (unique) name for service. -# This is an optional argument and defaults to the name of the -# service in serviceInfo. +# -serviceAlias - Alias (unique) name for service. +# This is an optional argument and defaults to the +# name of the service in serviceInfo. +# -serviceNumber - Number of service within the WSDL to assign the +# serviceAlias to. Only usable with a serviceAlias. +# First service (default) is addressed by value "1". +# +# NOTE -- Arguments are position independent. # # Returns : The parsed service definition # # Side-Effects : None # @@ -772,56 +1156,186 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version -# +# 2.4.4 2017-11-03 H.Oehlmann Included ticket [dcce437d7a] with +# solution by Wolfgang Winkler: +# Search namespace prfix also in element +# nodes and not only in definition node +# of wsdl file. +# 2.4.4 2017-11-06 H.Oehlmann Added check (for nested namespace prefix +# case), that a namespace prefix is not +# reused for another URI. +# 2.4.5 2017-11-24 H.Oehlmann Added option "inlineElementNS" to activate +# namespace definition search in element nodes +# 2.4.6 2017-12-07 H.Oehlmann Added argument "-serviceNumber". # ########################################################################### proc ::WS::Client::ParseWsdl {wsdlXML args} { + variable currentBaseUrl variable serviceArr + variable options - array set defaults { + # Build the argument array with the following defaults + array set argument { -createStubs 0 -headers {} -serviceAlias {} + -serviceNumber 1 } + array set argument $args - array set defaults $args + set first [string first {<} $wsdlXML] + if {$first > 0} { + set wsdlXML [string range $wsdlXML $first end] + } + ::log::logsubst debug {Parsing WSDL: $wsdlXML} - dom parse $wsdlXML wsdlDoc + # save parsed document node to tmpdoc + dom parse $wsdlXML tmpdoc + # save transformed document handle in variable wsdlDoc + $tmpdoc xslt $::WS::Utils::xsltSchemaDom wsdlDoc + $tmpdoc delete + # save top node in variable wsdlNode $wsdlDoc documentElement wsdlNode + set nsCount 1 + set targetNs [$wsdlNode getAttribute targetNamespace] + set ::WS::Utils::targetNs $targetNs + ## + ## Build the namespace prefix dict + ## + # nsDict contains two tables: + # 1) Lookup URI, get internal prefix + # url + # 2) Lookup wsdl namespace prefix, get internal namespace prefix + # tns + # : unique ID, mostly URL + # : namespace prefix used in wsdl + # internal namespace prefix which allows to use predefined prefixes + # not to clash with the wsdl prefix in + # Predefined: + # - tns1 : targetNamespace + # - w: http://schemas.xmlsoap.org/wsdl/ + # - d: http://schemas.xmlsoap.org/wsdl/soap/ + # - xs: http://www.w3.org/2001/XMLSchema + # + # The top node + # + # xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/ ...> + # contains the target namespace and all namespace definitions + dict set nsDict url $targetNs tns$nsCount + $wsdlDoc selectNodesNamespaces { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ - s http://www.w3.org/2001/XMLSchema + xs http://www.w3.org/2001/XMLSchema } - if {[string length $defaults(-serviceAlias)]} { - set serviceAlias $defaults(-serviceAlias) + + ## + ## build list of namespace definition nodes + ## + ## the top node is always used + set NSDefinitionNodeList [list $wsdlNode] + + ## + ## get namespace definitions in element nodes + ## + ## Element nodes may declare namespaces inline like: + ## + ## ticket [dcce437d7a] + + # This is only done, if option inlineElementNS is set in the default + # options. Service dependent options may not be used at this stage, + # as serviceArr is not created jet (Client::Config will fail) and the + # service name is not known jet. + if {$options(inlineElementNS)} { + lappend NSDefinitionNodeList {*}[$wsdlDoc selectNodes {//xs:element}] + } + foreach elemNode $NSDefinitionNodeList { + # Get list of xmlns attributes + # This list looks for the example like: {{q1 q1 {}} ... } + set xmlnsAttributes [$elemNode attributes xmlns:*] + # Loop over found namespaces + foreach itemList $xmlnsAttributes { + set ns [lindex $itemList 0] + set url [$elemNode getAttribute xmlns:$ns] + + if {[dict exists $nsDict url $url]} { + set tns [dict get $nsDict url $url] + } else { + ## + ## Check for hardcoded namespaces + ## + switch -exact -- $url { + http://schemas.xmlsoap.org/wsdl/ { + set tns w + } + http://schemas.xmlsoap.org/wsdl/soap/ { + set tns d + } + http://www.w3.org/2001/XMLSchema { + set tns xs + } + default { + set tns tns[incr nsCount] + } + } + dict set nsDict url $url $tns + } + ## + ## Check if same namespace prefix was already assigned to a + ## different URL + ## + # This may happen, if the element namespace prefix overwrites + # a global one, like + # + # + if { [dict exists $nsDict tns $ns] && $tns ne [dict get $nsDict tns $ns] } { + ::log::logsubst debug {Namespace prefix '$ns' with different URI '$url': $nsDict} + return \ + -code error \ + -errorcode [list WS CLIENT AMBIGNSPREFIX] \ + "element namespace prefix '$ns' used again for different URI '$url'.\ + Sorry, this is a current implementation limitation of TCLWS." + } + dict set nsDict tns $ns $tns + } + } + + if {[info exists currentBaseUrl]} { + set url $currentBaseUrl } else { - set serviceAlias {} + set url $targetNs } + array unset ::WS::Utils::includeArr + ::WS::Utils::ProcessIncludes $wsdlNode $url + set serviceInfo {} - foreach serviceInfo [buildServiceInfo $wsdlNode $serviceInfo $serviceAlias] { + foreach serviceInfo [buildServiceInfo $wsdlNode $nsDict $serviceInfo $argument(-serviceAlias) $argument(-serviceNumber)] { set serviceName [dict get $serviceInfo name] - if {[llength $defaults(-headers)]} { - dict set serviceInfo headers $defaults(-headers) + if {[llength $argument(-headers)]} { + dict set serviceInfo headers $argument(-headers) } + dict set serviceInfo types [::WS::Utils::GetServiceTypeDef Client $serviceName] + dict set serviceInfo simpletypes [::WS::Utils::GetServiceSimpleTypeDef Client $serviceName] set serviceArr($serviceName) $serviceInfo - if {$defaults(-createStubs)} { + if {$argument(-createStubs)} { catch {namespace delete $serviceName} namespace eval $serviceName {} CreateStubs $serviceName } } $wsdlDoc delete + unset -nocomplain ::WS::Utils::targetNs return $serviceInfo } @@ -882,20 +1396,23 @@ set serviceInfo $serviceArr($serviceName) set procList {} foreach operationName [dict get $serviceInfo operList] { + if {[dict get $serviceInfo operation $operationName cloned]} { + continue + } set procName [format {::%s::%s} $serviceName $operationName] set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] - if {[string equal $inputHeaderType {}]} { + if {$inputHeaderType eq {}} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] - if {![string equal $headerFields {}]} { + if {$headerFields ne {}} { lappend argList [lsort -dictionary $headerFields] } } set inputMsgType [dict get $serviceInfo operation $operationName inputs] ## Petasis, 14 July 2008: If an input message has no elements, just do @@ -902,14 +1419,14 @@ ## not add any arguments... set inputMsgTypeDefinition [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] if {[dict exists $inputMsgTypeDefinition definition]} { set inputFields [dict keys [dict get $inputMsgTypeDefinition definition]] } else { - ::log::log debug "no definition found for inputMsgType $inputMsgType" + ::log::logsubst debug {no definition found for inputMsgType $inputMsgType} set inputFields {} } - if {![string equal $inputFields {}]} { + if {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } set argList [join $argList] set body { @@ -918,11 +1435,11 @@ set operationName [string trim [namespace tail $procName] {:}] set argList {} foreach var [namespace eval ::${serviceName}:: [list info args $operationName]] { lappend argList $var [set $var] } - ::log::log debug [list ::WS::Client::DoCall $serviceName $operationName $argList] + ::log::logsubst debug {::WS::Client::DoCall $serviceName $operationName $argList} ::WS::Client::DoCall $serviceName $operationName $argList } proc $procName $argList $body append procList "\n\t[list $procName $argList]" } @@ -941,11 +1458,11 @@ # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call -# argList - The arguements to the operation as a dictionary object. +# argList - The arguments to the operation as a dictionary object. # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. @@ -957,11 +1474,11 @@ # The XML of the operation. # # Side-Effects : None # # Exception Conditions : -# WSCLIENT HTTPERROR - if an HTTP error occured +# WS CLIENT HTTPERROR - if an HTTP error occurred # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # @@ -972,17 +1489,21 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2.4.1 2017-08-31 H.Oehlmann Use utility function +# ::WS::Utils::geturl_fetchbody for http call +# which also follows redirects. +# 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoRawCall {serviceName operationName argList {headers {}}} { variable serviceArr - ::log::log debug "Entering ::WS::Client::DoRawCall {$serviceName $operationName $argList}" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -992,51 +1513,46 @@ return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" } + + ## + ## build query + ## + set url [dict get $serviceInfo location] - set query [buildCallquery $serviceName $operationName $url $argList] + SaveAndSetOptions $serviceName + if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} { + RestoreSavedOptions $serviceName + return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err + } else { + RestoreSavedOptions $serviceName + } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } if {[dict exists $serviceInfo operation $operationName action]} { - lappend headers SOAPAction [dict get $serviceInfo operation $operationName action] + lappend headers SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]] } + + ## + ## do http call + ## + + set largs {} if {[llength $headers]} { - set token [::http::geturl $url -query $query -type text/xml -headers $headers] - } else { - set token [::http::geturl $url -query $query -type text/xml] - } - ::http::wait $token - - ## - ## Check for errors - ## - set body [::http::data $token] - if {![string equal [::http::status $token] ok] || - ([::http::ncode $token] != 200 && [string equal $body {}])} { - set errorCode [list WSCLIENT HTTPERROR [::http::code $token]] - set errorInfo {} - set results [::http::error $token] - set hadError 1 - } else { - set hadError 0 - set results [::http::data $token] - } - ::http::cleanup $token - if {$hadError} { - ::log::log debug "Leaving (error) ::WS::Client::DoRawCall" - return \ - -code error \ - -errorcode $errorCode \ - -errorinfo $errorInfo \ - $results - } else { - ::log::log debug "Leaving ::WS::Client::DoRawCall with {$results}" - return $results - } + lappend largs -headers $headers + } + set body [::WS::Utils::geturl_fetchbody $url\ + -query $query\ + -type [dict get $serviceInfo contentType]\ + -timeout [dict get $serviceInfo queryTimeout]\ + {*}$largs] + + ::log::logsubst debug {Leaving ::WS::Client::DoRawCall with {$body}} + return $body } ########################################################################### # @@ -1050,11 +1566,11 @@ # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call -# argList - The arguements to the operation as a dictionary object +# argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. @@ -1066,11 +1582,11 @@ # The return value of the operation as a dictionary object. # # Side-Effects : None # # Exception Conditions : -# WSCLIENT HTTPERROR - if an HTTP error occured +# WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester @@ -1082,17 +1598,21 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2.4.1 2017-08-30 H.Oehlmann Use ::WS::Utils::geturl_fetchbody to do +# http call. This automates a lot and follows +# redirects. +# 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoCall {serviceName operationName argList {headers {}}} { variable serviceArr - ::log::log debug "Entering ::WS::Client::DoCall {$serviceName $operationName $argList}" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -1101,68 +1621,149 @@ if {![dict exists $serviceInfo operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" + } elseif {[dict get $serviceInfo operation $operationName cloned]} { + return \ + -code error \ + -errorcode [list WS CLIENT MUSTCALLCLONE [list $serviceName $operationName]] \ + "Operation '$operationName' for service '$serviceName' is overloaded, you must call one of its clones." } + set url [dict get $serviceInfo location] - set query [buildCallquery $serviceName $operationName $url $argList] + SaveAndSetOptions $serviceName + if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} { + RestoreSavedOptions $serviceName + return -code error -errorcode $::errorCode -errorinfo $::errorInfo "buildCallquery error -- $err" + } else { + RestoreSavedOptions $serviceName + } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } if {[dict exists $serviceInfo operation $operationName action]} { - lappend headers SOAPAction [dict get $serviceInfo operation $operationName action] + lappend headers SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]] } + ## + ## Do the http request + ## + # This will directly return with correct error + # side effect: sets the variable httpCode + set largs {} if {[llength $headers]} { - ::log::log debug [list ::http::geturl $url -query $query -type text/xml -headers $headers] - set token [::http::geturl $url -query $query -type text/xml -headers $headers] - } else { - ::log::log debug [list ::http::geturl $url -query $query -type text/xml] - set token [::http::geturl $url -query $query -type text/xml] - } - ::http::wait $token - - ## - ## Check for errors - ## - set body [::http::data $token] - ::log::log debug "\tReceived: $body" - set httpStatus [::http::status $token] - if {![string equal $httpStatus ok] || - ([::http::ncode $token] != 200 && [string equal $body {}])} { - ::log::log debug "\tHTTP error [array get $token]" - set results [::http::error $token] - if {[string equal $results {}] || [string equal $httpStatus eof]} { - set results {Unexpected EOF received from Server} - set errorCode [list WSCLIENT HTTPERROR UNEXPEOF] - } else { - set errorCode [list WSCLIENT HTTPERROR [::http::code $token]] - } - set errorInfo {} - set hadError 1 - } else { + lappend largs -headers $headers + } + set body [::WS::Utils::geturl_fetchbody -codeok {200 500} -codevar httpCode $url\ + -query $query\ + -type [dict get $serviceInfo contentType]\ + -headers $headers\ + {*}$largs] + # numerical http code was saved in variable httpCode + + ## + ## Process body + ## + set outTransform [dict get $serviceInfo outTransform] + if {$httpCode == 500} { + ## Code 500 treatment + if {$outTransform ne {}} { + SaveAndSetOptions $serviceName + catch {set body [$outTransform $serviceName $operationName REPLY $body]} + RestoreSavedOptions $serviceName + } + set hadError [catch {parseResults $serviceName $operationName $body} results] + if {$hadError} { + lassign $::errorCode mainError subError + if {$mainError eq {WSCLIENT} && $subError eq {NOSOAP}} { + ::log::logsubst debug {\tHTTP error $body} + set results $body + set errorCode [list WSCLIENT HTTPERROR $body] + set errorInfo {} + } else { + ::log::logsubst debug {Reply was $body} + set errorCode $::errorCode + set errorInfo $::errorInfo + } + } + } else { + if {$outTransform ne {}} { + SaveAndSetOptions $serviceName + catch {set body [$outTransform $serviceName $operationName REPLY $body]} + RestoreSavedOptions $serviceName + } + SaveAndSetOptions $serviceName set hadError [catch {parseResults $serviceName $operationName $body} results] + RestoreSavedOptions $serviceName if {$hadError} { - ::log::log debug "Reply was [::http::data $token]" + ::log::logsubst debug {Reply was $body} set errorCode $::errorCode set errorInfo $::errorInfo } } - ::http::cleanup $token if {$hadError} { ::log::log debug "Leaving (error) ::WS::Client::DoCall" return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $results } else { - ::log::log debug "Leaving ::WS::Client::DoCall with {$results}" + ::log::logsubst debug {Leaving ::WS::Client::DoCall with {$results}} return $results } } + +########################################################################### +# +# Public Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PUBLIC<< +# +# Procedure Name : ::WS::Client::FormatHTTPError +# +# Description : Format error after a http::geturl failure. +# A failure consists wether in the HTTP return code unequal to 200 +# or in the status equal "error". Status "timeout" is untreated, as this +# http feature is not used in the package. +# +# Arguments : +# tolken - tolken of the http::geturl request +# +# Returns : +# Error message +# +# Side-Effects : None +# +# Pre-requisite Conditions : HTTP failure must be present +# +# Original Author : Harald Oehlmann +# +#>>END PUBLIC<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 06/02/2015 H.Oehlmann Initial version +# +# +########################################################################### +proc ::WS::Client::FormatHTTPError {token} { + if {[::http::status $token] eq {ok}} { + if {[::http::size $token] == 0} { + return "HTTP failure socket closed" + } + return "HTTP failure code [::http::ncode $token]" + } else { + return "HTTP error: [::http::error $token]" + } +} ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. @@ -1174,18 +1775,18 @@ # Description : Call an operation of a web service asynchronously # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call -# argList - The arguements to the operation as a dictionary object +# argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # succesCmd - A command prefix to be called if the operations # does not raise an error. The results, as a dictionary -# object are concatinated to the prefix. +# object are concatenated to the prefix. # errorCmd - A command prefix to be called if the operations # raises an error. The error code and stack trace -# are concatinated to the prefix. +# are concatenated to the prefix. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header @@ -1196,11 +1797,11 @@ # None. # # Side-Effects : None # # Exception Conditions : -# WSCLIENT HTTPERROR - if an HTTP error occured +# WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester @@ -1218,11 +1819,11 @@ # ########################################################################### proc ::WS::Client::DoAsyncCall {serviceName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr - ::log::log debug "Entering ::WS::Client::DoAsyncCall [list $serviceName $operationName $argList $succesCmd $errorCmd $headers]" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -1236,25 +1837,35 @@ } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } set url [dict get $serviceInfo location] - set query [buildCallquery $serviceName $operationName $url $argList] - if {[llength $headers]} { - ::http::geturl $url \ - -query $query \ - -type text/xml \ - -headers $headers \ - -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] - } else { - ::http::geturl $url \ - -query $query \ - -type text/xml \ - -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] - } - ::log::log debug "Leaving ::WS::Client::DoAsyncCall" - return; + SaveAndSetOptions $serviceName + if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} { + RestoreSavedOptions $serviceName + return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err + } else { + RestoreSavedOptions $serviceName + } + set largs {} + if {[llength $headers]} { + lappend largs -headers $headers + } + ::log::logsubst info {::http::geturl $url \ + -query $query \ + -type [dict get $serviceInfo contentType] \ + -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd]\ + -timeout [dict get $serviceInfo queryTimeout] \ + {*}$largs} + ::http::geturl $url \ + -query $query \ + -type [dict get $serviceInfo contentType] \ + -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] \ + -timeout [dict get $serviceInfo queryTimeout] \ + {*}$largs + ::log::logsubst debug {Leaving ::WS::Client::DoAsyncCall} + return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure @@ -1306,28 +1917,36 @@ set serviceInfo $serviceArr($serviceName) set procList {} - foreach operationName [dict get $serviceInfo operList] { + foreach operationName [lsort -dictionary [dict get $serviceInfo operList]] { + if {[dict get $serviceInfo operation $operationName cloned]} { + continue + } set procName $operationName set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] - if {[string equal $inputHeaderType {}]} { + if {$inputHeaderType eq {}} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] - if {![string equal $headerFields {}]} { + if {$headerFields ne {}} { lappend argList [lsort -dictionary $headerFields] } } set inputMsgType [dict get $serviceInfo operation $operationName inputs] - set inputFields [dict keys [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] definition]] - if {![string equal $inputFields {}]} { - lappend argList [lsort -dictionary $inputFields] + if {$inputMsgType ne {}} { + set inTypeDef [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] + if {[dict exists $inTypeDef definition]} { + set inputFields [dict keys [dict get $inTypeDef definition]] + if {$inputFields ne {}} { + lappend argList [lsort -dictionary $inputFields] + } + } } set argList [join $argList] append procList "\n\t$procName $argList" } @@ -1391,22 +2010,22 @@ foreach operationName [dict keys [dict get $serviceInfo object $object operations]] { set procName $operationName set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] - if {[string equal $inputHeaderType {}]} { + if {$inputHeaderType eq {}} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] - if {![string equal $headerFields {}]} { + if {$headerFields ne {}} { lappend argList [lsort -dictionary $headerFields] } } set inputMsgType [dict get $serviceInfo operation $operationName inputs] set inputFields [dict keys [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] definition]] - if {![string equal $inputFields {}]} { + if {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } set argList [join $argList] append procList "\n\t$object $procName $argList" @@ -1458,28 +2077,34 @@ # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncCallDone {serviceName operationName succesCmd errorCmd token} { - ::log::log debug "Entering ::WS::Client::asyncCallDone {$serviceName $operationName $succesCmd $errorCmd $token}" + ::log::logsubst debug {Entering [info level 0]} ## ## Check for errors ## set body [::http::data $token] - if {![string equal [::http::status $token] ok] || - ([::http::ncode $token] != 200 && [string equal $body {}])} { - set errorCode [list WSCLIENT HTTPERROR [::http::code $token]] + ::log::logsubst info {\nReceived: $body} + set results {} + if {[::http::status $token] ne {ok} || + ( [::http::ncode $token] != 200 && $body eq {} )} { + set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 - set errorInfo [::http::error $token] + set results [FormatHTTPError $token] + set errorInfo "" } else { + SaveAndSetOptions $serviceName set hadError [catch {parseResults $serviceName $operationName $body} results] + RestoreSavedOptions $serviceName if {$hadError} { set errorCode $::errorCode set errorInfo $::errorInfo } } + ::http::cleanup $token ## ## Call the appropriate callback ## if {$hadError} { @@ -1486,18 +2111,20 @@ set cmd $errorCmd lappend cmd $errorCode $errorInfo } else { set cmd $succesCmd } - lappend cmd $results - catch $cmd - + if {$cmd ne ""} { + lappend cmd $results + if {[catch $cmd cmdErr]} { + ::log::log error "Error invoking callback '$cmd': $cmdErr" + } + } ## ## All done ## - ::http::cleanup $token - return; + return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -1517,15 +2144,15 @@ # Returns : A dictionary object representing the results # # Side-Effects : None # # Exception Conditions : -# WSCLIENT REMERR - The remote end raised an exception, the third element of +# WS CLIENT REMERR - The remote end raised an exception, the third element of # the error code is the remote fault code. # Error info is set to the remote fault details. -# The error message is the remote fault string; -# WSCLIENT BADREPLY - Badly formatted reply, the third element is a list of +# The error message is the remote fault string. +# WS CLIENT BADREPLY - Badly formatted reply, the third element is a list of # what message type was received vs what was expected. # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester @@ -1537,116 +2164,232 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version -# +# 2.4.2 2017-08-31 H.Oehlmann The response node name may also be the +# output name and not only the output type. +# (ticket [21f41e22bc]). +# 2.4.3 2017-11-03 H.Oehlmann Extended upper commit also to search +# for multiple child nodes. +# 2.5.1 2018-05-14 H.Oehlmann Add support to translate namespace prefixes +# in attribute values or text values. +# Translation dict "xnsDistantToLocalDict" is +# passed to ::WS::Utils::convertTypeToDict +# to translate abstract types. # ########################################################################### proc ::WS::Client::parseResults {serviceName operationName inXML} { variable serviceArr - ::log::log debug "In parseResults $serviceName $operationName {$inXML}" + ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) - set outTransform [dict get $serviceInfo outTransform] - if {![string equal $outTransform {}]} { - set inXML [$outTransform $serviceName $operationName REPLY $inXML] - } set expectedMsgType [dict get $serviceInfo operation $operationName outputs] + set expectedMsgTypeBase [lindex [split $expectedMsgType {:}] end] + + set first [string first {<} $inXML] + if {$first > 0} { + set inXML [string range $inXML $first end] + } + # parse xml and save handle in variable doc and free it when out of scope dom parse $inXML doc + + # save top node handle in variable top and free it if out of scope $doc documentElement top + set xns { ENV http://schemas.xmlsoap.org/soap/envelope/ xsi "http://www.w3.org/2001/XMLSchema-instance" xs "http://www.w3.org/2001/XMLSchema" } - foreach tmp [dict get $serviceInfo targetNamespace] { - lappend xns [lindex $tmp 0] [lindex $tmp 1] + foreach {prefixCur URICur} [dict get $serviceInfo targetNamespace] { + lappend xns $prefixCur $URICur } - ::log::log debug "Using namespaces {$xns}" + ::log::logsubst debug {Using namespaces {$xns}} $doc selectNodesNamespaces $xns - set body [$top selectNodes ENV:Body] - set rootNode [$body childNodes] - ::log::log debug "Have [llength $rootNode]" - if {[llength $rootNode] > 1} { - foreach tmp $rootNode { - #puts "\t Got {[$tmp localName]} looking for {$expectedMsgType}" - if {[string equal [$tmp localName] $expectedMsgType] || - [string equal [$tmp nodeName] $expectedMsgType]} { - set rootNode $tmp + + ## + ## When arguments with tags are passed (example: abstract types), + ## the upper "selectNodesNamespaces translation must be executed manually. + ## Thus, we need a list of server namespace prefixes to our client namespace + ## prefixes. (bug 584bfb77) + ## + # Example xml: + # + + set xnsDistantToLocalDict {} + foreach attributeCur [$top attributes] { + # attributeCur is a list of "prefix local URI", + # which is for xmlns tags: "prefix prefix {}". + set attributeCur [lindex $attributeCur 0] + # Check if this is a namespace prefix + if { ! [$top hasAttribute "xmlns:$attributeCur"] } {continue} + set URIServer [$top getAttribute "xmlns:$attributeCur"] + # Check if it is included in xns + foreach {prefixCur URICur} $xns { + if {$URIServer eq $URICur} { + dict set xnsDistantToLocalDict $attributeCur $prefixCur break } } } - if {![string equal $rootNode {}]} { - set rootName [$rootNode localName] - if {[string equal $rootName {}]} { - set rootName [$rootNode nodeName] - } - } else { - set rootName {} - } - ::log::log debug "root name is {$rootName}" - - ## - ## See if it is a standard error packet - ## - if {[string equal $rootName {Fault}]} { - set faultcode {} - set faultstring {} - set errorInfo {} - if {[catch {set faultcode [[$rootNode selectNodes ENV:faultcode] asText]}]} { - catch {set faultcode [[$rootNode selectNodes faultcode] asText]} - } - if {[catch {set faultstring [[$rootNode selectNodes ENV:faultstring] asText]}]} { - catch {set faultstring [[$rootNode selectNodes faultstring] asText]} - } - if {[catch {set errorInfo [[$rootNode selectNodes ENV:detail] asXML]}]} { - catch {set errorInfo [[$rootNode selectNodes detail/] asXML]} - } - $doc delete - return \ - -code error \ - -errorcode [list WSCLIENT REMERR $faultcode] \ - -errorinfo $errorInfo \ - $faultstring - } - - ## - ## Validated that it is the expected packet type - ## - if {![string equal $rootName $expectedMsgType]} { - $doc delete - return \ - -code error \ - -errorcode [list WSCLIENT BADREPLY [list $rootName $expectedMsgType]] \ - "Bad reply type, received '$rootName; but expected '$expectedMsgType'." + ::log::logsubst debug {Server to Client prefix dict: $xnsDistantToLocalDict} + + ## + ## Get body tag + ## + set body [$top selectNodes ENV:Body] + if {![llength $body]} { + return \ + -code error \ + -errorcode [list WS CLIENT BADREPLY $inXML] \ + "Bad reply type, no SOAP envelope received in: \n$inXML" + } + ## + ## Find the reply root node with the response. + ## + # + # + # <-- this one + # + # WSDL 1.0: http://xml.coverpages.org/wsdl20000929.html + # Chapter 2.4.2 (name optional) and 2.4.5 (default name) + # The node name could be: + # 1) an error node "Fault" + # 2) equal to the WSDL name property of the output node + # 3) if no name tag, equal to Response + # 4) the local output type name + # + # Possibility (2) "OutName" WSDL example: + # + # + # This possibility is requested by ticket [21f41e22bc] + # + # Possibility (3) default name "{OperationName}Result" WSDL example: + # + # *** no name tag *** + # + # Possibility (4) was not found in wsdl 1.0 standard but was used as only + # solution by TCLWS prior to 2.4.2. + # The following sketch shows the location of the local output type name + # "OutTypeName" in a WSDL file: + # -> In WSDL portType output message name + # + # + # -> then in message, use the element: + # + # + # -> The element "OutTypeName" is also find in a type definition: + # + # + # ... + # + # Build a list of possible names + set nodeNameCandidateList [list Fault $expectedMsgTypeBase] + # We check if the preparsed wsdl contains the name flag. + # This is not the case, if it was parsed with tclws prior 2.4.2 + # *** ToDo *** This security may be removed on a major release + if {[dict exists $serviceInfo operation $operationName outputsname]} { + lappend nodeNameCandidateList [dict get $serviceInfo operation $operationName outputsname] + } + + set rootNodeList [$body childNodes] + ::log::logsubst debug {Have [llength $rootNodeList] node under Body} + foreach rootNodeCur $rootNodeList { + set rootNameCur [$rootNodeCur localName] + if {$rootNameCur eq {}} { + set rootNameCur [$rootNodeCur nodeName] + } + if {$rootNameCur in $nodeNameCandidateList} { + set rootNode $rootNodeCur + set rootName $rootNameCur + ::log::logsubst debug {Result root name is '$rootName'} + break + } + ::log::logsubst debug {Result root name '$rootNameCur' not in candidates '$nodeNameCandidateList'} + } + ## + ## Exit if there is no such node + ## + if {![info exists rootName]} { + return \ + -code error \ + -errorcode [list WS CLIENT BADREPLY [list $rootNameCur $expectedMsgTypeBase]] \ + "Bad reply type, received '$rootNameCur'; but expected '$expectedMsgTypeBase'." + } + + ## + ## See if it is a standard error packet + ## + if {$rootName eq {Fault}} { + set faultcode {} + set faultstring {} + set detail {} + foreach item {faultcode faultstring detail} { + set tmpNode [$rootNode selectNodes ENV:$item] + if {$tmpNode eq {}} { + set tmpNode [$rootNode selectNodes $item] + } + if {$tmpNode ne {}} { + if {[$tmpNode hasAttribute href]} { + set tmpNode [GetReferenceNode $top [$tmpNode getAttribute href]] + } + set $item [$tmpNode asText] + } + } + $doc delete + return \ + -code error \ + -errorcode [list WS CLIENT REMERR $faultcode] \ + -errorinfo $detail \ + $faultstring } ## ## Convert the packet to a dictionary ## set results {} set headerRootNode [$top selectNodes ENV:Header] - foreach outHeaderType [dict get $serviceInfo operation $operationName soapReplyHeader] { - if {[string equal $outHeaderType {}]} { - continue - } - set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $outputHeaderType] xns] - set node [$headerRootNode selectNodes $xns:outHeaderType] - if {[llength $outHeaderAttrs]} { - ::WS::Utils::setAttr $node $outHeaderAttrs - } - ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode]" - lappend results [::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode] - } - ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $rootNode $expectedMsgType $body]" - if {![string equal $rootName {}]} { - lappend results [::WS::Utils::convertTypeToDict \ - Client $serviceName $rootNode $expectedMsgType $body] + if {[llength $headerRootNode]} { + foreach outHeaderType [dict get $serviceInfo operation $operationName soapReplyHeader] { + if {$outHeaderType eq {}} { + continue + } + set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $outHeaderType] xns] + set node [$headerRootNode selectNodes $outHeaderType] + if {![llength $node]} { + set node [$headerRootNode selectNodes $xns:$outHeaderType] + if {![llength $node]} { + continue + } + } + + #if {[llength $outHeaderAttrs]} { + # ::WS::Utils::setAttr $node $outHeaderAttrs + #} + ::log::logsubst debug {Calling convertTypeToDict from header node type '$outHeaderType'} + lappend results [::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode 0 $xnsDistantToLocalDict] + } + } + ## + ## Call Utility function to build result list + ## + if {$rootName ne {}} { + ::log::log debug "Calling convertTypeToDict with root node" + set bodyData [::WS::Utils::convertTypeToDict \ + Client $serviceName $rootNode $expectedMsgType $body 0 $xnsDistantToLocalDict] + if {![llength $bodyData] && ([dict get $serviceInfo skipLevelWhenActionPresent] || [dict get $serviceInfo skipLevelOnReply])} { + ::log::log debug "Calling convertTypeToDict with skipped action level (skipLevelWhenActionPresent was set)" + set bodyData [::WS::Utils::convertTypeToDict \ + Client $serviceName $body $expectedMsgType $body 0 $xnsDistantToLocalDict] + } + lappend results $bodyData } set results [join $results] $doc delete set ::errorCode {} set ::errorInfo {} @@ -1698,26 +2441,39 @@ variable serviceArr set serviceInfo $serviceArr($serviceName) set style [dict get $serviceInfo operation $operationName style] + set suppressTargetNS [dict get $serviceInfo suppressTargetNS] + set inSuppressNs [::WS::Utils::SetOption suppressNS] + if {$suppressTargetNS} { + ::WS::Utils::SetOption suppressNS tns1 + } else { + ::WS::Utils::SetOption suppressNS {} + } - switch $style { + switch -exact -- $style { document/literal { set xml [buildDocLiteralCallquery $serviceName $operationName $url $argList] } rpc/encoded { set xml [buildRpcEncodedCallquery $serviceName $operationName $url $argList] } + default { + return \ + -code error \ + "Unsupported Style '$style'" + } } + ::WS::Utils::SetOption suppressNS $inSuppressNs set inTransform [dict get $serviceInfo inTransform] - if {![string equal $inTransform {}]} { - set query [$inTransform $serviceName $operationName REQUEST $xml $url $argList] + if {$inTransform ne {}} { + set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } - ::log::log debug "Leaving ::::WS::Client::buildCallquery with {$xml}" + ::log::logsubst debug {Leaving ::WS::Client::buildCallquery with {$xml}} return $xml } ########################################################################### @@ -1761,77 +2517,108 @@ # ########################################################################### proc ::WS::Client::buildDocLiteralCallquery {serviceName operationName url argList} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo operation $operationName inputs] set url [dict get $serviceInfo location] set xnsList [dict get $serviceInfo targetNamespace] + # save the document in variable doc and free it if out of scope dom createDocument "SOAP-ENV:Envelope" doc $doc documentElement env $env setAttribute \ "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \ "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance" \ - "xmlns:xs" "http://www.w3.org/2001/XMLSchema" - array set tnsArray {} + "xmlns:xs" "http://www.w3.org/2001/XMLSchema" + if {[dict exists $serviceInfo noTargetNs] && ![dict get $serviceInfo noTargetNs]} { + $env setAttribute "xmlns" [dict get $xnsList tns1] + } array unset tnsArray * - foreach xns $xnsList { - set tns [lindex $xns 0] - set target [lindex $xns 1] + array set tnsArray { + "http://schemas.xmlsoap.org/soap/envelope/" "xmlns:SOAP-ENV" + "http://schemas.xmlsoap.org/soap/encoding/" "xmlns:SOAP-ENC" + "http://www.w3.org/2001/XMLSchema-instance" "xmlns:xsi" + "http://www.w3.org/2001/XMLSchema" "xmlns:xs" + } + foreach {tns target} $xnsList { + #set tns [lindex $xns 0] + #set target [lindex $xns 1] set tnsArray($target) $tns $env setAttribute \ xmlns:$tns $target } #parray tnsArray set firstHeader 1 foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { lassign $inputHeaderTypeItem inputHeaderType attrList - if {[string equal $inputHeaderType {}]} { + if {$inputHeaderType eq {}} { continue } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns] if {[info exists tnsArray($xns)]} { set xns $tnsArray($xns) } if {$firstHeader} { + # side effect: save new node handle in variable header $env appendChild [$doc createElement "SOAP-ENV:Header" header] set firstHeader 0 } - $header appendChild [$doc createElement $xns:$inputHeaderType headerData] - if {[llength $attrList]} { - ::WS::Utils::setAttr $headerData $attrList + if {[dict exists $serviceInfo skipHeaderLevel] && [dict get $serviceInfo skipHeaderLevel]} { + set headerData $header + } else { + set typeInfo [split $inputHeaderType {:}] + if {[llength $typeInfo] > 1} { + set headerType $inputHeaderType + } else { + set headerType $xns:$inputHeaderType + } + $header appendChild [$doc createElement $headerType headerData] + if {[llength $attrList]} { + ::WS::Utils::setAttr $headerData $attrList + } } ::WS::Utils::convertDictToType Client $serviceName $doc $headerData $argList $inputHeaderType } + # side effect: save new element handle in variable bod $env appendChild [$doc createElement "SOAP-ENV:Body" bod] + #puts "set xns \[dict get \[::WS::Utils::GetServiceTypeDef Client $serviceName $msgType\] xns\]" + #puts "\t [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType]" set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType] xns] if {[info exists tnsArray($xns)]} { set xns $tnsArray($xns) } - - ::log::log debug [list $bod appendChild \[$doc createElement $xns:$msgType reply\]] - $bod appendChild [$doc createElement $xns:$msgType reply] - - ::log::log debug "calling [list ::WS::Utils::convertDictToType Client $serviceName $doc $bod $argList $msgType]" - ::WS::Utils::convertDictToType Client $serviceName $doc $reply $argList $msgType - - append xml \ - {} \ - "\n" \ - [$doc asXML -indent none -doctypeDeclaration 0] - #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] {} xml + set typeInfo [split $msgType {:}] + if {[llength $typeInfo] != 1} { + set xns [lindex $typeInfo 0] + set msgType [lindex $typeInfo 1] + } + + if {[dict get $serviceInfo skipLevelWhenActionPresent] && [dict exists $serviceInfo operation $operationName action]} { + set forceNs 1 + set reply $bod + } else { + ::log::logsubst debug {$bod appendChild \[$doc createElement $xns:$msgType reply\]} + $bod appendChild [$doc createElement $xns:$msgType reply] + set forceNs 0 + } + + ::WS::Utils::convertDictToType Client $serviceName $doc $reply $argList $xns:$msgType $forceNs + + set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {:}] end] {=}] end] + set xml [format {} $encoding] + append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] $doc delete - ::log::log debug "Leaving ::::WS::Client::buildDocLiteralCallquery with {$xml}" + ::log::logsubst debug {Leaving ::WS::Client::buildDocLiteralCallquery with {$xml}} - return $xml + return [encoding convertto $encoding $xml] } ########################################################################### # @@ -1874,62 +2661,62 @@ # ########################################################################### proc ::WS::Client::buildRpcEncodedCallquery {serviceName operationName url argList} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo operation $operationName inputs] - #set url [dict get $serviceInfo location] set xnsList [dict get $serviceInfo targetNamespace] - #set action [dict get $serviceInfo operation $operationName action] dom createDocument "SOAP-ENV:Envelope" doc $doc documentElement env $env setAttribute \ xmlns:SOAP-ENV "http://schemas.xmlsoap.org/soap/envelope/" \ xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance" \ - xmlns:xs "http://www.w3.org/2001/XMLSchema" - foreach xns $xnsList { - set tns [lindex $xns 0] - set target [lindex $xns 1] - $env setAttribute \ - xmlns:$tns $target + xmlns:xs "http://www.w3.org/2001/XMLSchema" + + foreach {tns target} $xnsList { + $env setAttribute xmlns:$tns $target } + set firstHeader 1 foreach inputHeaderType [dict get $serviceInfo operation $operationName soapRequestHeader] { - if {[string equal $inputHeaderType {}]} { + if {$inputHeaderType eq {}} { continue } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns] - $env appendChild [$doc createElement "SOAP-ENV:Header" header] + if {$firstHeader} { + $env appendChild [$doc createElement "SOAP-ENV:Header" header] + set firstHeader 0 + } $header appendChild [$doc createElement $xns:$inputHeaderType headerData] ::WS::Utils::convertDictToEncodedType Client $serviceName $doc $headerData $argList $inputHeaderType } $env appendChild [$doc createElement "SOAP-ENV:Body" bod] + set baseName [dict get $serviceInfo operation $operationName name] set callXns [dict get $serviceInfo operation $operationName xns] + # side effect: node handle is saved in variable reply if {![string is space $callXns]} { - $bod appendChild [$doc createElement $callXns:$operationName reply] + $bod appendChild [$doc createElement $callXns:$baseName reply] } else { - $bod appendChild [$doc createElement $operationName reply] + $bod appendChild [$doc createElement $baseName reply] } $reply setAttribute \ SOAP-ENV:encodingStyle "http://schemas.xmlsoap.org/soap/encoding/" ::WS::Utils::convertDictToEncodedType Client $serviceName $doc $reply $argList $msgType - append xml \ - {} \ - "\n" \ - [$doc asXML -indent none -doctypeDeclaration 0] - #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] {} xml + set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {;}] end] {=}] end] + set xml [format {} $encoding] + append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] $doc delete - ::log::log debug "Leaving ::::WS::Client::buildRpcEncodedCallquery with {$xml}" + ::log::logsubst debug {Leaving ::WS::Client::buildRpcEncodedCallquery with {$xml}} - return $xml + return [encoding convertto $encoding $xml] } ########################################################################### # @@ -1942,14 +2729,17 @@ # # Description : Parse the WSDL into our internal representation # # Arguments : # wsdlNode - The top node of the WSDL -# results - Inital definition. This is optional and defaults to no definition. +# results - Initial definition. This is optional and defaults to no definition. # serviceAlias - Alias (unique) name for service. -# This is an optional argument and defaults to the name of the -# service in serviceInfo. +# This is an optional argument and defaults to the name of the +# service in serviceInfo. +# serviceNumber - Number of service within the WSDL to assign the +# serviceAlias to. Only usable with a serviceAlias. +# First service (default) is addressed by value "1". # # Returns : The parsed WSDL # # Side-Effects : Defines Client mode types as specified by the WSDL # @@ -1966,40 +2756,60 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2.4.6 2017-12-07 H.Oehlmann Added argument "serviceNumber" # # ########################################################################### -proc ::WS::Client::buildServiceInfo {wsdlNode {serviceInfo {}} {serviceAlias {}}} { +proc ::WS::Client::buildServiceInfo {wsdlNode tnsDict {serviceInfo {}} {serviceAlias {}} {serviceNumber 1}} { ## ## Need to refactor to foreach service parseService ## Service drills down to ports, which drills down to bindings and messages ## - ::log::log debug "Entering ::WS::Client::buildServiceInfo with doc $wsdlNode" + ::log::logsubst debug {Entering [info level 0]} ## ## Parse Service information ## + # WSDL snippet: + # + # + # ... + # + # + # ... + # + # + # Without serviceAlias and serviceNumber, two services "service1" and + # "service2" are created. + # With serviceAlias = "SE" and serviceNumber=2, "service2" is created as + # "SE". set serviceNameList [$wsdlNode selectNodes w:service] - if {[string length $serviceAlias] & ([llength $serviceNameList] > 1)} { - return \ - -code error \ - -errorcode [list WS CLIENT MULTISVC] \ - "Can not specify alias when WSDL defines multiple services" - } elseif {[llength $serviceNameList] == 0} { + # Check for no service node + if {[llength $serviceNameList] == 0} { return \ -code error \ -errorcode [list WS CLIENT NOSVC] \ "WSDL does not define any services" } - + if {"" ne $serviceAlias} { + if {$serviceNumber < 1 || $serviceNumber > [llength $serviceNameList]} { + return \ + -code error \ + -errorcode [list WS CLIENT INVALDCNT] \ + "WSDL does not define service number $serviceNumber" + } + set serviceNameList [lrange $serviceNameList $serviceNumber-1 $serviceNumber-1] + } foreach serviceNode $serviceNameList { - lappend serviceInfo [parseService $wsdlNode $serviceNode $serviceAlias] + lappend serviceInfo [parseService $wsdlNode $serviceNode $serviceAlias $tnsDict] } + + ::log::logsubst debug {Leaving ::WS::Client::buildServiceInfo with $serviceInfo} return $serviceInfo } ########################################################################### # @@ -2016,10 +2826,11 @@ # wsdlNode - The top node of the WSDL # serviceNode - The DOM node for the service. # serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the name of the # service in serviceInfo. +# tnsDict - Dictionary of URI to namespaces used # # Returns : The parsed service WSDL # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # @@ -2039,13 +2850,15 @@ # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### -proc ::WS::Client::parseService {wsdlNode serviceNode serviceAlias} { +proc ::WS::Client::parseService {wsdlNode serviceNode serviceAlias tnsDict} { variable serviceArr + variable options + ::log::logsubst debug {Entering [info level 0]} if {[string length $serviceAlias]} { set serviceName $serviceAlias } else { set serviceName [$serviceNode getAttribute name] } @@ -2068,12 +2881,24 @@ -code error \ -errorcode [list WS CLIENT NOSOAPADDR] \ "Malformed WSDL -- No SOAP address node found." } - CreateService $serviceName WSDL $location + set xns {} + foreach url [dict keys [dict get $tnsDict url]] { + lappend xns [list [dict get $tnsDict url $url] $url] + } + if {[$wsdlNode hasAttribute targetNamespace]} { + set target [$wsdlNode getAttribute targetNamespace] + } else { + set target $location + } + set tmpTargetNs $::WS::Utils::targetNs + set ::WS::Utils::targetNs $target + CreateService $serviceName WSDL $location $target xns $xns set serviceInfo $serviceArr($serviceName) + dict set serviceInfo tnsList $tnsDict set bindingName [lindex [split [$portNode getAttribute binding] {:}] end] ## ## Parse types ## @@ -2085,11 +2910,20 @@ parseBinding $wsdlNode $serviceName $bindingName serviceInfo ## ## All done, so return results ## + #dict unset serviceInfo tnsList + dict set serviceInfo suppressTargetNS $options(suppressTargetNS) + foreach {key value} [dict get $serviceInfo tnsList url] { + dict set serviceInfo targetNamespace $value $key + } set serviceArr($serviceName) $serviceInfo + + set ::WS::Utils::targetNs $tmpTargetNs + + ::log::logsubst debug {Leaving [lindex [info level 0] 0] with $serviceInfo} return $serviceInfo } ########################################################################### # @@ -2130,18 +2964,23 @@ # 1 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::parseTypes {wsdlNode serviceName serviceInfoVar} { - upvar $serviceInfoVar serviceInfo + ::log::log debug "Entering [info level 0]" - set tnsCount 0 + upvar 1 $serviceInfoVar serviceInfo + + + set tnsCount [llength [dict keys [dict get $serviceInfo tnsList url]]] set baseUrl [dict get $serviceInfo location] - foreach schemaNode [$wsdlNode selectNodes w:types/s:schema] { + foreach schemaNode [$wsdlNode selectNodes w:types/xs:schema] { + ::log::log debug "Parsing node $schemaNode" ::WS::Utils::parseScheme Client $baseUrl $schemaNode $serviceName serviceInfo tnsCount } + ::log::log debug "Leaving [lindex [info level 0] 0]" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -2178,92 +3017,154 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version +# 2.4.2 2017-08-31 H.Oehlmann Also set serviceArr operation members +# inputsName and outputsName. # # ########################################################################### proc ::WS::Client::parseBinding {wsdlNode serviceName bindingName serviceInfoVar} { - upvar $serviceInfoVar serviceInfo + ::log::log debug "Entering [info level 0]" + upvar 1 $serviceInfoVar serviceInfo + variable options set bindQuery [format {w:binding[attribute::name='%s']} $bindingName] array set msgToOper {} foreach binding [$wsdlNode selectNodes $bindQuery] { array unset msgToOper * set portName [lindex [split [$binding getAttribute type] {:}] end] + ::log::log debug "\t Processing binding '$bindingName' on port '$portName'" set operList [$binding selectNodes w:operation] set styleNode [$binding selectNodes d:binding] if {![info exists style]} { if {[catch {$styleNode getAttribute style} tmpStyle]} { set styleNode [$binding selectNodes {w:operation[1]/d:operation}] - if {[string equal $styleNode {}]} { + if {$styleNode eq {}} { ## ## This binding is for a SOAP level other than 1.1 ## + ::log::log debug "Skiping non-SOAP 1.1 binding [$binding asXML]" continue } set style [$styleNode getAttribute style] #puts "Using style for first operation {$style}" } else { set style $tmpStyle #puts "Using style for first binding {$style}" } - if {!([string equal $style document] || [string equal $style rpc])} { + if {!($style eq {document} || $style eq {rpc} )} { + ::log::log debug "Leaving [lindex [info level 0] 0] with error @1" return \ -code error \ - -errorcode [list WSCLIENT UNSSTY $style] \ + -errorcode [list WS CLIENT UNSSTY $style] \ "Unsupported calling style: '$style'" } if {![info exists use]} { set use [[$binding selectNodes {w:operation[1]/w:input/d:body}] getAttribute use] - if {!([string equal $style document] && [string equal $use literal]) && - !([string equal $style rpc] && [string equal $use encoded])} { + if {!($style eq {document} && $use eq {literal} ) && + !($style eq {rpc} && $use eq {encoded} )} { + ::log::log debug "Leaving [lindex [info level 0] 0] with error @2" return \ -code error \ - -errorcode [list WSCLIENT UNSMODE $use] \ + -errorcode [list WS CLIENT UNSMODE $use] \ "Unsupported mode: $style/$use" } } } + + set style $style/$use ## ## Process each operation ## foreach oper $operList { set operName [$oper getAttribute name] - dict lappend serviceInfo operList $operName + set baseName $operName + ::log::log debug "\t Processing operation '$operName'" + + ## + ## Check for overloading + ## + set inNode [$oper selectNodes w:input] + if {[llength $inNode] == 1 && [$inNode hasAttribute name]} { + set inName [$inNode getAttribute name] + } else { + set inName {} + } + if {[dict exists $serviceInfo operation $operName]} { + if {!$options(allowOperOverloading)} { + return -code error \ + -errorcode [list WS CLIENT NOOVERLOAD $operName] + } + ## + ## See if the existing operation needs to be cloned + ## + set origType [lindex [split [dict get $serviceInfo operation $operName inputs] {:}] end] + set newName ${operName}_${origType} + if {![dict exists $serviceInfo operation $newName]} { + ## + ## Clone it + ## + dict set serviceInfo operation $baseName cloned 1 + dict lappend serviceInfo operList $newName + dict set serviceInfo operation $newName [dict get $serviceInfo operation $operName] + } + # typNameList contains inType inName outType outName + set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style] + set operName ${operName}_[lindex [split [lindex $typeNameList 0] {:}] end] + set cloneList [dict get $serviceInfo operation $baseName cloneList] + lappend cloneList $operName + dict set serviceInfo operation $baseName cloneList $cloneList + dict set serviceInfo operation $operName isClone 1 + } else { + set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style] + dict set serviceInfo operation $operName isClone 0 + } #puts "Processing operation $operName" set actionNode [$oper selectNodes d:operation] - if {[string equal $actionNode {}]} { + if {$actionNode eq {}} { + ::log::log debug "Skiping operation with no action [$oper asXML]" continue } - dict set serviceInfo operation $operName style $style/$use + dict lappend serviceInfo operList $operName + dict set serviceInfo operation $operName cloneList {} + dict set serviceInfo operation $operName cloned 0 + dict set serviceInfo operation $operName name $baseName + dict set serviceInfo operation $operName style $style catch { set action [$actionNode getAttribute soapAction] dict set serviceInfo operation $operName action $action + if {[dict exists $serviceInfo soapActions $action]} { + set actionList [dict get $serviceInfo soapActions $action] + } else { + set actionList {} + } + lappend actionList $operName + dict set serviceInfo soapActions $action $actionList } ## ## Get the input headers, if any ## set soapRequestHeaderList {{}} foreach inHeader [$oper selectNodes w:input/d:header] { ##set part [$inHeader getAttribute part] set tmp [$inHeader getAttribute use] - if {![string equal $tmp $use]} { + if {$tmp ne $use} { + ::log::log debug "Leaving [lindex [info level 0] 0] with error @3" return \ -code error \ - -errorcode [list WSCLIENT MIXUSE $use $tmp] \ - "Mixed usageage not supported!'" + -errorcode [list WS CLIENT MIXUSE $use $tmp] \ + "Mixed usage not supported!'" } - set messagePath [$inHeader getAttribute message] - set msgName [lindex [split $messagePath {:}] end] - ::log:::log debug [list messageToType $wsdlNode $serviceName $operName $msgName serviceInfo] - set type [messageToType $wsdlNode $serviceName $operName $msgName serviceInfo] + set msgName [$inHeader getAttribute message] + ::log::log debug [list messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] + set type [messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] lappend soapRequestHeaderList $type } dict set serviceInfo operation $operName soapRequestHeader $soapRequestHeaderList if {![dict exists [dict get $serviceInfo operation $operName] action]} { dict set serviceInfo operation $operName action $serviceName @@ -2274,73 +3175,71 @@ ## set soapReplyHeaderList {{}} foreach outHeader [$oper selectNodes w:output/d:header] { ##set part [$outHeader getAttribute part] set tmp [$outHeader getAttribute use] - if {![string equal $tmp $use]} { + if {$tmp ne $use} { + ::log::log debug "Leaving [lindex [info level 0] 0] with error @4" return \ -code error \ - -errorcode [list WSCLIENT MIXUSE $use $tmp] \ - "Mixed usageage not supported!'" + -errorcode [list WS CLIENT MIXUSE $use $tmp] \ + "Mixed usage not supported!'" } set messagePath [$outHeader getAttribute message] set msgName [lindex [split $messagePath {:}] end] - ::log:::log debug [list messageToType $wsdlNode $serviceName $operName $msgName serviceInfo] - set type [messageToType $wsdlNode $serviceName $operName $msgName serviceInfo] + ::log::log debug [list messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] + set type [messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] lappend soapReplyHeaderList $type } dict set serviceInfo operation $operName soapReplyHeader $soapReplyHeaderList ## - ## Validate that the input and output uses + ## Validate that the input and output uses are the same ## set inUse $use set outUse $use catch {set inUse [[$oper selectNodes w:input/d:body] getAttribute use]} catch {set outUse [[$oper selectNodes w:output/d:body] getAttribute use]} foreach tmp [list $inUse $outUse] { - if {![string equal $tmp $use]} { + if {$tmp ne $use} { + ::log::log debug "Leaving [lindex [info level 0] 0] with error @5" return \ -code error \ - -errorcode [list WSCLIENT MIXUSE $use $tmp] \ - "Mixed usageage not supported!'" + -errorcode [list WS CLIENT MIXUSE $use $tmp] \ + "Mixed usage not supported!'" } } - set typeList [getTypesForPort $wsdlNode $serviceName $operName $portName serviceInfo] - foreach type $typeList mode {inputs outputs} { + ::log::log debug "\t Input/Output types and names are {$typeNameList}" + foreach {type name} $typeNameList mode {inputs outputs} { dict set serviceInfo operation $operName $mode $type + # also set outputsname which is used to match it as alternate response node name + dict set serviceInfo operation $operName ${mode}name $name + } + set inMessage [dict get $serviceInfo operation $operName inputs] + if {[dict exists $serviceInfo inputMessages $inMessage] } { + set operList [dict get $serviceInfo inputMessages $inMessage] + } else { + set operList {} } + lappend operList $operName + dict set serviceInfo inputMessages $inMessage $operList + ## ## Handle target namespace defined at WSDL level for older RPC/Encoded ## if {![dict exists $serviceInfo targetNamespace]} { catch { #puts "attempting to get tragetNamespace" - dict lappend serviceInfo targetNamespace [list tns1 [[$oper selectNodes w:input/d:body] getAttribute namespace]] + dict set serviceInfo targetNamespace tns1 [[$oper selectNodes w:input/d:body] getAttribute namespace] } } set xns tns1 - catch { - set xns {} - set target [[$oper selectNodes w:input/d:body] getAttribute namespace] - foreach item [dict get $serviceInfo targetNamespace] { - lassign $item ns url - if {[string equal $url $target]} { - set xns $ns - break - } - } - if {[string equal $xns {}]} { - set cnt [llength [dict get $serviceInfo targetNamespace]] - incr cnt - dict lappend serviceInfo targetNamespace [list tns$cnt $target] - set xns tns$cnt - } - } dict set serviceInfo operation $operName xns $xns } } + + ::log::log debug "Leaving [lindex [info level 0] 0]" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -2353,14 +3252,18 @@ # Description : Get the types for a port. # # Arguments : # wsdlNode - The top node of the WSDL # serviceNode - The DOM node for the service. +# operNode - The DOM node for the operation. +# portName - The name of the port. +# inName - The name of the input message. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. +# style - style of call # -# Returns : A list containing the input and output types +# Returns : A list containing the input and output types and names # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # @@ -2375,43 +3278,68 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version +# 2.4.2 2017-08-31 H.Oehlmann Extend return by names to verify this +# as return output node name. +# 2.4.3 2017-11-03 H.Oehlmann If name is not given, set the default +# name of Request/Response given by the +# WSDL 1.0 standard. # # ########################################################################### -proc ::WS::Client::getTypesForPort {wsdlNode serviceName operName portName serviceInfoVar} { - upvar $serviceInfoVar serviceInfo +proc ::WS::Client::getTypesForPort {wsdlNode serviceName operName portName inName serviceInfoVar style} { + ::log::log debug "Entering [info level 0]" + upvar 1 $serviceInfoVar serviceInfo - set style [dict get $serviceInfo operation $operName style] set inType {} set outType {} - set portQuery [format {w:portType[attribute::name='%s']} $portName] - set portNode [lindex [$wsdlNode selectNodes $portQuery] 0] - set operQuery [format {w:operation[attribute::name='%s']} $operName] - set operNode [lindex [$portNode selectNodes $operQuery] 0] - - set inputMsgNode [$operNode selectNodes {w:input}] - if {![string equal $inputMsgNode {}]} { - set inputMsgPath [$inputMsgNode getAttribute message] - set inputMsg [lindex [split $inputMsgPath {:}] end] - set inType [messageToType $wsdlNode $serviceName $operName $inputMsg serviceInfo] - } - - set outputMsgNode [$operNode selectNodes {w:output}] - if {![string equal $outputMsgNode {}]} { - set outputMsgPath [$outputMsgNode getAttribute message] - set outputMsg [lindex [split $outputMsgPath {:}] end] - set outType [messageToType $wsdlNode $serviceName $operName $outputMsg serviceInfo] + #set portQuery [format {w:portType[attribute::name='%s']} $portName] + #set portNode [lindex [$wsdlNode selectNodes $portQuery] 0] + if {$inName eq {}} { + set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \ + $portName $operName] + } else { + set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']/w:input[attribute::name='%s']/parent::*} \ + $portName $operName $inName] + } + ::log::log debug "\t operNode query is {$operQuery}" + set operNode [$wsdlNode selectNodes $operQuery] + if {$operNode eq {} && $inName ne {}} { + set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \ + $portName $operName] + ::log::log debug "\t operNode query is {$operQuery}" + set operNode [$wsdlNode selectNodes $operQuery] + } + + set resList {} + foreach sel {w:input w:output} defaultNameSuffix {Request Response} { + set nodeList [$operNode selectNodes $sel] + if {1 == [llength $nodeList]} { + set nodeCur [lindex $nodeList 0] + set msgPath [$nodeCur getAttribute message] + set msgCur [lindex [split $msgPath {:}] end] + # Append type + lappend resList [messageToType $wsdlNode $serviceName $operName $msgCur serviceInfo $style] + # Append name + if {[$nodeCur hasAttribute name]} { + lappend resList [$nodeCur getAttribute name] + } else { + # Build the default name according WSDL 1.0 as + # Request/Response + lappend resList ${operName}$defaultNameSuffix + } + } } ## ## Return the types ## - return [list $inType $outType] + ::log::log debug "Leaving [lindex [info level 0] 0] with $resList" + return $resList } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -2428,10 +3356,11 @@ # serviceName - The name of the service. # operName - The name of the operation. # msgName - The name of the message. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. +# style - Style of call # # Returns : The requested type name # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # @@ -2451,40 +3380,52 @@ # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### -proc ::WS::Client::messageToType {wsdlNode serviceName operName msgName serviceInfoVar} { - upvar $serviceInfoVar serviceInfo +proc ::WS::Client::messageToType {wsdlNode serviceName operName msgName serviceInfoVar style} { + upvar 1 $serviceInfoVar serviceInfo + ::log::log debug "Entering [info level 0]" #puts "Message to Type $serviceName $operName $msgName" - set style [dict get $serviceInfo operation $operName style] set msgQuery [format {w:message[attribute::name='%s']} $msgName] set msg [$wsdlNode selectNodes $msgQuery] - switch $style { + if {$msg eq {} && + [llength [set msgNameList [split $msgName {:}]]] > 1} { + set tmpMsgName [join [lrange $msgNameList 1 end] {:}] + set msgQuery [format {w:message[attribute::name='%s']} $tmpMsgName] + set msg [$wsdlNode selectNodes $msgQuery] + } + if {$msg eq {}} { + return \ + -code error \ + -errorcode [list WS CLIENT BADMSGSEC $msgName] \ + "Can not find message '$msgName'" + } + switch -exact -- $style { document/literal { set partNode [$msg selectNodes w:part] set partNodeCount [llength $partNode] + ::log::log debug "partNodeCount = {$partNodeCount}" if {$partNodeCount == 1} { if {[$partNode hasAttribute element]} { - set typePath [$partNode getAttribute element] - set type [lindex [split $typePath {:}] end] + set type [::WS::Utils::getQualifiedType $serviceInfo [$partNode getAttribute element] tns1] } } if {($partNodeCount > 1) || ![info exist type]} { set tmpType {} foreach part [$msg selectNodes w:part] { set partName [$part getAttribute name] if {[$part hasAttribute type]} { - set partType [lindex [split [$part getAttribute type] {:}] end] + set partType [$part getAttribute type] } else { - set partType [lindex [split [$part getAttribute element] {:}] end] + set partType [$part getAttribute element] } - lappend tmpType $partName [list type $partType comment {}] + lappend tmpType $partName [list type [::WS::Utils::getQualifiedType $serviceInfo $partType tns1] comment {}] } - set type $msgName + set type tns1:$msgName dict set serviceInfo types $type $tmpType ::WS::Utils::ServiceTypeDef Client $serviceName $type $tmpType tns1 } elseif {!$partNodeCount} { return \ -code error \ @@ -2495,31 +3436,32 @@ rpc/encoded { set tmpType {} foreach part [$msg selectNodes w:part] { set partName [$part getAttribute name] if {[$part hasAttribute type]} { - set partType [lindex [split [$part getAttribute type] {:}] end] - } else { - set partType [lindex [split [$part getAttribute element] {:}] end] - } - lappend tmpType $partName [list type $partType comment {}] - } - set type $msgName - dict set serviceInfo types $type $tmpType - ::WS::Utils::ServiceTypeDef Client $serviceName $type $tmpType xs + set partType [$part getAttribute type] + } else { + set partType [$part getAttribute element] + } + lappend tmpType $partName [list type [::WS::Utils::getQualifiedType $serviceInfo $partType tns1] comment {}] + } + set type tns1:$msgName + dict set serviceInfo types $type $tmpType + ::WS::Utils::ServiceTypeDef Client $serviceName $type $tmpType tns1 } default { return \ -code error \ - -errorcode [list WS CLIENT UNKSTYUSE [list $style $use]] \ - "Unknown style/use combination $style/$use" + -errorcode [list WS CLIENT UNKSTY $style] \ + "Unknown style combination $style" } } ## ## Return the type name ## + ::log::log debug "Leaving [lindex [info level 0] 0] with {$type}" return $type } #--------------------------------------- #--------------------------------------- @@ -2536,11 +3478,11 @@ # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call -# argList - The arguements to the operation as a dictionary object. +# argList - The arguments to the operation as a dictionary object. # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. @@ -2552,11 +3494,11 @@ # The XML of the operation. # # Side-Effects : None # # Exception Conditions : -# WSCLIENT HTTPERROR - if an HTTP error occured +# WS CLIENT HTTPERROR - if an HTTP error occurred # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # @@ -2567,17 +3509,21 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2.4.1 2017-08-31 H.Oehlmann Use utility function +# ::WS::Utils::geturl_fetchbody for http call +# which also follows redirects. +# 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoRawRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -2593,52 +3539,47 @@ return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ "Unknown operation '$operationName' for object '$objectName' of service '$serviceName'" } - if {![string equal $location {}]} { + + ## + ## build call query + ## + + if {$location ne {}} { set url $location } else { set url [dict get $serviceInfo object $objectName location] } - set query [buildRestCallquery $serviceName $objectName $operationName $url $argList] + SaveAndSetOptions $serviceName + if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { + RestoreSavedOptions $serviceName + return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err + } else { + RestoreSavedOptions $serviceName + } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } + + ## + ## do http call + ## + + set largs {} if {[llength $headers]} { - set token [::http::geturl $url -query $query -type text/xml -headers $headers] - } else { - set token [::http::geturl $url -query $query -type text/xml] - } - ::http::wait $token - - ## - ## Check for errors - ## - set body [::http::data $token] - if {![string equal [::http::status $token] ok] || - ([::http::ncode $token] != 200 && [string equal $body {}])} { - set errorCode [list WSCLIENT HTTPERROR [::http::code $token]] - set errorInfo {} - set results [::http::error $token] - set hadError 1 - } else { - set hadError 0 - set results [::http::data $token] - } - ::http::cleanup $token - if {$hadError} { - ::log::log debug "Leaving (error) ::WS::Client::DoRawRestCall" - return \ - -code error \ - -errorcode $errorCode \ - -errorinfo $errorInfo \ - $results - } else { - ::log::log debug "Leaving ::WS::Client::DoRawRestCall with {$results}" - return $results - } + lappend largs -headers $headers + } + set body [::WS::Utils::geturl_fetchbody $url\ + -query $query\ + -type [dict get $serviceInfo contentType]\ + -timeout [dict get $serviceInfo queryTimeout]\ + {*}$largs] + + ::log::logsubst debug {Leaving ::WS::Client::DoRawRestCall with {$body}} + return $body } ########################################################################### # @@ -2652,11 +3593,11 @@ # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call -# argList - The arguements to the operation as a dictionary object +# argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. @@ -2668,11 +3609,11 @@ # The return value of the operation as a dictionary object. # # Side-Effects : None # # Exception Conditions : -# WSCLIENT HTTPERROR - if an HTTP error occured +# WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester @@ -2684,17 +3625,21 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2.4.1 2017-08-31 H.Oehlmann Use utility function +# ::WS::Utils::geturl_fetchbody for http call +# which also follows redirects. +# 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -2710,66 +3655,59 @@ return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ "Unknown operation '$operationName' for object '$objectName' of service '$serviceName'" } - if {![string equal $location {}]} { + if {$location ne {}} { set url $location } else { set url [dict get $serviceInfo object $objectName location] } - set query [buildRestCallquery $serviceName $objectName $operationName $url $argList] + + ## + ## build call query + ## + + SaveAndSetOptions $serviceName + if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { + RestoreSavedOptions $serviceName + return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err + } + RestoreSavedOptions $serviceName + + ## + ## Do http call + ## + if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } + set largs {} if {[llength $headers]} { - set token [::http::geturl $url -query $query -type text/xml -headers $headers] - } else { - set token [::http::geturl $url -query $query -type text/xml] - } - ::http::wait $token - - ## - ## Check for errors - ## - set body [::http::data $token] - ::log::log debug "\tReceived: $body" - set httpStatus [::http::status $token] - set hadError 0 - set results {} - if {![string equal $httpStatus ok] || - ([::http::ncode $token] != 200 && [string equal $body {}])} { - ::log::log debug "\tHTTP error [array get $token]" - set results [::http::error $token] - if {[string equal $results {}] || [string equal $httpStatus eof]} { - set results {Unexpected EOF received from Server} - set errorCode [list WSCLIENT HTTPERROR UNEXPEOF] - } else { - set errorCode [list WSCLIENT HTTPERROR [::http::code $token]] - } - set errorInfo {} - set hadError 1 - } else { - set hadError [catch {parseRestResults $serviceName $objectName $operationName $body} results] - if {$hadError} { - ::log::log debug "Reply was [::http::data $token]" - set errorCode $::errorCode - set errorInfo $::errorInfo - } - } - ::http::cleanup $token - if {$hadError} { + lappend largs -headers $headers + } + set body [::WS::Utils::geturl_fetchbody $url\ + -query $query\ + -type [dict get $serviceInfo contentType]\ + -timeout [dict get $serviceInfo queryTimeout]\ + {*}$largs] + + ## + ## Parse results + ## + + SaveAndSetOptions $serviceName + if {[catch { + parseRestResults $serviceName $objectName $operationName $body + } results]} { + RestoreSavedOptions $serviceName ::log::log debug "Leaving (error) ::WS::Client::DoRestCall" - return \ - -code error \ - -errorcode $errorCode \ - -errorinfo $errorInfo \ - $results - } else { - ::log::log debug "Leaving ::WS::Client::DoRestCall with {$results}" - return $results - } + return -code error $results + } + RestoreSavedOptions $serviceName + ::log::logsubst debug {Leaving ::WS::Client::DoRestCall with {$results}} + return $results } ########################################################################### # @@ -2783,18 +3721,18 @@ # Description : Call an operation of a web service asynchronously # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call -# argList - The arguements to the operation as a dictionary object +# argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # succesCmd - A command prefix to be called if the operations # does not raise an error. The results, as a dictionary -# object are concatinated to the prefix. +# object are concatenated to the prefix. # errorCmd - A command prefix to be called if the operations # raises an error. The error code and stack trace -# are concatinated to the prefix. +# are concatenated to the prefix. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header @@ -2805,11 +3743,11 @@ # None. # # Side-Effects : None # # Exception Conditions : -# WSCLIENT HTTPERROR - if an HTTP error occured +# WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester @@ -2829,13 +3767,13 @@ proc ::WS::Client::DoRestAsyncCall {serviceName objectName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr set svcHeaders [dict get $serviceArr($serviceName) headers] if {[llength $svcHeaders]} { - lappend headers $svcHeaders + set headers [concat $headers $svcHeaders] } - ::log::log debug "Entering ::WS::Client::DoAsyncRestCall [list $serviceName $objectName $operationName $argList $succesCmd $errorCmd $headers]" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -2849,25 +3787,36 @@ } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } set url [dict get $serviceInfo object $objectName location] - set query [buildRestCallquery $serviceName $objectName $operationName $url $argList] - if {[llength $headers]} { - ::http::geturl $url \ - -query $query \ - -type text/xml \ - -headers $headers \ - -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] + SaveAndSetOptions $serviceName + if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { + RestoreSavedOptions $serviceName + return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { - ::http::geturl $url \ + RestoreSavedOptions $serviceName + } + set largs {} + if {[llength $headers]} { + lappend largs -headers $headers + } + ::log::logsubst info {::http::geturl $url \ + -query $query \ + -type [dict get $serviceInfo contentType] \ + -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ + -timeout [dict get $serviceInfo queryTimeout]\ + {*}$largs} + ::http::geturl $url \ -query $query \ - -type text/xml \ - -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] - } + -type [dict get $serviceInfo contentType] \ + -headers $headers \ + -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ + -timeout [dict get $serviceInfo queryTimeout]\ + {*}$largs ::log::log debug "Leaving ::WS::Client::DoAsyncRestCall" - return; + return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -2909,50 +3858,51 @@ # ########################################################################### proc ::WS::Client::buildRestCallquery {serviceName objectName operationName url argList} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo object $objectName operation $operationName inputs] set xnsList [dict get $serviceInfo targetNamespace] dom createDocument "request" doc $doc documentElement body $body setAttribute \ "method" $operationName - foreach xns $xnsList { - set tns [lindex $xns 0] - set target [lindex $xns 1] + foreach {tns target} $xnsList { + #set tns [lindex $xns 0] + #set target [lindex $xns 1] $body setAttribute \ xmlns:$tns $target } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType] xns] - ::log::log debug "calling [list ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType]" + ::log::logsubst debug {calling [list ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType]} set options [::WS::Utils::SetOption] ::WS::Utils::SetOption UseNS 0 ::WS::Utils::SetOption genOutAttr 1 + ::WS::Utils::SetOption valueAttr {} ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType + set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {;}] end] {=}] end] foreach {option value} $options { ::WS::Utils::SetOption $option $value } - append xml \ - {} \ - "\n" \ - [$doc asXML -indent none -doctypeDeclaration 0] + set xml [format {} $encoding] + append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] {} xml $doc delete + set xml [encoding convertto $encoding $xml] set inTransform [dict get $serviceInfo inTransform] - if {![string equal $inTransform {}]} { + if {$inTransform ne {}} { set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } - ::log::log debug "Leaving ::::WS::Client::buildRestCallquery with {$xml}" + ::log::logsubst debug {Leaving ::WS::Client::buildRestCallquery with {$xml}} return $xml } @@ -2975,15 +3925,15 @@ # Returns : A dictionary object representing the results # # Side-Effects : None # # Exception Conditions : -# WSCLIENT REMERR - The remote end raised an exception, the third element of +# WS CLIENT REMERR - The remote end raised an exception, the third element of # the error code is the remote fault code. # Error info is set to the remote fault details. -# The error message is the remote fault string; -# WSCLIENT BADREPLY - Badly formatted reply, the third element is a list of +# The error message is the remote fault string. +# WS CLIENT BADREPLY - Badly formatted reply, the third element is a list of # what message type was received vs what was expected. # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester @@ -3001,39 +3951,45 @@ # ########################################################################### proc ::WS::Client::parseRestResults {serviceName objectName operationName inXML} { variable serviceArr - ::log::log debug "In parseResults $serviceName $operationName {$inXML}" + ::log::logsubst debug {Entering [info level 0]} + set first [string first {<} $inXML] + if {$first > 0} { + set inXML [string range $inXML $first end] + } set serviceInfo $serviceArr($serviceName) set outTransform [dict get $serviceInfo outTransform] - if {![string equal $outTransform {}]} { + if {$outTransform ne {}} { set inXML [$outTransform $serviceName $operationName REPLY $inXML] } set expectedMsgType [dict get $serviceInfo object $objectName operation $operationName outputs] + # save parsed xml handle in variable doc dom parse $inXML doc + # save top node handle in variable top $doc documentElement top set xns {} foreach tmp [dict get $serviceInfo targetNamespace] { - lappend xns [lindex $tmp 0] [lindex $tmp 1] + lappend xns $tmp } - ::log::log debug "Using namespaces {$xns}" + ::log::logsubst debug {Using namespaces {$xns}} set body $top set status [$body getAttribute status] ## ## See if it is a standard error packet ## - if {![string equal $status {ok}]} { + if {$status ne {ok}} { set faultstring {} if {[catch {set faultstring [[$body selectNodes error] asText]}]} { catch {set faultstring [[$body selectNodes error] asText]} } $doc delete return \ -code error \ - -errorcode [list WSCLIENT REMERR $status] \ + -errorcode [list WS CLIENT REMERR $status] \ -errorinfo {} \ $faultstring } ## @@ -3041,18 +3997,18 @@ ## set results {} set options [::WS::Utils::SetOption] ::WS::Utils::SetOption UseNS 0 ::WS::Utils::SetOption parseInAttr 1 - ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $body $expectedMsgType $body]" - if {![string equal $expectedMsgType {}]} { + ::log::logsubst debug {Calling ::WS::Utils::convertTypeToDict Client $serviceName $body $expectedMsgType $body} + if {$expectedMsgType ne {}} { set node [$body childNodes] set nodeName [$node nodeName] - if {![string equal $objectName $nodeName]} { + if {$objectName ne $nodeName} { return \ -code error \ - -errorcode [list WSCLIENT BADRESPONSE [list $objectName $nodeName]] \ + -errorcode [list WS CLIENT BADRESPONSE [list $objectName $nodeName]] \ -errorinfo {} \ "Unexpected message type {$nodeName}, expected {$objectName}" } set results [::WS::Utils::convertTypeToDict \ Client $serviceName $node $expectedMsgType $body] @@ -3108,23 +4064,30 @@ # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncRestCallDone {serviceName objectName operationName succesCmd errorCmd token} { - ::log::log debug "Entering ::WS::Client::asyncCallDone {$serviceName $objectName $operationName $succesCmd $errorCmd $token}" + ::log::logsubst debug {Entering [info level 0]} ## ## Check for errors ## set body [::http::data $token] - if {![string equal [::http::status $token] ok] || - ([::http::ncode $token] != 200 && [string equal $body {}])} { - set errorCode [list WSCLIENT HTTPERROR [::http::code $token]] + ::log::logsubst info {\nReceived: $body} + if {[::http::status $token] ne {ok} || + ( [::http::ncode $token] != 200 && $body eq {} )} { + set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 - set errorInfo [::http::error $token] + set errorInfo [FormatHTTPError $token] } else { - set hadError [catch {parseRestResults $serviceName $objectName $operationName $body} results] + SaveAndSetOptions $serviceName + if {[catch {set hadError [catch {parseRestResults $serviceName $objectName $operationName $body} results]} err]} { + RestoreSavedOptions $serviceName + return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err + } else { + RestoreSavedOptions $serviceName + } if {$hadError} { set errorCode $::errorCode set errorInfo $::errorInfo } } @@ -3143,7 +4106,121 @@ ## ## All done ## ::http::cleanup $token - return; + return +} + + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Client::asyncRestobCallDone +# +# Description : Save the global options of the utilities package and +# set them for how this service needs them. +# +# Arguments : +# serviceName - the name of the service called +# +# Returns : Nothing +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 03/06/2012 G.Lester Initial version +# +# +########################################################################### +proc ::WS::Client::SaveAndSetOptions {serviceName} { + variable serviceArr + variable utilsOptionsList + + if {![info exists serviceArr($serviceName)]} { + return \ + -code error \ + -errorcode [list WS CLIENT UNKSRV $serviceName] \ + "Unknown service '$serviceName'" + } + set serviceInfo $serviceArr($serviceName) + set savedDict {} + foreach item $utilsOptionsList { + if {[dict exists $serviceInfo $item] && [string length [set value [dict get $serviceInfo $item]]]} { + dict set savedDict $item [::WS::Utils::SetOption $item] + ::WS::Utils::SetOption $item $value + } + } + dict set serviceArr($serviceName) UtilsSavedOptions $savedDict + return +} + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Client::RestoreSavedOptions +# +# Description : Restore the saved global options of the utilities package. +# +# Arguments : +# serviceName - the name of the service called +# +# Returns : Nothing +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 03/06/2012 G.Lester Initial version +# +# +########################################################################### +proc ::WS::Client::RestoreSavedOptions {serviceName} { + variable serviceArr + + if {![info exists serviceArr($serviceName)]} { + return \ + -code error \ + -errorcode [list WS CLIENT UNKSRV $serviceName] \ + "Unknown service '$serviceName'" + } + set serviceInfo $serviceArr($serviceName) + set savedDict {} + foreach {item value} [dict get $serviceInfo UtilsSavedOptions] { + ::WS::Utils::SetOption $item $value + } + dict set serviceArr($serviceName) UtilsSavedOptions {} + return } Index: Embedded.tcl ================================================================== --- Embedded.tcl +++ Embedded.tcl @@ -1,7 +1,8 @@ ############################################################################### ## ## +## Copyright (c) 2016-2020, Harald Oehlmann ## ## Copyright (c) 2008, Gerald W. Lester ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## @@ -31,22 +32,40 @@ ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### +package require Tcl 8.6- + 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 1.4.0 +package provide WS::Embeded 3.3.1 namespace eval ::WS::Embeded { - array set portInfo {} + variable portInfo {} + + variable handlerInfoDict {} + + variable returnCodeText [dict create 200 OK 404 "Not Found" \ + 500 "Internal Server Error" 501 "Not Implemented"] - set portList [list] - set forever {} + variable socketStateArray + } ########################################################################### # @@ -59,59 +78,13 @@ # # Description : Register a handler for a url on a port. # # Arguments : # port -- The port to register the callback on -# url -- The URL to register the callback for -# callback -- The callback prefix, two additionally argumens are lappended -# the callback: (1) the socket (2) the null string -# -# Returns : Nothing -# -# Side-Effects : -# None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port -# -# Original Author : Gerald W. Lester -# -#>>END PUBLIC<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 03/28/2008 G.Lester Initial version -# -# -########################################################################### -proc ::WS::Embeded::AddHandler {port url callback} { - variable portInfo - - dict set portInfo($port,handlers) $url $callback - return; -} - - -########################################################################### -# -# Public Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PUBLIC<< -# -# Procedure Name : ::WS::Embeded::AddHandlerAllPorts -# -# Description : Register a handler for a url on all "defined" ports. -# -# Arguments : -# url -- List of three elements: -# callback -- The callback prefix, two additionally argumens are lappended +# urlPath -- The URL path to register the callback for +# method -- HTTP method: GET or POST +# callback -- The callback prefix, two additionally arguments are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : @@ -130,21 +103,70 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 03/28/2008 G.Lester Initial version +# 3.2.0 2021-03-17 H.Oehlmann Also pass method. +# 3.3.0 2021-03-19 H.Oehlmann Put handler info to own dict, so order of +# Listen and AddHandler call is not important. +# +# +########################################################################### +proc ::WS::Embeded::AddHandler {port urlPath method callback} { + variable handlerInfoDict + + dict set handlerInfoDict $port $urlPath $method $callback + return +} + + +########################################################################### +# +# Public Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PUBLIC<< +# +# Procedure Name : ::WS::Embeded::GetValue +# +# Description : Get a value found in this module +# +# Arguments : +# index -- type of value to get. Possible values: +# -- isHTTPS : true, if https protocol is used. +# port -- concerned port. May be ommitted, if not relevant for value. +# +# Returns : the distinct value +# +# Side-Effects : +# None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port +# +# Original Author : Harald Oehlmann +# +#>>END PUBLIC<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 2.7.0 2020-10-26 H.Oehlmann Initial version # # ########################################################################### -proc ::WS::Embeded::AddHandlerAllPorts {url callback} { - variable portList - - foreach port $portList { - AddHandler $port $url $callback - } - - return; +proc ::WS::Embeded::GetValue {index {port ""}} { + variable portInfo + + switch -exact -- $index { + isHTTPS { return [dict get $portInfo $port $index] } + default {return -code error "Unknown index '$index'"} + } } ########################################################################### # @@ -157,17 +179,29 @@ # # Description : Instruct the module to listen on a Port, security information. # # Arguments : # port -- Port number to listen on -# certfile -- Name of the certificate file -# keyfile -- Name of the key file -# userpwds -- A list of username and passwords -# realm -- The seucrity realm -# logger -- A logging routines for errors +# certfile -- Name of the certificate file or a pfx archive for twapi. +# Defaults to {}. +# keyfile -- Name of the key file. Defaults to {}. +# To use twapi TLS, specify a list with the following elements: +# -- "-twapi": Flag, that TWAPI TLS should be used +# -- password: password of PFX file passed by +# [::twapi::conceal]. The concealing makes sure that the +# password is not readable in the error stack trace +# -- ?subject?: optional search string in pfx file, if +# multiple certificates are included. +# userpwds -- A list of username:password. Defaults to {}. +# realm -- The security realm. Defaults to {}. +# timeout -- A time in ms the sender may use to send the request. +# If a sender sends wrong data (Example: TLS if no TLS is +# used), the process will just stand and a timeout is required +# to clear the connection. Set to 0 to not use a timeout. +# Default: 60000 (1 Minuit). # -# Returns : Nothing +# Returns : socket handle # # Side-Effects : # None # # Exception Conditions : None @@ -183,93 +217,147 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 03/28/2008 G.Lester Initial version +# 3.0.0 2020-10-30 H.Oehlmann Add twapi tls support +# 3.3.0 2021-03-18 H.Oehlmann Add timeout option. Remove unused portList. +# Call Close, if we use the port already. +# Do not leave portInfo data, if open fails. +# 3.3.1 2021-03-23 H.Oehlmann Fix bug: pfx subject had added ")". # # ########################################################################### -proc ::WS::Embeded::Listen {port {certfile {}} {keyfile {}} {userpwds {}} {realm {}} {logger {::WS::Embeded::logger}}} { +proc ::WS::Embeded::Listen {port {certfile {}} {keyfile {}} {userpwds {}} {realm {}} {timeout 600000}} { variable portInfo - variable portList - - lappend portList $port - foreach key {port certfile keyfile userpwds realm logger} { - set portInfo($port,$key) [set $key] - } - if {![info exists portInfo($port,handlers)]} { - set portInfo($port,handlers) {} - } - foreach up $userpwds { - lappend portInfo($port,auths) [base64::encode $up]] - } - - if {$certfile ne ""} { - package require tls - - ::tls::init \ - -certfile $certfile \ - -keyfile $keyfile \ - -ssl2 1 \ - -ssl3 1 \ - -tls1 0 \ - -require 0 \ - -request 0 - ::tls::socket -server [list ::WS::Embeded::accept $port] $port + + ## + ## Check if port already used by us. If yes, close it. + ## + if {[dict exists $portInfo $port]} { + Close $port + } + + ## + ## Check if HTTPS protocol is used + ## + set isHTTPS [expr {$certfile ne ""}] + + if {$isHTTPS } { + if { [string is list $keyfile] && [lindex $keyfile 0] eq "-twapi"} { + + ## + ## Use TWAPI TLS + ## + + package require twapi_crypto + + # Decode parameters + # + # certfile is the pfx file name + # keyfile is a list of: + # -twapi: fix element + # password of the pfx file, passed by twapi::conceal + # Optional Subject of the certificate, if there are multiple + # certificates contained. + # If not given, the first certificate is used. + set pfxpassword [lindex $keyfile 1] + set pfxsubject "" + if {[llength $keyfile] > 2} { + set pfxsubject [lindex $keyfile 2] + } + # Create certificate selection tring + if {$pfxsubject eq ""} { + set pfxselection any + } else { + set pfxselection [list subject_substring $pfxsubject] + } + + set hFile [open $certfile rb] + set PFXCur [read $hFile] + close $hFile + # Set up the store containing the certificates + # Import the PFX file and search the certificate. + set certstore [twapi::cert_temporary_store -pfx $PFXCur \ + -password $pfxpassword] + set servercert [twapi::cert_store_find_certificate $certstore \ + {*}$pfxselection] + if {"" eq $servercert} { + # There was no certificate included in the pfx file + catch {twapi::cert_store_release $certstore} + return -code error "no certificate found in file '$certfile'" + } + # The following is catched to clean-up in case of any error + if {![catch { + # Start the TLS socket with the credentials + set creds [twapi::sspi_schannel_credentials \ + -certificates [list $servercert] \ + -protocols [list ssl3 tls1.1 tls1.2]] + set creds [twapi::sspi_acquire_credentials \ + -credentials $creds -package unisp -role server] + set handle [::twapi::tls_socket \ + -server [list ::WS::Embeded::accept $port] \ + -credentials $creds $port] + } errormsg errordict]} { + # All ok, clear error flag + unset errormsg + } + # Clean up certificate and certificate store + if {[info exists servercert]} { + catch {twapi::cert_release $servercert} + } + catch {twapi::cert_store_release $certstore} + # Return error if happened above + if {[info exists errormsg]} { + dict unset errordict -level + return -options $errordict $errormsg + } + } else { + + ## + ## Use TLS Package + ## + + package require tls + + ::tls::init \ + -certfile $certfile \ + -keyfile $keyfile \ + -require 0 \ + -request 0 + set handle [::tls::socket -server [list ::WS::Embeded::accept $port] $port] + } } else { - socket -server [list ::WS::Embeded::accept $port] $port - } -} - - -########################################################################### -# -# Public Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PUBLIC<< -# -# Procedure Name : ::WS::Embeded::ReturnData -# -# Description : Store the information to be returned. -# -# Arguments : -# socket -- Socket data is for -# type -- Mime type of data -# data -- Data -# code -- Status code -# -# Returns : Nothing -# -# Side-Effects : -# None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : A callback on the socket should be pending -# -# Original Author : Gerald W. Lester -# -#>>END PUBLIC<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 03/28/2008 G.Lester Initial version -# -# -########################################################################### -proc ::WS::Embeded::ReturnData {sock type data code} { - upvar #0 ::WS::Embeded::Httpd$sock dataArray - - foreach var {type data code} { - dict set dataArray(reply) $var [set $var] - } - return; + + ## + ## Use http protocol without encryption + ## + + ::log::logsubst debug {socket -server [list ::WS::Embeded::accept $port] $port} + set handle [socket -server [list ::WS::Embeded::accept $port] $port] + } + + ## + ## Prepare basic authentication + ## + set authlist {} + foreach up $userpwds { + lappend authlist [base64::encode $up] + } + + ## + ## Save the port information dict entry + ## + dict set portInfo $port [dict create\ + port $port\ + realm $realm\ + timeout $timeout\ + auths $authlist\ + isHTTPS $isHTTPS\ + handle $handle] + + return $handle } ########################################################################### # @@ -276,47 +364,63 @@ # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # -# Procedure Name : ::WS::Embeded::Start +# Procedure Name : ::WS::Embeded::Close # -# Description : Start listening on all ports (i.e. enter the event loop). +# Description : End listening, close the port. # -# Arguments : None +# Arguments : +# port -- Port number to listen on # -# Returns : Value that event loop was exited with. +# Returns : none # # Side-Effects : # None # # Exception Conditions : None # -# Pre-requisite Conditions : -# ::WS::Embeded::Listen should have been called for one or more port. +# Pre-requisite Conditions : None # -# -# Original Author : Gerald W. Lester +# Original Author : Harald Oehlmann # #>>END PUBLIC<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- -# 1 03/28/2008 G.Lester Initial version +# 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### -proc ::WS::Embeded::Start {} { - variable forever - - set forever 0 - vwait ::WS::Embeded::forever - return $forever +proc ::WS::Embeded::Close {port} { + variable socketStateArray + variable portInfo + + # Check, if port exists + if {![dict exists $portInfo $port handle]} {return} + + ::log::log info "closing server socket for port $port" + # close server port + if {[catch {close [dict get $portInfo $port handle]} msg]} { + ::log::log error "error closing server socket for port $port: $msg" + } + + # close existing connections + foreach sock [array names socketStateArray] { + if {[dict get $socketStateArray($sock) port] eq $port} { + cleanup $sock + } + } + + # remove registered data + dict unset portInfo $port + return } ########################################################################### # @@ -323,46 +427,45 @@ # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # -# Procedure Name : ::WS::Embeded::Stop +# Procedure Name : ::WS::Embeded::CloseAll # -# Description : Exit dispatching request. +# Description : End listening, close all ports. # # Arguments : -# value -- Value that ::WS::Embedded::Start should return, +# port -- Port number to listen on # -# Returns : Nothing +# Returns : none # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : None # -# Original Author : Gerald W. Lester +# Original Author : Harald Oehlmann # #>>END PUBLIC<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- -# 1 03/28/2008 G.Lester Initial version +# 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### -proc ::WS::Embeded::Stop {{value 1}} { - vairable forever - - set forever $value - vwait ::WS::Embeded::forever - return $forever +proc ::WS::Embeded::CloseAll {} { + variable portInfo + foreach port [dict keys $portInfo] { + Close $port + } } ########################################################################### # @@ -369,16 +472,19 @@ # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # -# Procedure Name : ::WS::Embeded::logger +# Procedure Name : ::WS::Embeded::respond # -# Description : Stub for a logger. +# Description : Send response back to user. # # Arguments : -# args - not used +# sock -- Socket to send reply on +# code -- Code to send +# body -- HTML body to send +# head -- Additional HTML headers to send # # Returns : # Nothing # # Side-Effects : None @@ -396,16 +502,82 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 03/28/2008 G.Lester Initial version +# 2.3.0 11/06/2012 H.Oehlmann Separate head and body, +# correct Content-length +# +# +########################################################################### +proc ::WS::Embeded::respond {sock code body {head ""}} { + set body [encoding convertto iso8859-1 $body\r\n] + if {[catch { + chan configure $sock -translation crlf + puts $sock "[httpreturncode $code]\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]" + if {"" ne $head} { + puts -nonewline $sock $head + } + # Separator head and body + puts $sock "" + chan configure $sock -translation binary + puts -nonewline $sock $body + close $sock + } msg]} { + log::log error "Error sending response: $msg" + cleanup $sock + } else { + cleanup $sock 1 + } +} + + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Embeded::httpreturncode +# +# Description : Format the first line of a http return including the status code +# +# Arguments : +# code -- numerical http return code +# +# Returns : +# Nothing +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 10/05/2012 H.Oehlmann Initial version # # ########################################################################### -proc ::WS::Embeded::logger {args} { - puts $args - puts $::errorInfo +proc ::WS::Embeded::httpreturncode {code} { + variable returnCodeText + if {[dict exist $returnCodeText $code]} { + set textCode [dict get $returnCodeText $code] + } else { + set textCode "???" + } + return "HTTP/1.0 $code $textCode" } ########################################################################### # @@ -412,19 +584,16 @@ # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # -# Procedure Name : ::WS::Embeded::respond +# Procedure Name : ::WS::Embeded::handler # -# Description : Send response back to user. +# Description : Handle a request. # # Arguments : -# sock -- Socket to send reply on -# code -- Code to send -# body -- HTML body to send -# head -- HTML header to send +# sock -- Incoming socket # # Returns : # Nothing # # Side-Effects : None @@ -442,150 +611,78 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 03/28/2008 G.Lester Initial version -# -# -########################################################################### -proc ::WS::Embeded::respond {sock code body {head ""}} { - puts -nonewline $sock "HTTP/1.0 $code ???\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]\n$head\n$body" -} - - -########################################################################### -# -# Private Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PRIVATE<< -# -# Procedure Name : ::WS::Embeded::checkauth -# -# Description : Check to see if the user is allowed. -# -# Arguments : -# port -- Port number -# sock -- Incoming socket -# ip -- Requester's IP address -# auth -- Authentication information -# -# Returns : -# Nothing -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Gerald W. Lester -# -#>>END PRIVATE<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 03/28/2008 G.Lester Initial version -# -# -########################################################################### -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 Unauthorized "WWW-Authenticate: Basic realm=\"$realm\"\n" - $portInfo($port,logger) "Unauthorized from $ip" - return -code error - } -} - - -########################################################################### -# -# Private Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PRIVATE<< -# -# Procedure Name : ::WS::Embeded::handler -# -# Description : Handle a request. -# -# Arguments : -# port -- Port number -# sock -- Incoming socket -# ip -- Requester's IP address -# reqstring -- Requester's message -# auth -- Authentication information -# -# Returns : -# Nothing -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Gerald W. Lester -# -#>>END PRIVATE<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 03/28/2008 G.Lester Initial version -# -# -########################################################################### -proc ::WS::Embeded::handler {port sock ip reqstring auth} { - variable portInfo - upvar #0 ::WS::Embeded::Httpd$sock req - - if {[catch {checkauth $port $sock $ip $auth}]} { - $portInfo($port,logger) {Auth Failed} - return; - } - - set ::errorInfo {} - array set req $reqstring - #foreach var {type data code} { - # dict set req(reply) $var [set $var] - #} - set path "/[string trim $req(path) /]" - if {[dict exists $portInfo($port,handlers) $path]} { - set cmd [dict get $portInfo($port,handlers) $path] - lappend cmd $sock {} - puts "Calling {$cmd}" - if {[catch {eval $cmd} msg]} { - $portInfo($port,logger) [list 404 b $msg] - respond $sock 404 Error $msg - } else { - set data [dict get $req(reply) data] - set reply "HTTP/1.0 [dict get $req(reply) code] ???\n" - append reply "Content-Type: [dict get $req(reply) type]; charset=UTF-8\n" - append reply "Connection: close\n" - append reply "Content-length: [string length $data]\n" - append reply "\n" - append reply $data - puts -nonewline $sock $reply - $portInfo($port,logger) ok - } - } else { - $portInfo($port,logger) {404 Error} - respond $sock 404 Error "Error" - } - - return; +# 2.3.0 10/31/2012 G.Lester bug fix for [68310fe3bd] -- correct encoding and data length +# 2.6.1 2020-10-22 H.Oehlmann Do not pass parameter reqstring. +# The corresponding value is found in global +# array anyway. +# Use charset handler of request decoding. +# 2.7.0 2020-10-26 H.Oehlmann Pass additional port parameter to handle +# functions. This helps to get isHTTPS +# status for WSDL. +# 3.1.0 2020-11-05 H.Oehlmann Pass additional port parameter with leading +# -port specifier to avoid clash with +# other parameters. +# 3.2.0 2021-03-17 H.Oehlmann Return the result directly by the call. +# Replace global parameter dict by parameter +# url and dataDict (for POST method). +# 3.3.0 2021-03-18 H.Oehlmann Use state array, move checks to Receive, +# do query recode here. +# +########################################################################### +proc ::WS::Embeded::handler {sock} { + variable socketStateArray + + set cmd [dict get $socketStateArray($sock) cmd] + if {[dict get $socketStateArray($sock) method] eq "POST"} { + # Recode the query data + dict set socketStateArray($sock) query [encoding convertfrom\ + [dict get $socketStateArray($sock) requestEncoding]\ + [dict get $socketStateArray($sock) query]] + + # The following dict keys are attended: query, ipaddr, headers + if {[catch { + lassign [$cmd $sock -data $socketStateArray($sock)] type data code + } msg]} { + ::log::log error "Return 404 due to post eval error: $msg" + tailcall respond $sock 404 "Error: $msg" + } + } else { + if {[catch { + lassign [$cmd $sock -port [dict get $socketStateArray($sock) port]] type data code + } msg]} { + ::log::log error "Return 404 due to get eval error: $msg" + tailcall respond $sock 404 "Error: $msg" + } + } + # This may modify the type variable, if encoding is not found + set encoding [contentTypeParse 0 type] + set data [encoding convertto $encoding $data] + set reply "[httpreturncode $code]\n" + append reply "Content-Type: $type\n" + append reply "Connection: close\n" + append reply "Content-length: [string length $data]\n" + + # Note: to avoid delay, full buffering is used on the channel. + # In consequence, the data is sent in the background after the close. + # Socket errors may not be detected, but the event queue is free. + # This is specially important with the Edge browser, which sometimes delays + # data reception. + if {[catch { + chan configure $sock -translation crlf + puts $sock $reply + chan configure $sock -translation binary + puts -nonewline $sock $data + close $sock + } msg]} { + ::log::log error "Error sending reply: $msg" + tailcall cleanup $sock + } + ::log::log debug ok + tailcall cleanup $sock 1 } ########################################################################### # @@ -594,11 +691,11 @@ # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::accept # -# Description : Accept an incoming connection. +# Description : Accept an incoming connection and register callback. # # Arguments : # port -- Port number # sock -- Incoming socket # ip -- Requester's IP address @@ -611,51 +708,515 @@ # # Exception Conditions : None # # Pre-requisite Conditions : None # -# Original Author : Gerald W. Lester +# Original Author : Harald Oehlmann +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 3.3.0 2021-03-18 H.Oehlmann Initial version +# +# +########################################################################### +proc ::WS::Embeded::accept {port sock ip clientport} { + variable portInfo + variable socketStateArray + + ::log::logsubst info {Received request on $port for $ip:$clientport} + + # Setup events + if {[catch { + chan configure $sock -blocking 0 -translation crlf + chan event $sock readable [list ::WS::Embeded::receive $sock] + } msg]} { + catch {chan close $sock} + ::log::log error "Error installing accepted socket on ip '$ip': $msg" + return + } + # Prepare socket state dict + set stateDict [dict create port $port ip $ip phase request] + # Install timeout + if {0 < [dict get $portInfo $port timeout]} { + dict set stateDict timeoutHandle [after\ + [dict get $portInfo $port timeout]\ + [list ::WS::Embeded::timeout $sock]] + } + # Save state dict + set socketStateArray($sock) $stateDict +} + + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Embeded::receive +# +# Description : handle a readable socket +# +# Arguments : +# sock -- Incoming socket +# +# Returns : +# Nothing +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Harald Oehlmann +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 3.3.0 2021-03-18 H.Oehlmann Initial version +# +# +########################################################################### +proc ::WS::Embeded::receive {sock} { + variable socketStateArray + variable portInfo + variable handlerInfoDict + + ## + ## Make data read attempts in this read loop. + ## + while 1 { + + ::log::logsubst debug {Top of loop with dict: $socketStateArray($sock)} + + ## + ## Read data + ## + if {[catch { + if {[dict get $socketStateArray($sock) phase] eq "body"} { + # Read binary data + set line [chan read $sock [dict get $socketStateArray($sock) readMax]] + } else { + # read line data + set line [chan gets $sock] + } + } msg]} { + ::log::log error "Data read error: $msg" + tailcall cleanup $sock + } + ::log::logsubst debug {Read: len [string length $line] eof [eof $sock] block [chan blocked $sock] data '$line'} + + ## + ## Check for early EOF + ## + if { [eof $sock] } { + ::log::log warning {Connection closed from client} + tailcall cleanup $sock + } + + ## + ## Check for no new data, so wait for next file event. + ## + ## For gets: + ## This makes also the difference between empty data read (crlf + ## terminated line) and no read (true). + ## For read with limit: + ## If not all characters could be read, block is flagged with data. + ## So check the data length to 0 for this case. + ## + if {[string length $line] == 0 && [chan blocked $sock]} { + return + } + + ## + ## Handle the received data + ## + switch -exact -- [dict get $socketStateArray($sock) phase] { + request { + ## + ## Handle Request line + ## + if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} { + ::log::logsubst warning {Wrong request: $line} + tailcall cleanup $sock + } + if {$method ni {"GET" "POST"}} { + ::log::logsubst warning {Unsupported method '$method'} + tailcall respond $sock 501 "Method not implemented" + } + + # Check if we have a handler for this method and URL path + set urlPath "/[string trim [dict get [uri::split $url] path] /]" + set port [dict get $socketStateArray($sock) port] + if {![dict exists $handlerInfoDict $port $urlPath $method]} { + ::log::log warning "404 Error: URL path '$urlPath' not found" + tailcall respond $sock 404 "URL not found" + } + # Save data and pass to header phase + dict set socketStateArray($sock) cmd [dict get $handlerInfoDict $port $urlPath $method] + dict set socketStateArray($sock) phase header + dict set socketStateArray($sock) method $method + dict set socketStateArray($sock) header "" + } + header { + ## + ## Handle Header lines + ## + if {[string length $line] > 0} { + if {[regexp {^([^:]*):(.*)$} $line -> key data]} { + dict set socketStateArray($sock) header [string tolower $key] [string trim $data] + } + } else { + # End of header by empty line + + ## + ## Get authorization failure condition + ## + # Authorization is ok, if no authrization required + # Authorization fails, if: + # - no authentication in current request + # - or current credentials incorrect + set port [dict get $socketStateArray($sock) port] + if { 0 != [llength [dict get $portInfo $port auths]] && + ! ( [dict exists $socketStateArray($sock) header authorization] && + [regexp -nocase {^basic +([^ ]+)$} \ + [dict get $socketStateArray($sock) header authorization] -> auth] && + $auth in [dict get $portInfo $port auths] ) + } { + set realm [dict get $portInfo $port realm] + ::log::log warning {Unauthorized} + tailcall respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n" + } + + # Within the GET method, we have all we need + if {[dict get $socketStateArray($sock) method] eq "GET"} { + tailcall handler $sock + } + + # Post method requires content-encoding header + if {![dict exists $socketStateArray($sock) header content-type]} { + ::log::logsubst warning {Header missing: 'Content-Type'} + tailcall cleanup $sock + } + set contentType [dict get $socketStateArray($sock) header content-type] + dict set socketStateArray($sock) requestEncoding [contentTypeParse 1 contentType] + + # Post method requires query data + dict set socketStateArray($sock) query "" + set fChunked [expr { + [dict exists $socketStateArray($sock) header transfer-encoding] && + [dict get $socketStateArray($sock) header transfer-encoding] eq "chunked"}] + dict set socketStateArray($sock) fChunked $fChunked + + if {$fChunked} { + dict set socketStateArray($sock) phase chunk + } else { + + # Check for content length + if { ! [dict exists $socketStateArray($sock) header content-length] || + 0 == [scan [dict get $socketStateArray($sock) header content-length] %d contentLength] + } { + ::log::log warning "Header content-length missing" + tailcall cleanup $sock + } + dict set socketStateArray($sock) readMax $contentLength + dict set socketStateArray($sock) phase body + + # Switch to binary data + if {[catch { chan configure $sock -translation binary } msg]} { + ::log::log error "Channel config error: $msg" + tailcall cleanup $sock + } + } + } + } + body { + ## + ## Read body data + ## + set query [dict get $socketStateArray($sock) query] + append query $line + dict set socketStateArray($sock) query $query + + set readMax [expr { + [dict get $socketStateArray($sock) readMax] - [string length $line] } ] + + if {$readMax > 0} { + # Data missing, so loop + dict set socketStateArray($sock) readMax $readMax + } else { + # We have all data + + if {[dict get $socketStateArray($sock) fChunked]} { + # Chunk read + # Switch to line mode + if {[catch { chan configure $sock -translation crlf } msg]} { + ::log::log error "Channel config error: $msg" + tailcall cleanup $sock + } + dict set socketStateArray($sock) phase chunk + } else { + # no chunk -> all data -> call handler + tailcall handler $sock + } + } + } + chunk { + ## + ## Handle chunk header + ## + if {[scan $line %x length] != 1} { + ::log::log warning "No chunk length in '$line'" + tailcall cleanup $sock + } + if {$length > 0} { + # Receive chunk data + # Switch to binary data + if {[catch { chan configure $sock -translation binary } msg]} { + ::log::log error "Channel config error: $msg" + tailcall cleanup $sock + } + dict set socketStateArray($sock) readMax $length + dict set socketStateArray($sock) phase body + } else { + # We have all data + tailcall handler $sock + } + } + } + } +} + + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Embeded::timeout +# +# Description : socket timeout fired +# +# Arguments : +# sock -- Incoming socket +# +# Returns : +# Nothing +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Harald Oehlmann +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 3.3.0 2021-03-18 H.Oehlmann Initial version +# +# +########################################################################### +proc ::WS::Embeded::timeout {sock} { + variable socketStateArray + + # The timeout fired, so the cancel handle is not required any more + dict unset socketStateArray($sock) timeoutHandle + + ::log::log warning "Cancelling request due to timeout" + tailcall cleanup $sock +} + + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Embeded::cleanup +# +# Description : cleanup a socket +# +# Arguments : +# sock -- Incoming socket +# fClosed -- Socket already closed +# +# Returns : +# Nothing +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Harald Oehlmann +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 3.3.0 2021-03-18 H.Oehlmann Initial version +# +# +########################################################################### +proc ::WS::Embeded::cleanup {sock {fClosed 0}} { + variable socketStateArray + if {!$fClosed} { + catch { chan close $sock } + } + if {[dict exists $socketStateArray($sock) timeoutHandle]} { + after cancel [dict get $socketStateArray($sock) timeoutHandle] + } + unset socketStateArray($sock) +} + + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Embeded::contentTypeParse +# +# Description : Parse a content-type value and get the encoding. +# When receiving, only the encoding is required. +# When sending, we have to correct the encoding, if not known +# by TCL. Thus, the content-type string is changed. +# +# Arguments : +# fReceiving -- When receiving, we only need the extracted codepage. +# If sending, the content-type string must be modified, +# if the codepage is not found in tcl +# contentTypeName -- The variable containing the content type string. +# +# Returns : +# tcl encoding to apply +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Harald Oehlmann # #>>END PRIVATE<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- -# 1 03/28/2008 G.Lester Initial version +# 2.6.1 2020-10-22 H.Oehlmann Initial version # # ########################################################################### -proc ::WS::Embeded::accept {port sock ip clientport} { - variable portInfo - - if {[catch { - gets $sock line - set auth "" - for {set c 0} {[gets $sock temp]>=0 && $temp ne "\r" && $temp ne ""} {incr c} { - regexp {Authorization: Basic ([^\r\n]+)} $temp -- auth - if {$c == 30} { - $portInfo($port,logger) "Too many lines from $ip" - } - } - if {[eof $sock]} { - $portInfo($port,logger) "Connection closed from $ip" - } - foreach {method url version} $line { break } - switch -exact $method { - GET { - handler $port $sock $ip [uri::split $url] $auth - } - default { - $portInfo($port,logger) "Unsupported method '$method' from $ip" - } - } - } msg]} { - $portInfo($port,logger) "Error: $msg" - } - - catch {flush $sock} - catch {close $sock} - return; -} +proc ::WS::Embeded::contentTypeParse {fReceiving contentTypeName} { + + upvar 1 $contentTypeName contentType + + ## + ## Extract charset parameter from content-type header + ## + + # content-type example content: text/xml;charset=utf-8 + set paramList [lassign [split $contentType ";"] typeOnly] + foreach parameterCur $paramList { + set parameterCur [string trim $parameterCur] + # Check for 'charset="', where data may contain '\"' + if {[regexp -nocase {^charset\s*=\s*\"((?:[^""]|\\\")*)\"$} \ + $parameterCur -> requestEncoding] + } { + set requestEncoding [string map {{\"} \"} $requestEncoding] + break + } else { + # check for 'charset=' + regexp -nocase {^charset\s*=\s*(\S+?)$} \ + $parameterCur -> requestEncoding + break + } + } + + ## + ## Find the corresponding TCL encoding name + ## + + if {[info exists requestEncoding]} { + if {[llength [info commands ::http::CharsetToEncoding]]} { + # Use private http package routine + set requestEncoding [::http::CharsetToEncoding $requestEncoding] + # Output is "binary" if not found + if {$requestEncoding eq "binary"} { + unset requestEncoding + } + } else { + # Reduced version of the http package version only honoring ISO8859-x + # and encoding names identical to tcl encoding names + set requestEncoding [string tolower $requestEncoding] + if {[regexp {iso-?8859-([0-9]+)} $requestEncoding -> num]} { + set requestEncoding "iso8859-$num" + } + if {$requestEncoding ni [encoding names]} { + unset requestEncoding + } + } + } + + ## + ## Output found encoding and eventually content type + ## + + # If encoding was found, just return it + if {[info exists requestEncoding]} { + return $requestEncoding + } + + # encoding was not found + if {$fReceiving} { + # This is the http default so use that + ::log::logsubst info {Use default encoding as content type header has missing/unknown charset in '$contentType'} + return iso8859-1 + } + + # When sending, be sure to cover all characters, so use utf-8 + # correct content-type string (upvar) + ::log::logsubst info {Set send charset to utf-8 due missing/unknown charset in '$contentType'} + if {[info exists typeOnly]} { + set contentType "${typeOnly};charset=utf-8" + } else { + set contentType "text/xml;charset=utf-8" + } + return utf-8 +} + + Index: Examples/Echo/CallEchoWebService.tcl ================================================================== --- Examples/Echo/CallEchoWebService.tcl +++ Examples/Echo/CallEchoWebService.tcl @@ -31,10 +31,12 @@ ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### +set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] +package require WS::Utils package require WS::Client ## ## Get Definition of the offered services ## ADDED Examples/Echo/EchoEmbeddedService.tcl Index: Examples/Echo/EchoEmbeddedService.tcl ================================================================== --- /dev/null +++ Examples/Echo/EchoEmbeddedService.tcl @@ -0,0 +1,100 @@ +############################################################################### +## ## +## Copyright (c) 2006, Visiprise Software, Inc ## +## All rights reserved. ## +## ## +## Redistribution and use in source and binary forms, with or without ## +## modification, are permitted provided that the following conditions ## +## are met: ## +## ## +## * Redistributions of source code must retain the above copyright ## +## notice, this list of conditions and the following disclaimer. ## +## * Redistributions in binary form must reproduce the above ## +## copyright notice, this list of conditions and the following ## +## disclaimer in the documentation and/or other materials provided ## +## with the distribution. ## +## * Neither the name of the Visiprise Software, Inc nor the names ## +## of its contributors may be used to endorse or promote products ## +## derived from this software without specific prior written ## +## permission. ## +## ## +## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## +## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## +## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## +## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## +## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## +## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## +## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## +## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## +## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## +## 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. ## +## ## +############################################################################### + +set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] +package require WS::Server +package require WS::Utils +package require WS::Embeded +catch {console show} + +## +## Define the service +## +::WS::Server::Service \ + -service wsEchoExample \ + -description {Echo Example - Tcl Web Services} \ + -host localhost:8015 \ + -mode embedded \ + -ports [list 8015] + +## +## Define any special types +## +::WS::Utils::ServiceTypeDef Server wsEchoExample echoReply { + echoBack {type string} + echoTS {type dateTime} +} + +## +## Define the operations available +## +::WS::Server::ServiceProc \ + wsEchoExample \ + {SimpleEcho {type string comment {Requested Echo}}} \ + { + TestString {type string comment {The text to echo back}} + } \ + {Echo a string back} { +::log::lvSuppressLE debug 0 + return [list SimpleEchoResult $TestString] +} + + +::WS::Server::ServiceProc \ + wsEchoExample \ + {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ + { + TestString {type string comment {The text to echo back}} + } \ + {Echo a string and a timestamp back} { + + set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] + return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] +} + +set ::errorInfo {} +set SocketHandle [::WS::Embeded::Listen 8015] +set ::errorInfo {} + +proc x {} { + close $::SocketHandle + exit +} + +puts stdout {Server started. Press x and Enter to stop} +flush stdout +fileevent stdin readable {set QuitNow 1} +vwait QuitNow +x ADDED Examples/Echo/EchoWibbleService.tcl Index: Examples/Echo/EchoWibbleService.tcl ================================================================== --- /dev/null +++ Examples/Echo/EchoWibbleService.tcl @@ -0,0 +1,81 @@ +############################################################################### +## ## +## Copyright (c) 2006, Visiprise Software, Inc ## +## All rights reserved. ## +## ## +## Redistribution and use in source and binary forms, with or without ## +## modification, are permitted provided that the following conditions ## +## are met: ## +## ## +## * Redistributions of source code must retain the above copyright ## +## notice, this list of conditions and the following disclaimer. ## +## * Redistributions in binary form must reproduce the above ## +## copyright notice, this list of conditions and the following ## +## disclaimer in the documentation and/or other materials provided ## +## with the distribution. ## +## * Neither the name of the Visiprise Software, Inc nor the names ## +## of its contributors may be used to endorse or promote products ## +## derived from this software without specific prior written ## +## permission. ## +## ## +## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## +## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## +## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## +## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## +## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## +## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## +## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## +## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## +## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## +## 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 WS::Server +package require WS::Utils + +## +## Define the service +## +::WS::Server::Service \ + -service wsEchoExample \ + -description {Echo Example - Tcl Web Services} \ + -mode wibble \ + -host $::Config(host):$::Config(port) + +## +## Define any special types +## +::WS::Utils::ServiceTypeDef Server wsEchoExample echoReply { + echoBack {type string} + echoTS {type dateTime} +} + +## +## Define the operations available +## +::WS::Server::ServiceProc \ + wsEchoExample \ + {SimpleEcho {type string comment {Requested Echo}}} \ + { + TestString {type string comment {The text to echo back}} + } \ + {Echo a string back} { + + return [list SimpleEchoResult $TestString] +} + + +::WS::Server::ServiceProc \ + wsEchoExample \ + {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ + { + TestString {type string comment {The text to echo back}} + } \ + {Echo a string and a timestamp back} { + + set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] + return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] +} ADDED Examples/Echo/EchoWibbleStart.tcl Index: Examples/Echo/EchoWibbleStart.tcl ================================================================== --- /dev/null +++ Examples/Echo/EchoWibbleStart.tcl @@ -0,0 +1,27 @@ +############# tclws.tcl, start script for wibble 24 (not included) ######## +# Adjust auto_path to your needs +lappend auto_path [file dir [info script]] lib +source wibble.tcl +# Set the root directory. +set root html +set ::Config(host) 127.0.0.1 +set ::Config(port) 8015 + +source EchoWebService.tcl + +# Define zone handlers. +::wibble::handle /vars vars +::wibble::handle / dirslash root $root +::wibble::handle / indexfile root $root indexfile index.html +::wibble::handle / static root $root +::wibble::handle / template root $root +::wibble::handle / script root $root +::wibble::handle / dirlist root $root +::wibble::handle / notfound + + +# Start a server and enter the event loop. +catch { + ::wibble::listen 8015 + vwait forever +} Index: Examples/Math/CallMathWebService.tcl ================================================================== --- Examples/Math/CallMathWebService.tcl +++ Examples/Math/CallMathWebService.tcl @@ -41,6 +41,86 @@ ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsMathExample/wsdl ## ## Add two numbers ## -::WS::Client::DoCall +puts stdout "Calling Add via DoCalls!" +set inputs [list N1 12 N2 34] +set results [::WS::Client::DoCall wsMathExample Add $inputs] +puts stdout "\t Received: {$results}" + +## +## Divide two numbers +## +puts stdout "Calling Divide via DoCalls!" +set inputs [list Dividend 34 Divisor 12] +set results [::WS::Client::DoCall wsMathExample Divide $inputs] +puts stdout "\t Received: {$results}" + +## +## Multiply two numbers +## +puts stdout "Calling Multiply via DoCalls!" +set inputs [list N1 12.0 N2 34] +set results [::WS::Client::DoCall wsMathExample Multiply $inputs] +puts stdout "\t Received: {$results}" + +## +## Subtract two numbers +## +puts stdout "Calling Subtract via DoCalls!" +set inputs [list Subtrahend 12 Minuend 34] +set results [::WS::Client::DoCall wsMathExample Subtract $inputs] +puts stdout "\t Received: {$results}" + +## +## Sqrt a number +## +puts stdout "Calling Sqrt via DoCalls!" +set inputs [list X 12] +set results [::WS::Client::DoCall wsMathExample Sqrt $inputs] +puts stdout "\t Received: {$results}" + + + +## +## Set up to evaluate a polynomial +## +dict set term var X +dict set term value 2.0 +dict lappend varList $term +dict set term var Y +dict set term value 3.0 +dict lappend varList $term + + +set term {} +set powerTerm {} +dict set powerTerm coef 2.0 +dict set term var X +dict set term pow 2.0 +dict lappend terms $term +dict set term var Y +dict set term pow 3.0 +dict lappend terms $term +dict set powerTerm powerTerms $terms + + +dict set powerTerm coef -2.0 +dict set term var X +dict set term pow 3.0 +dict lappend terms $term +dict set term var Y +dict set term pow 2.0 +dict lappend terms $term +dict set powerTerm powerTerms $terms +dict lappend polynomial powerTerms $powerTerm + + +dict set input varList $varList +dict set input polynomial $polynomial +## +## Call service +## +puts stdout "Calling EvaluatePolynomial with {$input}" +set resultsDict [::WS::Client::DoCall wsMathExample EvaluatePolynomial $input] +puts stdout "Results are {$resultsDict}" Index: Examples/Math/MathWebService.tcl ================================================================== --- Examples/Math/MathWebService.tcl +++ Examples/Math/MathWebService.tcl @@ -41,10 +41,28 @@ ## ::WS::Server::Service \ -service wsMathExample \ -description {Math Example - Tcl Web Services} \ -host $::Config(host):$::Config(port) + + +## +## Define any special types +## +::WS::Utils::ServiceTypeDef Server wsMathExample Term { + `coef {type float} + powerTerms {type PowerTerm()} +} +::WS::Utils::ServiceTypeDef Server wsMathExample PowerTerm { + var {type string} + exponet {type float} +} +::WS::Utils::ServiceTypeDef Server wsMathExample Variables { + var {type string} + value {type float} +} + ## ## Define the operations available ## ::WS::Server::ServiceProc \ @@ -97,11 +115,11 @@ -code error \ -errorcode [list MATH DIVBYZERO] \ "Can not divide by zero" } - return [list DivideResult [expr {$Dividend + $Divisor}]] + return [list DivideResult [expr {$Dividend / $Divisor}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Sqrt {type string comment {Square root of a non-negative number}}} \ @@ -117,6 +135,44 @@ "Can not take the square root of a negative number, $X" } return [list SqrtResult [expr {sqrt($X)}]] } + +## +## Define the operations available +## +::WS::Server::ServiceProc \ + wsMathExample \ + {EvaluatePolynomial {type float comment {Result of evaluating a polynomial}}} \ + { + varList {type Variables() comment {The variables to be substitued into the polynomial}} + polynomial {type Term() comment {The polynomial}} + } \ + {Evaluate a polynomial} { + set equation {0 } + foreach varDict $varList { + set var dict get $varDict var + set val dict get $varDict value + set vars($var) $val + } + foreach term $polynomial { + if {dict exists $term coef} { + set coef dict get $term coef + } else { + set coef 1 + } + append equation "+ ($coef" + foreach pow dict get $term powerTerms { + if {dict exists $pow exponet} { + set exp dict get $pow exponet + } else { + set exp 1 + } + append equation format { * pow($vars(%s),%s} [dict get $pow var $exp] + } + append equation ")" + } + set result expr $equation + return list SimpleEchoResult $result + } ADDED Examples/redirect_test/redirect_call.tcl Index: Examples/redirect_test/redirect_call.tcl ================================================================== --- /dev/null +++ Examples/redirect_test/redirect_call.tcl @@ -0,0 +1,9 @@ +# Call redirect server +# 2015-11-09 Harald Oehlmann +# Start the redirect_server.tcl and the embedded echo sample to test. +set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] +package require WS::Utils +package require WS::Client +catch {console show} +::log::lvSuppressLE debug 0 +::WS::Client::GetAndParseWsdl http://localhost:8014/service/wsEchoExample/wsdl ADDED Examples/redirect_test/redirect_server.tcl Index: Examples/redirect_test/redirect_server.tcl ================================================================== --- /dev/null +++ Examples/redirect_test/redirect_server.tcl @@ -0,0 +1,55 @@ +# Test tclws redirection +# 2015-11-09 by Harald Oehlmann +# +# If (set loop 1), infinite redirect is tested, otherwise one redirect. +# Start the embedded test server and use redirect_call to call. +# +set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] +catch {console show} +package require uri + +proc ::Listen {port} { + return [socket -server ::Accept $port] +} + + +proc ::Accept {sock ip clientport} { + if {1 == [catch { + gets $sock line + 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]} { + puts "Connection closed from $ip" + return + } + if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} { + puts "Wrong request: $line" + return + } + array set uri [::uri::split $url] + if {[info exists ::loop]} { + set uri(host) "localhost:8014" + } else { + set uri(host) "localhost:8015" + } + set url [eval ::uri::join [array get uri]] + puts "Redirecting to $url" + puts $sock "HTTP/1.1 301 Moved Permanently" + puts $sock "Location: $url" + puts $sock "Content-Type: text/html" + puts $sock "Content-Length: 0\n\n" + close $sock + } Err]} { + puts "Socket Error: $Err" + return + } +} + +Listen 8014 + + + Index: License.txt ================================================================== --- License.txt +++ License.txt @@ -1,8 +1,8 @@ +Copyright (c) 2006-2013, Gerald W. Lester Copyright (c) 2006, Visiprise Software, Inc -Copyright (c) 2006, Gerald W. Lester Copyright (c) 2006, Colin McCormack Copyright (c) 2006, Rolf Ade Copyright (c) 2001-2006, Pat Thoyts All rights reserved. @@ -11,6 +11,5 @@ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the Visiprise Software, Inc nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 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. - Index: ServerSide.tcl ================================================================== --- ServerSide.tcl +++ ServerSide.tcl @@ -1,8 +1,9 @@ ############################################################################### ## ## -## Copyright (c) 2006-2008, Gerald W. Lester ## +## Copyright (c) 2016-2021, Harald Oehlmann ## +## Copyright (c) 2006-2013, Gerald W. Lester ## ## Copyright (c) 2008, Georgios Petasis ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## Copyright (c) 2006, Colin McCormack ## ## Copyright (c) 2006, Rolf Ade ## ## Copyright (c) 2001-2006, Pat Thoyts ## @@ -36,25 +37,22 @@ ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### +package require Tcl 8.6- package require WS::Utils -#package require Tcl 8.5 -if {![llength [info command dict]]} { - package require dict -} package require html package require log package require tdom -package provide WS::Server 1.4.1 +package provide WS::Server 3.4.0 namespace eval ::WS::Server { - array set serviceArr {} - set procInfo {} - set mode {} + array set ::WS::Server::serviceArr {} + set ::WS::Server::procInfo {} + set ::WS::Server::mode {} } ########################################################################### # @@ -72,12 +70,37 @@ # Returns a WSDL describing the service # /service//op # Invoke an operation # # Arguments : this procedure uses position independent arguments, they are: -# -host - The host name for this service -# Defaults to "localhost" +# -hostcompatibility32 bool - Activate version 3.2.0 compatibility +# mode for -host parameter. +# Defaults to true. +# -host - The host specification within XML namespaces +# of the transmitted XML files. +# This should be unique. +# Defaults to localhost. +# If 3.2 compatibility is activated, the default +# value is changed to ip:port in embedded mode. +# -hostlocation - The host name, which is promoted within the +# generated WSDL file. Defaults to localhost. +# If 3.2 compatibility is activated, the +# default value is equal to the -host parameter. +# -hostlocationserver bool - If true, the host location is set by +# the current server settings. +# In case of httpd server, this value is imported. +# For other servers or if this fails, the value +# is the current ip:port. +# The default value is true. +# In case of 3.2 compatibility, the default +# value is true for tclhttpd, false otherwise. +# -hostprotocol - Define the host protocol (http, https) for the +# WSDL location URL. The special value "server" +# (default) follows the TCP/IP server specification. +# This is implemented for Embedded server and tclhttpd. +# Remark that the protocol for XML namespaces +# is always "http". # -description - The HTML description for this service # -service - The service name (this will also be used for # the Tcl namespace of the procedures that implement # the operations. # -premonitor - This is a command prefix to be called before @@ -88,10 +111,12 @@ # an operation is called. The following arguments are # added to the command prefix: # POST serviceName operationName OK|ERROR results # -inheaders - List of input header types. # -outheaders - List of output header types. +# -intransform - Inbound (request) transform procedure. +# -outtransform - Outbound (reply) transform procedure. # -checkheader - Command prefix to check headers. # If the call is not to be allowed, this command # should raise an error. # The signature of the command must be: # cmd \ @@ -126,10 +151,16 @@ # -traceEnabled - Boolean to enable/disable trace being passed back in exception # Defaults to "Y" # -docFormat - Format of the documentation for operations ("text" or "html"). # Defaults to "text" # -stylesheet - The CSS stylesheet URL used in the HTML documentation +# -errorCallback - Callback to be invoked in the event of an error being produced +# -verifyUserArgs - Boolean to enable/disable validating user supplied arguments +# Defaults to "N" +# -enforceRequired - Throw an error if a required field is not included in the +# response. +# Defaults to "N" # # # Returns : Nothing # # Side-Effects : None @@ -148,116 +179,240 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version -# +# 2.7.0 2020-10-26 H.Oehlmann Embedded server: Do not add port 443 to default url +# 3.0.0 2020-10-30 H.Oehlmann New option -hostProtocol +# 3.2.0 2021-03-17 H.Oehlmann Add HTTP method to embedded registration. +# Change default of -checkheader from +# ::WS::Server::ok to the empty string. +# 3.4.0 2021-10-15 H.Oehlmann Rename option -hostProtocol to -hostprotocol. +# Still accept -hostProtocol. +# The logic on .hostprotocol=server is changed +# to default to http and set an update flag. +# The default value of -host in embedded mode +# is :port. This is critial, if +# the IP changes and thus the XML namespace. +# If the old WSDL with old IP is used, there +# are no input parameters recognized, as the +# XML namespace has changed. +# In consequence, a new parameter set including +# options -host, -hostlocation, -hostlocationserver +# and -hostcompatibility32 is defined as +# described above. # ########################################################################### proc ::WS::Server::Service {args} { variable serviceArr variable procInfo variable mode - ::log::log debug "Defining Service as $args" - - array set defaults { - -host localhost - -description {} - -checkheader {::WS::Server::ok} - -inheaders {} - -outheaders {} - -htmlhead {TclHttpd Based Web Services} - -author {} - -description {} - -mode {tclhttpd} - -ports {80} - -traceEnabled {Y} - -docFormat {text} - -stylesheet {} - } - array set defaults $args - if {[string equal $defaults(-mode) channel]} { - set defaults(-ports) {stdin stdout} - array set defaults $args - } - set requiredList {-host -service} + ::log::logsubst debug {Defining Service as $args} + + set defaults [dict create\ + -checkheader {}\ + -inheaders {}\ + -outheaders {}\ + -intransform {}\ + -outtransform {}\ + -htmlhead {TclHttpd Based Web Services}\ + -author {}\ + -description {}\ + -mode {tclhttpd}\ + -ports {80}\ + -traceEnabled {Y}\ + -docFormat {text}\ + -stylesheet {}\ + -beautifyJson {N}\ + -errorCallback {}\ + -verifyUserArgs {N}\ + -enforceRequired {N}\ + -hostcompatibility32 1] + + set defaults [dict merge $defaults $args] + + # Set default -ports value if mode equal channel + if { [dict get $defaults -mode] eq "channel" && + ! [dict exists $args -ports] } { + dict set defaults -ports {stdin stdout} + } + set requiredList {-service} set missingList {} foreach opt $requiredList { - if {![info exists defaults($opt)]} { + if {![dict exists $defaults $opt]} { lappend missingList $opt } } if {[llength $missingList]} { return \ -code error \ -errorcode [list WSSERVER MISSREQARG $missingList] \ "Missing required arguments '[join $missingList {,}]'" } - set service $defaults(-service) - if {![info exists defaults(-prefix)]} { - set defaults(-prefix) /service/$service + set service [dict get $defaults -service] + if {![dict exists $defaults -prefix]} { + dict set defaults -prefix /service/$service + } + # find default host/host location + if {[dict get $defaults -hostcompatibility32]} { + + ## + ## Version 3.2.x compatibility mode: + ## -host: default value is changed to ip:port in embedded mode. + ## -hostlocation : default value is equal to the -host parameter. + ## -hostlocationserver: default true for tclhttpd, false otherwise. + ## + + if { ! [dict exists $defaults -hostlocationserver]} { + dict set defaults -hostlocationserver [expr { + [dict get $defaults -mode] eq "tclhttpd" }] + } + if {![dict exists $defaults -host]} { + if { [dict get $defaults -mode] eq "embedded" } { + set myHostLocation [MyHostLocationGet [dict get $defaults -ports]] + dict set defaults -host $myHostLocation + # Note: myHostLocation may be reused below + } else { + dict set defaults -host localhost + } + } + if { ! [dict exists $defaults -hostlocation]} { + dict set defaults -hostlocation [dict get $defaults -host] + } + } else { + + ## + ## No Version 3.2.x compatibility mode: + ## -host: defaults to localhost. + ## -hostlocation : defaults to localhost. + ## -hostlocationserver bool: defaults to true. + ## + + set defaults [dict merge \ + [dict create \ + -hostlocation "localhost" \ + -hostlocationserver 1 \ + -host "localhost"] \ + $defaults] + } + # Compatibility has done its work, remove it: + dict unset defaults -hostcompatibility32 + + ## + ## Update host location server to current value if specified + ## + + if { [dict get $defaults -hostlocationserver] } { + if {![info exists myHostLocation]} { + set myHostLocation [MyHostLocationGet [dict get $defaults -ports]] + } + dict set defaults -hostlocation $myHostLocation + } + + ## + ## Resolve -hostprotocol setting. + ## Also accept -hostProtocol + ## + + if {![dict exists $defaults -hostprotocol]} { + if {[dict exists $defaults -hostProtocol]} { + dict set defaults -hostprotocol [dict get $defaults -hostProtocol] + } else { + dict set defaults -hostprotocol server + } + } + dict unset defaults -hostProtocol + + ## + ## Resolve server protocol to http and set flag for server protocol. + ## If the flag is set, the protocol is corrected when required + ## + + dict set defaults hostProtocolServer [expr { + [dict get $defaults -hostprotocol] eq "server"}] + if {[dict get $defaults hostProtocolServer]} { + dict set defaults -hostprotocol http } - set defaults(-uri) $service + + dict set defaults -uri $service namespace eval ::$service {} - set serviceArr($service) [array get defaults] + set serviceArr($service) $defaults if {![dict exists $procInfo $service operationList]} { dict set procInfo $service operationList {} } - set mode $defaults(-mode) + set mode [dict get $defaults -mode] ## ## Install wsdl doc ## interp alias {} ::WS::Server::generateInfo_${service} \ {} ::WS::Server::generateInfo ${service} - ::log::log debug "Installing Generate info for $service at $defaults(-prefix)" + ::log::logsubst debug {Installing Generate info for $service at [dict get $defaults -prefix]} switch -exact -- $mode { embedded { package require WS::Embeded - foreach port $defaults(-ports) { - ::WS::Embeded::AddHandler $port $defaults(-prefix) ::WS::Server::generateInfo_${service} + foreach port [dict get $defaults -ports] { + ::WS::Embeded::AddHandler $port [dict get $defaults -prefix] GET ::WS::Server::generateInfo_${service} } } tclhttpd { - ::Url_PrefixInstall $defaults(-prefix) ::WS::Server::generateInfo_${service} \ + ::Url_PrefixInstall [dict get $defaults -prefix] ::WS::Server::generateInfo_${service} \ -thread 0 } wub { package require WS::Wub } aolserver { - package require WS::AOLserver + package require WS::AOLserver } rivet { package require Rivet } wibble { ## ## Define zone handler - get code from andy ## - proc wibble::webservice {state} { + proc ::wibble::webservice {state} { dict with state options {} - switch $suffix { - "" - \ - / { + switch -exact -- $suffix { + "" - / { ::WS::Server::generateInfo $name 0 response sendresponse $response } /op { ::WS::Server::callOperation $name 0 [dict get $state request] response sendresponse $response } /wsdl { - ::WS::Server::generateWsdl $name 0 response + ::WS::Server::generateWsdl $name 0 -responsename response sendresponse $response } + default { + ## Do nothing + } + } + } + if {[package present Wibble] eq "0.1"} { + proc ::WS::Wibble::ReturnData {responseDictVar type text status} { + upvar 1 $responseDictVar responseDict + dict set responseDict header content-type $type + dict set responseDict content $text + dict set responseDict status $status + } + } else { + proc ::WS::Wibble::ReturnData {responseDictVar type text status} { + upvar 1 $responseDictVar responseDict + dict set responseDict header content-type "" $type + dict set responseDict content $text + dict set responseDict status $status } } - ::wibble::handle $defaults(-prefix) webservice name $service + + ::wibble::handle [dict get $defaults -prefix] webservice name $service } default { return \ - -code error + -code error \ -errorcode [list WSSERVER UNSUPMODE $mode] \ "-mode '$mode' not supported" } } @@ -265,50 +420,73 @@ ## ## Install wsdl ## interp alias {} ::WS::Server::generateWsdl_${service} \ {} ::WS::Server::generateWsdl ${service} - ::log::log debug "Installing GenerateWsdl info for $service at $defaults(-prefix)/wsdl" + ::log::logsubst debug {Installing GenerateWsdl info for $service at [dict get $defaults -prefix]/wsdl} switch -exact -- $mode { embedded { - foreach port $defaults(-ports) { - ::WS::Embeded::AddHandler $port $defaults(-prefix)/wsdl ::WS::Server::generateWsdl_${service} + foreach port [dict get $defaults -ports] { + ::WS::Embeded::AddHandler $port [dict get $defaults -prefix]/wsdl GET ::WS::Server::generateWsdl_${service} } } channel { package require WS::Channel - ::WS::Channel::AddHandler $defaults(-ports) {} ::WS::Server::generateWsdl_${service} + ::WS::Channel::AddHandler [dict get $defaults -ports] {} ::WS::Server::generateWsdl_${service} } tclhttpd { - ::Url_PrefixInstall $defaults(-prefix)/wsdl ::WS::Server::generateWsdl_${service} \ + ::Url_PrefixInstall [dict get $defaults -prefix]/wsdl ::WS::Server::generateWsdl_${service} \ -thread 0 } + default { + ## Do nothing + } } ## ## Install operations ## interp alias {} ::WS::Server::callOperation_${service} \ {} ::WS::Server::callOperation ${service} - ::log::log debug "Installing callOperation info for $service at $defaults(-prefix)/op" + ::log::logsubst debug {Installing callOperation info for $service at [dict get $defaults -prefix]/op} switch -exact -- $mode { embedded { - foreach port $defaults(-ports) { - ::WS::Embeded::AddHandler $port $defaults(-prefix)/op ::WS::Server::callOperation_${service} + foreach port [dict get $defaults -ports] { + ::WS::Embeded::AddHandler $port [dict get $defaults -prefix]/op POST ::WS::Server::callOperation_${service} } } channel { package require WS::Channel - ::WS::Channel::AddHandler $defaults(-ports) {op} ::WS::Server::callOperation_${service} + ::WS::Channel::AddHandler [dict get $defaults -ports] {op} ::WS::Server::callOperation_${service} } tclhttpd { - ::Url_PrefixInstall $defaults(-prefix)/op ::WS::Server::callOperation_${service} \ + ::Url_PrefixInstall [dict get $defaults -prefix]/op ::WS::Server::callOperation_${service} \ -thread 1 } + default { + ## Do nothing + } + } + + return +} + +# Get my computers IP address +proc ::WS::Server::MyHostLocationGet {ports} { + if {[catch { + set me [socket -server garbage_word -myaddr [info hostname] 0] + set myHostLocation [lindex [fconfigure $me -sockname] 0] + close $me + } errorMessage]} { + ::log::logsubst error {Error '$errorMessage' when querying my own IP\ + address. Use 'localhost' instead.} + set myHostLocation "localhost" + } + if { 0 !=[llength $ports] && [lindex $ports 0] ni {80 433} } { + append myHostLocation ":[lindex $ports 0]" } - - return; + return $myHostLocation } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure @@ -321,22 +499,25 @@ # Description : Register an operation for a service and declare the procedure to handle # the operations. # # Arguments : # ServiceName -- Name of the service this operation is for -# NameInfo -- List of three elements: +# NameInfo -- List of four elements: # 1) OperationName -- the name of the operation # 2) ReturnType -- the type of the procedure return, # this can be a simple or complex type # 3) Description -- description of the return method +# 4) Version -- optional version for the service +# if ommitted then available in all versions # Arglist -- List of argument definitions, # each list element must be of the form: # 1) ArgumentName -- the name of the argument # 2) ArgumentTypeInfo -- A list of: -# {type typeName comment commentString} +# {type typeName comment commentString version versionCode} # typeName can be any simple or defined type. # commentString is a quoted string describing the field. +# versionCode is the version which this argument is available for # Documentation -- HTML describing what this operation does # Body -- The tcl code to be called when the operation is invoked. . This # code should return a dictionary with Result as a # key and the operation's result as the value. # @@ -366,13 +547,14 @@ ########################################################################### proc ::WS::Server::ServiceProc {service nameInfo arglist documentation body} { variable procInfo set name [lindex $nameInfo 0] - ::log::log debug "Defining operation $name for $service" + set version [expr {[llength $nameInfo] > 3 ? [lindex $nameInfo 3] : {}}] + ::log::logsubst debug {Defining operation $name for $service} set argOrder {} - ::log::log debug "\targs are {$arglist}" + ::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] @@ -382,16 +564,19 @@ dict set procInfo $service op$name argList $arglist dict set procInfo $service op$name argOrder $argOrder dict set procInfo $service op$name docs $documentation dict set procInfo $service op$name returnInfo [lindex $nameInfo 1] set typeInfo [dict get $procInfo $service op$name returnInfo] - ::WS::Utils::ServiceTypeDef Server $service ${name}Results [list ${name}Result $typeInfo] - ::WS::Utils::ServiceTypeDef Server $service ${name}Request $arglist - set tclArgList {} + dict set procInfo $service op$name version $version + ::WS::Utils::ServiceTypeDef Server $service ${name}Results [list ${name}Result $typeInfo] {} {} $version + ::WS::Utils::ServiceTypeDef Server $service ${name}Request $arglist {} {} $version + set tclArgList [list] foreach {arg typeinfo} $arglist { - lappend tclArgList [lindex $arg 0] + lappend tclArgList [list [lindex $arg 0] ""] } + lappend tclArgList [list tclws_op_version ""] + proc ::${service}::${name} $tclArgList $body } ########################################################################### @@ -406,10 +591,12 @@ # Description : Generates a WSDL for a registered service. # # Arguments : # serviceName - The name of the service # urlPrefix - (optional) Prefix to use for location; defaults to http:// +# version - (optional) specific version of service to generate. If ommitted +# then returns the lastest # # Returns : # XML for the WSDL # # Side-Effects : None @@ -429,152 +616,165 @@ # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # 2 12/12/2009 W.Kocjan Support for services over SSL in Tclhttpd +# 3 11/13/2018 J.Cone Version support +# 2.7.0 2020-10-26 H.Oehlmann urlPrefix is a mandatory parameter. +# The caller has to think about it. +# 3.3.0 2021-10-15 H.Oehlmann Build default location from options +# -hostprotocol and -hostlocation replacing +# http and option -host. # # ########################################################################### -proc ::WS::Server::GetWsdl {serviceName {urlPrefix ""}} { +proc ::WS::Server::GetWsdl {serviceName {urlPrefix ""} {version {}}} { variable serviceArr variable procInfo - array set serviceData $serviceArr($serviceName) + set serviceData $serviceArr($serviceName) - set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]] - ::log::log debug "Generating WSDL for $serviceName" + set operList {} + foreach oper [lsort -dictionary [dict get $procInfo $serviceName operationList]] { + if {$version ne {} && [dict exists $procInfo $serviceName op$oper version] + && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$oper version] $version]} { + continue + } + lappend operList $oper + } + ::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 } set msg {} - set reply [::dom createDocument definitions] + set reply [::dom createDocument wsdl:definitions] $reply documentElement definition $definition setAttribute \ - xmlns "http://schemas.xmlsoap.org/wsdl/" \ + xmlns:wsdl "http://schemas.xmlsoap.org/wsdl/" \ xmlns:http "http://schemas.xmlsoap.org/wsdl/http/" \ xmlns:mime "http://schemas.xmlsoap.org/wsdl/mime/" \ - xmlns:s "http://www.w3.org/2001/XMLSchema" \ + xmlns:xs "http://www.w3.org/2001/XMLSchema" \ xmlns:soap "http://schemas.xmlsoap.org/wsdl/soap/" \ xmlns:soapenc "http://schemas.xmlsoap.org/soap/encoding/" \ - xmlns:${serviceName} "http://$serviceData(-host)$serviceData(-prefix)" \ - targetNamespace "http://$serviceData(-host)$serviceData(-prefix)" + xmlns:${serviceName} "http://[dict get $serviceData -host][dict get $serviceData -prefix]" \ + targetNamespace "http://[dict get $serviceData -host][dict get $serviceData -prefix]" foreach topLevel {types} { - $definition appendChild [$reply createElement $topLevel $topLevel] + $definition appendChild [$reply createElement wsdl:$topLevel $topLevel] } ## ## Messages ## ## Operations foreach oper $operList { - $definition appendChild [$reply createElement message input] + $definition appendChild [$reply createElement wsdl:message input] $input setAttribute name ${oper}In - $input appendChild [$reply createElement part part] + $input appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${oper}Request - $definition appendChild [$reply createElement message output] + $definition appendChild [$reply createElement wsdl:message output] $output setAttribute name ${oper}Out - $output appendChild [$reply createElement part part] + $output appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${oper}Results } ## Input headers - foreach headerType $serviceData(-inheaders) { - $definition appendChild [$reply createElement message header] + foreach headerType [dict get $serviceData -inheaders] { + $definition appendChild [$reply createElement wsdl:message header] $header setAttribute name $headerType - $header appendChild [$reply createElement part part] + $header appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${headerType} } ## Output headers - foreach headerType $serviceData(-outheaders) { - $definition appendChild [$reply createElement message header] + foreach headerType [dict get $serviceData -outheaders] { + $definition appendChild [$reply createElement wsdl:message header] $header setAttribute name $headerType - $header appendChild [$reply createElement part part] + $header appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${headerType} } ## ## Add the rest of the toplevels in ## foreach topLevel {portType binding service} { - $definition appendChild [$reply createElement $topLevel $topLevel] + $definition appendChild [$reply createElement wsdl:$topLevel $topLevel] } ## ## Service ## $service setAttribute name $serviceName - $service appendChild [$reply createElement documentation documentation] - $documentation appendChild [$reply createTextNode $serviceData(-description)] + $service appendChild [$reply createElement wsdl:documentation documentation] + $documentation appendChild [$reply createTextNode [dict get $serviceData -description]] - $service appendChild [$reply createElement port port] + $service appendChild [$reply createElement wsdl:port port] $port setAttribute \ name ${serviceName}Soap \ binding ${serviceName}:${serviceName}Soap $port appendChild [$reply createElement soap:address address] if {$urlPrefix == ""} { - set urlPrefix "http://$serviceData(-host)" + set urlPrefix "[dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation]" } - $address setAttribute \ - location "$urlPrefix$serviceData(-prefix)/op" + $address setAttribute \ + location "$urlPrefix[dict get $serviceData -prefix]/op" ## ## Bindings ## $binding setAttribute \ name ${serviceName}Soap \ type ${serviceName}:${serviceName}Soap $binding appendChild [$reply createElement soap:binding b2] - $b2 setAttribute\ + $b2 setAttribute \ style document \ transport "http://schemas.xmlsoap.org/soap/http" foreach oper $operList { - $binding appendChild [$reply createElement operation operNode] + $binding appendChild [$reply createElement wsdl:operation operNode] $operNode setAttribute name $oper $operNode appendChild [$reply createElement soap:operation o2] $o2 setAttribute \ soapAction $serviceName:$oper \ style document ## Input message - $operNode appendChild [$reply createElement input input] + $operNode appendChild [$reply createElement wsdl:input input] $input appendChild [$reply createElement soap:body tmp] $tmp setAttribute use literal - foreach headerType $serviceData(-inheaders) { - $operNode appendChild [$reply createElement header header] + foreach headerType [dict get $serviceData -inheaders] { + $operNode appendChild [$reply createElement wsdl:header header] $header appendChild [$reply createElement soap:header tmp] $tmp setAttribute \ use literal \ message ${serviceName}:${headerType} \ part $headerType } ## Output message - $operNode appendChild [$reply createElement output output] + $operNode appendChild [$reply createElement wsdl:output output] $output appendChild [$reply createElement soap:body tmp] $tmp setAttribute use literal - foreach headerType $serviceData(-outheaders) { - $operNode appendChild [$reply createElement header header] + foreach headerType [dict get $serviceData -outheaders] { + $operNode appendChild [$reply createElement wsdl:header header] $header appendChild [$reply createElement soap:header tmp] $tmp setAttribute \ use literal \ message ${serviceName}:${headerType} \ part $headerType @@ -584,22 +784,22 @@ ## ## Ports ## $portType setAttribute name ${serviceName}Soap foreach oper $operList { - $portType appendChild [$reply createElement operation operNode] + $portType appendChild [$reply createElement wsdl:operation operNode] $operNode setAttribute name $oper - $operNode appendChild [$reply createElement input input] + $operNode appendChild [$reply createElement wsdl:input input] $input setAttribute message ${serviceName}:${oper}In - $operNode appendChild [$reply createElement output output] + $operNode appendChild [$reply createElement wsdl:output output] $output setAttribute message ${serviceName}:${oper}Out } ## ## Types ## - GenerateScheme Server $serviceName $reply $types + GenerateScheme Server $serviceName $reply $types $version append msg \ {} \ "\n" \ [$reply asXML \ @@ -624,15 +824,18 @@ # Description : Generates a WSDL for a registered service. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on -# args - not used +# args - Multi-function depending on server: +# embedded: -port number: embedded server port number +# unknown server: -version number: version +# wibble: -responsename name: response variable name # # Returns : -# 1 - On error -# 0 - On success +# Embedded mode: return list of contentType, message, httpcode +# Other modes: 1 - On error, 0 - On success # # Side-Effects : None # # Exception Conditions : None # @@ -648,22 +851,38 @@ # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # 2 12/12/2009 W.Kocjan Support for services over SSL in Tclhttpd -# +# 3 11/13/2018 J.Cone Version support +# 2.7.0 2020-10-26 H.Oehlmann Support https for embedded server. +# 3.1.0 2020-11-06 H.Oehlmann Pass port parameter from embedded server +# with prefix "-port" to be compatible with +# the -version parameter. +# Pass wibble responsename also with prefix +# "-responsename". +# 3.2.0 2021-03-17 H.Oehlmann In embedded mode, directly return the data +# 3.3.0 2021-10-15 H.Oehlmann Change the setting/update of the host location +# by using the new parameter -hostlocationserver +# and -hostlocation. # ########################################################################### proc ::WS::Server::generateWsdl {serviceName sock args} { variable serviceArr variable procInfo variable mode - array set serviceData $serviceArr($serviceName) - set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]] - ::log::log debug "Generating WSDL for $serviceName on $sock with {$args}" + ::log::logsubst debug {Generating WSDL for $serviceName on $sock with {$args}} + # ToDo HaO 2020-11-06: if confirmed, args may be interpreted as a dict + # and the code may be simplified. It is not clear, if any server does not + # pass any unused data not being a dict. + set version "" + set argsIdx [lsearch -exact $args "-version"] + if {$argsIdx != -1} { + set version [lindex $args [expr {$argsIdx + 1}]] + } if {![info exists serviceArr($serviceName)]} { set msg "Unknown service '$serviceName'" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData \ @@ -671,83 +890,132 @@ "text/html; charset=UTF-8" \ "Webservice Error

$msg

" \ 404 } embedded { - ::WS::Embeded::ReturnData \ - $sock \ - text/html \ + return [list\ + "text/html; charset=UTF-8" \ "Webservice Error

$msg

" \ - 404 + 404] } channel { ::WS::Channel::ReturnData \ $sock \ - text/html \ + "text/xml; charset=UTF-8" \ "Webservice Error

$msg

" \ 404 } rivet { - headers type text/html + headers type "text/html; charset=UTF-8" headers numeric 404 puts "Webservice Error

$msg

" } - aolserver { + aolserver { ::WS::AOLserver::ReturnData \ $sock \ text/html \ "Webservice Error

$msg

" \ 404 } wibble { upvar 1 [lindex $args 0] responseDict - dict set responseDict header content-type text/html - dict set responseDict status 404 - dict set responseDict content "Webservice Error

$msg

" + ::WS::Wibble::ReturnData responseDict text/html "Webservice Error

$msg

" 404 + } + default { + ## Do nothing } } return 1 } + set serviceData $serviceArr($serviceName) + + ## + ## Check if the server protocol (and host) should be used + ## + + ## + ## Prepare default URL prefix + ## + + set urlPrefix "[dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation]" + + ## + ## Return the WSDL + ## switch -exact -- $mode { tclhttpd { upvar #0 ::Httpd$sock s - - set urlPrefix "" - catch { - set urlPrefix [lindex $s(self) 0]://$serviceData(-host) - set urlPrefix [lindex $s(self) 0]://$s(mime,host) + # Get protocol and host location from server if configured + if { [dict get $serviceData hostProtocolServer] } { + catch { + dict set serviceData -hostprotocol [lindex $s(self) 0] + } + } + if { [dict get $serviceData -hostlocationserver] } { + catch { + dict set serviceData -hostprotocol $s(mime,host) + } } - set xml [GetWsdl $serviceName $urlPrefix] + set urlPrefix [dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation] + set xml [GetWsdl $serviceName $urlPrefix $version] ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } channel { - set xml [GetWsdl $serviceName] - ::WS::Channel::ReturnData $sock text/xml $xml 200 + set xml [GetWsdl $serviceName $urlPrefix $version] + ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } embedded { - set xml [GetWsdl $serviceName] - ::WS::Embeded::ReturnData $sock text/xml $xml 200 + if {[dict get $serviceData hostProtocolServer]} { + + ## + ## For https, change the URL prefix + ## + + set argsIdx [lsearch -exact $args "-port"] + if {$argsIdx == -1} { + ::log::logsubst error {Parameter '-port' missing from\ + embedded server in arguments '$args'} + } elseif { [::WS::Embeded::GetValue isHTTPS\ + [lindex $args [expr {$argsIdx + 1}]]] + } { + dict set serviceData -hostprotocol https + } else { + dict set serviceData -hostprotocol http + } + set urlPrefix "[dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation]" + } + set xml [GetWsdl $serviceName $urlPrefix $version] + return [list "text/xml; charset=UTF-8" $xml 200] } rivet { - set xml [GetWsdl $serviceName] - headers type text/xml + set xml [GetWsdl $serviceName $urlPrefix $version] + headers type "text/xml; charset=UTF-8" headers numeric 200 puts $xml } aolserver { - set xml [GetWsdl $serviceName] + set xml [GetWsdl $serviceName $urlPrefix $version] ::WS::AOLserver::ReturnData $sock text/xml $xml 200 } wibble { - upvar 1 [lindex $args 0] responseDict - dict set responseDict header content-type text/xml - dict set responseDict status 200 - dict set responseDict content $xml + set xml [GetWsdl $serviceName $urlPrefix $version] + set argsIdx [lsearch -exact $args "-responsename"] + if {$argsIdx == -1} { + ::log::logsubst error {Parameter '-responsename' missing from\ + wibble server in arguments '$args'} + } else { + upvar 1 [lindex $args [expr {$argsIdx + 1}]] responseDict + ::WS::Wibble::ReturnData responseDict text/xml $xml 200 + } + } + default { + ## Do nothing } } + return 0 } ########################################################################### # @@ -763,10 +1031,11 @@ # Arguments : # mode - Client/Server # serviceName - The service name # doc - The document to add the scheme to # parent - The parent node of the scheme +# version - Service version # # Returns : nothing # # Side-Effects : None # @@ -784,20 +1053,212 @@ # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 02/15/2008 G.Lester Made Scheme generation a utility # 2 02/03/2008 G.Lester Moved scheme generation into WS::Utils namespace +# 3 11/13/2018 J.Cone Version support +# +########################################################################### +proc ::WS::Server::GenerateScheme {mode serviceName doc parent {version {}}} { + variable serviceArr + + set serviceData $serviceArr($serviceName) + set targetNamespace "http://[dict get $serviceData -host][dict get $serviceData -prefix]" + return [::WS::Utils::GenerateScheme $mode $serviceName $doc $parent $targetNamespace $version] + +} + + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Server::generateJsonInfo +# +# Description : Generate an json description of the service, the operations +# and all applicable type definitions. +# +# Arguments : +# serviceName - The name of the service +# sock - The socket to return the WSDL on +# args - supports passing service version info. +# Eg: -version 3 +# +# Returns : +# 1 - On error +# 0 - On success +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : James Sulak +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 05/16/2012 J.Sulak Initial version +# 2 09/04/2018 A.Brooks Send an 'example' field +# 3 11/13/2018 J.Cone Version support +# # ########################################################################### -proc ::WS::Server::GenerateScheme {mode serviceName doc parent} { +# NOTE: This proc only works with Rivet +# TODO: Update to handle jsonp? +proc ::WS::Server::generateJsonInfo { serviceName sock args } { variable serviceArr + variable procInfo - array set serviceData $serviceArr($serviceName) - set targetNamespace "http://$serviceData(-host)$serviceData(-prefix)" - return [::WS::Utils::GenerateScheme $mode $serviceName $doc $parent $targetNamespace] + ::log::logsubst debug {Generating JSON Documentation for $serviceName on $sock with {$args}} + set version {} + set versionIdx [lsearch -exact $args "-version"] + if {$versionIdx != -1} { + set version [lindex $args [expr {$versionIdx + 1}]] + } + set serviceData $serviceArr($serviceName) + set doc [yajl create #auto -beautify [dict get $serviceData -beautifyJson]] + $doc map_open + + $doc string operations array_open + ::log::log debug "\tDisplay Operations (json)" + + foreach oper [lsort -dictionary [dict get $procInfo $serviceName operationList]] { + # version check + if {$version ne {} && [dict exists $procInfo $serviceName op$oper version] + && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$oper version] $version]} { + continue + } + + $doc map_open + + # operation name + $doc string name string $oper + + # description + set description [dict get $procInfo $serviceName op$oper docs] + $doc string description string $description + + # parameters + if {[llength [dict get $procInfo $serviceName op$oper argOrder]]} { + $doc string inputs array_open + + foreach arg [dict get $procInfo $serviceName op$oper argOrder] { + # version check + if {$version ne {} && [dict exists $procInfo $serviceName op$oper argList $arg version] + && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$oper argList $arg version] $version]} { + continue + } + ::log::logsubst debug {\t\t\tDisplaying '$arg'} + set comment {} + if {[dict exists $procInfo $serviceName op$oper argList $arg comment]} { + set comment [dict get $procInfo $serviceName op$oper argList $arg comment] + } + set example {} + if {[dict exists $procInfo $serviceName op$oper argList $arg example]} { + set example [dict get $procInfo $serviceName op$oper argList $arg example] + } + set type [dict get $procInfo $serviceName op$oper argList $arg type] + + $doc map_open \ + string name string $arg \ + string type string $type \ + string comment string $comment \ + string example string $example \ + map_close + } + + $doc array_close + } else { + $doc string inputs array_open array_close + } + + $doc string returns map_open + set comment {} + if {[dict exists $procInfo $serviceName op$oper returnInfo comment]} { + set comment [dict get $procInfo $serviceName op$oper returnInfo comment] + } + set example {} + if {[dict exists $procInfo $serviceName op$oper returnInfo example]} { + set example [dict get $procInfo $serviceName op$oper returnInfo example] + } + + set type [dict get $procInfo $serviceName op$oper returnInfo type] + + $doc string comment string $comment string type string $type string example string $example + $doc map_close + + $doc map_close + } + + $doc array_close + + ::log::log debug "\tDisplay custom types" + $doc string types array_open + set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $serviceName] + foreach type [lsort -dictionary [dict keys $localTypeInfo]] { + # version check + if {$version ne {} && [dict exists $localTypeInfo $type version] + && ![::WS::Utils::check_version [dict get $localTypeInfo $type version] $version]} { + continue + } + ::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]] { + # version check + if {$version ne {} && [dict exists $typeDetails $part version] + && ![::WS::Utils::check_version [dict get $typeDetails $part version] $version]} { + continue + } + ::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] + } + set example {} + if {[dict exists $typeDetails $part example]} { + set example [dict get $typeDetails $part example] + } + $doc map_open \ + string field string $part \ + string type string $subType \ + string comment string $comment \ + string example string $example \ + map_close + } + + $doc array_close + $doc map_close + } + + $doc array_close + + $doc map_close + + set contentType "application/json; charset=UTF-8" + headers type $contentType + headers numeric 200 + puts [$doc get] + $doc delete } + ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. @@ -810,15 +1271,16 @@ # and all applicable type definitions. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on -# args - not used +# args - Supports passing a wibble dictionary ref or a +# service version. Eg: -version 3 # # Returns : -# 1 - On error -# 0 - On success +# Embedded mode: return list of contentType, message, httpcode +# Other modes: 1 - On error, 0 - On success # # Side-Effects : None # # Exception Conditions : None # @@ -833,35 +1295,42 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2 11/13/2018 J.Cone Version support +# 3.2.0 2021-03-17 H.Oehlmann In embedded mode, directly return the data # # ########################################################################### -proc ::WS::Server::generateInfo {service sock args} { +proc ::WS::Server::generateInfo {serviceName sock args} { variable serviceArr variable procInfo variable mode - ::log::log debug "Generating HTML Documentation for $service on $sock with {$args}" - if {![info exists serviceArr($service)]} { - set msg "Unknown service '$service'" + ::log::logsubst debug {Generating HTML Documentation for $serviceName on $sock with {$args}} + set version {} + if {$args ne {}} { + if {[lindex $args 0] eq {-version}} { + set version [lindex $args 1] + } + } + if {![info exists serviceArr($serviceName)]} { + set msg "Unknown service '$serviceName'" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData \ $sock \ "text/html; charset=UTF-8" \ "Webservice Error

$msg

" \ 404 } embedded { - ::WS::Embeded::ReturnData \ - $sock \ - text/html \ - "Webservice Error

$msg

" \ - 404 + return [list\ + "text/html; charset=UTF-8" \ + "Webservice Error

$msg

" \ + 404] } channel { ::WS::Channel::ReturnData \ $sock \ text/html \ @@ -880,13 +1349,17 @@ "Webservice Error

$msg

" \ 404 } wibble { upvar 1 [lindex $args 0] responseDict - dict set responseDict header content-type text/html - dict set responseDict status 404 - dict set responseDict content "Webservice Error

$msg

" + ::WS::Wibble::ReturnData responseDict \ + text/html \ + "Webservice Error

$msg

" \ + 404 + } + default { + ## Do nothing } } return 1 } @@ -898,34 +1371,34 @@ } ## ## Display Service General Information ## - append msg [generateGeneralInfo $serviceArr($service) $menuList] + append msg [generateGeneralInfo $serviceArr($serviceName) $menuList] ## ## Display TOC ## - append msg [generateTocInfo $serviceArr($service) $menuList] + append msg [generateTocInfo $serviceArr($serviceName) $menuList $version] ## ## Display Operations ## ::log::log debug "\tDisplay Operations" - append msg [generateOperationInfo $serviceArr($service) $menuList] + append msg [generateOperationInfo $serviceArr($serviceName) $menuList $version] ## ## Display custom types ## ::log::log debug "\tDisplay custom types" - append msg [generateCustomTypeInfo $serviceArr($service) $menuList] + append msg [generateCustomTypeInfo $serviceArr($serviceName) $menuList $version] ## ## Display list of simple types ## ::log::log debug "\tDisplay list of simply types" - append msg [generateSimpleTypeInfo $serviceArr($service) $menuList] + append msg [generateSimpleTypeInfo $serviceArr($serviceName) $menuList] ## ## All Done ## append msg [::html::end] @@ -932,31 +1405,32 @@ switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "text/html; charset=UTF-8" $msg 200 } embedded { - ::WS::Embeded::ReturnData $sock text/html $msg 200 + return [list "text/html; charset=UTF-8" $msg 200] } channel { - ::WS::Channel::ReturnData $sock text/html $msg 200 + ::WS::Channel::ReturnData $sock "text/html; charset=UTF-8" $msg 200 } rivet { headers numeric 200 - headers type text/html + headers type "text/html; charset=UTF-8" puts $msg } aolserver { ::WS::AOLserver::ReturnData $sock text/html $msg 200 } wibble { upvar 1 [lindex $args 0] responseDict - dict set responseDict header content-type text/html - dict set responseDict status 200 - dict set responseDict content $msg + ::WS::Wibble::ReturnData responseDict text/html $msg 200 + } + default { + ## Do nothing } } - + return 0 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -993,11 +1467,11 @@ # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::displayType {serviceName type} { - set testType [string trimright $type {()}] + set testType [string trimright $type {()?}] if {([lindex [::WS::Utils::TypeInfo Server $serviceName $testType] 0] == 0) && ([info exists ::WS::Utils::simpleTypes($testType)])} { set result $type } else { set result [format {%2$s} $testType $type] @@ -1019,15 +1493,22 @@ # is sent. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on -# args - not used +# -rest - Use Rest flavor call instead of SOAP +# -version - specify service version +# args - additional arguments and flags: +# -rest: choose rest flavor instead soap +# -version num: choose a version number +# -data dict: data dict in embedded mode. +# Used keys are: query, ipaddr, headers. +# first element: response dict name in wibble mode # # Returns : -# 1 - On error -# 0 - On success +# Embedded mode: return list of contentType, message, httpcode +# Other modes: 1 - On error, 0 - On success # # Side-Effects : None # # Exception Conditions : None # @@ -1042,108 +1523,188 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2 11/13/2018 J.Cone Version support +# 3.1.0 2020-11-06 H.Oehlmann Get global validHttpStatusCodes in this +# module, was deleted in Utilities.tcl. +# 3.2.0 2021-03-17 H.Oehlmann Embedded mode: directly return data. +# Embedded mode: directly receive data via +# argument -data dict. +# The result return is not protected any more +# by a catch to allow direct return. # # ########################################################################### -proc ::WS::Server::callOperation {service sock args} { +proc ::WS::Server::callOperation {serviceName sock args} { variable procInfo variable serviceArr variable mode - switch -exact $mode { + switch -exact -- $mode { + embedded { + # Get the data dict as argument behind call flag "-data" + set embeddedServerDataDict [lindex $args\ + [lsearch -exact $args "-data"]+1] + set inXML [dict get $embeddedServerDataDict query] + } wibble { set requestDict [lindex $args 0] upvar 1 [lindex $args 1] responseDict - set inXml [dict get $requestDict post xml ""] + set inXML [dict get $requestDict post xml ""] } default { upvar #0 Httpd$sock data set inXML $data(query) } } - ::log::log debug "In ::WS::Server::callOperation {$service $sock $args}" - array set serviceInfo $serviceArr($service) - ::log::log debug "\tDocument is {$inXML}" + # decide if SOAP or REST mode should be used. + set flavor "soap" + if {[lsearch -exact $args "-rest"] != -1} { + set flavor "rest" + } + + # check if a version number was passed + set version {} + set versionIdx [lsearch -exact $args "-version"] + if {$versionIdx != -1} { + set version [lindex $args [expr {$versionIdx + 1}]] + } + + ::log::logsubst debug {In ::WS::Server::callOperation {$serviceName $sock $args}} + set serviceData $serviceArr($serviceName) + ::log::logsubst debug {\tDocument is {$inXML}} set ::errorInfo {} set ::errorCode {} - set ns $service - dom parse $inXML doc - $doc documentElement top - ::log::log debug [list $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 - - - ## - ## Determine the name of the method being invoked. - ## - 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::log debug "requestMessage = {$requestMessage}" - 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 - } - - - ## - ## Check that the method exists. - ## - if {![dict exists $procInfo $service op$operation argList]} { + set ns $serviceName + + set inTransform [dict get $serviceData -intransform] + set outTransform [dict get $serviceData -outtransform] + if {$inTransform ne {}} { + set inXML [$inTransform REQUEST $inXML] + } + + # Get a reference to the error callback + set errorCallback [dict get $serviceData -errorCallback] + + ## + ## Parse the input and determine the name of the method being invoked. + ## + switch -exact -- $flavor { + rest { + package require yajltcl ; # only needed for rest, not soap. + + set operation [lindex $inXML 0] + set contentType "application/json" + set doc "" + + array set rawargs [lindex $inXML 1] + if {[info exists rawargs(jsonp_callback)]} { + if {![regexp {^[a-zA-Z_0-9]+$} $rawargs(jsonp_callback)]} { + # sanitize the JSONP callback function name for security. + set rawargs(jsonp_callback) JsonpCallback + } + set contentType "text/javascript" + } + } + soap { + # skip any XML header + 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/ \ + $serviceName http://[dict get $serviceData -host][dict get $serviceData -prefix]]} + $doc selectNodesNamespaces \ + [list ENV http://schemas.xmlsoap.org/soap/envelope/ \ + $serviceName http://[dict get $serviceData -host][dict get $serviceData -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" + } + } + + ## + ## Check that the method exists and version checks out. + ## + if {![dict exists $procInfo $serviceName op$operation argList] || + ([dict exists $procInfo $serviceName op$operation version] && + ![::WS::Utils::check_version [dict get $procInfo $serviceName op$operation version] $version])} { set msg "Method $operation not found" ::log::log error $msg set ::errorInfo {} set ::errorCode [list Server UNKNOWN_METHOD $operation] - set xml [generateError \ - $serviceInfo(-traceEnabled) \ + set response [generateError \ + [dict get $serviceData -traceEnabled] \ CLIENT \ $msg \ - [list "errorCode" $::errorCode "stackTrace" $::errorInfo]] + [list "errorCode" $::errorCode "stackTrace" $::errorInfo] \ + $flavor] catch {$doc delete} - ::log::log debug "Leaving @ error 1::WS::Server::callOperation $xml" + 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 { tclhttpd { - ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 500 + ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } embedded { - ::WS::Embeded::ReturnData $sock text/xml $xml 500 + return [list "$contentType; charset=UTF-8" $response $httpStatus] } rivet { - headers type text/xml - headers numeric 500 - puts $xml + headers type "$contentType; charset=UTF-8" + headers numeric $httpStatus + puts $response } aolserver { - ::WS::AOLserver::ReturnData $sock text/xml $xml 500 + ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } wibble { - dict set responseDict header content-type text/xml - dict set responseDict status 500 - dict set responseDict content $xml + ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus + } + default { + ## Do nothing } } - return; + return 1 } set baseName $operation set cmdName op$baseName set methodName "${ns}::$baseName" @@ -1150,240 +1711,383 @@ ## ## Parse the arguments for the method. ## set argInfo [dict get $procInfo $ns $cmdName argList] if {[catch { - foreach pass [list 1 2 3] { - set tclArgList {} - set gotAnyArgs 0 - set argIndex 0 - foreach argName [dict get $procInfo $ns $cmdName argOrder] { - set argType [string trim [dict get $argInfo $argName type]] - set typeInfoList [::WS::Utils::TypeInfo Server $service $argType] - if {$pass == 1} { - # access arguments by name using full namespace - set path $service:$argName - set node [$top selectNodes $path] - } elseif {$pass == 2} { - # legacyRpcMode only, access arguments by unqualified name - set path $argName - set node [$top selectNodes $path] - } 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::log debug "did not find argument for $argName using $path, leaving blank" - lappend tclArgList {} - continue - } - ::log::log debug "found argument $argName using $path, processing $node" - set gotAnyArgs 1 - switch $typeInfoList { - {0 0} { - ## - ## Simple non-array - ## - lappend tclArgList [$node asText] - } - {0 1} { - ## - ## Simple array - ## - set tmp {} - foreach row $node { - lappend tmp [$row asText] - } - lappend tclArgList $tmp - } - {1 0} { - ## - ## Non-simple non-array - ## - lappend tclArgList [::WS::Utils::convertTypeToDict Server $service $node $argType $top] - } - {1 1} { - ## - ## Non-simple array - ## - set tmp {} - set argType [string trimright $argType {()}] - foreach row $node { - lappend tmp [::WS::Utils::convertTypeToDict Server $service $row $argType $top] - } - lappend tclArgList $tmp - } - } - } - ::log::log debug "gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode" - if {$gotAnyArgs || !$legacyRpcMode} break - } - ::log::log debug "finalargs $tclArgList" + # Check that all supplied arguments are valid + set methodArgs {} + foreach arg [dict get $procInfo $ns $cmdName argOrder] { + lappend methodArgs $arg + } + if {$flavor eq "rest"} { + lappend methodArgs jsonp_callback "_" + } + if {[dict get $serviceData -verifyUserArgs]} { + foreach {key value} [array get rawargs] { + if {[lsearch -exact $methodArgs $key] == -1} { + error "Invalid argument '$key' supplied" + } + } + } + switch -exact -- $flavor { + rest { + set tclArgList {} + foreach argName $methodArgs { + if {$argName eq "jsonp_callback" || $argName eq "_"} { + continue + } + set argType [string trim [dict get $argInfo $argName type]] + set typeInfoList [::WS::Utils::TypeInfo Server $serviceName $argType] + + if {[dict exists $procInfo $ns $cmdName argList $argName version] && + ![::WS::Utils::check_version [dict get $procInfo $ns $cmdName argList $argName version] $version]} { + ::log::log debug "user supplied argument not supported in the requested version" + lappend tclArgList {} + continue + } + 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 + lappend tclArgList $rawargs($argName) + } + {0 1} { + ## Simple array + lappend tclArgList $rawargs($argName) + } + {1 0} { + ## Non-simple non-array + error "TODO JSON" + #lappend tclArgList [::WS::Utils::convertTypeToDict Server $serviceName $node $argType $top] + } + {1 1} { + ## Non-simple array + error "TODO JSON" + #set tmp {} + #set argType [string trimright $argType {()?}] + #foreach row $node { + # lappend tmp [::WS::Utils::convertTypeToDict Server $serviceName $row $argType $top] + #} + #lappend tclArgList $tmp + } + default { + ## Do nothing + } + } + + } + } + soap { + foreach pass [list 1 2 3] { + set tclArgList {} + set gotAnyArgs 0 + set argIndex 0 + foreach argName $methodArgs { + set argType [string trim [dict get $argInfo $argName type]] + set typeInfoList [::WS::Utils::TypeInfo Server $serviceName $argType] + if {$pass == 1} { + # access arguments by name using full namespace + set path $serviceName:$argName + set node [$top selectNodes $path] + } elseif {$pass == 2} { + # legacyRpcMode only, access arguments by unqualified name + set path $argName + set node [$top selectNodes $path] + } else { + # legacyRpcMode only, access arguments by index + set path "legacy argument index $argIndex" + set node [lindex [$top childNodes] $argIndex] + incr argIndex + } + if {[dict exists $procInfo $ns $cmdName argList $argName version] && + ![::WS::Utils::check_version [dict get $procInfo $ns $cmdName argList $argName version] $version]} { + ::log::log debug "user supplied argument not supported in the requested version" + lappend tclArgList {} + continue + } + 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} { + ## Simple array + set tmp {} + foreach row $node { + lappend tmp [$row asText] + } + lappend tclArgList $tmp + } + {1 0} { + ## Non-simple non-array + set argType [string trimright $argType {?}] + lappend tclArgList [::WS::Utils::convertTypeToDict Server $serviceName $node $argType $top] + } + {1 1} { + ## Non-simple array + set tmp {} + set argType [string trimright $argType {()?}] + foreach row $node { + lappend tmp [::WS::Utils::convertTypeToDict Server $serviceName $row $argType $top] + } + 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" + } + } + # If the user passed a version, pass that along + if {$version ne {}} { + lappend tclArgList $version + } + + ::log::logsubst debug {finalargs $tclArgList} } errMsg]} { ::log::log error $errMsg set localerrorCode $::errorCode set localerrorInfo $::errorInfo - set xml [generateError \ - $serviceInfo(-traceEnabled) \ + set response [generateError \ + [dict get $serviceData -traceEnabled] \ CLIENT \ "Error Parsing Arguments -- $errMsg" \ - [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo]] + [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \ + $flavor] catch {$doc delete} - ::log::log debug "Leaving @ error 3::WS::Server::callOperation $xml" + 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 { tclhttpd { - ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 500 + ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } embedded { - ::WS::Embeded::ReturnData $sock text/xml $xml 500 + return [list "$contentType; charset=UTF-8" $response $httpStatus] } channel { - ::WS::Channel::ReturnData $sock text/xml $xml 500 + ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } rivet { - headers type text/xml - headers numeric 500 - puts $xml + headers type "$contentType; charset=UTF-8" + headers numeric $httpStatus + puts $response } aolserver { - ::WS::AOLserver::ReturnData $sock text/xml $xml 500 + ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } wibble { - dict set responseDict header content-type text/xml - dict set responseDict status 500 - dict set responseDict content $xml + ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus + } + default { + ## Do nothing } } - return; + return 1 } ## ## Run the premonitor hook, if necessary. ## - if {[info exists serviceInfo(-premonitor)] && [string length $serviceInfo(-premonitor)]} { - set precmd $serviceInfo(-premonitor) - lappend precmd PRE $service $operation $tclArgList + if {[dict exists $serviceData -premonitor] && "" ne [dict get $serviceData -premonitor]} { + set precmd [dict get $serviceData -premonitor] + lappend precmd PRE $serviceName $operation $tclArgList catch $precmd } ## ## Convert the HTTP request headers. ## set headerList {} - foreach headerType $serviceInfo(-inheaders) { + foreach headerType [dict get $serviceData -inheaders] { if {[string equal $headerType {}]} { continue } foreach node [$top selectNodes data:$headerType] { - lappend headerList [::WS::Utils::convertTypeToDict Server $service $node $headerType $top] + lappend headerList [::WS::Utils::convertTypeToDict Server $serviceName $node $headerType $top] } } ## ## Actually execute the method. ## if {[catch { - set cmd $serviceInfo(-checkheader) - switch -exact -- $mode { - wibble { - lappend cmd \ - $ns \ - $baseName \ - [dict get $requestDict peerhost] \ - [dict keys [dict get $requestDict header]] \ - $headerList - } - default { - lappend cmd $ns $baseName $data(ipaddr) $data(headerlist) $headerList - } - } - eval $cmd + set cmd [dict get $serviceData -checkheader] + if {$cmd ne ""} { + switch -exact -- $mode { + wibble { + lappend cmd \ + $ns \ + $baseName \ + [dict get $requestDict peerhost] \ + [dict keys [dict get $requestDict header]] \ + $headerList + } + embedded { + lappend cmd $ns $baseName [dict get $embeddedServerDataDict ipaddr] [dict get $embeddedServerDataDict headers] $headerList + } + default { + lappend cmd $ns $baseName $data(ipaddr) $data(headerlist) $headerList + } + } + # This will return with error, if the header is not ok + eval $cmd + } set results [eval \$methodName $tclArgList] # generate a reply packet - set xml [generateReply $ns $baseName $results] - # regsub "\]+>\n" $xml {} xml + set response [generateReply $ns $baseName $results $flavor] + + # wrap in JSONP + if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} { + set response "$rawargs(jsonp_callback)($response)" + } + + # mangle the XML declaration + if {$flavor == "soap"} { + # regsub "\]+>\n" $response {} response + set response [string map {{} {}} $response] + } + catch {$doc delete} - set xml [string map {{} {}} $xml] - if {[info exists serviceInfo(-postmonitor)] && - [string length $serviceInfo(-postmonitor)]} { - set precmd $serviceInfo(-postmonitor) - lappend precmd POST $service $operation OK $results - catch $precmd - } - ::log::log debug "Leaving ::WS::Server::callOperation $xml" - switch -exact -- $mode { - tclhttpd { - ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 200 - } - embedded { - ::WS::Embeded::ReturnData $sock text/xml $xml 200 - } - channel { - ::WS::Channel::ReturnData $sock text/xml $xml 200 - } - rivet { - headers type text/xml - headers numeric 200 - puts $xml - } - aolserver { - ::WS::AOLserver::ReturnData $sock text/xml $xml 200 - } - wibble { - dict set responseDict header content-type text/xml - dict set responseDict status 200 - dict set responseDict content $xml - } + if {![string equal $outTransform {}]} { + set response [$outTransform REPLY $response $operation $results] + } + if {[dict exists $serviceData -postmonitor] && + "" ne [dict get $serviceData -postmonitor]} { + set precmd [dict get $serviceData -postmonitor] + lappend precmd POST $serviceName $operation OK $results + catch $precmd } } msg]} { ## ## Handle errors ## set localerrorCode $::errorCode set localerrorInfo $::errorInfo - if {[info exists serviceInfo(-postmonitor)] && - [string length $serviceInfo(-postmonitor)]} { - set precmd $serviceInfo(-postmonitor) - lappend precmd POST $service $operation ERROR $msg + if {[dict exists $serviceData -postmonitor] && + "" ne [dict get $serviceData -postmonitor]} { + set precmd [dict get $serviceData -postmonitor] + lappend precmd POST $serviceName $operation ERROR $msg catch $precmd } - set xml [generateError \ - $serviceInfo(-traceEnabled) \ + catch {$doc delete} + set httpStatus 500 + if {$errorCallback ne {}} { $errorCallback $msg httpStatus $operation $flavor } + set response [generateError \ + [dict get $serviceData -traceEnabled] \ CLIENT \ $msg \ - [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo]] - catch {$doc delete} - ::log::log debug "Leaving @ error 2::WS::Server::callOperation $xml" + [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \ + $flavor] + ::log::logsubst debug {Leaving @ error 2::WS::Server::callOperation $response} + + # Check if the localerrorCode is a valid http status code + set validHttpStatusCodes {100 101 102 + 200 201 202 203 204 205 206 207 208 226 + 300 301 302 303 304 305 306 307 308 + 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 421 422 423 424 425 426 427 428 429 430 431 451 + 500 501 502 503 504 505 506 507 508 509 510 511 + } + if {[lsearch -exact $validHttpStatusCodes $localerrorCode] > -1} { + set httpStatus $localerrorCode + } + + # wrap in JSONP + if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} { + set response "$rawargs(jsonp_callback)($response)" + } + switch -exact -- $mode { tclhttpd { - ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 500 + ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } embedded { - ::WS::Embeded::ReturnData $sock text/xml $xml 500 + return [list "$contentType; charset=UTF-8" $response $httpStatus] } channel { - ::WS::Channel::ReturnData $sock text/xml $xml 500 + ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } rivet { - headers type text/xml - headers numeric 500 - puts $xml + if {[lindex $localerrorCode 0] == "RIVET" && [lindex $localerrorCode 1] == "ABORTPAGE"} { + # if we caught an abort_page, then re-trigger it. + abort_page + } + headers type "$contentType; charset=UTF-8" + headers numeric $httpStatus + puts $response } aolserver { - ::WS::AOLserver::ReturnData $sock text/xml $xml 500 + ::WS::AOLserver::ReturnData $sock $contentType $response $httpStatus } wibble { - dict set responseDict header content-type text/xml - dict set responseDict status 500 - dict set responseDict content $xml + ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus + } + default { + ## Do nothing } } - return; + return 1 + } + + ## + ## Return result + ## + + ::log::logsubst debug {Leaving ::WS::Server::callOperation $response} + switch -exact -- $mode { + tclhttpd { + ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response 200 + } + embedded { + return [list "$contentType; charset=UTF-8" $response 200] + } + channel { + ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response 200 + } + rivet { + headers type "$contentType; charset=UTF-8" + headers numeric 200 + puts $response + } + aolserver { + ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response 200 + } + wibble { + ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response 200 + } + default { + ## Do nothing + } } - return; + + return 0 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -1398,10 +2102,11 @@ # Arguments : # includeTrace - Boolean indicate if the trace is to be included. # faultcode - The code describing the error # faultstring - The string describing the error. # detail - Optional details of error. +# flavor - Output mode: "soap" or "rest" # # Returns : XML formatted standard error packet # # Side-Effects : None # @@ -1421,12 +2126,12 @@ # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### -proc ::WS::Server::generateError {includeTrace faultcode faultstring detail} { - ::log::log debug "Entering ::WS::Server::generateError $faultcode $faultstring {$detail}" +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" } @@ -1437,47 +2142,64 @@ set code "SOAP-ENV:Client" } "Server" { set code "SOAP-ENV:Server" } - } - dom createDocument "SOAP-ENV:Envelope" doc - $doc documentElement env - $env setAttribute \ - "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ - "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \ - "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \ - "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" - $env appendChild [$doc createElement "SOAP-ENV:Body" bod] - $bod appendChild [$doc createElement "SOAP-ENV:Fault" flt] - $flt appendChild [$doc createElement "SOAP-ENV:faultcode" fcd] - $fcd appendChild [$doc createTextNode $faultcode] - $flt appendChild [$doc createElement "SOAP-ENV:faultstring" fst] - $fst appendChild [$doc createTextNode $faultstring] - - if { $detail != {} } { - $flt appendChild [$doc createElement "SOAP-ENV:detail" dtl0] - $dtl0 appendChild [$doc createElement "e:errorInfo" dtl] - $dtl setAttribute "xmlns:e" "urn:TclErrorInfo" - - foreach {detailName detailInfo} $detail { - if {!$includeTrace && $detailName == "stackTrace"} { - continue - } - $dtl appendChild [$doc createElement $detailName err] - $err appendChild [$doc createTextNode $detailInfo] - } - } - - # serialize the DOM document and return the XML text - append xml \ - {} \ - "\n" \ - [$doc asXML -indent none -doctypeDeclaration 0] - $doc delete - ::log::log debug "Leaving (error) ::WS::Server::generateError $xml" - return $xml + default { + ## Do nothing + } + } + + switch -exact -- $flavor { + rest { + set doc [yajl create #auto] + $doc map_open string "error" string $faultstring map_close + set response [$doc get] + $doc delete + } + soap { + dom createDocument "SOAP-ENV:Envelope" doc + $doc documentElement env + $env setAttribute \ + "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ + "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \ + "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \ + "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" + $env appendChild [$doc createElement "SOAP-ENV:Body" bod] + $bod appendChild [$doc createElement "SOAP-ENV:Fault" flt] + $flt appendChild [$doc createElement "faultcode" fcd] + $fcd appendChild [$doc createTextNode $faultcode] + $flt appendChild [$doc createElement "faultstring" fst] + $fst appendChild [$doc createTextNode $faultstring] + + if { $detail != {} } { + $flt appendChild [$doc createElement "SOAP-ENV:detail" dtl0] + $dtl0 appendChild [$doc createElement "e:errorInfo" dtl] + $dtl setAttribute "xmlns:e" "urn:TclErrorInfo" + + foreach {detailName detailInfo} $detail { + if {!$includeTrace && $detailName == "stackTrace"} { + continue + } + $dtl appendChild [$doc createElement $detailName err] + $err appendChild [$doc createTextNode $detailInfo] + } + } + + # serialize the DOM document and return the XML text + append response \ + {} \ + "\n" \ + [$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 @@ -1491,10 +2213,12 @@ # # Arguments : # serviceName - The name of the service # operation - The name of the operation # results - The results as a dictionary object +# flavor - Output mode: "soap" or "rest" +# version - Requested service version # # # Returns : The results as an XML formatted packet. # # Side-Effects : None @@ -1512,104 +2236,83 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2 11/13/2018 J.Cone Version support # # ########################################################################### -proc ::WS::Server::generateReply {serviceName operation results} { - ::log::log debug "Entering ::WS::Server::generateReply $serviceName $operation {$results}" +proc ::WS::Server::generateReply {serviceName operation results flavor {version {}}} { + ::log::logsubst debug {Entering ::WS::Server::generateReply $serviceName $operation {$results}} variable serviceArr - array set serviceData $serviceArr($serviceName) - - if {[info exists ::Config(docRoot)] && [file exists [file join $::Config(docRoot) $serviceName $operation.css]]} { - set replaceText [format {}\ - $serviceData(-host) \ - $serviceName \ - $operation] - append replaceText "\n" - } else { - set replaceText {} - } - - dom createDocument "SOAP-ENV:Envelope" doc - $doc documentElement env - $env setAttribute \ - "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ - "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \ - "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \ - "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \ - xmlns:$serviceName "http://$serviceData(-host)$serviceData(-prefix)" - if {[llength $serviceData(-outheaders)]} { - $env appendChild [$doc createElement "SOAP-ENV:Header" header] - foreach headerType $serviceData(-outheaders) { - #$header appendChild [$doc createElement ${serviceName}:${headerType} part] - #::WS::Utils::convertDictToType Server $serviceName $doc $part $results $headerType - ::WS::Utils::convertDictToType Server $serviceName $doc $header $results $headerType - } - } - $env appendChild [$doc createElement "SOAP-ENV:Body" body] - $body appendChild [$doc createElement ${serviceName}:${operation}Results reply] - - ::WS::Utils::convertDictToType Server $serviceName $doc $reply $results ${operation}Results - - append xml \ - {} \ - "\n" \ - [$doc asXML -indent none -doctypeDeclaration 0] - #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] $replaceText xml - $doc delete - - ::log::log debug "Leaving ::WS::Server::generateReply $xml" - return $xml - -} - -########################################################################### -# -# Private Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PRIVATE<< -# -# Procedure Name : :WS::Server::ok -# -# Description : Stub for header check -# -# Arguments : -# serviceName - The name of the service -# operation - The name of the operation -# results - The results as a dictionary object -# -# -# Returns : The results as an XML formatted packet. -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Gerald W. Lester -# -#>>END PRIVATE<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 07/06/2006 G.Lester Initial version -# -# -########################################################################### -proc ::WS::Server::ok {args} { - return; + set serviceData $serviceArr($serviceName) + + + switch -exact -- $flavor { + rest { + set doc [yajl create #auto -beautify [dict get $serviceData -beautifyJson]] + + $doc map_open + ::WS::Utils::convertDictToJson Server $serviceName $doc $results ${serviceName}:${operation}Results [dict get $serviceData -enforceRequired] $version + $doc map_close + + set output [$doc get] + $doc delete + } + soap { + if {[info exists ::Config(docRoot)] && [file exists [file join $::Config(docRoot) $serviceName $operation.css]]} { + # *** Bug: the -hostprotocol in -hostprotocol=server is not + # *** corrected, if no WSDL is required before this call. + set replaceText [format {}\ + [dict get $serviceData -hostprotocol] \ + [dict get $serviceData -hostlocation] \ + $serviceName \ + $operation] + append replaceText "\n" + } else { + set replaceText {} + } + + dom createDocument "SOAP-ENV:Envelope" doc + $doc documentElement env + $env setAttribute \ + "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ + "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \ + "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \ + "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \ + xmlns:$serviceName "http://[dict get $serviceData -host][dict get $serviceData -prefix]" + if {0 != [llength [dict get $serviceData -outheaders]]} { + $env appendChild [$doc createElement "SOAP-ENV:Header" header] + foreach headerType [dict get $serviceData -outheaders] { + #$header appendChild [$doc createElement ${serviceName}:${headerType} part] + #::WS::Utils::convertDictToType Server $serviceName $doc $part $results $headerType + ::WS::Utils::convertDictToType Server $serviceName $doc $header $results $headerType 0 [dict get $serviceData -enforceRequired] $version + } + } + $env appendChild [$doc createElement "SOAP-ENV:Body" body] + $body appendChild [$doc createElement ${serviceName}:${operation}Results reply] + + ::WS::Utils::convertDictToType Server $serviceName $doc $reply $results ${serviceName}:${operation}Results 0 [dict get $serviceData -enforceRequired] $version + + append output \ + {} \ + "\n" \ + [$doc asXML -indent none -doctypeDeclaration 0] + #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] $replaceText xml + $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 @@ -1621,12 +2324,12 @@ # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : -# serviceName - The name of the service -# sock - The socket to return the WSDL on +# serviceData -- Service information dict +# menuList -- html menu # args - not used # # Returns : # 1 - On error # 0 - On success @@ -1649,44 +2352,43 @@ # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### -proc ::WS::Server::generateGeneralInfo {serviceInfo menuList} { +proc ::WS::Server::generateGeneralInfo {serviceData menuList} { variable procInfo ::log::log debug "\tDisplay Service General Information" - array set serviceData $serviceInfo - set service [dict get $serviceInfo -service] + set service [dict get $serviceData -service] ::html::init - ::html::author $serviceData(-author) - if {[string equal $serviceData(-description) {}]} { + ::html::author [dict get $serviceData -author] + if {"" eq [dict get $serviceData -description]} { ::html::description "Automatically generated human readable documentation for '$service'" } else { - ::html::description $serviceData(-description) + ::html::description [dict get $serviceData -description] } - if {$serviceData(-stylesheet) != ""} { - ::html::headTag "link rel=\"stylesheet\" type=\"text/css\" href=\"$serviceData(-stylesheet)\"" + if {[dict get $serviceData -stylesheet] ne ""} { + ::html::headTag "link rel=\"stylesheet\" type=\"text/css\" href=\"[dict get $serviceData -stylesheet]\"" } - set head $serviceData(-htmlhead) + set head [dict get $serviceData -htmlhead] set msg [::html::head $head] append msg [::html::bodyTag] - array unset serviceData -service - if {[info exists serviceData(-description)]} { - set serviceData(-description) [::html::nl2br $serviceData(-description)] + dict unset serviceData -service + if {[dict exists $serviceData -description]} { + dict set serviceData -description [::html::nl2br [dict get $serviceData -description]] } - set wsdl [format {WSDL(xml)} $serviceData(-prefix) wsdl] + set wsdl [format {WSDL(xml)} [dict get $serviceData -prefix] wsdl] append msg [::html::openTag center] [::html::h1 "$head -- $wsdl"] [::html::closeTag] \ [::html::openTag table {border="2"}] - foreach key [lsort -dictionary [array names serviceData]] { - if {[string equal $serviceData($key) {}]} { + foreach key [lsort -dictionary [dict keys $serviceData]] { + if {"" eq [dict get $serviceData $key]} { append msg [::html::row [string range $key 1 end] {N/A}] } else { - append msg [::html::row [string range $key 1 end] $serviceData($key)] + append msg [::html::row [string range $key 1 end] [dict get $serviceData $key]] } } append msg [::html::closeTag] \ "\n
\n" @@ -1704,13 +2406,13 @@ # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : -# serviceName - The name of the service -# sock - The socket to return the WSDL on -# args - not used +# serviceData -- Service option dict +# menuList -- html menu +# version - Requested service version # # Returns : # 1 - On error # 0 - On success # @@ -1729,25 +2431,32 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2 11/13/2018 J.Cone Version support # # ########################################################################### -proc ::WS::Server::generateTocInfo {serviceInfo menuList} { +proc ::WS::Server::generateTocInfo {serviceData menuList version} { variable procInfo ## ## Display TOC ## ::log::log debug "\tTOC" - set service [dict get $serviceInfo -service] + set service [dict get $serviceData -service] append msg [::html::h2 {List of Operations}] set operList {} foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] { + if {$version ne {} && [dict exists $procInfo $service op$oper version]} { + if {![::WS::Utils::check_version [dict get $procInfo $service op$oper version] $version]} { + ::log::log debug "Skipping operation '$oper' because version is incompatible" + continue + } + } lappend operList $oper "#op_$oper" } append msg [::html::minorList $operList] append msg "\n
\n
" [::html::minorMenu $menuList] "
" @@ -1767,13 +2476,13 @@ # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : -# serviceName - The name of the service -# sock - The socket to return the WSDL on -# args - not used +# serviceData -- Service option dict +# menuList -- html menu +# version - Requested service version # # Returns : # 1 - On error # 0 - On success # @@ -1792,36 +2501,45 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2 11/13/2018 J.Cone Version support # # ########################################################################### -proc ::WS::Server::generateOperationInfo {serviceInfo menuList} { +proc ::WS::Server::generateOperationInfo {serviceData menuList version} { variable procInfo ## ## Display Operations ## ::log::log debug "\tDisplay Operations" - set service [dict get $serviceInfo -service] + set service [dict get $serviceData -service] set operList {} foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] { lappend operList $oper "#op_$oper" } append msg [::html::h2 {Operation Details}] - set docFormat [dict get $serviceInfo -docFormat] + set docFormat [dict get $serviceData -docFormat] + set opCount 0 foreach {oper anchor} $operList { - ::log::log debug "\t\tDisplaying '$oper'" + if {$version ne {} && [dict exists $procInfo $service op$oper version]} { + if {![::WS::Utils::check_version [dict get $procInfo $service op$oper version] $version]} { + ::log::log debug "Skipping operation '$oper' because version is incompatible" + continue + } + } + ::log::logsubst debug {\t\tDisplaying '$oper'} + incr opCount append msg [::html::h3 "$oper"] append msg [::html::h4 {Description}] "\n" append msg [::html::openTag div {style="margin-left: 40px;"}] - switch $docFormat { + switch -exact -- $docFormat { "html" { append msg [dict get $procInfo $service op$oper docs] } "text" - default { @@ -1833,26 +2551,44 @@ append msg "\n" append msg [::html::h4 {Inputs}] "\n" append msg [::html::openTag div {style="margin-left: 40px;"}] - append msg [::html::openTag {table} {border="2"}] - append msg [::html::hdrRow Name Type Description] - foreach arg [dict get $procInfo $service op$oper argOrder] { - ::log::log 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 \ - [displayType $service [dict get $procInfo $service op$oper argList $arg type]] \ - $comment \ - ] - } - append msg [::html::closeTag] + + set inputCount 0 + if {[llength [dict get $procInfo $service op$oper argOrder]]} { + foreach arg [dict get $procInfo $service op$oper argOrder] { + if {$version ne {} && [dict exists $procInfo $service op$oper argList $arg version]} { + if {![::WS::Utils::check_version [dict get $procInfo $service op$oper argList $arg version] $version]} { + ::log::log debug "Skipping field '$arg' because version is incompatible" + continue + } + } + ::log::logsubst debug {\t\t\tDisplaying '$arg'} + if {!$inputCount} { + append msg [::html::openTag {table} {border="2"}] + append msg [::html::hdrRow Name Type Description] + } + incr inputCount + 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 \ + [displayType $service [dict get $procInfo $service op$oper argList $arg type]] \ + $comment \ + ] + } + if {$inputCount} { + append msg [::html::closeTag] + } + } + if {!$inputCount} { + append msg "No inputs." + } append msg [::html::closeTag] ::log::log debug "\t\tReturns" append msg [::html::h4 {Returns}] "\n" @@ -1873,11 +2609,11 @@ append msg "\n
\n
" [::html::minorMenu $menuList] "
" append msg "\n
\n" } - if {![llength $operList]} { + if {!$opCount} { append msg "\n
\n
" [::html::minorMenu $menuList] "
" append msg "\n
\n" } return $msg @@ -1895,13 +2631,108 @@ # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : -# serviceName - The name of the service -# sock - The socket to return the WSDL on -# args - not used +# serviceData -- Service option dict +# menuList -- html menu +# version - Requested service version +# +# Returns : +# 1 - On error +# 0 - On success +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 07/06/2006 G.Lester Initial version +# 2 11/13/2018 J.Cone Version support +# +# +########################################################################### +proc ::WS::Server::generateCustomTypeInfo {serviceData menuList version} { + variable procInfo + + ## + ## Display custom types + ## + ::log::log debug "\tDisplay custom types" + set service [dict get $serviceData -service] + append msg [::html::h2 {Custom Types}] + + set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service] + foreach type [lsort -dictionary [dict keys $localTypeInfo]] { + if {$version ne {} && [dict exists $localTypeInfo $type version]} { + set typeVersion [dict get $localTypeInfo $type version] + if {![::WS::Utils::check_version $typeVersion $version]} { + ::log::log debug "Skipping type '$type' because version is incompatible" + continue + } + } + ::log::logsubst debug {\t\tDisplaying '$type'} + set href_type [lindex [split $type :] end] + set typeOverloadArray($type) 1 + append msg [::html::h3 "$type"] + 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]] { + if {$version ne {} && [dict exists $typeDetails $part version]} { + if {![::WS::Utils::check_version [dict get $typeDetails $part version] $version]} { + ::log::log debug "Skipping field '$part' because version is incompatible" + continue + } + } + ::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 \ + [displayType $service [dict get $typeDetails $part type]] \ + $comment \ + ] + } + append msg [::html::closeTag] + } + + append msg "\n
\n
" [::html::minorMenu $menuList] "
" + append msg "\n
\n" + + return $msg +} + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Server::generateSimpleTypeInfo +# +# Description : Generate an HTML description of the service, the operations +# and all applicable type definitions. +# +# Arguments : +# serviceData -- Service option dict +# menuList -- html menu # # Returns : # 1 - On error # 0 - On success # @@ -1923,112 +2754,37 @@ # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### -proc ::WS::Server::generateCustomTypeInfo {serviceInfo menuList} { - variable procInfo - - ## - ## Display custom types - ## - ::log::log debug "\tDisplay custom types" - set service [dict get $serviceInfo -service] - append msg [::html::h2 {Custom Types}] - - set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service] - foreach type [lsort -dictionary [dict keys $localTypeInfo]] { - ::log::log debug "\t\tDisplaying '$type'" - set typeOverloadArray($type) 1 - append msg [::html::h3 "$type"] - set typeDetails [dict get $localTypeInfo $type definition] - append msg [::html::openTag {table} {border="2"}] - append msg [::html::hdrRow Field Type] - foreach part [lsort -dictionary [dict keys $typeDetails]] { - ::log::log debug "\t\t\tDisplaying '$part'" - append msg [::html::row \ - $part \ - [displayType $service [dict get $typeDetails $part type]] - ] - } - append msg [::html::closeTag] - } - - append msg "\n
\n
" [::html::minorMenu $menuList] "
" - append msg "\n
\n" - - return $msg -} - -########################################################################### -# -# Private Procedure Header - as this procedure is modified, please be sure -# that you update this header block. Thanks. -# -#>>BEGIN PRIVATE<< -# -# Procedure Name : ::WS::Server::generateInfo -# -# Description : Generate an HTML description of the service, the operations -# and all applicable type definitions. -# -# Arguments : -# serviceName - The name of the service -# sock - The socket to return the WSDL on -# args - not used -# -# Returns : -# 1 - On error -# 0 - On success -# -# Side-Effects : None -# -# Exception Conditions : None -# -# Pre-requisite Conditions : None -# -# Original Author : Gerald W. Lester -# -#>>END PRIVATE<< -# -# Maintenance History - as this file is modified, please be sure that you -# update this segment of the file header block by -# adding a complete entry at the bottom of the list. -# -# Version Date Programmer Comments / Changes / Reasons -# ------- ---------- ---------- ------------------------------------------- -# 1 07/06/2006 G.Lester Initial version -# -# -########################################################################### -proc ::WS::Server::generateSimpleTypeInfo {serviceInfo menuList} { +proc ::WS::Server::generateSimpleTypeInfo {serviceData menuList} { variable procInfo ## ## Display list of simple types ## ::log::log debug "\tDisplay list of simply types" - set service [dict get $serviceInfo -service] + set service [dict get $serviceData -service] append msg [::html::h2 {Simple Types}] append msg "\n
\n
" [::html::minorMenu $menuList] "
" set localTypeInfo [::WS::Utils::GetServiceSimpleTypeDef Server $service] foreach typeDetails [lsort -dictionary -index 0 $localTypeInfo] { set type [lindex $typeDetails 0] - ::log::log debug "\t\tDisplaying '$type'" + ::log::logsubst debug {\t\tDisplaying '$type'} set typeOverloadArray($type) 1 append msg [::html::h3 "$type"] append msg [::html::openTag {table} {border="2"}] append msg [::html::hdrRow Attribute Value] foreach part [lsort -dictionary [dict keys [lindex $typeDetails 1]]] { - ::log::log debug "\t\t\tDisplaying '$part'" + ::log::logsubst debug {\t\t\tDisplaying '$part'} append msg [::html::row \ $part \ - [dict get [lindex $typeDetails 1] $part] + [dict get [lindex $typeDetails 1] $part] \ ] } append msg [::html::closeTag] } append msg "\n
\n" return $msg } Index: Utilities.tcl ================================================================== --- Utilities.tcl +++ Utilities.tcl @@ -1,8 +1,8 @@ ############################################################################### ## ## -## Copyright (c) 2006-2008, Gerald W. Lester ## +## Copyright (c) 2006-2013, Gerald W. Lester ## ## Copyright (c) 2008, Georgios Petasis ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## Copyright (c) 2006, Arnulf Wiedemann ## ## Copyright (c) 2006, Colin McCormack ## ## Copyright (c) 2006, Rolf Ade ## @@ -37,32 +37,66 @@ ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### -package require Tcl 8.4 -if {![llength [info command dict]]} { - package require dict -} +package require Tcl 8.6- + 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 1.4.1 +package provide WS::Utils 3.1.0 namespace eval ::WS {} namespace eval ::WS::Utils { - set typeInfo {} - set currentSchema {} - array set importedXref {} + set ::WS::Utils::typeInfo {} + set ::WS::Utils::currentSchema {} + array set ::WS::Utils::importedXref {} + variable redirectArray + array set redirectArray {} set nsList { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ - s http://www.w3.org/2001/XMLSchema + xs http://www.w3.org/2001/XMLSchema } - array set simpleTypes { + + # mapping of how the simple SOAP types should be serialized using YAJL into JSON. + array set ::WS::Utils::simpleTypesJson { + boolean "bool" + float "number" + double "double" + integer "integer" + int "integer" + long "integer" + short "integer" + byte "integer" + nonPositiveInteger "integer" + negativeInteger "integer" + nonNegativeInteger "integer" + unsignedLong "integer" + unsignedInt "integer" + unsignedShort "integer" + unsignedByte "integer" + positiveInteger "integer" + decimal "number" + } + + array set ::WS::Utils::simpleTypes { + anyType 1 string 1 boolean 1 decimal 1 float 1 double 1 @@ -104,20 +138,28 @@ unsignedInt 1 unsignedShort 1 unsignedByte 1 positiveInteger 1 } - array set options { + array set ::WS::Utils::options { UseNS 1 StrictMode error parseInAttr 0 genOutAttr 0 + valueAttrCompatiblityMode 1 + includeDirectory {} + suppressNS {} + useTypeNs 0 + nsOnChangeOnly 0 + anyType string + queryTimeout 60000 } - set standardAttributes { + set ::WS::Utils::standardAttributes { baseType comment + example pattern length fixed maxLength minLength @@ -125,14 +167,39 @@ maxInclusive enumeration type } + dom parse { + + + + + + + + + + + + + + + + + } ::WS::Utils::xsltSchemaDom + + set currentNs {} + } - + + ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # @@ -173,11 +240,11 @@ array set crossreference {} dict for {type typeDict} [dict get $typeInfo $mode $service] { foreach {field fieldDict} [dict get $typeDict definition] { - set fieldType [string trimright [dict get $fieldDict type] {()}] + set fieldType [string trimright [dict get $fieldDict type] {()?}] incr crossreference($fieldType,count) lappend crossreference($fieldType,usedBy) $type.$field } if {![info exists crossreference($type,count) ]} { set crossreference($type,count) 0 @@ -231,42 +298,42 @@ if {[llength $args] == 0} { ::log::log debug {Return all options} return [array get options] } elseif {[llength $args] == 1} { set opt [lindex $args 0] - ::log::log debug "One Option {$opt}" + ::log::logsubst debug {One Option {$opt}} if {[info exists options($opt)]} { return $options($opt) } else { - ::log::log debug "Unkown option {$opt}" + ::log::logsubst debug {Unknown option {$opt}} return \ -code error \ -errorcode [list WS CLIENT UNKOPTION $opt] \ "Unknown option'$opt'" } } elseif {([llength $args] % 2) == 0} { ::log::log debug {Multiple option pairs} foreach {opt value} $args { if {[info exists options($opt)]} { - ::log::log debug "Setting Option {$opt} to {$value}" + ::log::logsubst debug {Setting Option {$opt} to {$value}} set options($opt) $value } else { - ::log::log debug "Unkown option {$opt}" + ::log::logsubst debug {Unknown option {$opt}} return \ -code error \ -errorcode [list WS CLIENT UNKOPTION $opt] \ "Unknown option'$opt'" } } } else { - ::log::log debug "Bad number of arguments {$args}" + ::log::logsubst debug {Bad number of arguments {$args}} return \ -code error \ -errorcode [list WS CLIENT INVARGCNT $args] \ "Invalid argument count'$args'" } - return; + return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure @@ -281,16 +348,18 @@ # Arguments : # mode - Client|Server # service - The name of the service this type definition is for # type - The type to be defined/redefined # definition - The definition of the type's fields. This consist of one -# or more occurance of a field definition. Each field definition +# or more occurence of a field definition. Each field definition # consist of: fieldName fieldInfo # Where field info is: {type typeName comment commentString} # typeName can be any simple or defined type. # commentString is a quoted string describing the field. # xns - The namespace +# abstract - Boolean indicating if this is an abstract, and hence mutable type +# version - Version code for the custom type # # Returns : Nothing # # Side-Effects : None # @@ -307,23 +376,31 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2 11/13/2018 J.Cone Version support # # ########################################################################### -proc ::WS::Utils::ServiceTypeDef {mode service type definition {xns {}}} { - ::log::log debug [info level 0] +proc ::WS::Utils::ServiceTypeDef {mode service type definition {xns {}} {abstract {false}} {version {}}} { + ::log::logsubst debug {Entering [info level 0]} variable typeInfo if {![string length $xns]} { set xns $service + } + if {[llength [split $type {:}]] == 1} { + set type $xns:$type } dict set typeInfo $mode $service $type definition $definition dict set typeInfo $mode $service $type xns $xns - return; + dict set typeInfo $mode $service $type abstract $abstract + if {$version ne {}} { + dict set typeInfo $mode $service $type version $version + } + return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure @@ -331,21 +408,21 @@ # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::MutableTypeDef # -# Description : Define a mutalbe type for a service. +# Description : Define a mutable type for a service. # # Arguments : # mode - Client|Server # service - The name of the service this type definition is for # type - The type to be defined/redefined -# fromSwitchCmd - The cmd to deternmine the actaul type when converting +# fromSwitchCmd - The cmd to determine the actaul type when converting # from DOM to a dictionary. The actual call will have # the following arguments appended to the command: # mode service type xns DOMnode -# toSwitchCmd - The cmd to deternmine the actaul type when converting +# toSwitchCmd - The cmd to determine the actual type when converting # from a dictionary to a DOM. The actual call will have # the following arguments appended to the command: # mode service type xns remainingDictionaryTree # xns - The namespace # @@ -377,11 +454,11 @@ if {![string length $xns]} { set xns $service } set mutableTypeInfo([list $mode $service $type]) \ [list $fromSwitchCmd $toSwitchCmd] - return; + return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure @@ -438,19 +515,22 @@ ########################################################################### proc ::WS::Utils::ServiceSimpleTypeDef {mode service type definition {xns {tns1}}} { variable simpleTypes variable typeInfo + ::log::logsubst debug {Entering [info level 0]} if {![dict exists $definition xns]} { set simpleTypes($mode,$service,$type) [concat $definition xns $xns] } else { set simpleTypes($mode,$service,$type) $definition } - if {[dict exists $typeInfo $mode $service]} { + if {[dict exists $typeInfo $mode $service $type]} { + ::log::logsubst debug {\t Unsetting typeInfo $mode $service $type} + ::log::logsubst debug {\t Was [dict get $typeInfo $mode $service $type]} dict unset typeInfo $mode $service $type } - return; + return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure @@ -511,23 +591,32 @@ ########################################################################### proc ::WS::Utils::GetServiceTypeDef {mode service {type {}}} { variable typeInfo variable simpleTypes + set type [string trimright $type {()?}] + set results {} if {[string equal $type {}]} { + ::log::log debug "@1" set results [dict get $typeInfo $mode $service] } else { set typeInfoList [TypeInfo $mode $service $type] - if {[lindex $typeInfoList 0] == 0} { - if {[info exists simpleTypes($mode,$service,$type)]} { - set results $simpleTypes($mode,$service,$type) - } elseif {[info exists simpleTypes($type)]} { - set results [list type $type] - } else { - set results {} - } - } else { + if {[string equal -nocase -length 3 $type {xs:}]} { + set type [string range $type 3 end] + } + ::log::logsubst debug {Type = {$type} typeInfoList = {$typeInfoList}} + if {[info exists simpleTypes($mode,$service,$type)]} { + ::log::log debug "@2" + set results $simpleTypes($mode,$service,$type) + } elseif {[info exists simpleTypes($type)]} { + ::log::log debug "@3" + set results [list type xs:$type xns xs] + } elseif {[dict exists $typeInfo $mode $service $service:$type]} { + ::log::log debug "@5" + set results [dict get $typeInfo $mode $service $service:$type] + } elseif {[dict exists $typeInfo $mode $service $type]} { + ::log::log debug "@6" set results [dict get $typeInfo $mode $service $type] } } return $results @@ -592,20 +681,24 @@ # ########################################################################### proc ::WS::Utils::GetServiceSimpleTypeDef {mode service {type {}}} { variable simpleTypes + set type [string trimright $type {()?}] + if {[string equal -nocase -length 3 $type {xs:}]} { + return [::WS::Utils::GetServiceTypeDef $mode $service $type] + } if {[string equal $type {}]} { set results {} foreach {key value} [array get simpleTypes $mode,$service,*] { lappend results [list [lindex [split $key {,}] end] $simpleTypes($key)] } } else { if {[info exists simpleTypes($mode,$service,$type)]} { set results $simpleTypes($mode,$service,$type) } elseif {[info exists simpleTypes($type)]} { - set results [list type $type] + set results [list type $type xns xs] } else { return \ -code error \ -errorcode [list WS CLIENT UNKSMPTYP $type] \ "Unknown simple type '$type'" @@ -627,10 +720,11 @@ # Description : Parse the bindings for a service from a WSDL into our # internal representation # # Arguments : # mode - The mode, Client or Server +# baseUrl - The URL we are processing # xml - The XML string to parse # serviceName - The name service. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # tnsCountVar - The name of the variable containing the count of the @@ -653,40 +747,196 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version -# +# 2.6.1 07/20/2018 A.Goth Correct variable access problems. Ticket [7bb1cd7b43] +# Corrected access of right document. Ticket [61fd346dc3] +# Bugs introduced 2015-05-24 Checkin [9c7e118edb] +# 2018-09-03 H.Oehlmann Replaced stderr error print by error log. # ########################################################################### proc ::WS::Utils::ProcessImportXml {mode baseUrl xml serviceName serviceInfoVar tnsCountVar} { - ::log::log debug "Entering ProcessImportXml $mode $baseUrl $xml $serviceName $serviceInfoVar $tnsCountVar" - upvar $serviceInfoVar serviceInfo - upvar $tnsCountVar tnsCount + ::log::logsubst debug {Entering [info level 0]} + upvar 1 $serviceInfoVar serviceInfo + upvar 1 $tnsCountVar tnsCount variable currentSchema + variable nsList + variable xsltSchemaDom - if {[catch {dom parse $xml doc}]} { + set first [string first {<} $xml] + if {$first > 0} { + set xml [string range $xml $first end] + } + if {[catch {dom parse $xml tmpdoc}]} { set first [string first {?>} $xml] incr first 2 set xml [string range $xml $first end] - dom parse $xml doc + dom parse $xml tmpdoc } + $tmpdoc xslt $xsltSchemaDom doc + $tmpdoc delete $doc selectNodesNamespaces { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ - s http://www.w3.org/2001/XMLSchema + xs http://www.w3.org/2001/XMLSchema } $doc documentElement schema + if {[catch {ProcessIncludes $schema $baseUrl} errMsg]} { + ::log::log error "Error processing include $schema $baseUrl: $errMsg" + } + set prevSchema $currentSchema - set currentSchema $schema - - parseScheme $mode $baseUrl $schema $serviceName serviceInfo tnsCount + set nodeList [$doc selectNodes -namespaces $nsList descendant::xs:schema] + foreach node $nodeList { + set currentSchema $node + parseScheme $mode $baseUrl $node $serviceName serviceInfo tnsCount + } set currentSchema $prevSchema $doc delete } + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PUBLIC<< +# +# Procedure Name : ::WS::Utils::ProcessIncludes +# +# Description : Replace all include nodes with the contents of the included url. +# +# Arguments : +# rootNode - the root node of the document +# baseUrl - The URL being processed +# +# Returns : nothing +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PUBLIC<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 25/05/2006 G.Lester Initial version +# +# +########################################################################### +proc ::WS::Utils::ProcessIncludes {rootNode baseUrl {includePath {}}} { + variable xsltSchemaDom + variable nsList + variable options + variable includeArr + + ::log::logsubst debug {Entering [info level 0]} + + set includeNodeList [concat \ + [$rootNode selectNodes -namespaces $nsList descendant::xs:include] \ + [$rootNode selectNodes -namespaces $nsList descendant::w:include] \ + [$rootNode selectNodes -namespaces $nsList descendant::w:import] \ + ] + set inXml [$rootNode asXML] + set included 0 + foreach includeNode $includeNodeList { + ::log::logsubst debug {\t Processing Include [$includeNode asXML]} + if {[$includeNode hasAttribute schemaLocation]} { + set urlTail [$includeNode getAttribute schemaLocation] + set url [::uri::resolve $baseUrl $urlTail] + } elseif {[$includeNode hasAttribute location]} { + set url [$includeNode getAttribute location] + set urlTail [file tail [dict get [::uri::split $url] path]] + } else { + continue + } + if {[lsearch -exact $includePath $url] != -1} { + log::logsubst warning {Include loop detected: [join $includePath { -> }]} + continue + } elseif {[info exists includeArr($url)]} { + continue + } else { + set includeArr($url) 1 + } + incr included + ::log::logsubst info {\t Including {$url} from base {$baseUrl}} + switch -exact -- [dict get [::uri::split $url] scheme] { + file { + upvar #0 [::uri::geturl $url] token + set xml $token(data) + unset token + } + https - + http { + set ncode -1 + catch { + ::log::logsubst info {[list ::http::geturl $url\ + -timeout $options(queryTimeout)]} + set token [::http::geturl $url -timeout $options(queryTimeout)] + set ncode [::http::ncode $token] + set xml [::http::data $token] + ::log::logsubst info {Received Ncode = ($ncode), $xml} + ::http::cleanup $token + } + if {($ncode != 200) && [string equal $options(includeDirectory) {}]} { + return \ + -code error \ + -errorcode [list WS CLIENT HTTPFAIL $url $ncode] \ + "HTTP get of import file failed '$url'" + } elseif {($ncode != 200) && ![string equal $options(includeDirectory) {}]} { + set fn [file join $options(includeDirectory) $urlTail] + set ifd [open $fn r] + set xml [read $ifd] + close $ifd + } + } + default { + return \ + -code error \ + -errorcode [list WS CLIENT UNKURLTYP $url] \ + "Unknown URL type '$url'" + } + } + set parentNode [$includeNode parentNode] + set nextSibling [$includeNode nextSibling] + set first [string first {<} $xml] + if {$first > 0} { + set xml [string range $xml $first end] + } + dom parse $xml tmpdoc + $tmpdoc xslt $xsltSchemaDom doc + $tmpdoc delete + set children 0 + set top [$doc documentElement] + ::WS::Utils::ProcessIncludes $top $url [concat $includePath $baseUrl] + foreach childNode [$top childNodes] { + if {[catch { + #set newNode [$parentNode appendXML [$childNode asXML]] + #$parentNode removeChild $newNode + #$parentNode insertBefore $newNode $includeNode + $parentNode insertBefore $childNode $includeNode + }]} { + continue + } + incr children + } + $doc delete + $includeNode delete + } +} + ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # @@ -693,14 +943,14 @@ #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::TypeInfo # # Description : Return a list indicating if the type is simple or complex -# and if it is a scalar or an array. +# and if it is a scalar or an array. Also if it is optional # # Arguments : -# type - the type name, possiblely with a () to specify it is an array +# type - the type name, possibly with a () to specify it is an array # # Returns : A list of two elements, as follows: # 0|1 - 0 means a simple type, 1 means a complex type # 0|1 - 0 means a scalar, 1 means an array # @@ -719,27 +969,39 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version -# +# 2.3.0 10/16/2012 G. Lester Corrected detection of service specific simple type. +# 2.3.0 10/31/2012 G. Lester Corrected missing newline. # ########################################################################### -proc ::WS::Utils::TypeInfo {mode service type} { +proc ::WS::Utils::TypeInfo {mode service type {findOptional 0}} { variable simpleTypes variable typeInfo set type [string trim $type] + set isOptional 0 + if {[string equal [string index $type end] {?}]} { + set isOptional 1 + set type [string trimright $type {?}] + } if {[string equal [string range $type end-1 end] {()}]} { set isArray 1 set type [string range $type 0 end-2] } elseif {[string equal $type {array}]} { set isArray 1 } else { set isArray 0 } - set isNotSimple [dict exists $typeInfo $mode $service $type] + #set isNotSimple [dict exists $typeInfo $mode $service $type] + #set isNotSimple [expr {$isNotSimple || [dict exists $typeInfo $mode $service $service:$type]}] + lassign [split $type {:}] tns baseType + set isNotSimple [expr {!([info exist simpleTypes($type)] || [info exist simpleTypes($baseType)] || [info exist simpleTypes($mode,$service,$type)] || [info exist simpleTypes($mode,$service,$baseType)] )}] + if {$findOptional} { + return [list $isNotSimple $isArray $isOptional] + } return [list $isNotSimple $isArray] } ########################################################################### @@ -760,11 +1022,11 @@ # serviceName - The service name # xmlString - The XML string to validate # tagName - The name of the starting tag # typeName - The type for the tag # -# Returns : 1 if valition ok, 0 if not +# Returns : 1 if validation ok, 0 if not # # Side-Effects : # ::errorCode - cleared if validation ok # - contains validation failure information if validation # failed. @@ -789,10 +1051,14 @@ # # ########################################################################### proc ::WS::Utils::Validate {mode serviceName xmlString tagName typeName} { + set first [string first {<} $xmlString] + if {$first > 0} { + set xmlString [string range $xmlString $first end] + } dom parse $xmlString resultTree $resultTree documentElement currNode set nodeName [$currNode localName] if {![string equal $nodeName $tagName]} { return \ @@ -847,11 +1113,11 @@ # 1 08/13/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to generate qualified XML # ########################################################################### proc ::WS::Utils::BuildRequest {mode serviceName tagName typeName valueInfos} { - upvar $valueInfos values + upvar 1 $valueInfos values variable resultTree variable currNode set resultTree [::dom createDocument $tagName] set typeInfo [GetServiceTypeDef $mode $serviceName $typeName] @@ -938,10 +1204,11 @@ # mode - Client/Server # serviceName - The service name # doc - The document to add the scheme to # parent - The parent node of the scheme # targetNamespace - Target namespace +# version - Requested service version # # Returns : nothing # # Side-Effects : None # @@ -959,44 +1226,56 @@ # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 02/15/2008 G.Lester Made Scheme generation a utility # 2 02/03/2008 G.Lester Moved scheme generation into WS::Utils namespace +# 3 11/13/2018 J.Cone Version support # ########################################################################### -proc ::WS::Utils::GenerateScheme {mode serviceName doc parent targetNamespace} { +proc ::WS::Utils::GenerateScheme {mode serviceName doc parent targetNamespace {version {}}} { set localTypeInfo [GetServiceTypeDef $mode $serviceName] array set typeArr {} foreach type [dict keys $localTypeInfo] { set typeArr($type) 1 } if {[string equal $parent {}]} { $doc documentElement schema $schema setAttribute \ - xmlns:s "http://www.w3.org/2001/XMLSchema" + xmlns:xs "http://www.w3.org/2001/XMLSchema" } else { - $parent appendChild [$doc createElement s:schema schema] + $parent appendChild [$doc createElement xs:schema schema] } $schema setAttribute \ elementFormDefault qualified \ targetNamespace $targetNamespace foreach baseType [lsort -dictionary [array names typeArr]] { - ::log::log debug "Outputing $baseType" - $schema appendChild [$doc createElement s:element elem] - $elem setAttribute name $baseType - $elem setAttribute type ${serviceName}:${baseType} - $schema appendChild [$doc createElement s:complexType comp] - $comp setAttribute name $baseType - $comp appendChild [$doc createElement s:sequence seq] + if {$version ne {} && [dict exists $localTypeInfo $baseType version]} { + if {![check_version [dict get $localTypeInfo $baseType version] $version]} { + continue + } + } + ::log::logsubst debug {Outputing $baseType} + $schema appendChild [$doc createElement xs:element elem] + set name [lindex [split $baseType {:}] end] + $elem setAttribute name $name + $elem setAttribute type $baseType + $schema appendChild [$doc createElement xs:complexType comp] + $comp setAttribute name $name + $comp appendChild [$doc createElement xs:sequence seq] set baseTypeInfo [dict get $localTypeInfo $baseType definition] - ::log::log debug "\t parts {$baseTypeInfo}" + ::log::logsubst debug {\t parts {$baseTypeInfo}} foreach {field tmpTypeInfo} $baseTypeInfo { - $seq appendChild [$doc createElement s:element tmp] + if {$version ne {} && [dict exists $tmpTypeInfo version]} { + if {![check_version [dict get $tmpTypeInfo version] $version]} { + continue + } + } + $seq appendChild [$doc createElement xs:element tmp] set tmpType [dict get $tmpTypeInfo type] - ::log::log debug "Field $field of $tmpType" + ::log::logsubst debug {Field $field of $tmpType} foreach {name value} [getTypeWSDLInfo $mode $serviceName $field $tmpType] { $tmp setAttribute $name $value } } } @@ -1043,24 +1322,28 @@ # ########################################################################### proc ::WS::Utils::getTypeWSDLInfo {mode serviceName field type} { set typeInfo {maxOccurs 1 minOccurs 1 name * type *} dict set typeInfo name $field - set typeList [TypeInfo $mode $serviceName $type] + set typeList [TypeInfo $mode $serviceName $type 1] if {[lindex $typeList 0] == 0} { - dict set typeInfo type s:[string trimright $type {()}] + dict set typeInfo type xs:[string trimright $type {()?}] } else { - dict set typeInfo type $serviceName:[string trimright $type {()}] + dict set typeInfo type $serviceName:[string trimright $type {()?}] } if {[lindex $typeList 1]} { dict set typeInfo maxOccurs unbounded } + if {[lindex $typeList 2]} { + dict set typeInfo minOccurs 0 + } return $typeInfo } - + + ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # @@ -1075,10 +1358,11 @@ # mode - The mode, Client or Server # serviceName - The service name the type is defined in # node - The base node for the type. # type - The name of the type # root - The root node of the document +# isArray - We are looking for array elements # # Returns : A dictionary object for a given type. # # Side-Effects : None # @@ -1096,29 +1380,56 @@ # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # +# 2.4.2 2018-05-14 H.Oehlmann Add support to translate namespace prefixes +# in attribute values or text values. +# New parameter "xnsDistantToLocalDict". # ########################################################################### -proc ::WS::Utils::convertTypeToDict {mode serviceName node type root} { +proc ::WS::Utils::convertTypeToDict { + mode serviceName node type root {isArray 0} {xnsDistantToLocalDict {}} +} { variable typeInfo variable mutableTypeInfo variable options - ::log::log debug [list ::WS::Utils::convertTypeToDict $mode $serviceName $node $type $root] - set typeDefInfo [dict get $typeInfo $mode $serviceName $type] - ::log::log debug "\t type def = {$typeDefInfo}" + if {$options(valueAttrCompatiblityMode)} { + set valueAttr {} + } else { + set valueAttr {::value} + } + set xsiNsUrl {http://www.w3.org/2001/XMLSchema-instance} + ::log::logsubst debug {Entering [info level 0]} + if {[dict exists $typeInfo $mode $serviceName $type]} { + set typeName $type + } elseif {[dict exists $typeInfo $mode $serviceName $serviceName:$type]} { + set typeName $serviceName:$type + } else { + ## + ## Assume this is a simple type + ## + set baseType [::WS::Utils::GetServiceTypeDef $mode $serviceName $type] + if {[string equal $baseType {XML}]} { + set results [$node asXML] + } else { + set results [$node asText] + } + return $results + } + set typeDefInfo [dict get $typeInfo $mode $serviceName $typeName] + ::log::logsubst debug {\t type def = {$typeDefInfo}} set xns [dict get $typeDefInfo xns] if {[$node hasAttribute href]} { set node [GetReferenceNode $root [$node getAttribute href]] } - ::log::log debug "\t XML of node is [$node asXML]" - if {[info exists mutableTypeInfo([list $mode $serviceName $type])]} { - set type [(*)[lindex mutableTypeInfo([list $mode $serviceName $type]) 0] $mode $serviceName $type $xns $node] - set typeDefInfo [dict get $typeInfo $mode $serviceName $type] - ::log::log debug "\t type def replaced with = {$typeDefInfo}" + ::log::logsubst debug {\t XML of node is [$node asXML]} + if {[info exists mutableTypeInfo([list $mode $serviceName $typeName])]} { + set type [(*)[lindex mutableTypeInfo([list $mode $serviceName $type]) 0] $mode $serviceName $typeName $xns $node] + set typeDefInfo [dict get $typeInfo $mode $serviceName $typeName] + ::log::logsubst debug {\t type def replaced with = {$typeDefInfo}} } set results {} #if {$options(parseInAttr)} { # foreach attr [$node attributes] { # if {[llength $attr] == 1} { @@ -1125,125 +1436,225 @@ # dict set results $attr [$node getAttribute $attr] # } # } #} set partsList [dict keys [dict get $typeDefInfo definition]] - ::log::log debug "\t partsList is {$partsList}" + ::log::logsubst debug {\t partsList is {$partsList}} + set arrayOverride [expr {$isArray && ([llength $partsList] == 1)}] foreach partName $partsList { set partType [dict get $typeDefInfo definition $partName type] + set partType [string trimright $partType {?}] + if {[dict exists $typeDefInfo definition $partName allowAny] && [dict get $typeDefInfo definition $partName allowAny]} { + set allowAny 1 + } else { + set allowAny 0 + } if {[string equal $partName *] && [string equal $partType *]} { ## ## Type infomation being handled dynamically for this part ## set savedTypeInfo $typeInfo parseDynamicType $mode $serviceName $node $type - set tmp [convertTypeToDict $mode $serviceName $node $type $root] + set tmp [convertTypeToDict $mode $serviceName $node $type $root 0 $xnsDistantToLocalDict] foreach partName [dict keys $tmp] { dict set results $partName [dict get $tmp $partName] } set typeInfo $savedTypeInfo continue } set partXns $xns catch {set partXns [dict get $typeInfo $mode $serviceName $partType xns]} set typeInfoList [TypeInfo $mode $serviceName $partType] - ::log::log debug "\tpartName $partName partType $partType xns $xns typeInfoList $typeInfoList" + set tmpTypeInfo [::WS::Utils::GetServiceTypeDef $mode $serviceName $partType] + ::log::logsubst debug {\tpartName $partName partType $partType xns $xns typeInfoList $typeInfoList} ## ## Try for fully qualified name ## - ::log::log debug "Trying #1 [list $node selectNodes $partXns:$partName]" + ::log::logsubst debug {Trying #1 [list $node selectNodes $partXns:$partName]} if {[catch {llength [set item [$node selectNodes $partXns:$partName]]} len] || ($len == 0)} { - ::log::log debug "Trying #2 [list $node selectNodes $xns:$partName]" + ::log::logsubst debug {Trying #2 [list $node selectNodes $xns:$partName]} if {[catch {llength [set item [$node selectNodes $xns:$partName]]} len] || ($len == 0)} { ## ## Try for unqualified name ## - ::log::log debug "Trying #3 [list $node selectNodes $partName]" + ::log::logsubst debug {Trying #3 [list $node selectNodes $partName]} if {[catch {llength [set item [$node selectNodes $partName]]} len] || ($len == 0)} { ::log::log debug "Trying #4 -- search of children" set item {} set matchList [list $partXns:$partName $xns:$partName $partName] foreach childNode [$node childNodes] { + set nodeType [$childNode nodeType] + ::log::logsubst debug {\t\t Looking at {[$childNode localName],[$childNode nodeName]} ($allowAny,$isArray,$nodeType,$partName)} # From SOAP1.1 Spec: # Within an array value, element names are not significant # for distinguishing accessors. Elements may have any name. # Here we don't need check the element name, just simple check # it's a element node - if { [$childNode nodeType] != "ELEMENT_NODE" } { - continue + if {$allowAny || ($arrayOverride && [string equal $nodeType "ELEMENT_NODE"])} { + ::log::logsubst debug {\t\t Found $partName [$childNode asXML]} + lappend item $childNode } - lappend item $childNode } if {![string length $item]} { ::log::log debug "\tSkipping" continue } + } else { + ::log::logsubst debug {\t\t Found [llength $item] $partName} } + } else { + ::log::logsubst debug {\t\t Found [llength $item] $partName} } + } else { + ::log::logsubst debug {\t\t Found [llength $item] $partName} } set origItemList $item set newItemList {} foreach item $origItemList { if {[$item hasAttribute href]} { set oldXML [$item asXML] + ::log::logsubst debug {\t\t Replacing: $oldXML} set item [GetReferenceNode $root [$item getAttribute href]] - ::log::log debug "\t\t Replacing: $oldXML" - ::log::log debug "\t\t With: [$item asXML]" + ::log::logsubst debug {\t\t With: [$item asXML]} } lappend newItemList $item } set item $newItemList - switch $typeInfoList { + set isAbstract false + if {[dict exists $typeInfo $mode $serviceName $partType abstract]} { + set isAbstract [dict get $typeInfo $mode $serviceName $partType abstract] + } + switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## + if {[dict exists $tmpTypeInfo base]} { + set baseType [dict get $tmpTypeInfo base] + } else { + set baseType string + } if {$options(parseInAttr)} { - foreach attr [$item attributes] { - if {[llength $attr] == 1} { - dict set results $partName $attr [$item getAttribute $attr] + foreach attrList [$item attributes] { + catch { + lassign $attrList attr nsAlias nsUrl + if {[string equal $nsUrl $xsiNsUrl]} { + set attrValue [$item getAttribute ${nsAlias}:$attr] + dict set results $partName ::$attr $attrValue + } elseif {![string equal $nsAlias {}]} { + set attrValue [$item getAttribute ${nsAlias}:$attr] + dict set results $partName $attr $attrValue + } else { + set attrValue [$item getAttribute $attr] + dict set results $partName $attr $attrValue + } } } - dict set results $partName {} [$item asText] + if {[string equal $baseType {XML}]} { + dict set results $partName $valueAttr [$item asXML] + } else { + dict set results $partName $valueAttr [$item asText] + } } else { - dict set results $partName [$item asText] + if {[string equal $baseType {XML}]} { + dict set results $partName [$item asXML] + } else { + dict set results $partName [$item asText] + } } } {0 1} { ## ## Simple array ## + if {[dict exists $tmpTypeInfo base]} { + set baseType [dict get $tmpTypeInfo base] + } else { + set baseType string + } set tmp {} foreach row $item { if {$options(parseInAttr)} { set rowList {} - foreach attr [$item attributes] { - if {[llength $attr] == 1} { - append rowList $attr [$row getAttribute $attr] + foreach attrList [$row attributes] { + catch { + lassign $attrList attr nsAlias nsUrl + if {[string equal $nsUrl $xsiNsUrl]} { + set attrValue [$row getAttribute ${nsAlias}:$attr] + lappend rowList ::$attr $attrValue + } elseif {![string equal $nsAlias {}]} { + set attrValue [$row getAttribute ${nsAlias}:$attr] + lappend rowList $attr $attrValue + } else { + set attrValue [$row getAttribute $attr] + lappend rowList $attr $attrValue + } } } - lappend rowList {} [$row asText] + if {[string equal $baseType {XML}]} { + lappend rowList $valueAttr [$row asXML] + } else { + lappend rowList $valueAttr [$row asText] + } lappend tmp $rowList } else { - lappend tmp [$row asText] + if {[string equal $baseType {XML}]} { + lappend tmp [$row asXML] + } else { + lappend tmp [$row asText] + } } } dict set results $partName $tmp } {1 0} { ## ## Non-simple non-array ## if {$options(parseInAttr)} { - foreach attr [$item attributes] { - if {[llength $attr] == 1} { - dict set results $partName $attr [$item getAttribute $attr] + ## Translate an abstract type from the WSDL to a type given + ## in the response + ## Example xml response from bug 584bfb772: + ## + ## + ## + ## + ## Layers + ## + ## + ## + ## The element FullExtend gets type "tns:EnvelopeN". + ## + ## xnsDistantToLocalDict + if {$isAbstract && [$item hasAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]} { + # partType is now tns::EnvelopeN + set partType [XNSDistantToLocal $xnsDistantToLocalDict \ + [$item getAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]] + + # Remove this type attribute from the snippet. + # So, it is not handled in the loop below. + $item removeAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type + } + foreach attrList [$item attributes] { + catch { + lassign $attrList attr nsAlias nsUrl + if {[string equal $nsUrl $xsiNsUrl]} { + set attrValue [$item getAttribute ${nsAlias}:$attr] + dict set results $partName ::$attr $attrValue + } elseif {![string equal $nsAlias {}]} { + set attrValue [$item getAttribute ${nsAlias}:$attr] + dict set results $partName $attr $attrValue + } else { + set attrValue [$item getAttribute $attr] + dict set results $partName $attr $attrValue + } } } - dict set results $partName {} [convertTypeToDict $mode $serviceName $item $partType $root] + dict set results $partName $valueAttr [convertTypeToDict $mode $serviceName $item $partType $root 0 $xnsDistantToLocalDict] } else { - dict set results $partName [convertTypeToDict $mode $serviceName $item $partType $root] + dict set results $partName [convertTypeToDict $mode $serviceName $item $partType $root 0 $xnsDistantToLocalDict] } } {1 1} { ## ## Non-simple array @@ -1251,28 +1662,99 @@ set partType [string trimright $partType {()}] set tmp [list] foreach row $item { if {$options(parseInAttr)} { set rowList {} - foreach attr [$item attributes] { - if {[llength $attr] == 1} { - append rowList $attr [$row getAttribute $attr] + if {$isAbstract && [$row hasAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]} { + set partType [$row getAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type] + $row removeAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type + } + foreach attrList [$row attributes] { + catch { + lassign $attrList attr nsAlias nsUrl + if {[string equal $nsUrl $xsiNsUrl]} { + set attrValue [$row getAttribute ${nsAlias}:$attr] + lappend rowList ::$attr $attrValue + } elseif {![string equal $nsAlias {}]} { + set attrValue [$row getAttribute ${nsAlias}:$attr] + lappend rowList $attr $attrValue + } else { + set attrValue [$row getAttribute $attr] + lappend rowList $attr $attrValue + } } } - lappend rowList {} [convertTypeToDict $mode $serviceName $row $partType $root] + lappend rowList $valueAttr [convertTypeToDict $mode $serviceName $row $partType $root 1 $xnsDistantToLocalDict] lappend tmp $rowList } else { - lappend tmp [convertTypeToDict $mode $serviceName $row $partType $root] + lappend tmp [convertTypeToDict $mode $serviceName $row $partType $root 1 $xnsDistantToLocalDict] } } dict set results $partName $tmp } + default { + ## + ## Placed here to shut up tclchecker + ## + } } } - ::log::log debug [list Leaving ::WS::Utils::convertTypeToDict with $results] + ::log::logsubst debug {Leaving ::WS::Utils::convertTypeToDict with result '$results'} return $results } + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Utils::XNSDistantToLocal +# +# Description : Get a reference node. +# +# Arguments : +# xnsDistantToLocalDict - Dict to translate distant to local NS prefixes +# typeDistant - Type string with possible distant namespace prefix +# +# Returns : type with local namespace prefix +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Harald Oehlmann +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 2.4.2 2017-11-03 H.Oehlmann Initial version +# +########################################################################### +proc ::WS::Utils::XNSDistantToLocal {xnsDistantToLocalDict type} { + set collonPos [string first ":" $type] + # check for namespace prefix present + if {-1 < $collonPos} { + set prefixDistant [string range $type 0 $collonPos-1] + if {[dict exists $xnsDistantToLocalDict $prefixDistant]} { + set type [dict get $xnsDistantToLocalDict $prefixDistant][string range $type $collonPos end] + log::logsubst debug {Mapped distant namespace prefix '$prefixDistant' to type '$type'} + } else { + log::logsubst warning {Distant type '$type' does not have a known namespace prefix ([dict keys $xnsDistantToLocalDict])} + } + } + return $type +} + ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. @@ -1334,10 +1816,13 @@ # service - The service name the type is defined in # parent - The parent node of the type. # doc - The document # dict - The dictionary to convert # type - The name of the type +# forceNs - Force the response to use a namespace +# enforceRequired - Boolean setting for enforcing required vars be set +# version - Requested service version # # Returns : None # # Side-Effects : None # @@ -1354,172 +1839,474 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2 11/13/2018 J.Cone Version support # # ########################################################################### -proc ::WS::Utils::convertDictToType {mode service doc parent dict type} { - ::log::log debug "Entering ::WS::Utils::convertDictToType $mode $service $doc $parent {$dict} $type" +proc ::WS::Utils::convertDictToType {mode service doc parent dict type {forceNs 0} {enforceRequired 0} {version {}}} { + ::log::logsubst debug {Entering [info level 0]} + # ::log::logsubst debug { Parent xml: [$parent asXML]} variable typeInfo variable simpleTypes variable options variable standardAttributes - - if {!$options(UseNS)} { - return [::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent $dict $type] - } - - set typeInfoList [TypeInfo $mode $service $type] - if {[lindex $typeInfoList 0]} { - set itemList [dict get $typeInfo $mode $service $type definition] - set xns [dict get $typeInfo $mode $service $type xns] - } else { - set xns $simpleTypes($mode,$service,$type) - set itemList [list $type {type string}] - } - if {[info exists mutableTypeInfo([list $mode $service $type])]} { - set type [(*)[lindex mutableTypeInfo([list $mode $service $type]) 0] $mode $service $type $xns $dict] - set typeInfoList [TypeInfo $mode $service $type] - if {[lindex $typeInfoList 0]} { - set itemList [dict get $typeInfo $mode $service $type definition] - set xns [dict get $typeInfo $mode $service $type xns] - } else { - set xns $simpleTypes($mode,$service,$type) - set itemList [list $type {type string}] - } - } - ::log::log debug "\titemList is {$itemList} in $xns" - set fieldList {} - foreach {itemName itemDef} $itemList { - lappend fieldList $itemName - set itemType [dict get $itemDef type] - ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} itemType ={$itemType}" - set typeInfoList [TypeInfo $mode $service $itemType] - if {![dict exists $dict $itemName]} { - continue - } - set tmpInfo [GetServiceTypeDef $mode $service [string trimright $itemType {()}]] - if {[dict exists $tmpInfo xns]} { - set itemXns [dict get $tmpInfo xns] - } else { - set itemXns $xns - } - set attrList {} - foreach key [dict keys $itemDef] { - if {[lsearch -exact $standardAttributes $key] == -1} { - lappend attrList $key [dict get $itemDef $key] - ::log::log debug "key = {$key} standardAttributes = {$standardAttributes}" - } - } - ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} itemXns = {$itemXns} tmpInfo = {$tmpInfo} attrList = {$attrList}" - switch $typeInfoList { + variable currentNs + + if {!$options(UseNS)} { + return [::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent $dict $type $enforceRequired $version] + } + + if {$options(valueAttrCompatiblityMode)} { + set valueAttr {} + } else { + set valueAttr {::value} + } + set typeInfoList [TypeInfo $mode $service $type] + set type [string trimright $type {?}] + ::log::logsubst debug {\t typeInfoList = {$typeInfoList}} + if {[dict exists $typeInfo $mode $service $service:$type]} { + set typeName $service:$type + } else { + set typeName $type + } + if {$version ne {} && [dict exists $typeInfo $mode $service $typeName version]} { + if {![check_version [dict get $typeInfo $mode $service $typeName version] $version]} { + return + } + } + set itemList {} + if {[lindex $typeInfoList 0] && [dict exists $typeInfo $mode $service $typeName definition]} { + set itemList [dict get $typeInfo $mode $service $typeName definition] + set xns [dict get $typeInfo $mode $service $typeName xns] + } else { + if {[info exists simpleTypes($mode,$service,$typeName)]} { + set xns [dict get $simpleTypes($mode,$service,$typeName) xns] + } elseif {[info exists simpleTypes($mode,$service,$currentNs:$typeName)]} { + set xns [dict get $simpleTypes($mode,$service,$currentNs:$typeName) xns] + } else { + error "Simple type cannot be found: $typeName" + } + set itemList [list $typeName {type string}] + } + if {[info exists mutableTypeInfo([list $mode $service $typeName])]} { + set typeName [(*)[lindex mutableTypeInfo([list $mode $service $type]) 0] $mode $service $type $xns $dict] + set typeInfoList [TypeInfo $mode $service $typeName] + if {[lindex $typeInfoList 0]} { + set itemList [dict get $typeInfo $mode $service $typeName definition] + set xns [dict get $typeInfo $mode $service $typeName xns] + } else { + if {[info exists simpleTypes($mode,$service,$typeName)]} { + set xns [dict get $simpleTypes($mode,$service,$typeName) xns] + } elseif {[info exists simpleTypes($mode,$service,$currentNs:$typeName)]} { + set xns [dict get $simpleTypes($mode,$service,$currentNs:$typeName) xns] + } else { + error "Simple type cannot be found: $typeName" + } + set itemList [list $type {type string}] + } + } + ::log::logsubst debug {\titemList is {$itemList} in $xns} + set entryNs $currentNs + if {!$forceNs} { + set currentNs $xns + } + set fieldList {} + foreach {itemName itemDef} $itemList { + if {[dict exists $itemDef version] && ![check_version [dict get $itemDef version] $version]} { + continue + } + set baseName [lindex [split $itemName {:}] end] + lappend fieldList $itemName + set itemType [dict get $itemDef type] + ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} itemType ={$itemType}} + set typeInfoList [TypeInfo $mode $service $itemType 1] + ::log::logsubst debug {Expr [list ![dict exists $dict $itemName] && ![dict exists $dict $baseName]]} + if {![dict exists $dict $itemName] && ![dict exists $dict $baseName]} { + ::log::logsubst debug {Neither {$itemName} nor {$baseName} are in dictionary {$dict}, skipping} + # If required parameters are being enforced and this field is not optional, throw an error + if {$enforceRequired && ![lindex $typeInfoList 2]} { + error "Required field $itemName is missing from response" + } + continue + } elseif {[dict exists $dict $baseName]} { + set useName $baseName + } else { + set useName $itemName + } + set itemXns $xns + set tmpInfo [GetServiceTypeDef $mode $service [string trimright $itemType {()?}]] + if {$options(useTypeNs) && [dict exists $tmpInfo xns]} { + set itemXns [dict get $tmpInfo xns] + } + set attrList {} + if {$options(useTypeNs) && [string equal $itemXns xs]} { + set itemXns $xns + } + if {$options(nsOnChangeOnly) && [string equal $itemXns $currentNs]} { + set itemXns {} + } + foreach key [dict keys $itemDef] { + if {[lsearch -exact $standardAttributes $key] == -1 && $key ne "isList" && $key ne "xns"} { + lappend attrList $key [dict get $itemDef $key] + ::log::logsubst debug {key = {$key} standardAttributes = {$standardAttributes}} + } + } + ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} itemXns = {$itemXns} tmpInfo = {$tmpInfo} attrList = {$attrList}} + set isAbstract false + set baseType [string trimright $itemType {()?}] + if {$options(genOutAttr) && [dict exists $typeInfo $mode $service $baseType abstract]} { + set isAbstract [dict get $typeInfo $mode $service $baseType abstract] + } + ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} isAbstract = {$isAbstract}} + # Strip the optional flag off the typeInfoList + set typeInfoList [lrange $typeInfoList 0 1] + switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## - $parent appendChild [$doc createElement $itemXns:$itemName retNode] + if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { + $parent appendChild [$doc createElement $itemName retNode] + } else { + $parent appendChild [$doc createElement $itemXns:$itemName retNode] + } if {$options(genOutAttr)} { - set dictList [dict keys [dict get $dict $itemName]] + set resultValue {} + set dictList [dict keys [dict get $dict $useName]] + #::log::log debug "$useName <$dict> '$dictList'" foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { - if {[string equal $attr {}]} { - lappend attrList $attr [dict get $dict $itemName $attr] - } else { - set resultValue [dict get $dict $itemName $attr] - } - } - } else { - set resultValue [dict get $dict $itemName] - } - $retNode appendChild [$doc createTextNode $resultValue] + if {[string equal $attr $valueAttr]} { + set resultValue [dict get $dict $useName $attr] + } elseif {[string match {::*} $attr]} { + set baseAttr [string range $attr 2 end] + set attrValue [dict get $dict $useName $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue + } else { + lappend attrList $attr [dict get $dict $useName $attr] + } + } + } else { + set resultValue [dict get $dict $useName] + } + if {[dict exists $tmpInfo base] && [string equal [dict get $tmpInfo base] {XML}]} { + $retNode appendXML $resultValue + } else { + $retNode appendChild [$doc createTextNode $resultValue] + } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } {0 1} { ## ## Simple array ## - set dataList [dict get $dict $itemName] + set dataList [dict get $dict $useName] + #::log::log debug "\t\t [llength $dataList] rows {$dataList}" foreach row $dataList { - $parent appendChild [$doc createElement $itemXns:$itemName retNode] + if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { + $parent appendChild [$doc createElement $itemName retNode] + } else { + $parent appendChild [$doc createElement $itemXns:$itemName retNode] + } if {$options(genOutAttr)} { set dictList [dict keys $row] + ::log::logsubst debug {<$row> '$dictList'} + set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { - if {[string equal $attr {}]} { - lappend attrList $attr [dict get $row $attr] - } else { + if {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] + } elseif {[string match {::*} $attr]} { + set baseAttr [string range $attr 2 end] + set attrValue [dict get $row $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue + } else { + lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } - $retNode appendChild [$doc createTextNode $resultValue] + if {[dict exists $tmpInfo base] && [string equal [dict get $tmpInfo base] {XML}]} { + $retNode appendXML $resultValue + } else { + $retNode appendChild [$doc createTextNode $resultValue] + } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } } {1 0} { ## ## Non-simple non-array ## - $parent appendChild [$doc createElement $itemXns:$itemName retNode] + if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { + $parent appendChild [$doc createElement $itemName retNode] + } else { + $parent appendChild [$doc createElement $itemXns:$itemName retNode] + } if {$options(genOutAttr)} { - set dictList [dict keys [dict get $dict $itemName]] + #::log::log debug "Before 150 useName {$useName} dict {$dict}" + set dictList [dict keys [dict get $dict $useName]] + #::log::log debug "$useName <$dict> '$dictList'" + set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { - if {[string equal $attr {}]} { - lappend attrList $attr [dict get $dict $itemName $attr] - } else { - set resultValue [dict get $dict $itemName $attr] - } - } - } else { - set resultValue [dict get $dict $itemName] - } - convertDictToType $mode $service $doc $retNode $resultValue $itemType + if {$isAbstract && [string equal $attr {::type}]} { + set itemType [dict get $dict $useName $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $itemType + set itemType $itemXns:$itemType + } elseif {[string equal $attr $valueAttr]} { + set resultValue [dict get $dict $useName $attr] + } elseif {[string match {::*} $attr]} { + set baseAttr [string range $attr 2 end] + set attrValue [dict get $dict $useName $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue + } else { + lappend attrList $attr [dict get $dict $useName $attr] + } + } + } else { + set resultValue [dict get $dict $useName] + } + if {![string equal $currentNs $itemXns] && ![string equal $itemXns {}]} { + set tmpNs $currentNs + set currentNs $itemXns + convertDictToType $mode $service $doc $retNode $resultValue $itemType $forceNs $enforceRequired $version + } else { + convertDictToType $mode $service $doc $retNode $resultValue $itemType $forceNs $enforceRequired $version + } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } {1 1} { ## ## Non-simple array ## - set dataList [dict get $dict $itemName] - set tmpType [string trimright $itemType ()] + set dataList [dict get $dict $useName] + #::log::log debug "\t\t [llength $dataList] rows {$dataList}" foreach row $dataList { - $parent appendChild [$doc createElement $itemXns:$itemName retNode] + if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { + $parent appendChild [$doc createElement $itemName retNode] + } else { + $parent appendChild [$doc createElement $itemXns:$itemName retNode] + } if {$options(genOutAttr)} { set dictList [dict keys $row] + set resultValue {} + #::log::log debug "<$row> '$dictList'" foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { - if {[string equal $attr {}]} { - lappend attrList $attr [dict get $row $attr] - } else { + if {$isAbstract && [string equal $attr {::type}]} { + set tmpType [dict get $row $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $tmpType + set tmpType $itemXns:$tmpType + } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] + } elseif {[string match {::*} $attr]} { + set baseAttr [string range $attr 2 end] + set attrValue [dict get $row $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue + } else { + lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } - convertDictToType $mode $service $doc $retNode $resultValue $tmpType + if {[string index $itemType end] eq {?}} { + set tmpType "[string trimright $itemType {()?}]?" + } else { + set tmpType [string trimright $itemType {()}] + } + if {![string equal $currentNs $itemXns] && ![string equal $itemXns {}]} { + set tmpNs $currentNs + set currentNs $itemXns + convertDictToType $mode $service $doc $retNode $resultValue $tmpType $forceNs $enforceRequired $version + } else { + convertDictToType $mode $service $doc $retNode $resultValue $tmpType $forceNs $enforceRequired $version + } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } + } + default { + ## + ## Placed here to shut up tclchecker + ## } } #if {$options(genOutAttr)} { # set dictList [dict keys $dict] # foreach attr [lindex [::struct::set intersect3 $fieldList $dictList] end] { # $parent setAttribute $attr [dict get $dict $attr] # } #} } - return; + set currentNs $entryNs + ::log::logsubst debug {Leaving ::WS::Utils::convertDictToType with xml: [$parent asXML]} + return +} + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Utils::convertDictToJson +# +# Description : Convert a dictionary object into a JSON tree. +# +# Arguments : +# mode - The mode, Client or Server +# service - The service name the type is defined in +# doc - The document (yajltcl) +# dict - The dictionary to convert +# type - The name of the type +# enforceRequired - Boolean setting for enforcing required vars be set +# version - The requested service version +# +# Returns : None +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Jeff Lawson +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 03/23/2011 J.Lawson Initial version +# 2 11/13/2018 J.Cone Version support +# +# +########################################################################### +proc ::WS::Utils::convertDictToJson {mode service doc dict type {enforceRequired 0} {version {}}} { + ::log::logsubst debug {Entering [info level 0]} + variable typeInfo + variable simpleTypes + variable simpleTypesJson + variable options + variable standardAttributes + + set typeInfoList [TypeInfo $mode $service $type] + set type [string trimright $type {?}] + if {[dict exists $typeInfo $mode $service $service:$type]} { + set typeName $service:$type + } else { + set typeName $type + } + if {$version ne {} && [dict exists $typeInfo $mode $service $typeName version]} { + if {![check_version [dict get $typeInfo $mode $service $typeName version] $version]} { + return + } + } + set itemList {} + if {[lindex $typeInfoList 0] && [dict exists $typeInfo $mode $service $typeName definition]} { + set itemList [dict get $typeInfo $mode $service $typeName definition] + set xns [dict get $typeInfo $mode $service $typeName xns] + } else { + set xns $simpleTypes($mode,$service,$typeName) + set itemList [list $typeName {type string}] + } + if {[info exists mutableTypeInfo([list $mode $service $typeName])]} { + set typeName [(*)[lindex mutableTypeInfo([list $mode $service $type]) 0] $mode $service $type $xns $dict] + set typeInfoList [TypeInfo $mode $service $typeName] + if {[lindex $typeInfoList 0]} { + set itemList [dict get $typeInfo $mode $service $typeName definition] + } else { + set itemList [list $type {type string}] + } + } + ::log::logsubst debug {\titemList is {$itemList}} + set fieldList {} + foreach {itemName itemDef} $itemList { + if {[dict exists $itemDef version] && ![check_version [dict get $itemDef version] $version]} { + continue + } + lappend fieldList $itemName + set itemType [dict get $itemDef type] + ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} itemType = {$itemType}} + set typeInfoList [TypeInfo $mode $service $itemType 1] + if {![dict exists $dict $itemName]} { + if {$enforceRequired && ![lindex $typeInfoList 2]} { + error "Required field $itemName is missing from response" + } + continue + } + + if {[info exists simpleTypesJson([string trimright $itemType {()?}])]} { + set yajlType $simpleTypesJson([string trimright $itemType {()?}]) + } else { + set yajlType "string" + } + + ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}} + set typeInfoList [lrange $typeInfoList 0 1] + switch -- $typeInfoList { + {0 0} { + ## + ## Simple non-array + ## + set resultValue [dict get $dict $itemName] + $doc string $itemName $yajlType $resultValue + } + {0 1} { + ## + ## Simple array + ## + set dataList [dict get $dict $itemName] + $doc string $itemName array_open + foreach row $dataList { + $doc $yajlType $row + } + $doc array_close + } + {1 0} { + ## + ## Non-simple non-array + ## + $doc string $itemName map_open + set resultValue [dict get $dict $itemName] + convertDictToJson $mode $service $doc $resultValue $itemType $enforceRequired $version + $doc map_close + } + {1 1} { + ## + ## Non-simple array + ## + set dataList [dict get $dict $itemName] + $doc string $itemName array_open + if {[string index $itemType end] eq {?}} { + set tmpType "[string trimright $itemType {()?}]?" + } else { + set tmpType [string trimright $itemType {()}] + } + foreach row $dataList { + $doc map_open + convertDictToJson $mode $service $doc $row $tmpType $enforceRequired $version + $doc map_close + } + $doc array_close + } + } + } + return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -1535,10 +2322,12 @@ # mode - The mode, Client or Server # service - The service name the type is defined in # parent - The parent node of the type. # dict - The dictionary to convert # type - The name of the type +# enforceRequired - Boolean setting for enforcing required vars be set +# version - The requested service version # # Returns : None # # Side-Effects : None # @@ -1555,55 +2344,93 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version +# 2 11/13/2018 J.Cone Version support # # ########################################################################### -proc ::WS::Utils::convertDictToTypeNoNs {mode service doc parent dict type} { - ::log::log debug "Entering ::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent {$dict} $type" +proc ::WS::Utils::convertDictToTypeNoNs {mode service doc parent dict type {enforceRequired 0} {version {}}} { + ::log::logsubst debug {Entering [info level 0]} + # ::log::log debug " Parent xml: [$parent asXML]" variable typeInfo variable simpleTypes + variable options + variable standardAttributes + variable currentNs + if {$version ne {} && [dict exists $typeInfo $mode $service $type version]} { + if {![check_version [dict get $typeInfo $mode $service $type version] $version]} { + return + } + } + if {$options(valueAttrCompatiblityMode)} { + set valueAttr {} + } else { + set valueAttr {::value} + } set typeInfoList [TypeInfo $mode $service $type] if {[lindex $typeInfoList 0]} { set itemList [dict get $typeInfo $mode $service $type definition] set xns [dict get $typeInfo $mode $service $type xns] } else { - set xns $simpleTypes($mode,$service,$type) + if {[info exists simpleTypes($mode,$service,$type)]} { + set xns [dict get $simpleTypes($mode,$service,$type) xns] + } elseif {[info exists simpleTypes($mode,$service,$currentNs:$type)]} { + set xns [dict get $simpleTypes($mode,$service,$currentNs:$type) xns] + } else { + error "Simple type cannot be found: $type" + } set itemList [list $type {type string}] } - ::log::log debug "\titemList is {$itemList}" + ::log::logsubst debug {\titemList is {$itemList}} foreach {itemName itemDef} $itemList { - ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef}" + if {[dict exists $itemDef version] && ![check_version [dict get $itemDef version] $version]} { + continue + } + ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef}} set itemType [dict get $itemDef type] - set typeInfoList [TypeInfo $mode $service $itemType] + set isAbstract false + set baseType [string trimright $itemType {()?}] + if {$options(genOutAttr) && [dict exists $typeInfo $mode $service $baseType abstract]} { + set isAbstract [dict get $typeInfo $mode $service $baseType abstract] + } + set typeInfoList [TypeInfo $mode $service $itemType 1] if {![dict exists $dict $itemName]} { + if {$enforceRequired && ![lindex $typeInfoList 2]} { + error "Required field $itemName is missing from response" + } continue } set attrList {} foreach key [dict keys $itemDef] { - if {[lsearch -exact $standardAttributes $key] == -1} { + if {[lsearch -exact $standardAttributes $key] == -1 && $key ne "isList" && $key ne "xns"} { lappend attrList $key [dict get $itemDef $key] - ::log::log debug "key = {$key} standardAttributes = {$standardAttributes}" + ::log::logsubst debug {key = {$key} standardAttributes = {$standardAttributes}} } } - ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}" - switch $typeInfoList { + ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}} + set typeInfoList [lrange $typeInfoList 0 1] + switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys [dict get $dict $itemName]] + set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { - if {[string equal $attr {}]} { - lappend attrList $attr [dict get $dict $itemName $attr] - } else { + if {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $itemName $attr] + } elseif {[string match {::*} $attr]} { + set baseAttr [string range $attr 2 end] + set attrValue [dict get $dict $itemName $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue + } else { + lappend attrList $attr [dict get $dict $itemName $attr] } } } else { set resultValue [dict get $dict $itemName] } @@ -1619,15 +2446,20 @@ set dataList [dict get $dict $itemName] foreach row $dataList { $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys $row] + set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { - if {[string equal $attr {}]} { - lappend attrList $attr [dict get $row $attr] - } else { + if {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] + } elseif {[string match {::*} $attr]} { + set baseAttr [string range $attr 2 end] + set attrValue [dict get $row $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue + } else { + lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } @@ -1639,57 +2471,80 @@ } {1 0} { ## ## Non-simple non-array ## - $parent appendChild [$doc createElement $itemName retnode] + $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys [dict get $dict $itemName]] + set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { - if {[string equal $attr {}]} { - lappend attrList $attr [dict get $dict $itemName $attr] - } else { + if {$isAbstract && [string equal $attr {::type}]} { + # *** HaO: useName is never defined + set itemType [dict get $dict $useName $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $itemType + } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $itemName $attr] + } elseif {[string match {::*} $attr]} { + set baseAttr [string range $attr 2 end] + set attrValue [dict get $dict $itemName $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue + } else { + lappend attrList $attr [dict get $dict $itemName $attr] } } } else { set resultValue [dict get $dict $itemName] } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } - convertDictToTypeNoNs $mode $service $doc $retnode $resultValue $itemType + convertDictToTypeNoNs $mode $service $doc $retNode $resultValue $itemType $enforceRequired $version } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $itemName] - set tmpType [string trimright $itemType ()] + set tmpType [string trimright $itemType {()}] foreach row $dataList { - $parent appendChild [$doc createElement $itemName retnode] + $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys $row] + set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { - if {[string equal $attr {}]} { - lappend attrList $attr [dict get $row $attr] - } else { + if {$isAbstract && [string equal $attr {::type}]} { + set tmpType [dict get $row $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $tmpType + } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] + } elseif {[string match {::*} $attr]} { + set baseAttr [string range $attr 2 end] + set attrValue [dict get $row $attr] + $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue + } else { + lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } - convertDictToTypeNoNs $mode $service $doc $retnode $resultValue $tmpType + convertDictToTypeNoNs $mode $service $doc $retNode $resultValue $tmpType $enforceRequired $version } + } + default { + ## + ## Placed here to shut up tclchecker + ## } } } - return; + # ::log::log debug "Leaving ::WS::Utils::convertDictToTypeNoNs with xml: [$parent asXML]" + return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -1698,11 +2553,11 @@ #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::convertDictToEncodedType # # Description : Convert a dictionary object into a XML DOM tree with type -# enconding. +# encoding. # # Arguments : # mode - The mode, Client or Server # service - The service name the type is defined in # parent - The parent node of the type. @@ -1730,68 +2585,145 @@ # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::convertDictToEncodedType {mode service doc parent dict type} { - ::log::log debug "Entering ::WS::Utils::convertDictToType $mode $service $doc $parent {$dict} $type" + ::log::logsubst debug {Entering [info level 0]} variable typeInfo + variable options - set itemList [dict get $typeInfo $mode $service $type definition] - set xns [dict get $typeInfo $mode $service $type xns] - ::log::log debug "\titemList is {$itemList}" + + set typeInfoList [TypeInfo $mode $service $type] + ::log::logsubst debug {\t typeInfoList = {$typeInfoList}} + set type [string trimright $type {?}] + if {[lindex $typeInfoList 0]} { + set itemList [dict get $typeInfo $mode $service $type definition] + set xns [dict get $typeInfo $mode $service $type xns] + } else { + if {[info exists simpleTypes($mode,$service,$type)]} { + set xns [dict get $simpleTypes($mode,$service,$type) xns] + } else { + error "Simple type cannot be found: $type" + } + set itemList [list $type {type string}] + } + if {[info exists mutableTypeInfo([list $mode $service $type])]} { + set type [(*)[lindex mutableTypeInfo([list $mode $service $type]) 0] $mode $service $type $xns $dict] + set typeInfoList [TypeInfo $mode $service $type] + if {[lindex $typeInfoList 0]} { + set itemList [dict get $typeInfo $mode $service $type definition] + set xns [dict get $typeInfo $mode $service $type xns] + } else { + if {[info exists simpleTypes($mode,$service,$type)]} { + set xns [dict get $simpleTypes($mode,$service,$type) xns] + } else { + error "Simple type cannot be found: $type" + } + set itemList [list $type {type string}] + } + } + ::log::logsubst debug {\titemList is {$itemList} in $xns} foreach {itemName itemDef} $itemList { - set itemType [dict get $itemList $itemName type] + set itemType [string trimright [dict get $itemList $itemName type] {?}] set typeInfoList [TypeInfo $mode $service $itemType] + ::log::logsubst debug {\t\t Looking for {$itemName} in {$dict}} if {![dict exists $dict $itemName]} { + ::log::log debug "\t\t Not found, skipping" continue } - switch $typeInfoList { + ::log::logsubst debug {\t\t Type info is {$typeInfoList}} + switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## - $parent appendChild [$doc createElement $xns:$itemName retNode] - $retNode setAttribute xsi:type xs:$itemType + if {[string equal $xns $options(suppressNS)]} { + $parent appendChild [$doc createElement $itemName retNode] + } else { + $parent appendChild [$doc createElement $xns:$itemName retNode] + } + if {![string match {*:*} $itemType]} { + set attrType $xns:$itemType + } else { + set attrType $itemType + } + $retNode setAttribute xsi:type $attrType set resultValue [dict get $dict $itemName] $retNode appendChild [$doc createTextNode $resultValue] } {0 1} { ## ## Simple array ## set dataList [dict get $dict $itemName] set tmpType [string trimright $itemType {()}] + if {![string match {*:*} $itemType]} { + set attrType $xns:$itemType + } else { + set attrType $itemType + } foreach resultValue $dataList { - $parent appendChild [$doc createElement $xns:$itemName retNode] - $retNode setAttribute xsi:type xs:$itemType - set resultValue [dict get $dict $itemName] + if {[string equal $xns $options(suppressNS)]} { + $parent appendChild [$doc createElement $itemName retNode] + } else { + $parent appendChild [$doc createElement $xns:$itemName retNode] + } + $retNode setAttribute xsi:type $attrType $retNode appendChild [$doc createTextNode $resultValue] } } {1 0} { ## ## Non-simple non-array ## - $parent appendChild [$doc createElement $xns:$itemName retNode] - $retNode setAttribute xsi:type xs:$itemType - convertDictToEncodedType $mode $service $doc $retNode [dict get $dict $itemName] $itemType + if {[string equal $xns $options(suppressNS)]} { + $parent appendChild [$doc createElement $itemName retNode] + } else { + $parent appendChild [$doc createElement $xns:$itemName retNode] + } + if {![string match {*:*} $itemType]} { + set attrType $xns:$itemType + } else { + set attrType $itemType + } + $retNode setAttribute xsi:type $attrType + convertDictToEncodedType $mode $service $doc $retNode [dict get $dict $itemName] $itemType } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $itemName] - set tmpType [string trimright $itemType ()] + set tmpType [string trimright $itemType {()}] + if {![string match {*:*} $itemType]} { + set attrType $xns:$itemType + } else { + set attrType $itemType + } + set attrType [string trim $attrType {()?}] + $parent setAttribute xmlns:soapenc {http://schemas.xmlsoap.org/soap/encoding/} + $parent setAttribute soapenc:arrayType [format {%s[%d]} $attrType [llength $dataList]] + $parent setAttribute xsi:type soapenc:Array + #set itemName [$parent nodeName] foreach item $dataList { - $parent appendChild [$doc createElement $xns:$itemName retNode] - $retNode setAttribute xsi:type xs:$itemType + if {[string equal $xns $options(suppressNS)]} { + $parent appendChild [$doc createElement $itemName retNode] + } else { + $parent appendChild [$doc createElement $xns:$itemName retNode] + } + $retNode setAttribute xsi:type $attrType convertDictToEncodedType $mode $service $doc $retNode $item $tmpType } } + default { + ## + ## Placed here to shut up tclchecker + ## + } } } - return; + return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -1799,21 +2731,21 @@ # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::parseDynamicType # -# Description : Parse the Xschme for a dynamically typed part. +# Description : Parse the schema for a dynamically typed part. # # Arguments : # mode - The mode, Client or Server # serviceName - The service name the type is defined in # node - The base node for the type. # type - The name of the type # # Returns : A dictionary object for a given type. # -# Side-Effects : Type deginitions added +# Side-Effects : Type definitions added # # Exception Conditions : None # # Pre-requisite Conditions : None # @@ -1833,31 +2765,31 @@ ########################################################################### proc ::WS::Utils::parseDynamicType {mode serviceName node type} { variable typeInfo variable nsList - ::log::log debug [list ::WS::Utils::parseDynamicType $mode $serviceName $node $type] + ::log::logsubst debug {Entering [info level 0]} foreach child [$node childNodes] { - ::log::log debug "\t Child $child is [$child nodeName]" + ::log::logsubst debug {\t Child $child is [$child nodeName]} } ## ## Get type being defined ## - set schemeNode [$node selectNodes -namespaces $nsList s:schema] - set newTypeNode [$node selectNodes -namespaces $nsList s:schema/s:element] + set schemeNode [$node selectNodes -namespaces $nsList xs:schema] + set newTypeNode [$node selectNodes -namespaces $nsList xs:schema/xs:element] set newTypeName [lindex [split [$newTypeNode getAttribute name] :] end] ## ## Get sibling node to scheme and add tempory type definitions ## ## type == sibing of temp type ## temp_type == newType of newType ## set tnsCountVar [llength [dict get $::WS::Client::serviceArr($serviceName) targetNamespace]] - set tns tnx$tnsCountVar + set tns tns$tnsCountVar set dataNode {} $schemeNode nextSibling dataNode if {![info exists dataNode] || ![string length $dataNode]} { $schemeNode previousSibling dataNode } @@ -1874,11 +2806,11 @@ parseScheme $mode {} $schemeNode $serviceName typeInfo tnsCountVar ## ## All done ## - return; + return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -1920,54 +2852,284 @@ # 1 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseScheme {mode baseUrl schemaNode serviceName serviceInfoVar tnsCountVar} { - ::log::log debug "Entering :WS::Utils::parseScheme $mode $baseUrl $schemaNode $serviceName $serviceInfoVar $tnsCountVar" + ::log::logsubst debug {Entering [info level 0]} - upvar $tnsCountVar tnsCount - upvar $serviceInfoVar serviceInfo + upvar 1 $tnsCountVar tnsCount + upvar 1 $serviceInfoVar serviceInfo variable currentSchema variable nsList variable options - - #if {[dict exists $serviceInfo targetNamespace]} { - # foreach pair [dict get $serviceInfo targetNamespace] { - # if {[string equal $baseUrl [lindex $pair 1]]} { - # ::log::log debug "\t Already definec" - # return - # } - # } - #} + variable unknownRef + set currentSchema $schemaNode + set tmpTargetNs $::WS::Utils::targetNs + foreach attr [$schemaNode attributes] { + set value {?} + catch {set value [$schemaNode getAttribute $attr]} + ::log::logsubst debug {Attribute $attr = $value} + } if {[$schemaNode hasAttribute targetNamespace]} { set xns [$schemaNode getAttribute targetNamespace] + ::log::logsubst debug {In Parse Scheme, found targetNamespace attribute with {$xns}} + set ::WS::Utils::targetNs $xns + } else { + set xns $::WS::Utils::targetNs + } + ::log::logsubst debug {@3a {$xns} {[dict get $serviceInfo tnsList url]}} + if {![dict exists $serviceInfo tnsList url $xns]} { + set tns [format {tns%d} [incr tnsCount]] + dict set serviceInfo targetNamespace $tns $xns + dict set serviceInfo tnsList url $xns $tns + dict set serviceInfo tnsList tns $tns $tns } else { - set xns $baseUrl - } - set tns [format {tns%d} [incr tnsCount]] - dict lappend serviceInfo targetNamespace [list $tns $xns] - ::log::log debug "@3 TNS count for $baseUrl is $tnsCount {$tns}" - - ## - ## Process Imports - ## - foreach element [$schemaNode selectNodes -namespaces $nsList s:import] { - ::log::log debug "\tprocessing $element" + set tns [dict get $serviceInfo tnsList url $xns] + } + ::log::logsubst debug {@3 TNS count for $xns is $tnsCount {$tns}} + + set prevTnsDict [dict get $serviceInfo tnsList tns] + dict set serviceInfo tns {} + foreach itemList [$schemaNode attributes xmlns:*] { + set ns [lindex $itemList 0] + set url [$schemaNode getAttribute xmlns:$ns] + if {[dict exists $serviceInfo tnsList url $url]} { + set tmptns [dict get $serviceInfo tnsList url $url] + } else { + ## + ## Check for hardcoded namespaces + ## + switch -exact -- $url { + http://schemas.xmlsoap.org/wsdl/ { + set tmptns w + } + http://schemas.xmlsoap.org/wsdl/soap/ { + set tmptns d + } + http://www.w3.org/2001/XMLSchema { + set tmptns xs + } + default { + set tmptns tns[incr tnsCount] + } + } + dict set serviceInfo tnsList url $url $tmptns + } + dict set serviceInfo tnsList tns $ns $tmptns + } + + ## + ## Process the scheme in multiple passes to handle forward references and extensions + ## + set pass 1 + set lastUnknownRefCount 0 + array unset unknownRef + while {($pass == 1) || ($lastUnknownRefCount != [array size unknownRef])} { + ::log::logsubst debug {Pass $pass over schema} + incr pass + set lastUnknownRefCount [array size unknownRef] + array unset unknownRef + + foreach element [$schemaNode selectNodes -namespaces $nsList xs:import] { + if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { + ::log::logsubst notice {Import failed due to: {$msg}. Trace: $::errorInfo} + } + } + + foreach element [$schemaNode selectNodes -namespaces $nsList w:import] { + if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { + ::log::logsubst notice {Import failed due to: {$msg}. Trace: $::errorInfo} + } + } + + ::log::logsubst debug {Parsing Element types for $xns as $tns} + foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:element] { + ::log::logsubst debug {\tprocessing $element} + if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { + ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} + } + } + + ::log::logsubst debug {Parsing Attribute types for $xns as $tns} + foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:attribute] { + ::log::logsubst debug {\tprocessing $element} + if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { + ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} + } + } + + ::log::logsubst debug {Parsing Simple types for $xns as $tns} + foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:simpleType] { + ::log::logsubst debug {\tprocessing $element} + if {[catch {parseSimpleType $mode serviceInfo $serviceName $element $tns} msg]} { + ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} + } + } + + ::log::logsubst debug {Parsing Complex types for $xns as $tns} + foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:complexType] { + ::log::logsubst debug {\tprocessing $element} + if {[catch {parseComplexType $mode serviceInfo $serviceName $element $tns} msg]} { + ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} + } + } + } + + set lastUnknownRefCount [array size unknownRef] + foreach {unkRef usedByTypeList} [array get unknownRef] { + foreach usedByType $usedByTypeList { + switch -exact -- $options(StrictMode) { + debug - + warning { + ::log::logsubst $options(StrictMode) {Unknown type reference $unkRef in type $usedByType} + } + error - + default { + ::log::logsubst error {Unknown type reference $unkRef in type $usedByType} + } + } + } + } + + if {$lastUnknownRefCount} { + switch -exact -- $options(StrictMode) { + debug - + warning { + set ::WS::Utils::targetNs $tmpTargetNs + ::log::logsubst $options(StrictMode) {Found $lastUnknownRefCount forward type references: [join [array names unknownRef] {,}]} + } + error - + default { + set ::WS::Utils::targetNs $tmpTargetNs + return \ + -code error \ + -errorcode [list WS $mode UNKREFS [list $lastUnknownRefCount]] \ + "Found $lastUnknownRefCount forward type references: [join [array names unknownRef] {,}]" + } + } + } + + + + ## + ## Ok, one more pass to report errors + ## + set importNodeList [concat \ + [$schemaNode selectNodes -namespaces $nsList xs:import] \ + [$schemaNode selectNodes -namespaces $nsList w:import] \ + ] + foreach element $importNodeList { if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { switch -exact -- $options(StrictMode) { debug - warning { - log::log $options(StrictMode) "Could not parse:\n [$element asXML]" - log::log $options(StrictMode) "\t error was: $msg" + ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} + ::log::logsubst $options(StrictMode) {\t error was: $msg} + } + error - + default { + set errorCode $::errorCode + set errorInfo $::errorInfo + ::log::logsubst error {Could not parse:\n [$element asXML]} + ::log::logsubst error {\t error was: $msg} + ::log::logsubst error {\t error info: $errorInfo} + ::log::logsubst error {\t error in: [lindex [info level 0] 0]} + ::log::logsubst error {\t error code: $errorCode} + set ::WS::Utils::targetNs $tmpTargetNs + return \ + -code error \ + -errorcode $errorCode \ + -errorinfo $errorInfo \ + $msg + } + } + } + } + + ::log::logsubst debug {Parsing Element types for $xns as $tns} + foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:element] { + ::log::logsubst debug {\tprocessing $element} + if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { + switch -exact -- $options(StrictMode) { + debug - + warning { + ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} + ::log::logsubst $options(StrictMode) {\t error was: $msg} + } + error - + default { + set errorCode $::errorCode + set errorInfo $::errorInfo + ::log::logsubst error {Could not parse:\n [$element asXML]} + ::log::logsubst error {\t error was: $msg} + ::log::logsubst error {\t error info: $errorInfo} + ::log::logsubst error {\t last element: $::elementName} + ::log::logsubst error {\t error in: [lindex [info level 0] 0]} + ::log::logsubst error {\t error code: $errorCode} + set ::WS::Utils::targetNs $tmpTargetNs + return \ + -code error \ + -errorcode $errorCode \ + -errorinfo $errorInfo \ + $msg + } + } + } + } + + ::log::logsubst debug {Parsing Attribute types for $xns as $tns} + foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:attribute] { + ::log::logsubst debug {\tprocessing $element} + if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { + switch -exact -- $options(StrictMode) { + debug - + warning { + ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} + ::log::logsubst $options(StrictMode) {\t error was: $msg} + } + error - + default { + set errorCode $::errorCode + set errorInfo $::errorInfo + ::log::logsubst error {Could not parse:\n [$element asXML]} + ::log::logsubst error {\t error was: $msg} + ::log::logsubst error {\t error info: $errorInfo} + ::log::logsubst error {\t error in: [lindex [info level 0] 0]} + ::log::logsubst error {\t error code: $errorCode} + ::log::logsubst error {\t last element: $::elementName} + set ::WS::Utils::targetNs $tmpTargetNs + return \ + -code error \ + -errorcode $errorCode \ + -errorinfo $errorInfo \ + $msg + } + } + } + } + + ::log::logsubst debug {Parsing Simple types for $xns as $tns} + foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:simpleType] { + ::log::logsubst debug {\tprocessing $element} + if {[catch {parseSimpleType $mode serviceInfo $serviceName $element $tns} msg]} { + switch -exact -- $options(StrictMode) { + debug - + warning { + ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} + ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo - log::log error "Could not parse:\n [$element asXML]" - log::log error "\t error was: $msg" + ::log::logsubst error {Could not parse:\n [$element asXML]} + ::log::logsubst error {\t error was: $msg} + ::log::logsubst error {\t error info: $errorInfo} + ::log::logsubst error {\t error in: [lindex [info level 0] 0]} + ::log::logsubst error {\t error code: $errorCode} + set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg @@ -1974,52 +3136,30 @@ } } } } - ::log::log debug "Parsing Element types" - foreach element [$schemaNode selectNodes -namespaces $nsList s:element] { - ::log::log debug "\tprocessing $element" - if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { - switch -exact -- $options(StrictMode) { - debug - - warning { - log::log $options(StrictMode) "Could not parse:\n [$element asXML]" - log::log $options(StrictMode) "\t error was: $msg" - } - error - - default { - set errorCode $::errorCode - set errorInfo $::errorInfo - log::log error "Could not parse:\n [$element asXML]" - log::log error "\t error was: $msg" - return \ - -code error \ - -errorcode $errorCode \ - -errorinfo $errorInfo \ - $msg - } - } - } - } - - ::log::log debug "Parsing Attribute types" - foreach element [$schemaNode selectNodes -namespaces $nsList s:attribute] { - ::log::log debug "\tprocessing $element" - if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { - switch -exact -- $options(StrictMode) { - debug - - warning { - log::log $options(StrictMode) "Could not parse:\n [$element asXML]" - log::log $options(StrictMode) "\t error was: $msg" - } - error - - default { - set errorCode $::errorCode - set errorInfo $::errorInfo - log::log error "Could not parse:\n [$element asXML]" - log::log error "\t error was: $msg" + ::log::logsubst debug {Parsing Complex types for $xns as $tns} + foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:complexType] { + ::log::logsubst debug {\tprocessing $element} + if {[catch {parseComplexType $mode serviceInfo $serviceName $element $tns} msg]} { + switch -exact -- $options(StrictMode) { + debug - + warning { + ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} + ::log::logsubst $options(StrictMode) {\t error was: $msg} + } + error - + default { + set errorCode $::errorCode + set errorInfo $::errorInfo + ::log::logsubst error {Could not parse:\n [$element asXML]} + ::log::logsubst error {\t error was: $msg} + ::log::logsubst error {\t error info: $errorInfo} + ::log::logsubst error {\t error in: [lindex [info level 0] 0]} + ::log::logsubst error {\t error code: $errorCode} + set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg @@ -2026,61 +3166,14 @@ } } } } - ::log::log debug "Parsing Simple types" - foreach element [$schemaNode selectNodes -namespaces $nsList s:simpleType] { - ::log::log debug "\tprocessing $element" - if {[catch {parseSimpleType $mode serviceInfo $serviceName $element $tns} msg]} { - switch -exact -- $options(StrictMode) { - debug - - warning { - log::log $options(StrictMode) "Could not parse:\n [$element asXML]" - log::log $options(StrictMode) "\t error was: $msg" - } - error - - default { - set errorCode $::errorCode - set errorInfo $::errorInfo - log::log error "Could not parse:\n [$element asXML]" - log::log error "\t error was: $msg" - return \ - -code error \ - -errorcode $errorCode \ - -errorinfo $errorInfo \ - $msg - } - } - } - } - - ::log::log debug "Parsing Complex types" - foreach element [$schemaNode selectNodes -namespaces $nsList s:complexType] { - ::log::log debug "\tprocessing $element" - if {[catch {parseComplexType $mode serviceInfo $serviceName $element $tns} msg]} { - switch -exact -- $options(StrictMode) { - debug - - warning { - log::log $options(StrictMode) "Could not parse:\n [$element asXML]" - log::log $options(StrictMode) "\t error was: $msg" - } - error - - default { - set errorCode $::errorCode - set errorInfo $::errorInfo - log::log error "Could not parse:\n [$element asXML]" - log::log error "\t error was: $msg" - return \ - -code error \ - -errorcode $errorCode \ - -errorinfo $errorInfo \ - $msg - } - } - } - } + set ::WS::Utils::targetNs $tmpTargetNs + ::log::logsubst debug {Leaving :WS::Utils::parseScheme $mode $baseUrl $schemaNode $serviceName $serviceInfoVar $tnsCountVar} + ::log::logsubst debug {Target NS is now: $::WS::Utils::targetNs} + dict set serviceInfo tnsList tns $prevTnsDict } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -2119,70 +3212,116 @@ # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version +# 3.0.0 2020-10-26 H.Oehlmann Added query timeout +# 3.1.0 2020-11-06 H.Oehlmann Access namespace variable redirectArray +# via variable command # # ########################################################################### proc ::WS::Utils::processImport {mode baseUrl importNode serviceName serviceInfoVar tnsCountVar} { - upvar $serviceInfoVar serviceInfo - upvar $tnsCountVar tnsCount + upvar 1 $serviceInfoVar serviceInfo + upvar 1 $tnsCountVar tnsCount variable currentSchema variable importedXref + variable options + variable redirectArray - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} ## ## Get the xml ## set attrName schemaLocation if {![$importNode hasAttribute $attrName]} { - set attrName location - if {![$importNode hasAttribute $attrName]} { - set attrName namespace - if {![$importNode hasAttribute $attrName]} { - ::log::log debug "\t No schema location, existing" - set xml [$importNode asXML] - return \ - -code error \ - -errorcode [list WS CLIENT MISSCHLOC $xml] \ - "Missing Schema Location in '$xml'" - } - } - } - set url [::uri::resolve $baseUrl [$importNode getAttribute $attrName]] - ::log::log debug "\t Importing {$url}" + set attrName namespace + if {![$importNode hasAttribute $attrName]} { + ::log::log debug "\t No schema location, existing" + return \ + -code error \ + -errorcode [list WS CLIENT MISSCHLOC $baseUrl] \ + "Missing Schema Location in '$baseUrl'" + } + } + set urlTail [$importNode getAttribute $attrName] + set url [::uri::resolve $baseUrl $urlTail] + ::log::logsubst debug {Including $url} + + set lastPos [string last / $url] + set testUrl [string range $url 0 [expr {$lastPos - 1}]] + if { [info exists redirectArray($testUrl)] } { + set newUrl $redirectArray($testUrl) + append newUrl [string range $url $lastPos end] + ::log::logsubst debug {newUrl = $newUrl} + set url $newUrl + } + + ::log::logsubst debug {\t Importing {$url}} + + ## + ## Skip "known" namespace + ## + switch -exact -- $url { + http://schemas.xmlsoap.org/wsdl/ - + http://schemas.xmlsoap.org/wsdl/soap/ - + http://www.w3.org/2001/XMLSchema { + return + } + default { + ## + ## Do nothing + ## + } + } + ## ## Short-circuit infinite loop on inports ## if { [info exists importedXref($mode,$serviceName,$url)] } { - ::log::log debug "$mode,$serviceName,$url was already imported: $importedXref($mode,$serviceName,$url)" - return - } - set importedXref($mode,$serviceName,$url) [list $mode $serviceName $tnsCount] - switch [dict get [::uri::split $url] scheme] { - file { - upvar #0 [::uri::geturl $url] token - set xml $token(data) - unset token - ProcessImportXml $mode $baseUrl $xml $serviceName $serviceInfoVar $tnsCountVar - } - http { - set ncode -1 - catch { - set token [::http::geturl $url] - ::http::wait $token - set ncode [::http::ncode $token] - set xml [::http::data $token] - ::http::cleanup $token - ProcessImportXml $mode $baseUrl $xml $serviceName $serviceInfoVar $tnsCountVar - } - if {$ncode != 200} { + ::log::logsubst debug {$mode,$serviceName,$url was already imported: $importedXref($mode,$serviceName,$url)} + return + } + dict lappend serviceInfo imports $url + set importedXref($mode,$serviceName,$url) [list $mode $serviceName $tnsCount] + set urlScheme [dict get [::uri::split $url] scheme] + ::log::logsubst debug {URL Scheme of {$url} is {$urlScheme}} + switch -exact -- $urlScheme { + file { + ::log::logsubst debug {In file processor -- {$urlTail}} + set fn [file join $options(includeDirectory) [string range $urlTail 8 end]] + set ifd [open $fn r] + set xml [read $ifd] + close $ifd + ProcessImportXml $mode $baseUrl $xml $serviceName $serviceInfoVar $tnsCountVar + } + https - + http { + ::log::log debug "In http/https processor" + set ncode -1 + set token [geturl_followRedirects $url -timeout $options(queryTimeout)] + set ncode [::http::ncode $token] + ::log::log debug "returned code {$ncode}" + set xml [::http::data $token] + ::http::cleanup $token + if {($ncode != 200) && [string equal $options(includeDirectory) {}]} { return \ -code error \ -errorcode [list WS CLIENT HTTPFAIL $url $ncode] \ "HTTP get of import file failed '$url'" + } elseif {($ncode == 200) && ![string equal $options(includeDirectory) {}]} { + set fn [file join $options(includeDirectory) [file tail $urlTail]] + ::log::logsubst info {Could not access $url -- using $fn} + set ifd [open $fn r] + set xml [read $ifd] + close $ifd + } + if {[catch {ProcessImportXml $mode $baseUrl $xml $serviceName $serviceInfoVar $tnsCountVar} err]} { + ::log::logsubst info {Error during processing of XML: $err} + #puts stderr "error Info: $::errorInfo" + } else { + #puts stderr "import successful" } } default { return \ -code error \ @@ -2204,12 +3343,12 @@ # # Description : Parse a complex type declaration from the Schema into our # internal representation # # Arguments : -# dcitVar - The name of the results dictionary -# servcieName - The service name this type belongs to +# dictVar - The name of the results dictionary +# serviceName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing # @@ -2232,85 +3371,173 @@ # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseComplexType {mode dictVar serviceName node tns} { - upvar $dictVar results + upvar 1 $dictVar results variable currentSchema variable nsList + variable unknownRef + variable defaultType - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} - set typeName [$node getAttribute name] + set isAbstractType false + set defaultType string + set typeName $tns:[$node getAttribute name] + ::log::logsubst debug {Complex Type is $typeName} + if {[$node hasAttribute abstract]} { + set isAbstractType [$node getAttribute abstract] + ::log::logsubst debug {\t Abstract type = $isAbstractType} + } + #if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $typeName]]} { + # ::log::log debug "\t Type $typeName is already defined -- leaving" + # return + #} set partList {} set nodeFound 0 array set attrArr {} set comment {} - catch { - set commentNodeList [$middleNode selectNodes -namespaces $nsList s:annotation] - set commentNode [lindex $commentNodeList 0] - set comment [string trim [$commentNode asText]] - } - foreach middleNode [$node childNodes] { + set middleNodeList [$node childNodes] + foreach middleNode $middleNodeList { + set commentNodeList [$middleNode selectNodes -namespaces $nsList xs:annotation] + if {[llength $commentNodeList]} { + set commentNode [lindex $commentNodeList 0] + set comment [string trim [$commentNode asText]] + } set middle [$middleNode localName] - ::log::log debug "Complex Type is $typeName, middle is $middle" - #puts "Complex Type is $typeName, middle is $middle" - switch $middle { + ::log::logsubst debug {Complex Type is $typeName, middle is $middle} + #if {$isAbstractType && [string equal $middle attribute]} { + # ## + # ## Abstract type, so treat like an element + # ## + # set middle element + #} + + switch -exact -- $middle { + attribute - annotation { ## ## Do nothing ## continue } - element - - attribute { + element { set nodeFound 1 - set partName [$middleNode getAttribute name] - set partType [lindex [split [$middleNode getAttribute type string:string] {:}] end] - set partMax [$middleNode getAttribute maxOccurs 1] - if {[string equal $partMax 1]} { - lappend partList $partName [list type $partType comment $comment] + if {[$middleNode hasAttribute ref]} { + set partType [$middleNode getAttribute ref] + ::log::logsubst debug {\t\t has a ref of {$partType}} + if {[catch { + set refTypeInfo [split $partType {:}] + set partName [lindex $refTypeInfo end] + set refNS [lindex $refTypeInfo 0] + if {[string equal $refNS {}]} { + set partType $tns:$partType + } + ## + ## Convert the reference to the local tns space + ## + set partType [getQualifiedType $results $partType $tns $middleNode] + set refTypeInfo [GetServiceTypeDef $mode $serviceName $partType] + set refTypeInfo [dict get $refTypeInfo definition] + set tmpList [dict keys $refTypeInfo] + if {[llength $tmpList] == 1} { + ## + ## See if the reference is to an element or a type + ## + if {![dict exists $results elements $partType]} { + ## + ## To at type, so redefine the name + ## + set partName [lindex [dict keys $refTypeInfo] 0] + } + set partType [getQualifiedType $results [dict get $refTypeInfo $partName type] $tns $middleNode] + } + lappend partList $partName [list type $partType] + }]} { + lappend unknownRef($partType) $typeName + return \ + -code error \ + -errorcode [list WS $mode UNKREF [list $typeName $partType]] \ + "Unknown forward type reference {$partType} in {$typeName}" + } } else { - lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment] + set partName [$middleNode getAttribute name] + set partType [string trimright \ + [getQualifiedType $results [$middleNode getAttribute type string:string] $tns $middleNode] {?}] + set partMax [$middleNode getAttribute maxOccurs 1] + if {$partMax <= 1} { + lappend partList $partName [list type $partType comment $comment] + } else { + lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment] + } } } extension { - set baseName [lindex [split [$middleNode getAttribute base] {:}] end] + #set baseName [lindex [split [$middleNode getAttribute base] {:}] end] set tmp [partList $mode $middleNode $serviceName results $tns] if {[llength $tmp]} { set nodeFound 1 set partList [concat $partList $tmp] } } choice - sequence - all { - set elementList [$middleNode selectNodes -namespaces $nsList s:element] + # set elementList [$middleNode selectNodes -namespaces $nsList xs:element] set partMax [$middleNode getAttribute maxOccurs 1] set tmp [partList $mode $middleNode $serviceName results $tns $partMax] if {[llength $tmp]} { - ::log::log debug "\tadding {$tmp} to partslist" + ::log::logsubst debug {\tadding {$tmp} to partslist} set nodeFound 1 set partList [concat $partList $tmp] - } else { + } elseif {!$nodeFound} { ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base string comment $comment] $tns return } + # simpleType { + # $middleNode setAttribute name [$node getAttribute name] + # parseSimpleType $mode results $serviceName $middleNode $tns + # return + # } } complexType { $middleNode setAttribute name $typeName parseComplexType $mode results $serviceName $middleNode $tns } simpleContent - complexContent { - set contentType [[$middleNode childNodes] localName] - switch $contentType { - restriction { - set nodeFound 1 - set restriction [$middleNode selectNodes -namespaces $nsList s:restriction] - catch { - set element [$middleNode selectNodes -namespaces $nsList s:restriction/s:attribute] + ## + ## Save simple or complex content for abstract types, which + ## may have content type with no fields. [Bug 584bfb77] + ## Example xml type snippet: + ## + ## + ## + ## + ## + ## + ## ... + ## + ## + ## + + set isComplexContent [expr {$middle eq "complexContent"}] + ::log::logsubst debug {isComplexContent = $isComplexContent} + + ## + ## Loop over the components of the type + ## + foreach child [$middleNode childNodes] { + set parent [$child parent] + set contentType [$child localName] + ::log::logsubst debug {Content Type is {$contentType}} + switch -exact -- $contentType { + restriction { + set nodeFound 1 + set restriction $child + set element [$child selectNodes -namespaces $nsList xs:attribute] set typeInfoList [list baseType [$restriction getAttribute base]] array unset attrArr foreach attr [$element attributes] { if {[llength $attr] > 1} { set name [lindex $attr 0] @@ -2320,41 +3547,80 @@ set ref $attr } catch {set attrArr($name) [$element getAttribute $ref]} } set partName item - set partType [lindex [split $attrArr(arrayType) {:}] end] + set partType [getQualifiedType $results $attrArr(arrayType) $tns] set partType [string map {{[]} {()}} $partType] - lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment] + lappend partList $partName [list type [string trimright ${partType} {()?}]() comment $comment allowAny 1] set nodeFound 1 } - } - extension { - set tmp [partList $mode $middleNode $serviceName results $tns] - if {[llength $tmp]} { - set nodeFound 1 - set partList [concat $partList $tmp] + extension { + ::log::logsubst debug {Calling partList for $contentType of $typeName} + if {[catch {set tmp [partList $mode $child $serviceName results $tns]} msg]} { + ::log::logsubst debug {Error in partList {$msg}, errorInfo: $errorInfo} + } + ::log::logsubst debug {partList for $contentType of $typeName is {$tmp}} + if {[llength $tmp] && ![string equal [lindex $tmp 0] {}]} { + set nodeFound 1 + set partList [concat $partList $tmp] + } elseif {[llength $tmp]} { + ## + ## Found extension, but it is an empty type + ## + } else { + ::log::log debug "Unknown extension!" + return + } + } + default { + ## + ## Placed here to shut up tclchecker + ## } } } } restriction { - parseSimpleType $mode results $serviceName $node $tns - return + if {!$nodeFound} { + parseSimpleType $mode results $serviceName $node $tns + return + } } default { - parseElementalType $mode results $serviceName $node $tns - return + if {!$nodeFound} { + parseElementalType $mode results $serviceName $node $tns + return + } } } } - if {[llength $partList]} { + ::log::logsubst debug {at end of foreach {$typeName} with {$partList}} + if {[llength $partList] || $isAbstractType} { + #dict set results types $tns:$typeName $partList dict set results types $typeName $partList - ::WS::Utils::ServiceTypeDef $mode $serviceName $typeName $partList $tns + ::log::logsubst debug {Defining $typeName as '$partList'} + ## + ## Add complex type definition, if: + ## * there is a part list + ## * or it is an abstract type announced as complex + ## (see xml snipped above about [Bug 584bfb77]) + ## -> will set dict typeInfo client $service tns1:envelope { + ## definition {} xns tns1 abstract true} + ## + if { ([llength $partList] && ![string equal [lindex $partList 0] {}]) + || ($isAbstractType && [info exists isComplexContent] && $isComplexContent) + } { + ::WS::Utils::ServiceTypeDef $mode $serviceName $typeName $partList $tns $isAbstractType + } else { + ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base $defaultType comment {}] $tns + } + } elseif {!$nodeFound} { #puts "Defined $typeName as simple type" - ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base string comment {}] $tns + #::WS::Utils::ServiceTypeDef $mode $serviceName $typeName $partList $tns $isAbstractType + ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base $defaultType comment {}] $tns } else { set xml [string trim [$node asXML]] return \ -code error \ -errorcode [list WS $mode BADCPXTYPDEF [list $typeName $xml]] \ @@ -2369,15 +3635,15 @@ # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::partList # -# Description : Prase the list of parts of a type definition from the Schema into our +# Description : Parse the list of parts of a type definition from the Schema into our # internal representation # # Arguments : -# dcitVar - The name of the results dictionary +# dictVar - The name of the results dictionary # servcieName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing @@ -2402,53 +3668,76 @@ # # ########################################################################### proc ::WS::Utils::partList {mode node serviceName dictVar tns {occurs {}}} { variable currentSchema + variable unknownRef variable nsList - upvar $dictVar results + variable defaultType + variable options + variable simpleTypes + upvar 1 $dictVar results set partList {} set middle [$node localName] - ::log::log debug "Entering [info level 0] -- for $middle" - switch $middle { - element - + ::log::logsubst debug {Entering [info level 0] -- for $middle} + switch -exact -- $middle { + anyAttribute - attribute { + ## + ## Do Nothing + ## + } + element { catch { set partName [$node getAttribute name] - set partType [lindex [split [$node getAttribute type string:string] {:}] end] + set partType [string trimright [getQualifiedType $results [$node getAttribute type string] $tns $node] {?}] set partMax [$node getAttribute maxOccurs 1] - if {[string equal $partMax 1]} { + if {$partMax <= 1} { set partList [list $partName [list type $partType comment {}]] } else { set partList [list $partName [list type [string trimright ${partType} {()}]() comment {}]] } } } extension { - set baseName [lindex [split [$node getAttribute base] {:}] end] - #puts "base name $baseName" - if {[lindex [TypeInfo Client $serviceName $baseName] 0]} { + set baseName [getQualifiedType $results [$node getAttribute base string] $tns $node] + set baseTypeInfo [TypeInfo Client $serviceName $baseName] + ::log::logsubst debug {\t base name of extension is {$baseName} with typeinfo {$baseTypeInfo}} + if {[lindex $baseTypeInfo 0]} { if {[catch {::WS::Utils::GetServiceTypeDef Client $serviceName $baseName}]} { set baseQuery [format {child::*[attribute::name='%s']} $baseName] set baseNode [$currentSchema selectNodes $baseQuery] #puts "$baseQuery gave {$baseNode}" set baseNodeType [$baseNode localName] - switch $baseNodeType { + switch -exact -- $baseNodeType { complexType { - parseComplexType $mode serviceInfo $serviceName $baseNode $tns + parseComplexType $mode results $serviceName $baseNode $tns } element { - parseElementalType $mode serviceInfo $serviceName $baseNode $tns + parseElementalType $mode results $serviceName $baseNode $tns } simpleType { - parseSimpleType $mode serviceInfo $serviceName $baseNode $tns + parseSimpleType $mode results $serviceName $baseNode $tns + } + default { + ## + ## Placed here to shut up tclchecker + ## } } } set baseInfo [GetServiceTypeDef $mode $serviceName $baseName] + ::log::logsubst debug {\t baseInfo is {$baseInfo}} + if {[llength $baseInfo] == 0} { + ::log::logsubst debug {\t Unknown reference '$baseName'} + set unknownRef($baseName) 1 + return + } catch {set partList [concat $partList [dict get $baseInfo definition]]} + } else { + ::log::logsubst debug {\t Simple type} } foreach elementNode [$node childNodes] { set tmp [partList $mode $elementNode $serviceName results $tns] if {[llength $tmp]} { set partList [concat $partList $tmp] @@ -2456,16 +3745,17 @@ } } choice - sequence - all { - set elementList [$node selectNodes -namespaces $nsList s:element] + set elementList [$node selectNodes -namespaces $nsList xs:element] set elementsFound 0 - ::log::log debug "\telement list is {$elementList}" + ::log::logsubst debug {\telement list is {$elementList}} foreach element $elementList { - ::log::log debug "\t\tprocessing $element ([$element nodeName])" + ::log::logsubst debug {\t\tprocessing $element ([$element nodeName])} set comment {} + set additional_defininition_elements {} if {[catch { set elementsFound 1 set attrName name set isRef 0 if {![$element hasAttribute name]} { @@ -2472,32 +3762,48 @@ set attrName ref set isRef 1 } set partName [$element getAttribute $attrName] if {$isRef} { - set partType [dict get [::WS::Utils::GetServiceTypeDef $mode $serviceName $partName] definition $partName type] + set partType {} + set partTypeInfo {} + set partType [string trimright [getQualifiedType $results $partName $tns] {?}] + set partTypeInfo [::WS::Utils::GetServiceTypeDef $mode $serviceName $partType] + set partName [lindex [split $partName {:}] end] + ::log::logsubst debug {\t\t\t part name is {$partName} type is {$partTypeInfo}} + if {[dict exists $partTypeInfo definition $partName]} { + set partType [dict get $partTypeInfo definition $partName type] + } + ::log::logsubst debug {\t\t\t part name is {$partName} type is {$partType}} } else { ## ## See if really a complex definition ## if {[$element hasChildNodes]} { - set isComplex 0 + set isComplex 0; set isSimple 0 foreach child [$element childNodes] { - if {[string equal [$child localName] {annotation}]} { - set comment [string trim [$child asText]] - } else { - set isComplex 1 + switch -exact -- [$child localName] { + annotation {set comment [string trim [$child asText]]} + simpleType {set isSimple 1} + default {set isComplex 1} } } if {$isComplex} { set partType $partName parseComplexType $mode results $serviceName $element $tns + } elseif {$isSimple} { + set partType $partName + parseComplexType $mode results $serviceName $element $tns + if {[info exists simpleTypes($mode,$serviceName,$tns:$partName)]} { + set additional_defininition_elements $simpleTypes($mode,$serviceName,$tns:$partName) + set partType [dict get $additional_defininition_elements baseType] + } } else { - set partType [lindex [split [$element getAttribute type string:string] {:}] end] + set partType [getQualifiedType $results [$element getAttribute type string] $tns $element] } } else { - set partType [lindex [split [$element getAttribute type string:string] {:}] end] + set partType [getQualifiedType $results [$element getAttribute type string] $tns $element] } } if {[string length $occurs]} { set partMax [$element getAttribute maxOccurs 1] if {$partMax < $occurs} { @@ -2504,29 +3810,34 @@ set partMax $occurs } } else { set partMax [$element getAttribute maxOccurs 1] } - if {[string equal $partMax 1]} { - lappend partList $partName [list type $partType comment $comment] + if {$partMax <= 1} { + lappend partList $partName [concat [list type $partType comment $comment] $additional_defininition_elements] } else { - lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment] + lappend partList $partName [concat [list type [string trimright ${partType} {()?}]() comment $comment] $additional_defininition_elements] } } msg]} { - ::log::log error "\tError processing {$msg} for [$element asXML]" + ::log::logsubst error {\tError processing {$msg} for [$element asXML]} + if {$isRef} { + ::log::log error "\t\t Was a reference. Additionally information is:" + ::log::logsubst error {\t\t\t part name is {$partName} type is {$partType} with {$partTypeInfo}} + } } } if {!$elementsFound} { + set defaultType $options(anyType) return } } complexContent { set contentType [[$node childNodes] localName] - switch $contentType { + switch -exact -- $contentType { restriction { - set restriction [$node selectNodes -namespaces $nsList s:restriction] - set element [$node selectNodes -namespaces $nsList s:restriction/s:attribute] + set restriction [$node selectNodes -namespaces $nsList xs:restriction] + set element [$node selectNodes -namespaces $nsList xs:restriction/xs:attribute] set typeInfoList [list baseType [$restriction getAttribute base]] array unset attrArr foreach attr [$element attributes] { if {[llength $attr] > 1} { set name [lindex $attr 0] @@ -2536,17 +3847,22 @@ set ref $attr } catch {set attrArr($name) [$element getAttribute $ref]} } set partName item - set partType [lindex [split $attrArr(arrayType) {:}] end] + set partType [getQualifiedType $results $attrArr(arrayType) $tns] set partType [string map {{[]} {()}} $partType] - set partList [list $partName [list type [string trimright ${partType} {()}]() comment {}]] + set partList [list $partName [list type [string trimright ${partType} {()?}]() comment {} allowAny 1]] } extension { - set extension [$node selectNodes -namespaces $nsList s:extension] + set extension [$node selectNodes -namespaces $nsList xs:extension] set partList [partList $mode $extension $serviceName results $tns] + } + default { + ## + ## Placed here to shut up tclchecker + ## } } } simpleContent { foreach elementNode [$node childNodes] { @@ -2563,10 +3879,13 @@ default { parseElementalType $mode results $serviceName $node $tns return } } + if {[llength $partList] == 0} { + set partList {{}} + } return $partList } ########################################################################### # @@ -2579,11 +3898,11 @@ # # Description : Parse an elemental type declaration from the Schema into our # internal representation # # Arguments : -# dcitVar - The name of the results dictionary +# dictVar - The name of the results dictionary # servcieName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing @@ -2608,134 +3927,192 @@ # # ########################################################################### proc ::WS::Utils::parseElementalType {mode dictVar serviceName node tns} { - upvar $dictVar results + upvar 1 $dictVar results variable importedXref variable nsList + variable unknownRef - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} set attributeName name if {![$node hasAttribute $attributeName]} { set attributeName ref } set typeName [$node getAttribute $attributeName] + if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $tns:$typeName]]} { + ::log::logsubst debug {\t Type $tns:$typeName is already defined -- leaving} + return + } set typeType "" if {[$node hasAttribute type]} { - set typeType [$node getAttribute type] + set typeType [getQualifiedType $results [$node getAttribute type string] $tns $node] } - ::log::log debug "Elemental Type is $typeName" + ::log::logsubst debug {Elemental Type is $typeName} set partList {} - set elements [$node selectNodes -namespaces $nsList s:complexType/s:sequence/s:element] - ::log::log debug "\t element list is {$elements}" + set partType {} + set isAbstractType false + if {[$node hasAttribute abstract]} { + set isAbstractType [$node getAttribute abstract] + ::log::logsubst debug {\t Abstract type = $isAbstractType} + } + set elements [$node selectNodes -namespaces $nsList xs:complexType/xs:sequence/xs:element] + ::log::logsubst debug {\t element list is {$elements} partList {$partList}} foreach element $elements { - ::log::log debug "\t\t Processing element {[$element nodeName]}" + set ::elementName [$element asXML] + ::log::logsubst debug {\t\t Processing element {[$element nodeName]}} set elementsFound 1 set typeAttribute "" if {[$element hasAttribute ref]} { - ::log::log debug "\t\t has a ref of {[$element getAttribute ref]}" - set refTypeInfo [split [$element getAttribute ref] {:}] - set refNS [lindex $refTypeInfo 0] - if {[string equal $refNS {}]} { - set refType [lindex $refTypeInfo 1] - set namespaceList [$element selectNodes namespace::*] - set index [lsearch -glob $namespaceList "xmlns:$refNS *"] - set url [lindex $namespaceList $index 1] - ::log::log debug "\t\t reference is {$refNS} {$refType} {$url}" - if {![info exists importedXref($mode,$serviceName,$url)]} { - return \ - -code error \ - -errorcode [list WS CLIENT NOTIMP $url] \ - "Schema not imported: {$url}'" - } - set partName $refType - set partType $refType - } elseif {[string equal -nocase [lindex $refTypeInfo 1] schema]} { - set partName * - set partType * - } else { - set partName $refTypeInfo - set partType $refTypeInfo - } - } else { - ::log::log debug "\t\t has no ref has {[$element attributes]}" - set childList [$element selectNodes -namespaces $nsList s:complexType/s:sequence/s:element] + set partType [$element getAttribute ref] + ::log::logsubst debug {\t\t has a ref of {$partType}} + if {[catch { + set refTypeInfo [split $partType {:}] + set partName [lindex $refTypeInfo end] + set refNS [lindex $refTypeInfo 0] + if {[string equal $refNS {}]} { + set partType $tns:$partType + } + ## + ## Convert the reference to the local tns space + ## + set partType [getQualifiedType $results $partType $tns] + set refTypeInfo [GetServiceTypeDef $mode $serviceName $partType] + log::logsubst debug {looking up ref {$partType} got {$refTypeInfo}} + if {![llength $refTypeInfo]} { + error "lookup failed" + } + if {[dict exists $refTypeInfo definition]} { + set refTypeInfo [dict get $refTypeInfo definition] + } + set tmpList [dict keys $refTypeInfo] + if {[llength $tmpList] == 1} { + ## + ## See if the reference is to an element or a type + ## + if {![dict exists $results elements $partType]} { + ## + ## To at type, so redefine the name + ## + set partName [lindex [dict keys $refTypeInfo] 0] + } + if {[dict exists $refTypeInfo $partName type]} { + set partType [getQualifiedType $results [dict get $refTypeInfo $partName type] $tns] + } else { + ## + ## Not a simple element, so point type to type of same name as element + ## + set partType [getQualifiedType $results $partName $tns] + } + } + } msg]} { + lappend unknownRef($partType) $typeName + log::logsubst debug {Unknown ref {$partType,$typeName} error: {$msg} trace: $::errorInfo} + return \ + -code error \ + -errorcode [list WS $mode UNKREF [list $typeName $partType]] \ + "Unknown forward type reference {$partType} in {$typeName}" + } + } else { + ::log::logsubst debug {\t\t\t has no ref has {[$element attributes]}} + set childList [$element selectNodes -namespaces $nsList xs:complexType/xs:sequence/xs:element] + ::log::logsubst debug {\t\t\ has no ref has [llength $childList]} if {[llength $childList]} { ## ## Element defines another element layer ## set partName [$element getAttribute name] - set partType $partName + set partType [getQualifiedType $results $partName $tns $element] parseElementalType $mode results $serviceName $element $tns } else { set partName [$element getAttribute name] - set partType [lindex [split [$element getAttribute type string:string] {:}] end] + if {[$element hasAttribute type]} { + set partType [getQualifiedType $results [$element getAttribute type] $tns $element] + } else { + set partType xs:string + } + } } - set partMax [$element getAttribute maxOccurs 1] - ::log::log debug "\t\t part is {$partName} {$partType} {$partMax}" + set partMax [$element getAttribute maxOccurs -1] + ::log::logsubst debug {\t\t\t part is {$partName} {$partType} {$partMax}} - if {[string equal $partMax 1]} { + if {[string equal $partMax -1]} { + set partMax [[$element parent] getAttribute maxOccurs -1] + } + if {$partMax <= 1} { lappend partList $partName [list type $partType comment {}] } else { - lappend partList $partName [list type [string trimright ${partType} {()}]() comment {}] + lappend partList $partName [list type [string trimright ${partType} {()?}]() comment {}] } } if {[llength $elements] == 0} { # # Validate this is not really a complex or simple type # - set childList [$node hasChildNodes] + set childList [$node childNodes] foreach childNode $childList { if {[catch {$childNode setAttribute name $typeName}]} { continue } set childNodeType [$childNode localName] - switch $childNodeType { + switch -exact -- $childNodeType { complexType { - parseComplexType $mode serviceInfo $serviceName $childNode $tns + parseComplexType $mode results $serviceName $childNode $tns return } element { - parseElementalType $mode serviceInfo $serviceName $childNode $tns + parseElementalType $mode results $serviceName $childNode $tns return } simpleType { - parseSimpleType $mode serviceInfo $serviceName $childNode $tns + parseSimpleType $mode results $serviceName $childNode $tns return + } + default { + ## + ## Placed here to shut up tclchecker + ## } } } # have an element with a type only, so do the work here - set partType [lindex [split [$node getAttribute type string:string] {:}] end] + if {[$node hasAttribute type]} { + set partType [getQualifiedType $results [$node getAttribute type] $tns $node] + } elseif {[$node hasAttribute base]} { + set partType [getQualifiedType $results [$node getAttribute base] $tns $node] + } else { + set partType xs:string + } set partMax [$node getAttribute maxOccurs 1] - if {[string equal $partMax 1]} { + if {$partMax <= 1} { ## ## See if this is just a restriction on a simple type ## if {([lindex [TypeInfo $mode $serviceName $partType] 0] == 0) && - [string equal $typeName $partType]} { + [string equal $tns:$typeName $partType]} { return } else { lappend partList $typeName [list type $partType comment {}] } } else { - lappend partList $typeName [list type [string trimright ${partType} {()}]() comment {}] + lappend partList $typeName [list type [string trimright ${partType} {()?}]() comment {}] } } if {[llength $partList]} { - dict set results types $typeName $partList - ::WS::Utils::ServiceTypeDef $mode $serviceName $typeName $partList $tns + ::WS::Utils::ServiceTypeDef $mode $serviceName $tns:$typeName $partList $tns $isAbstractType } else { - if {![dict exists $results types $typeName]} { + if {![dict exists $results types $tns:$typeName]} { set partList [list base string comment {} xns $tns] - ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName $partList - dict set results simpletypes $typeName $partList + ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $tns:$typeName $partList $tns + dict set results simpletypes $tns:$typeName $partList } } + dict set results elements $tns:$typeName 1 + ::log::log debug "\t returning" } ########################################################################### # @@ -2744,15 +4121,15 @@ # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::parseSimpleType # -# Description : Parse a simnple type declaration from the Schema into our +# Description : Parse a simple type declaration from the Schema into our # internal representation # # Arguments : -# dcitVar - The name of the results dictionary +# dictVar - The name of the results dictionary # servcieName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing @@ -2776,31 +4153,50 @@ # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseSimpleType {mode dictVar serviceName node tns} { - upvar $dictVar results + upvar 1 $dictVar results variable nsList - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} set typeName [$node getAttribute name] - ::log::log debug "Simple Type is $typeName" + if {$typeName in {SAP_VALID_FROM}} { + set foo 1 + } + set isList no + ::log::logsubst debug {Simple Type is $typeName} + if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $tns:$typeName]]} { + ::log::logsubst debug {\t Type $tns:$typeName is already defined -- leaving} + return + } #puts "Simple Type is $typeName" - set restrictionNode [$node selectNodes -namespaces $nsList s:restriction] + set restrictionNode [$node selectNodes -namespaces $nsList xs:restriction] + if {[string equal $restrictionNode {}]} { + set restrictionNode [$node selectNodes -namespaces $nsList xs:simpleType/xs:restriction] + } + if {[string equal $restrictionNode {}]} { + set restrictionNode [$node selectNodes -namespaces $nsList xs:list/xs:simpleType/xs:restriction] + } if {[string equal $restrictionNode {}]} { - set restrictionNode [$node selectNodes -namespaces $nsList s:list/s:simpleType/s:restriction] + set restrictionNode [$node selectNodes -namespaces $nsList xs:list] + set isList yes } if {[string equal $restrictionNode {}]} { set xml [string trim [$node asXML]] return \ -code error \ -errorcode [list WS $mode BADSMPTYPDEF [list $typeName $xml]] \ "Bad simple type definition for '$typeName' :: \n'$xml'" } - set baseType [lindex [split [$restrictionNode getAttribute base] {:}] end] - set partList [list baseType $baseType xns $tns] + if {$isList} { + set baseType [lindex [split [$restrictionNode getAttribute itemType] {:}] end] + } else { + set baseType [lindex [split [$restrictionNode getAttribute base] {:}] end] + } + set partList [list baseType $baseType xns $tns isList $isList] set enumList {} foreach item [$restrictionNode childNodes] { set itemName [$item localName] set value [$item getAttribute value] #puts "\t Item {$itemName} = {$value}" @@ -2814,17 +4210,20 @@ } } if {[llength $enumList]} { lappend partList enumeration $enumList } - if {![dict exists $results types $typeName]} { - ServiceSimpleTypeDef $mode $serviceName $typeName $partList - dict set results simpletypes $typeName $partList + if {![dict exists $results types $tns:$typeName]} { + ServiceSimpleTypeDef $mode $serviceName $tns:$typeName $partList $tns + dict set results simpletypes $tns:$typeName $partList + } else { + ::log::logsubst debug {\t type already exists as $tns:$typeName} } } - + + ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # @@ -2873,11 +4272,12 @@ ## ## Get the type information ## set typeInfoList [TypeInfo $mode $serviceName $typeName] - set baseTypeName [string trimright $typeName {()}] + set baseTypeName [string trimright $typeName {()?}] + set typeName [string trimright $typeName {?}] set typeInfo [GetServiceTypeDef $mode $serviceName $baseTypeName] set isComplex [lindex $typeInfoList 0] set isArray [lindex $typeInfoList 1] if {$isComplex} { @@ -2901,11 +4301,11 @@ array set fieldInfoArr $fieldDef if {$fieldInfoArr(minOccurs) && ![info exists fieldInfoArr($field)]} { ## ## Fields was required but is missing ## - set ::errorCode [list WS CHECK MISSREQFLD [list $type $field]] + set ::errorCode [list WS CHECK MISSREQFLD [list $typeName $field]] set result 0 } elseif {$fieldInfoArr(minOccurs) && ($fieldInfoArr(minOccurs) > [llength $fieldInfoArr($field)])} { ## ## Fields was required and present, but not enough times @@ -2916,11 +4316,11 @@ [string is integer fieldInfoArr(maxOccurs)] && ($fieldInfoArr(maxOccurs) < [llength $fieldInfoArr($field)])} { ## ## Fields was required and present, but too many times ## - set ::errorCode [list WS CHECK MAXOCCUR [list $type $field]] + set ::errorCode [list WS CHECK MAXOCCUR [list $typeName $field]] set result 0 } elseif {[info exists fieldInfoArr($field)]} { foreach node $fieldInfoArr($field) { set result [checkTags $mode $serviceName $node $fieldInfoArr(type)] if {!$result} { @@ -2941,11 +4341,12 @@ } return $result } - + + ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # @@ -2992,34 +4393,36 @@ array set typeInfos { minLength 0 maxLength -1 fixed false } + # returns indexes type, xns, ... array set typeInfos [GetServiceTypeDef $mode $serviceName $type] foreach {var value} [array get typeInfos] { set $var $value } set result 1 if {$minLength >= 0 && [string length $value] < $minLength} { - set ::errorCode [list WS CHECK VALUE_TO_SHORT [list $key $value $minLength $typeInfo]] + set ::errorCode [list WS CHECK VALUE_TO_SHORT [list $type $value $minLength $typeInfo]] set result 0 } elseif {$maxLength >= 0 && [string length $value] > $maxLength} { - set ::errorCode [list WS CHECK VALUE_TO_LONG [list $key $value $maxLength $typeInfo]] + set ::errorCode [list WS CHECK VALUE_TO_LONG [list $type $value $maxLength $typeInfo]] set result 0 } elseif {[info exists enumeration] && ([lsearch -exact $enumeration $value] == -1)} { - set errorCode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $key $value $enumerationVals $typeInfo]] + set errorCode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $type $value $enumeration $typeInfo]] set result 0 - } elseif {[info exists pattern] && (![regexp $pattern $value])} { - set errorCode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $value $pattern $typeInfo]] + } elseif {[info exists pattern] && (![regexp -- $pattern $value])} { + set errorCode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $type $value $pattern $typeInfo]] set result 0 } return $result } - + + ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # @@ -3059,28 +4462,29 @@ # 1 08/13/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to generate qualified XML # ########################################################################### proc ::WS::Utils::buildTags {mode serviceName typeName valueInfos doc currentNode} { - upvar $valueInfos values + upvar 1 $valueInfos values ## ## Get the type information ## - set baseTypeName [string trimright $typeName {()}] + set baseTypeName [string trimright $typeName {()?}] set typeInfo [GetServiceTypeDef $mode $serviceName $baseTypeName] - set xns [dict get $typeInfo $mode $service $type xns] + set typeName [string trimright $typeName {?}] + set xns [dict get $typeInfo $mode $serviceName $typeName xns] foreach {field fieldDef} [dict get $typeInfo definition] { ## ## Get info about this field and its type ## array unset fieldInfoArr set fieldInfoArr(minOccurs) 0 array set fieldInfoArr $fieldDef set typeInfoList [TypeInfo $mode $serviceName $fieldInfoArr(type)] - set fieldBaseType [string trimright $fieldInfoArr(type) {()}] + set fieldBaseType [string trimright $fieldInfoArr(type) {()?}] set isComplex [lindex $typeInfoList 0] set isArray [lindex $typeInfoList 1] if {[dict exists $valueInfos $field]} { if {$isArray} { set valueList [dict get $valueInfos $field] @@ -3114,11 +4518,11 @@ ## ## Fields was required and present, but too many times ## set minOccurs $fieldInfoArr(maxOccurs) return \ - -errorcode [list WS CHECK MAXOCCUR [list $type $field]] \ + -errorcode [list WS CHECK MAXOCCUR [list $typeName $field]] \ "Field '$field' of type '$typeName' could only occur $minOccurs time(s) but occured $valueListLenght time(s)" } elseif {[dict exists $valueInfos $field]} { foreach value $valueList { $currentNode appendChild [$doc createElement $xns:$field retNode] if {$isComplex} { @@ -3130,11 +4534,11 @@ } if {[checkValue $mode $serviceName $fieldBaseType $value]} { $retNode appendChild [$doc createTextNode $value] } else { set msg "Field '$field' of type '$typeName' " - switch -exact [lindex $::errorCode 2] { + switch -exact -- [lindex $::errorCode 2] { VALUE_TO_SHORT { append msg "value required to be $fieldInfoArr(minLength) long but is only [string length $value] long" } VALUE_TO_LONG { append msg "value allowed to be only $fieldInfoArr(minLength) long but is [string length $value] long" @@ -3143,10 +4547,15 @@ append msg "value '$value' not in ([join $fieldInfoArr(enumeration) {, }])" } VALUE_NOT_MATCHES_PATTERN { append msg "value '$value' does not match pattern: $fieldInfoArr(pattern)" } + default { + ## + ## Placed here to shut up tclchecker + ## + } } return \ -errorcode $::errorCode \ $msg } @@ -3154,12 +4563,333 @@ } } } } +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Utils::getQualifiedType +# +# Description : Get a qualified type name from a local reference. +# Thus return : which is in the global type list. +# The is adjusted to point to the global type list. +# +# Arguments : +# serviceInfo - service information dictionary +# type - type to get local qualified type on +# tns - current namespace +# node - optional XML item to search for xmlns:* attribute +# +# Returns : nothing +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald Lester +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 02/24/2011 G. Lester Initial version +# 2.6.2 2018-09-22 C. Werner Added parameter "node" to first search a +# namespace attribute "xmlns:yprefix>" in the +# current node. +# +########################################################################### +proc ::WS::Utils::getQualifiedType {serviceInfo type tns {node {}}} { + + set typePartsList [split $type {:}] + if {[llength $typePartsList] == 1} { + # No namespace prefix given - use current prefix + set result $tns:$type + } else { + lassign $typePartsList tmpTns tmpType + # Search the namespace attribute in the current node for a node-local prefix. + # Aim is to translate the node-local prefix to a global namespace prefix. + # Example: + # + # + # Variable setup: + # - type: x1:ArrayOfSomething + # - tmpTns: x1 + # - tmpType: ArrayOfSomething + # Return value: + # - + # - plus ":ArrayOfSomething" + if {$node ne {}} { + set attr xmlns:$tmpTns + if {[$node hasAttribute $attr]} { + # There is a node-local attribute (Example: xmlns:x1) giving the node namespace + set xmlns [$node getAttribute $attr] + if {[dict exists $serviceInfo tnsList url $xmlns]} { + set result [dict get $serviceInfo tnsList url $xmlns]:$tmpType + ::log::logsubst debug {Got global qualified type '$result' from node-local qualified namespace '$xmlns'} + return $result + } else { + # The node namespace (Ex: http://foo.org/bar) was not found as global prefix. + # Thus, the type is refused. + # HaO 2018-11-05 Opinion: + # Continuing here is IMHO not an option, as the prefix (Ex: x1) might have a + # different namespace on the global level which would lead to a misassignment. + # + # One day, we may support cascading namespace prefixes. Then, we may define + # the namespace here + set errMsg "Node local namespace URI '$xmlns' not found for type: '$type'" + ::log::log error $errMsg + return -code error $errMsg + } + # fail later if namespace not found + } + } + if {[dict exists $serviceInfo tnsList tns $tmpTns]} { + set result [dict get $serviceInfo tnsList tns $tmpTns]:$tmpType + } elseif {[dict exists $serviceInfo types $type]} { + set result $type + } else { + ::log::log error $serviceInfo + ::log::logsubst error {Could not find tns '$tmpTns' in '[dict get $serviceInfo tnsList tns]' for type {$type}} + return -code error "Namespace prefix of type '$type' not found." + } + } + return $result +} + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Utils::GenerateTemplateDict +# +# Description : Generate a template dictionary object for +# a given type. +# +# Arguments : +# mode - The mode, Client or Server +# serviceName - The service name the type is defined in +# type - The name of the type +# arraySize - Number of elements to generate in an array. Default is 2 +# +# Returns : A dictionary object for a given type. If any circular references +# exist, they will have the value of <** Circular Reference **> +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 07/06/2006 G.Lester Initial version +# +# +########################################################################### +proc ::WS::Utils::GenerateTemplateDict {mode serviceName type {arraySize 2}} { + variable generatedTypes + + ::log::logsubst debug {Entering [info level 0]} + unset -nocomplain -- generatedTypes + + set result [_generateTemplateDict $mode $serviceName $type $arraySize] + + unset -nocomplain -- generatedTypes + ::log::logsubst debug {Leaving [info level 0] with {$result}} + + return $result +} + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Utils::_generateTemplateDict +# +# Description : Private procedure to generate a template dictionary. This needs +# setup work done by ::WS::Utils::GnerateTemplateDict +# +# Arguments : +# mode - The mode, Client or Server +# serviceName - The service name the type is defined in +# type - The name of the type +# arraySize - Number of elements to generate in an array. +# +# Returns : A dictionary object for a given type. If any circular references +# exist, they will have the value of <** Circular Reference **> +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald W. Lester +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 07/06/2006 G.Lester Initial version +# +# +########################################################################### +proc ::WS::Utils::_generateTemplateDict {mode serviceName type arraySize {xns {}}} { + variable typeInfo + variable mutableTypeInfo + variable options + variable generatedTypes + + ::log::logsubst debug {Entering [info level 0]} + set results {} + + ## + ## Check for circular reference + ## + if {[info exists generatedTypes([list $mode $serviceName $type])]} { + set results {<** Circular Reference **>} + ::log::logsubst debug {Leaving [info level 0] with {$results}} + return $results + } else { + set generatedTypes([list $mode $serviceName $type]) 1 + } + + set type [string trimright $type {?}] + # set typeDefInfo [dict get $typeInfo $mode $serviceName $type] + set typeDefInfo [GetServiceTypeDef $mode $serviceName $type] + if {![llength $typeDefInfo]} { + ## We failed to locate the type. try with the last known xns... + set typeDefInfo [GetServiceTypeDef $mode $serviceName ${xns}:$type] + } + + ::log::logsubst debug {\t type def = {$typeDefInfo}} + set xns [dict get $typeDefInfo xns] + + ## + ## Check for mutable type + ## + if {[info exists mutableTypeInfo([list $mode $serviceName $type])]} { + set results {<** Mutable Type **>} + ::log::logsubst debug {Leaving [info level 0] with {$results}} + return $results + } + + if {![dict exists $typeDefInfo definition]} { + ## This is a simple type, simulate a type definition... + if {![dict exists $typeDefInfo type]} { + if {[dict exists $typeDefInfo baseType]} { + dict set typeDefInfo type [dict get $typeDefInfo baseType] + } else { + dict set typeDefInfo type xs:string + } + } + set typeDefInfo [dict create definition [dict create $type $typeDefInfo]] + } + set partsList [dict keys [dict get $typeDefInfo definition]] + ::log::logsubst debug {\t partsList is {$partsList}} + foreach partName $partsList { + set partType [string trimright [dict get $typeDefInfo definition $partName type] {?}] + set partXns $xns + catch {set partXns [dict get $typeInfo $mode $serviceName $partType xns]} + set typeInfoList [TypeInfo $mode $serviceName $partType] + set isArray [lindex $typeInfoList end] + + ::log::logsubst debug {\tpartName $partName partType $partType xns $xns typeInfoList $typeInfoList} + switch -exact -- $typeInfoList { + {0 0} { + ## + ## Simple non-array + ## + set msg {Simple non-array} + ## Is there an enumenration? + foreach attr {enumeration type comment} { + if {[dict exists $typeDefInfo definition $partName $attr]} { + set value [dict get $typeDefInfo definition $partName $attr] + set value [string map {\{ ( \} ) \" '} $value] + append msg ", $attr=\{$value\}" + } + } + dict set results $partName $msg + } + {0 1} { + ## + ## Simple array + ## + set tmp {} + for {set row 1} {$row <= $arraySize} {incr row} { + lappend tmp [format {Simple array element #%d} $row] + } + dict set results $partName $tmp + } + {1 0} { + ## + ## Non-simple non-array + ## + dict set results $partName [_generateTemplateDict $mode $serviceName $partType $arraySize $xns] + } + {1 1} { + ## + ## Non-simple array + ## + set partType [string trimright $partType {()}] + set tmp [list] + set isRecursive [info exists generatedTypes([list $mode $serviceName $partType])] + for {set row 1} {$row <= $arraySize} {incr row} { + if {$isRecursive} { + lappend tmp $partName {<** Circular Reference **>} + } else { + unset -nocomplain -- generatedTypes([list $mode $serviceName $partType]) + lappend tmp [_generateTemplateDict $mode $serviceName $partType $arraySize $xns] + } + } + dict set results $partName $tmp + } + default { + ## + ## Placed here to shut up tclchecker + ## + } + } + } + ::log::logsubst debug {Leaving [info level 0] with {$results}} + return $results +} + + - + ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # @@ -3169,11 +4899,11 @@ # # Description : Set attributes on a DOM node # # Arguments : # node - node to set attributes on -# attrList - List of attibute name value pairs +# attrList - List of attribute name value pairs # # Returns : nothing # # Side-Effects : None # @@ -3192,22 +4922,265 @@ # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 02/24/2011 G. Lester Initial version # ########################################################################### -if {[package vcompare [info patchlevel] 8.5] == -1} { - ## - ## 8.4, so can not use {*} expansion - ## - proc ::WS::Utils::setAttr {node attrList} { - foreach {name value} $attrList { - $node setAttribute $name $value - } - } -} else { - ## - ## 8.5 or later, so use {*} expansion - ## - proc ::WS::Utils::setAttr {node attrList} { - $node setAttribute {*}$attrList - } -} +proc ::WS::Utils::setAttr {node attrList} { + $node setAttribute {*}$attrList +} + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Utils::geturl_followRedirects +# +# Description : fetch via http following redirects. +# May not be used as asynchronous call with -command option. +# +# Arguments : +# url - target document url +# args - additional argument list to http::geturl call +# +# Returns : http package token of received data +# +# Side-Effects : Save final url in redirectArray to forward info to +# procedure "processImport". +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Gerald Lester +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 02/24/2011 G. Lester Initial version +# 2.3.10 11/09/2015 H. Oehlmann Allow only 5 redirects (loop protection) +# 3.1.0 2020-11-06 H.Oehlmann Access namespace variable redirectArray +# via variable command +# +########################################################################### +proc ::WS::Utils::geturl_followRedirects {url args} { + variable redirectArray + ::log::logsubst debug {[info level 0]} + set initialUrl $url + set finalUrl $url + array set URI [::uri::split $url] ;# Need host info from here + for {set loop 1} {$loop <=5} {incr loop} { + ::log::logsubst info {[concat [list ::http::geturl $url] $args]} + set token [http::geturl $url {*}$args] + set ncode [::http::ncode $token] + ::log::logsubst info {ncode = $ncode} + if {![string match {30[12378]} $ncode]} { + ::log::logsubst debug {initialUrl = $initialUrl, finalUrl = $finalUrl} + if {![string equal $finalUrl {}]} { + ::log::log debug "Getting initial URL directory" + set lastPos [string last / $initialUrl] + set initialUrlDir [string range $initialUrl 0 [expr {$lastPos - 1}]] + set lastPos [string last / $finalUrl] + set finalUrlDir [string range $finalUrl 0 [expr {$lastPos - 1}]] + ::log::logsubst debug {initialUrlDir = $initialUrlDir, finalUrlDir = $finalUrlDir} + set redirectArray($initialUrlDir) $finalUrlDir + } + return $token + } elseif {![string match {20[1237]} $ncode]} { + return $token + } + # http code announces redirect (3xx) + array set meta [set ${token}(meta)] + if {![info exist meta(Location)]} { + ::log::log debug "Redirect http code without Location" + return $token + } + array set uri [::uri::split $meta(Location)] + unset meta + array unset meta + ::http::cleanup $token + if { $uri(host) eq "" } { + set uri(host) $URI(host) + } + # problem w/ relative versus absolute paths + set url [eval ::uri::join [array get uri]] + ::log::logsubst debug {url = $url} + set finalUrl $url + } + # > 5 redirects reached -> exit with error + return -errorcode [list WS CLIENT REDIRECTLIMIT $url] \ + -code error "http redirect limit exceeded for $url" +} +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Utils::geturl_fetchbody +# +# Description : fetch via http following redirects and return data or error +# +# Arguments : +# ?-codeok list? - list of acceptable http codes. +# If not given, 200 is used +# ?-codevar varname ? - Uplevel variable name to return current code +# value. +# ?-bodyalwaysok bool? - If a body is delivered any ncode is ok +# url - target document url +# args - additional argument list to http::geturl call +# +# Returns : fetched data +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Harald Oehlmann +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 11/08/2015 H.Oehlmann Initial version +# 3.0.0 2020-10-26 H.Oehlmann Honor timeout and eof status +# +########################################################################### +proc ::WS::Utils::geturl_fetchbody {args} { + set codeOkList {200} + set codeVar "" + set bodyAlwaysOk 0 + ::log::logsubst info {Entering [info level 0]} + if {[lindex $args 0] eq "-codeok"} { + set codeOkList [lindex $args 1] + set args [lrange $args 2 end] + } + if {[lindex $args 0] eq "-codevar"} { + set codeVar [lindex $args 1] + set args [lrange $args 2 end] + } + if {[lindex $args 0] eq "-bodyalwaysok"} { + set bodyAlwaysOk [lindex $args 1] + set args [lrange $args 2 end] + } + + set token [eval ::WS::Utils::geturl_followRedirects $args] + switch -exact -- [::http::status $token] { + ok { + if {[::http::size $token] == 0} { + ::log::log debug "\tHTTP error: no data" + ::http::cleanup $token + return -errorcode [list WS CLIENT NODATA [lindex $args 0]]\ + -code error "HTTP failure socket closed" + } + if {$codeVar ne ""} { + upvar 1 $codeVar ncode + } + set ncode [::http::ncode $token] + set body [::http::data $token] + ::http::cleanup $token + if {$bodyAlwaysOk && $body ne "" + || $ncode in $codeOkList + } { + # >> Fetch ok + ::log::logsubst debug {\tReceived: $body} + return $body + } + ::log::logsubst debug {\tHTTP error: Wrong code $ncode or no data} + return -code error -errorcode [list WS CLIENT HTTPERROR $ncode]\ + "HTTP failure code $ncode" + } + eof { + set error "socket closed by server" + } + error { + set error [::http::error $token] + } + timeout { + set error "timeout" + } + default { + set error "unknown http::status: [::http::status $token]" + } + } + ::log::logsubst debug {\tHTTP error [array get $token]} + + ::http::cleanup $token + return -errorcode [list WS CLIENT HTTPERROR $error]\ + -code error "HTTP error: $error" +} + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Utils::check_version +# +# Description : for a particular version code, check if the requested version +# is allowd +# +# Arguments : +# version - The specified version for the type, proc, etc +# requestedVersion - The version being requested by the user +# +# Returns : boolean - true if allowed, false if not +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Jonathan Cone +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 1 10/23/2018 J. Cone Initial version +# +########################################################################### +proc ::WS::Utils::check_version {version requestedVersion} { + if {$version eq {} || $requestedVersion eq {}} { + return 1 + } + if {[regexp {^(\d+)([+-])?(\d+)?$} $version _ start modifier end]} { + if {$start ne {} && $end ne {}} { + return [expr {$requestedVersion >= $start && $requestedVersion <= $end}] + } elseif {$start ne {}} { + switch -- $modifier { + "+" { + return [expr {$requestedVersion >= $start}] + } + "-" { + return [expr {$requestedVersion <= $start}] + } + "" { + return [expr {$requestedVersion == $start}] + } + } + } + } + return 0 +} + Index: Wub.tcl ================================================================== --- Wub.tcl +++ Wub.tcl @@ -37,15 +37,20 @@ ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### +package require Tcl 8.4- +# WS::Utils usable here for dict? +if {![llength [info command dict]]} { + package require dict +} package require uri package require base64 package require html -package provide WS::Wub 1.4.0 +package provide WS::Wub 2.4.0 namespace eval ::WS::Wub { array set portInfo {} @@ -66,11 +71,11 @@ # Description : Register a handler for a url on a port. # # Arguments : # port -- The port to register the callback on # url -- The URL to register the callback for -# callback -- The callback prefix, two additionally argumens are lappended +# callback -- The callback prefix, two additionally arguments are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : @@ -166,11 +171,11 @@ # Arguments : # port -- Port number to listen on # certfile -- Name of the certificate file # keyfile -- Name of the key file # userpwds -- A list of username and passwords -# realm -- The seucrity realm +# realm -- The security realm # logger -- A logging routines for errors # # Returns : Nothing # # Side-Effects : @@ -202,11 +207,11 @@ foreach key {port certfile keyfile userpwds realm logger} { set portInfo($port,$key) [set $key] } set portInfo($port,$handlers) {} foreach up $userpwds { - lappend portInfo($port,auths) [base64::encode $up]] + lappend portInfo($port,auths) [base64::encode $up] } if {$certfile ne ""} { package require tls @@ -639,11 +644,11 @@ $portInfo($port,logger) "Connection closed from $ip" } foreach {method url version} $line { break } switch -exact $method { GET { - handler $sock $ip [uri::split $url] $auth + handler $port $sock $ip [uri::split $url] $auth } default { $portInfo($port,logger) "Unsupported method '$method' from $ip" } } } msg]} { Index: WubServer.tcl ================================================================== --- WubServer.tcl +++ WubServer.tcl @@ -1,15 +1,20 @@ # WSWub - Wub interface to WebServices +package require Tcl 8.4- +# WS::Utils usable here for dict? +if {![llength [info command dict]]} { + package require dict +} package require WS::Server package require OO package require Direct package require Debug Debug off wsdl 10 -package provide WS::Wub 1.4.0 -package provide Wsdl 1.0 +package provide WS::Wub 2.4.0 +package provide Wsdl 2.4.0 class create Wsdl { method / {r args} { return [Http Ok $r [::WS::Server::generateInfo $service 0] text/html] } DELETED docs/Calling a Web Service.html Index: docs/Calling a Web Service.html ================================================================== --- docs/Calling a Web Service.html +++ /dev/null @@ -1,313 +0,0 @@ - - -Calling a Web Service from Tcl - - - -

Calling a Web Service from Tcl

- -
- - - -
-

Contents

-
-

- -

- -

Overview

-

The Webservices Client package provides a several ways to define what -operations a remote Web Services Server provides and how to call those -operations. It also includes several ways to call an operation.

-

The following ways are provided to define remote operations:

-
    -
  • Loading a pre-parsed WSDL -
  • Quering a remote Web Services Server for its WSDL and parsing it -
  • Parsing a saved WSDL
-
  • Defining a REST based service by hand
    • -

    The parsed format is much more compact than the XML of a WSDL.

    -

    The following ways are provided to directly call an operation of a Web -Service Server:

    -
      -
    • Synchronous Call returning a dictionary object -
    • Synchronous Call returning the raw XML -
    • Asynchronous Call with separate success and error callbacks -
    • Creation of stub Tcl procedures to make synchronous calls
    - -

    Loading the Webservices Client Package

    -

    To load the webservices server package, do: 

     package require WS::Client
-
    -

    This command will only load the utilities the first time it is used, so it -causes no ill effects to put this in each file using the utilties.

    -
    - - - -

    Quering a remote Web Services Server for its WSDL and parsing it

    -

    Procedure Name : ::WS::Client::GetAndParseWsdl

    -

    Description :

    -

    Arguments : 

         url     - The url of the WSDL
-     headers - Extra headers to add to the HTTP request. This
-                 is a key value list argument. It must be a list with
-                 an even number of elements that alternate between
-                 keys and values. The keys become header field names.
-                 Newlines are stripped from the values so the header
-                 cannot be corrupted.
-                 This is an optional argument and defaults to {}.
-     serviceAlias - Alias (unique) name for service.
-                     This is an optional argument and defaults to the name of the
-                     service in serviceInfo.
-
    -

    Returns : The parsed service definition

    -

    Side-Effects : None

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : None

    -
    - - -

    Parsing a saved WSDL

    -

    Procedure Name : ::WS::Client::ParseWsdl

    -

    Description : Parse a WSDL

    -

    Arguments : 

         wsdlXML - XML of the WSDL
-
    -

    Optional Arguments: 

         -createStubs 0|1 - create stub routines for the service
-                             NOTE -- Webservice arguments are position
-                                     independent, thus the proc arguments
-                                     will be defined in alphabetical order.
-     -headers         - Extra headers to add to the HTTP request. This
-                        is a key value list argument. It must be a list with
-                        an even number of elements that alternate between
-                        keys and values. The keys become header field names.
-                        Newlines are stripped from the values so the header
-                        cannot be corrupted.
-                        This is an optional argument and defaults to {}.
-     -serviceAlias - Alias (unique) name for service.
-                      This is an optional argument and defaults to the name of the
-                      service in serviceInfo.
-
    -

    Returns : The parsed service definition

    -

    Side-Effects : None

    -

    Exception Conditions :None

    -

    Pre-requisite Conditions : None

    -
    - - - -

    Loading a pre-parsed WSDL

    -

    Procedure Name : ::WS::Client::LoadParsedWsdl

    -

    Description : Load a saved service definition in

    -

    Arguments : 

         serviceInfo - parsed service definition, as returned from
-                   ::WS::Client::ParseWsdl or ::WS::Client::GetAndParseWsdl
-     headers     - Extra headers to add to the HTTP request. This
-                     is a key value list argument. It must be a list with
-                     an even number of elements that alternate between
-                     keys and values. The keys become header field names.
-                     Newlines are stripped from the values so the header
-                     cannot be corrupted.
-                     This is an optional argument and defaults to {}.
-     serviceAlias - Alias (unique) name for service.
-                     This is an optional argument and defaults to the name of the
-                     service in serviceInfo.
-
    -

    Returns : The name of the service loaded

    -

    Side-Effects : None

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : None

    -
    - - -

    Defining a REST based service by hand

    -
    -

    Service Definition

    -

    Procedure Name : ::WS::Client::CreateService

    -

    Description : Define a REST service

    -

    Arguments : 

    -     serviceName - Service name to add namespace to
-     type        - The type of service, currently only REST is supported.
-     url          - URL of namespace.
-     args         - Optional arguments:
-                            This is an optional argument and defaults to the name of the
-                                -header httpHeaderList.
-
    -

    Returns : The local alias (tns)

    -

    Side-Effects : None

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : None

    - -

    Method Definition

    -

    Procedure Name : ::WS::Client::DefineRestMethod

    -

    Description : Define a method on a REST service

    -

    Arguments : 

    -     serviceName - Service name to add namespace to
-     methodName  - The name of the method to add.
-     inputArgs   - List of input argument definitions where each argument
-                           definition is of the format: name typeInfo.
-     returnType  - The type, if any returned by the procedure.  Format is:
-                           xmlTag typeInfo.
-
-    where, typeInfo is of the format {type typeName comment commentString}
-
    -

    Returns : The current service definition

    -

    Side-Effects : None

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : None

    -
    - - - -

    Defining Transforms

    -

    Procedure Name : ::WS::Client::SetServiceTransforms

    -

    Description : Define a service's transforms -

    -               Transform signature is:
-                   cmd serviceName operationName transformType xml {url {}} {argList {}}
-               where transformType is REQUEST or REPLY
-               and url and argList will only be present for transformType == REQUEST
-

    -

    Arguments : 

    -     serviceName  - The name of the Webservice
-     inTransform  - Input transform cmd, defaults to {}
-     outTransform - Output transformcmd, defaults to {}
-
    -

    Returns : None

    -

    Side-Effects : None

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : Service must have been defined.

    -
    - - -

    Synchronous Call returning a dictionary object

    -

    Procedure Name : ::WS::Client::DoCall

    -

    Description : Call an operation of a web service

    -

    Arguments : 

         serviceName     - The name of the Webservice
-     operationName   - The name of the Operation to call
-     argList         - The arguements to the operation as a dictionary object
-                       This is for both the Soap Header and Body messages.
-     headers         - Extra headers to add to the HTTP request. This
-                       is a key value list argument. It must be a list with
-                       an even number of elements that alternate between
-                       keys and values. The keys become header field names.
-                       Newlines are stripped from the values so the header
-                       cannot be corrupted.
-                       This is an optional argument and defaults to {}.
-
    -

    Returns :

    -
         The return value of the operation as a dictionary object.
-       This includes both the return result and any return headers.
-
    -

    Side-Effects : None

    -

    Exception Conditions : 

         WSCLIENT HTTPERROR      - if an HTTP error occured
-     others                  - as raised by called Operation
-
    -

    Pre-requisite Conditions : Service must have been defined.

    -
    - - -

    Asynchronous Call with separate success and error callbacks

    -

    Procedure Name : ::WS::Client::DoAsyncCall

    -

    Description : Call an operation of a web service asynchronously -

    -

    Arguments : 

         serviceName     - The name of the Webservice
-     operationName   - The name of the Operation to call
-     argList         - The arguements to the operation as a dictionary object
-                       This is for both the Soap Header and Body messages.
-     succesCmd       - A command prefix to be called if the operations
-                       does not raise an error.  The results, as a dictionary
-                       object are concatinated to the prefix. This includes
-                       both the return result and any return headers.
-
-     errorCmd        - A command prefix to be called if the operations
-                       raises an error.  The error code and stack trace
-                       are concatinated to the prefix.
-     headers         - Extra headers to add to the HTTP request. This
-                       is a key value list argument. It must be a list with
-                       an even number of elements that alternate between
-                       keys and values. The keys become header field names.
-                       Newlines are stripped from the values so the header
-                       cannot be corrupted.
-                       This is an optional argument and defaults to {}.
-
    -

    Returns : Nothing.

    -

    Side-Effects : None

    -

    Exception Conditions : 

         WSCLIENT HTTPERROR      - if an HTTP error occured
-     others                  - as raised by called Operation
-
    -

    Pre-requisite Conditions : Service must have been defined.

    -
    - - -

    Creation of stub Tcl procedures to make synchronous calls

    -

    Procedure Name : ::WS::Client::CreateStubs

    -

    Description : Create stubs routines to make calls to Webservice -Operations. 

                 All routines will be create in a namespace that is the same
-             as the service name.  The procedure name will be the same
-             as the operation name.
-
                 NOTE -- Webservice arguments are position independent, thus
-                     the proc arguments will be defined in alphabetical order.
-
    -

    Arguments : 

         serviceName     - The service to create stubs for
-
    -

    Returns : A string describing the created procedures.

    -

    Side-Effects : Existing namespace is deleted.

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : Service must have been defined.

    -
    - - -

    Synchronous Call returning the raw XML

    -

    Procedure Name : ::WS::Client::DoRawCall

    -

    Description : Call an operation of a web service

    -

    Arguments : 

         serviceName     - The name of the Webservice
-     operationName   - The name of the Operation to call
-     argList         - The arguements to the operation as a dictionary object
-                       This is for both the Soap Header and Body messages.
-     headers         - Extra headers to add to the HTTP request. This
-                       is a key value list argument. It must be a list with
-                       an even number of elements that alternate between
-                       keys and values. The keys become header field names.
-                       Newlines are stripped from the values so the header
-                       cannot be corrupted.
-                       This is an optional argument and defaults to {}.
-
    -

    Returns : 

         The XML of the operation.
-
    -

    Side-Effects : None

    -

    Exception Conditions : 

         WSCLIENT HTTPERROR      - if an HTTP error occured
-
    -

    Pre-requisite Conditions : Service must have been defined.

    - - - ADDED docs/Calling_a_Web_Service.html Index: docs/Calling_a_Web_Service.html ================================================================== --- /dev/null +++ docs/Calling_a_Web_Service.html @@ -0,0 +1,568 @@ + + +Calling a Web Service from Tcl + + + + +

    Calling a Web Service from Tcl

    + +
    + + + +
    +

    Contents

    +
    +

    + +

    + +

    Overview

    +

    The Webservices Client package provides a several ways to define what +operations a remote Web Services Server provides and how to call those +operations. It also includes several ways to call an operation.

    +

    The following ways are provided to define remote operations:

    +
      +
    • Loading a pre-parsed WSDL +
    • Quering a remote Web Services Server for its WSDL and parsing it +
    • Parsing a saved WSDL
    +
    • Defining a REST based service by hand
    +

    The parsed format is much more compact than the XML of a WSDL.

    +

    The following ways are provided to directly call an operation of a Web +Service Server:

    +
      +
    • Synchronous Call returning a dictionary object +
    • Synchronous Call returning the raw XML +
    • Asynchronous Call with separate success and error callbacks +
    • Creation of stub Tcl procedures to make synchronous calls
    + +

    This package makes use of the log package from TclLib. In particular the following levels are used: +

      +
    • error/warning -- errors encountered when parsing a WSDL. Actual level depends on options that are set in the ::WS::Utils package. +
    • info -- HTTP calls, including the XML, made to invoke operations and the replies received. Introduced in 2.2.8. +
    • debug -- detailed internal information. This should only be used if you want to code dive into the TclWs package internals. +
    + + +

    Loading the Webservices Client Package

    +

    To load the webservices server package, do: 

     package require WS::Client
+
    +

    This command will only load the utilities the first time it is used, so it +causes no ill effects to put this in each file using the utilties.

    +
    + + + +

    Quering a remote Web Services Server for its WSDL and parsing it

    +

    Procedure Name : ::WS::Client::GetAndParseWsdl

    +

    Description : Fetch the WSDL file from the given URL, aprse it and create the service.

    +

    Arguments : 

    +     url     - The url of the WSDL
+     headers - Extra headers to add to the HTTP request. This
+               is a key value list argument. It must be a list with
+               an even number of elements that alternate between
+               keys and values. The keys become header field names.
+               Newlines are stripped from the values so the header
+               cannot be corrupted.
+               This is an optional argument and defaults to {}.
+     serviceAlias - Alias (unique) name for service.
+                    This is an optional argument and defaults to the name of the
+                    service in serviceInfo.
+     serviceNumber - Number of service within the WSDL to assign the
+                     serviceAlias to. Only recognized with a serviceAlias.
+                     First service (default) is addressed by value "1".
+
    +

    The following example WSDL snipped defines two services:

    +
    +  >definitions ...<
+    >service name="service1"<
+      ...
+    >/service<
+    >service name="service1"<
+      ...
+    >/service<
+  >/definitions<
+
    + +

    Using an empty or no serviceAlias would result in the creation of the services "service1" and "service2".

    +

    Using serviceAlias="SE" and serviceNumber=2 would result in the creation of the service "SE" containing the "service2" of the WSDL.

    + +

    Returns : The parsed service definition

    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : None

    +
    + + +

    Parsing a saved WSDL

    +

    Procedure Name : ::WS::Client::ParseWsdl

    +

    Description : Parse a WSDL and create the service. Create also the stubs if specified.

    +

    Arguments : 

         wsdlXML - XML of the WSDL
+
    +

    Optional Arguments:

    +
    +     -createStubs 0|1 - create stub routines for the service
+     -headers         - Extra headers to add to the HTTP request. This
+                        is a key value list argument. It must be a list with
+                        an even number of elements that alternate between
+                        keys and values. The keys become header field names.
+                        Newlines are stripped from the values so the header
+                        cannot be corrupted.
+                        This is an optional argument and defaults to {}.
+     -serviceAlias    - Alias (unique) name for service.
+                        This is an optional argument and defaults to the name of the
+                        service in serviceInfo.
+     serviceNumber - Number of service within the WSDL to assign the
+                     serviceAlias to. Only recognized with a serviceAlias.
+                     First service (default) is addressed by value "1".
+
    + +

    The arguments are position independent.

    +

    For an example use of serviceAlias and serviceNumber, see the chapter above.

    +

    Returns : The parsed service definition

    +

    Side-Effects : None

    +

    Exception Conditions :None

    +

    Pre-requisite Conditions : None

    +
    + + + +

    Loading a pre-parsed WSDL

    +

    Procedure Name : ::WS::Client::LoadParsedWsdl

    +

    Description : Load a saved service definition in

    +

    Arguments : 

         serviceInfo - parsed service definition, as returned from
+                   ::WS::Client::ParseWsdl or ::WS::Client::GetAndParseWsdl
+     headers     - Extra headers to add to the HTTP request. This
+                     is a key value list argument. It must be a list with
+                     an even number of elements that alternate between
+                     keys and values. The keys become header field names.
+                     Newlines are stripped from the values so the header
+                     cannot be corrupted.
+                     This is an optional argument and defaults to {}.
+     serviceAlias - Alias (unique) name for service.
+                     This is an optional argument and defaults to the name of the
+                     service in serviceInfo.
+
    +

    Returns : The name of the service loaded

    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : None

    +
    + + +

    Defining a REST based service by hand

    +
    +

    Service Definition

    +

    Procedure Name : ::WS::Client::CreateService

    +

    Description : Define a REST service

    +

    Arguments : 

    +     serviceName - Service name to add namespace to
+     type        - The type of service, currently only REST is supported.
+     url          - URL of namespace.
+     args         - Optional arguments:
+                            This is an optional argument and defaults to the name of the
+                                -header httpHeaderList.
+
    +

    Returns : The local alias (tns)

    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : None

    + +

    Method Definition

    +

    Procedure Name : ::WS::Client::DefineRestMethod

    +

    Description : Define a method on a REST service

    +

    Arguments : 

    +     serviceName - Service name to add namespace to
+     methodName  - The name of the method to add.
+     returnType  - The type, if any returned by the procedure.  Format is:
+                           xmlTag typeInfo.
+     inputArgs   - List of input argument definitions where each argument
+                           definition is of the format: name typeInfo.
+
+    where, typeInfo is of the format {type typeName comment commentString}
+
    +

    Returns : The current service definition

    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : None

    +
    + + + +

    Defining Transforms

    +

    Procedure Name : ::WS::Client::SetServiceTransforms

    +

    Description : Define a service's transforms +

    +               Transform signature is:
+                   cmd serviceName operationName transformType xml {url {}} {argList {}}
+               where transformType is REQUEST or REPLY
+               and url and argList will only be present for transformType == REQUEST
+

    +

    Arguments : 

    +     serviceName  - The name of the Webservice
+     inTransform  - Input transform cmd, defaults to {}.
+     The inTransform is the proc which allows to transform the SOAP output message, which will be input in the server.
+     outTransform - Output transformcmd, defaults to {}.
+     The outTransform is the proc which allows to transform the SOAP input message, which is the answer of the server.
+
    +

    Returns : None

    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : Service must have been defined.

    +
    + + +

    Synchronous Call returning a dictionary object

    +

    Procedure Name : ::WS::Client::DoCall

    +

    Description : Call an operation of a web service

    +

    Arguments : 

         serviceName     - The name of the Webservice
+     operationName   - The name of the Operation to call
+     argList         - The arguements to the operation as a dictionary object
+                       This is for both the Soap Header and Body messages.
+     headers         - Extra headers to add to the HTTP request. This
+                       is a key value list argument. It must be a list with
+                       an even number of elements that alternate between
+                       keys and values. The keys become header field names.
+                       Newlines are stripped from the values so the header
+                       cannot be corrupted.
+                       This is an optional argument and defaults to {}.
+
    +

    Returns :

    +
         The return value of the operation as a dictionary object.
+       This includes both the return result and any return headers.
+
    +

    Side-Effects : None

    +

    Exception Conditions : 

         WSCLIENT HTTPERROR      - if an HTTP error occured
+     others                  - as raised by called Operation
+
    +

    Pre-requisite Conditions : Service must have been defined.

    +
    + + +

    Asynchronous Call with separate success and error callbacks

    +

    Procedure Name : ::WS::Client::DoAsyncCall

    +

    Description : Call an operation of a web service asynchronously +

    +

    Arguments : 

         serviceName     - The name of the Webservice
+     operationName   - The name of the Operation to call
+     argList         - The arguements to the operation as a dictionary object
+                       This is for both the Soap Header and Body messages.
+     succesCmd       - A command prefix to be called if the operations
+                       does not raise an error.  The results, as a dictionary
+                       object are concatinated to the prefix. This includes
+                       both the return result and any return headers.  Leave
+                       empty to not call any function.
+
+     errorCmd        - A command prefix to be called if the operations
+                       raises an error.  The error code, stack trace and
+                       error message are concatinated to the prefix.  Leave
+                       empty to not call any function.
+     headers         - Extra headers to add to the HTTP request. This
+                       is a key value list argument. It must be a list with
+                       an even number of elements that alternate between
+                       keys and values. The keys become header field names.
+                       Newlines are stripped from the values so the header
+                       cannot be corrupted.
+                       This is an optional argument and defaults to {}.
+
    +

    Returns : Nothing.

    +

    Side-Effects : None

    +

    Exception Conditions : 

         WSCLIENT HTTPERROR      - if an HTTP error occured
+     others                  - as raised by called Operation
+
    +

    Pre-requisite Conditions : Service must have been defined.

    +
    + + +

    Creation of stub Tcl procedures to make synchronous calls

    +

    Procedure Name : ::WS::Client::CreateStubs

    +

    Description : Create stubs routines to make calls to Webservice +Operations. 

                 All routines will be create in a namespace that is the same
+             as the service name.  The procedure name will be the same
+             as the operation name.
+
                 NOTE -- Webservice arguments are position independent, thus
+                     the proc arguments will be defined in alphabetical order.
+
    +

    Arguments : 

         serviceName     - The service to create stubs for
+
    +

    Returns : A string describing the created procedures.

    +

    Side-Effects : Existing namespace is deleted.

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : Service must have been defined.

    +
    + + +

    Synchronous Call returning the raw XML

    +

    Procedure Name : ::WS::Client::DoRawCall

    +

    Description : Call an operation of a web service

    +

    Arguments : 

         serviceName     - The name of the Webservice
+     operationName   - The name of the Operation to call
+     argList         - The arguements to the operation as a dictionary object
+                       This is for both the Soap Header and Body messages.
+     headers         - Extra headers to add to the HTTP request. This
+                       is a key value list argument. It must be a list with
+                       an even number of elements that alternate between
+                       keys and values. The keys become header field names.
+                       Newlines are stripped from the values so the header
+                       cannot be corrupted.
+                       This is an optional argument and defaults to {}.
+
    +

    Returns : 

         The XML of the operation.
+
    +

    Side-Effects : None

    +

    Exception Conditions : 

         WSCLIENT HTTPERROR      - if an HTTP error occured
+
    +

    Pre-requisite Conditions : Service must have been defined.

    + +
    + +

    +

    Generating a Template Dictionary

    +

    Procedure Name : ::WS::Utils::GenerateTemplateDict

    +

    Description : Generate a template dictionary object for a given type.

    +

    Arguments :

    +
    +     mode            - The mode, Client or Server
+     serviceName     - The name of the Webservice
+     type            - The name of the type
+     arraySize       - Number of elements to generate in an array.  Default is 2
+
      
+
    +

    Returns : 

    A dictionary object for a given type.  If any circular references exist, they will have the value of <** Circular Reference **>
+
    Side-Effects : None 
    
+
    Exception Conditions  : None 
    
+
    Pre-requisite Conditions : Service must have been defined.

    + +
    + +

    +

    Configuring a Service

    + +There are two procedures to configure a service: +
      +
    • ::WS::Client::SetOption
      • +
    • ::WS::Client::Config
      • +
    + +

    The first procedure contains the default options of the package. +The default options are used on service creation and are then copied to the service.

    + +

    The second procedure contains the options of each service. +They are copied on service creation from the default options.

    + +

    Most option items may be accessed by both functions. +Some options are only used on service creation phase, which do not exist as service option. +Other options do not exist as default option, as they are initialized from the WSDL file.

    + +

    In the following, first the two access routines are described. +Then, a list of options for both functions are given, with remarks, if they are only valid for one of the two procedures.

    + +

    Procedure Name : ::WS::Client::SetOption

    +

    Description : Get or set the default options of the package

    +

    Arguments :

    +
    +     -globalonly   - Return a list of global-only options and their values.
+                     Global-only options are not copied to the service.
+     -defaultonly  - Return a list of default-only options and their values.
+                     default-only options are copied to the service.
+     --            - End of options
+     item          - The option item to get or configure.
+                     Return a list of all item/value pairs if ommitted. 
+     value         - The value to set the option item to.
+                     Return current value if omitted.
+
    + +

    Procedure Name : ::WS::Client::Config

    +

    Description : Get or set the options local to a service definition

    +

    Arguments :

    +
    +     serviceName - The name of the Webservice.
+                   Return a list of default items/values paires if not given.
+     item        - The option item to get or configure.
+                   Return a list of all item/value pairs, if not given. 
+     value       - The value to set the option item to.
+                   Return current value if omitted.
+
    + +

    Option List:

    + +
      +
    • allowOperOverloading
      +

      An overloaded operation is an operation with the same name but different may exist with different input parameter sets.

      +

      This option throws an error, if a WSDL is parsed with an overloaded operation.

      + Default: 1
      • + +
    • contentType
      + The http content type of the http request sent to call the web service.
      + Default: "text/xml;charset=utf-8"
      • + +
    • errorOnRedefine
      +

      Throw an error, if a service is created (CreateService etc) for an already existing service.

      +

      Default value: 0

      +

      This item may not be used with ::WS::Client::Config.

      +
      • + +
    • genOutAttr
      + generate attributes on outbound tags, see here for details
      • + +
    • inlineElementNS
      +

      Namespace prefixes for types may be defined within the WSDL root element.

      +

      This item may not be used with ::WS::Client::Config.

      +

      Activate this option, to also search namespace prefixes in the type definition. + As those are seen as global prefixes, there might be a double-used prefix which will cause a processing error, if different URI's are assigned.

      + +

      The error would be caused by a WSDL as follows

      + 
      +	<wsdl:definitions targetNamespace="http://www.webserviceX.NET/"
+        xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/
+		xmlns:q1="myURI1"
+		...>
+	    ...
+	    <xs:element xmlns:q1="myURI2" type="q1:MessageQ1"/>
+
      +
      • +
    • location
      +

      The URL of the service. This is initialized on the value in the WSDL file, when the WSDL file is parsed. The value may be overwritten setting this option.

      +

      This item may not be used with ::WS::Client::SetOption.

      +
      • + +
    • noTargetNs
      + The target namespace URI is normally included twice in the envelope of the webservice call:
      + 
      +<SOAP-ENV:Envelope
+	...
+	xmlns="http://targeturi.org/"
+	xmlns:tns1="http://targeturi.org/"
+	...>
+
      + Setting this option to 1 suppresses the line with "xmlns=". +
      This option was set to call a service published by SAP. +
      Default value: 0
      • +
    • nsOnChangeOnly
      + only put namespace prefix when namespaces change
      • +
    • parseInAttr
      + parse attributes on inbound tags, see here for details
      • +
    • queryTimeout
      + Timeout to any network query in ms. Default value: 60000 (1 minuite). + The utility package has an option with the same functionality, which is used, when there is no call option context. +
      • +
    • skipHeaderLevel
      + boolean indicating the first level of the XML in a request header shall be skipped. Derived from options. Default is 0 (do not skip). (Introduced in 2.2.8)
      • +
    • skipLevelOnReply
      + boolean indicating the first level of the XML in a reply may be skipped. Derived from options. Default is 0 (do not skip). (Introduced in 2.2.8)
      • +
    • skipLevelWhenActionPresent
      + boolean indicating if the first level of the XML is to be skipped. Derived from options. Default is 0 (do not skip).
      • +
    • suppressNS (default: empty string)
      + do not put a particular namespace prefix
      • +
    • suppressTargetNS
      +

      Do not add the Target Namespace URI prefix "tns1" to all parameters in the webservice call XML.

      +

      As an example, the XML is modified from (option not set): + 

      +<SOAP-ENV:Envelope ...
+    xmlns:tns1="http://targeturi.org/"
+    ... >
+  <SOAP-ENV:Body>
+    <tns1:CalledMethod>
+      <tns1:Parameter1>Value;/tns1:Parameter1>
+    </tns1:CalledMethod>
+  </SOAP-ENV:Body>
+</SOAP-ENV:Envelope>
+
      + to (option set) + 
      +<SOAP-ENV:Envelope ...
+    xmlns:tns1="http://targeturi.org/"
+    ... >
+<SOAP-ENV:Envelope ...
+  <SOAP-ENV:Body>
+    <tns1:CalledMethod>
+      <Parameter1>Value;/Parameter1>
+    </tns1:CalledMethod>
+  </SOAP-ENV:Body>
+</SOAP-ENV:Envelope>
+
      +

      + Derived from options. +
      Internally, this option sets the option "suppressNS" to "tns1". +
      This option was set to call a service published by SAP. +
      This option made a call to a certain MS Web Service fail with the error message: "Input parameter 'Parameter1' can not be NULL or Empty.". +
      Default is 0 (do not suppress). +
      • +
    • targetNamespace (default: empty string)
      +

      the target namespace of the service, derived from the WSDL.

      +

      This item may not be used with ::WS::Client::SetOption.

      +
      • +
    • UseNS (default: empty string)
      + See here +
      • +
    • useTypeNS (default: empty string)
      + use type's namespace prefix as prefix of elements
      • +
    • valueAttrCompatiblityMode (default: 1)
      + If this and genOutAttr/parseInAttr are set, then values are specified in the dictionary as {}. Otherwise if genOutAttr/parseInAttr is set this is not set, then the values are specified in the dictionary as ::value.
      • +
    +
    +     value         - Optional, the new value.
+
    +

    Returns : 

         The value of the item.
+
    Side-Effects : None 
    
+
    Exception Conditions  : None 
    
+
    Pre-requisite Conditions : Service must have been defined.

    + + +

    +

    Dealing With Casting Abstract Types to Concrete Types

    +

    + If you turn on parseInAttr and genOutAttr, the system will + semi-automatically deal with casting of elements declared as a being of a + type that is an abstract type to/from the concrete type actually to be used + in a message. On an element that is decleared to be a type which is an + abstract type, the value of the ::type key in the dictionary will + specify the concrete type to be actually used (or for a reply message the + concrete type that was actually used). +

    +

    + NOTE: While in the WSDL the concreate type must be an extention + of the abstract type, the package does not enforce this restriction, so + caution must be taken. +

    + + + + DELETED docs/Creating a Tcl Web Service.html Index: docs/Creating a Tcl Web Service.html ================================================================== --- docs/Creating a Tcl Web Service.html +++ /dev/null @@ -1,203 +0,0 @@ - - -Creating a Tcl Web Service - - - - -

    Creating a Tcl Web Service

    - - - - - - - -
    -
    -

    Contents

    - -
    - - -

    Loading the Webservices Server Package

    - -

    To load the webservices server package, do:

    -
     package require WS::Server
    -

    This command will only load the server the first time it is used, so it -causes no ill effects to put this in each file declaring a service or service -procedure.

    - -

    Using as part of TclHttpd

    - -

    -The Web Services package, WS::Server, is not a standalone application, but rather is designed -be a "module" of TclHttpd. -The following command is normally placed in httpdthread.tcl: -

    - - -

    Embedding in a Standalone Application

    - -

    -To embed a Web Service into an application, the application needs to be event -driven and you also need to use the WS::Embeded package. You also must -define the service with the -mode=embedded option. -

    - -

    -See also -Embedding a Web Service into an application. -

    - -

    Using with Apache Rivet

    - -

    -Apache Rivet is a module (mod_rivet) that can be loaded by Apache httpd server to -allow web pages to run embedded Tcl commands in a way similar to PHP. To create -a Web Service in Rivet, use the example EchoRivetService.rvt as a starting point -by simply copying it into any directory served by your Apache instance. You should be able to -immediately access that new location at the following URLs: -

    -
                   /path/to/EchoRivetService.rvt/doc
-                     Displays an HTML page describing the service
-               /path/to/EchoRivetService.rvt/wsdl
-                     Returns a WSDL describing the service
-               /path/to/EchoRivetService.rvt/op
-                     Invoke an operation
-
    -

    -If you would prefer to expose the published URLs of your service differently, you can use the -standard Apache mod_rewrite or mod_alias modules to transparently map any other URL to those locations. -

    - - -
    - - -

    Defining a Service

    - -

    -The code that defines a service is normally placed in one or more files in the custom directory. -

    - -

    Procedure Name : ::WS::Server::Service

    -

    Description : Declare a Web Service, the following URLs will -exist 

                   /service/<ServiceName>
-                     Displays an HTML page describing the service
-               /service/<ServiceName>/wsdl
-                     Returns a WSDL describing the service
-               /service/<ServiceName>/op
-                     Invoke an operation
-
    -

    Arguments : this procedure uses position independent arguments, -they are: 

                 -host           - The host name for this service
-                                     Defaults to "localhost"
-             -description    - The HTML description for this service
-             -xmlnamespace   - Extra XML namespaces used by the service
-             -service        - The service name (this will also be used for
-                                 the Tcl namespace of the procedures that implement
-                                 the operations.
-             -premonitor     - This is a command prefix to be called before
-                                 an operation is called.  The following arguments are
-                                 added to the command prefix:
-                                    PRE serviceName operationName operArgList
-             -postmonitor    - This is a command prefix to be called after
-                                 an operation is called.  The following arguments are
-                                 added to the command prefix:
-                                    POST serviceName operationName OK|ERROR results
-             -inheaders      - List of input header types.
-             -outheaders     - List of output header types.
-             -checkheader    - Command prefix to check headers.
-                                   If the call is not to be allowed, this command
-                                   should raise an error.
-                                   The signature of the command must be:
-                                     cmd \
-                                         service \
-                                         operation \
-                                         caller_ipaddr \
-                                         http_header_list \
-                                         soap_header_list
-            -mode           - Mode that service is running in.  Must be one of:
-                                   tclhttpd  -- running inside of tclhttpd or an
-                                                environment that supplies a
-                                                compatible Url_PrefixInstall
-                                                and Httpd_ReturnData commands
-                                   embedded  -- using the ::WS::Embedded package
-                                   aolserver -- using the ::WS::AolServer package
-                                   wub       -- using the ::WS::Wub package
-                                   wibble    -- running inside wibble
-                                   rivet     -- running inside Apache Rivet (mod_rivet)
-            -ports          - List of ports for embedded mode. Default: 80
-                                    NOTE -- a call should be to
-                                            ::WS::Embedded::Listen for each port
-                                            in this list prior to this call
-            -prefix         - Path prefix used for the namespace and endpoint
-                              Defaults to "/service/" plus the service name
-            -traceEnabled   - Boolean to enable/disable trace being passed back in exception
-                              Defaults to "Y"
-            -docFormat      - Format of the documentation for operations ("text" or "html").
-                              Defaults to "text"
-
-
    -

    Returns : Nothing

    -

    Side-Effects : None

    -

    Exception Conditions : 

         MISSREQARG -- Missing required arguments
-
    -

    Pre-requisite Conditions : None

    -
    - - -

    Defining an Operation (aka a Service Procedure)

    -

    Procedure Name : ::WS::Server::ServiceProc

    -

    Description : Register an operation for a service and declare the -procedure to handle the operations.

    -

    Arguments : 

         ServiceName     -- Name of the service this operation is for
-     NameInfo        -- List of three elements:
-                             1) OperationName -- the name of the operation
-                             2) ReturnType    -- the type of the procedure return,
-                                                 this can be a simple or complex type
-                             3) Description   -- description of the return method
-     Arglist         -- List of argument definitions,
-                         each list element must be of the form:
-                             1) ArgumentName -- the name of the argument
-                             2) ArgumentTypeInfo -- -- A list of:
-                                    {type typeName comment commentString}
-                                         typeName can be any simple or defined type.
-                                         commentString is a quoted string describing the field
-     Documentation   -- HTML describing what this operation does
-     Body            -- The tcl code to be called when the operation is invoked. This
-                            code should return a dictionary with <OperationName>Result as a
-                            key and the operation's result as the value.
-
    -

    Returns : Nothing

    -

    Side-Effects : 

       A procedure named "<ServiceName>::<OperationName>" defined
-   A type name with the name <OperationName>Result is defined.
-
    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : ::WS::Server::Server must have -been called for the ServiceName

    -
    - - -

    Declaring Complex Types

    -

    See: Creating -a Web Service Type from Tcl

    - - - DELETED docs/Creating a Web Service Type.html Index: docs/Creating a Web Service Type.html ================================================================== --- docs/Creating a Web Service Type.html +++ /dev/null @@ -1,126 +0,0 @@ - - -Creating a Web Service Type from Tcl - - - - - - -

    Creating a Web Service Type from Tcl

    - - - -
    -
    -

    Contents

    -
    -

    - - -

    - - -

    Overview

    -

    Webservice Type declaration is part of the Webservices Utility package.

    -

    When writing a web service it is often requried to write a complex type -definition for an argument containing structured data.

    -

    When calling an operation on a web service it is sometimes convient to define -a complex type to return structured data as an XML fragment even though the -sevice may state that it is only expecting a string.

    - - -

    Loading the Webservices Utility Package

    -

    To load the webservices server package, do: 

     package require WS::Utils
-
    -

    This command will only load the utilities the first time it is used, so it -causes no ill effects to put this in each file using the utilties.

    -
    - - -

    Defining a type

    -

    Procedure Name : ::WS::Utils::ServiceTypeDef

    -

    Description : Define a type for a service.

    -

    Arguments : 

         mode            - Client or Server
-     service         - The name of the service this type definition is for
-     type            - The type to be defined/redefined
-     definition      - The definition of the type's fields.  This consist of one
-                           or more occurance of a field definition.  Each field definition
-                           consist of:  fieldName fieldInfo
-                           Where field info is: {type typeName comment commentString}
-                              typeName can be any simple or defined type.
-                              commentString is a quoted string describing the field.
-
    -

    Returns : Nothing

    -

    Side-Effects : None

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : None

    -
    - - -

    Defining a derived type

    -

    Procedure Name : ::WS::Utils::ServiceSimpleTypeDef

    -

    Description : Define a derived type for a service.

    -

    Arguments : 

         mode            - Client or Server
-     service         - The name of the service this type definition is for
-     type            - The type to be defined/redefined
-     definition      - The definition of the type's fields.  This consist of one
-                           or more occurance of a field definition.  Each field definition
-                           consist of:  fieldName fieldInfo
-                           Where: {type typeName comment commentString}
-                              baseType typeName - any simple or defined type.
-                              comment commentString - a quoted string describing the field.
-                              pattern value
-                              length value
-                              fixed "true"|"false"
-                              maxLength value
-                              minLength value
-                              minInclusive value
-                              maxInclusive value
-                              enumeration value
-
-
    -

    Returns : Nothing

    -

    Side-Effects : None

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : None

    -
    - - -

    Getting a type definition

    -

    Procedure Name : ::WS::Utils::GetServiceTypeDef

    -

    Description : Query for type definitions.

    -

    Arguments : 

         mode            - Client or Server
-     service         - The name of the service this query is for
-     type            - The type to be retrieved (optional)
-
    -

    Returns : 

         If type not provided, a dictionary object describing all of the types
-     for the service.
-     If type provided, a dictionary object describing the type.
-       A definition consist of a dictionary object with the following key/values:
-         xns         - The namespace for this type.
-         definition  - The definition of the type's fields.  This consist of one
-                       or more occurance of a field definition.  Each field definition
-                       consist of:  fieldName fieldInfo
-                       Where field info is: {type typeName comment commentString}
-                         typeName can be any simple or defined type.
-                         commentString is a quoted string describing the field.
-
    -

    Side-Effects : None

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : The service must be defined.

    - - - ADDED docs/Creating_a_Tcl_Web_Service.html Index: docs/Creating_a_Tcl_Web_Service.html ================================================================== --- /dev/null +++ docs/Creating_a_Tcl_Web_Service.html @@ -0,0 +1,263 @@ + + +Creating a Tcl Web Service + + + + + +

    Creating a Tcl Web Service

    + + + + + + + +
    +
    +

    Contents

    + +
    + + +

    Loading the Webservices Server Package

    + +

    To load the webservices server package, do:

    +
     package require WS::Server
    +

    This command will only load the server the first time it is used, so it +causes no ill effects to put this in each file declaring a service or service +procedure.

    + +

    Using as part of TclHttpd

    + +

    +The Web Services package, WS::Server, is not a standalone application, but rather is designed +to be a "module" of TclHttpd. +The following command is normally placed in httpdthread.tcl: +

    + + +

    Embedding in a Standalone Application

    + +

    +To embed a Web Service into an application, the application needs to be event +driven and you also need to use the WS::Embeded package. You also must +define the service with the -mode=embedded option. +

    + +

    +See also +Embedding a Web Service into an application. +

    + +

    Using with Apache Rivet

    + +

    +Apache Rivet is a module (mod_rivet) that can be loaded by Apache httpd server to +allow web pages to run embedded Tcl commands in a way similar to PHP. To create +a Web Service in Rivet, use the example EchoRivetService.rvt as a starting point +by simply copying it into any directory served by your Apache instance. You should be able to +immediately access that new location at the following URLs: +

    +
                   /path/to/EchoRivetService.rvt/doc
+                     Displays an HTML page describing the service
+               /path/to/EchoRivetService.rvt/wsdl
+                     Returns a WSDL describing the service
+               /path/to/EchoRivetService.rvt/op
+                     Invoke an operation
+
    +

    +If you would prefer to expose the published URLs of your service differently, you can use the +standard Apache mod_rewrite or mod_alias modules to transparently map any other URL to those locations. +

    + + +
    + + +

    Defining a Service

    + +

    +The code that defines a service is normally placed in one or more files in the custom directory. +

    + +

    Procedure Name : ::WS::Server::Service

    +

    Description : Declare a Web Service, the following URLs will +exist 

                   /service/<ServiceName>
+                     Displays an HTML page describing the service
+               /service/<ServiceName>/wsdl
+                     Returns a WSDL describing the service
+               /service/<ServiceName>/op
+                     Invoke an operation
+
    +

    Arguments : this procedure uses position independent arguments, +they are: 

    +             -hostcompatibility32 bool - Activate version 3.2.0 compatibility
+                               mode for -host parameter.
+                               Defaults to true.
+             -host           - The host specification within XML namespaces
+                               of the transmitted XML files.
+                               This should be unique.
+                               Defaults to localhost.
+                               If 3.2 compatibility is activated, the default
+                               value is changed to ip:port in embedded mode.
+             -hostlocation   - The host name, which is promoted within the
+                               generated WSDL file. Defaults to localhost.
+                               If 3.2 compatibility is activated, the
+                               default value is equal to the -host parameter.
+             -hostlocationserver bool - If true, the host location is set by
+                               the current server settings.
+                               In case of httpd server, this value is imported.
+                               For other servers or if this fails, the value
+                               is the current ip:port.
+                               The default value is true.
+                               In case of 3.2 compatibility, the default
+                               value is true for tclhttpd, false otherwise.
+             -hostProtocol   - Define the host protocol (http, https) for the
+                               WSDL location URL. The special value "server"
+                               (default) follows the TCP/IP server specification.
+                               This is implemented for Embedded server and tclhttpd.
+                               Remark that the protocol for XML namespaces
+                               is always "http".
+             -description    - The HTML description for this service
+             -htmlhead       - The title string of the service description
+             -author         - The author property in the service description
+             -xmlnamespace   - Extra XML namespaces used by the service
+             -service        - The service name (this will also be used for
+                                 the Tcl namespace of the procedures that implement
+                                 the operations.
+             -premonitor     - This is a command prefix to be called before
+                                 an operation is called.  The following arguments are
+                                 added to the command prefix:
+                                    PRE serviceName operationName operArgList
+             -postmonitor    - This is a command prefix to be called after
+                                 an operation is called.  The following arguments are
+                                 added to the command prefix:
+                                    POST serviceName operationName OK|ERROR results
+             -inheaders      - List of input header types.
+             -outheaders     - List of output header types.
+             -intransform    - Inbound (request) transform procedure (2.0.3 and later).
+                                The signature of the command must be:
+                                     cmd \
+                                         mode (REQUEST) \
+                                         xml \
+                                         notUsed_1 \
+                                         notUsed_2
+             -outtransform   - Outbound (reply) transform procedure (2.0.3 and later).
+                                The signature of the command must be:
+                                     cmd \
+                                         mode (REPLY) \
+                                         xml \
+                                         operation \
+                                         resultDict
+             -checkheader    - Command prefix to check headers.
+                                   If the call is not to be allowed, this command
+                                   should raise an error.
+                                   The signature of the command must be:
+                                     cmd \
+                                         service \
+                                         operation \
+                                         caller_ipaddr \
+                                         http_header_list \
+                                         soap_header_list
+            -mode           - Mode that service is running in.  Must be one of:
+                                   tclhttpd  -- running inside of tclhttpd or an
+                                                environment that supplies a
+                                                compatible Url_PrefixInstall
+                                                and Httpd_ReturnData commands
+                                   embedded  -- using the ::WS::Embedded package
+                                   aolserver -- using the ::WS::AolServer package
+                                   wub       -- using the ::WS::Wub package
+                                   wibble    -- running inside wibble
+                                   rivet     -- running inside Apache Rivet (mod_rivet)
+            -ports          - List of ports for embedded mode. Default: 80
+                                    NOTE -- a call should be to
+                                            ::WS::Embedded::Listen for each port
+                                            in this list prior to calling ::WS::Embeded::Start
+            -prefix         - Path prefix used for the namespace and endpoint
+                              Defaults to "/service/" plus the service name
+            -traceEnabled   - Boolean to enable/disable trace being passed back in exception
+                              Defaults to "Y"
+            -docFormat      - Format of the documentation for operations ("text" or "html").
+                              Defaults to "text"
+            -stylesheet     - The CSS stylesheet URL used in the HTML documentation
+
+            -errorCallback  - Callback to be invoked in the event of an error being produced
+            -verifyUserArgs - Boolean to enable/disable validating user supplied arguments
+                              Defaults to "N"
+            -enforceRequired - Throw an error if a required field is not included in the
+                               response.
+                               Defaults to "N"
+
    +

    Returns : Nothing

    +

    Side-Effects : None

    +

    Exception Conditions : 

         MISSREQARG -- Missing required arguments
+
    +

    Pre-requisite Conditions : None

    +
    + + +

    Defining an Operation (aka a Service Procedure)

    +

    Procedure Name : ::WS::Server::ServiceProc

    +

    Description : Register an operation for a service and declare the +procedure to handle the operations.

    +

    Arguments : 

         ServiceName     -- Name of the service this operation is for
+     NameInfo        -- List of two elements:
+                             1) OperationName -- the name of the operation
+                             2) ReturnType    -- the type of the procedure return,
+                                                 this can be a simple or complex type
+     Arglist         -- List of argument definitions,
+                         each list element must be of the form:
+                             1) ArgumentName -- the name of the argument
+                             2) ArgumentTypeInfo -- -- A list of:
+                                    {type typeName comment commentString}
+                                         typeName can be any simple or defined type.
+                                         commentString is a quoted string describing the field
+     Documentation   -- HTML describing what this operation does
+     Body            -- The tcl code to be called when the operation is invoked. This
+                            code should return a dictionary with <OperationName>Result as a
+                            key and the operation's result as the value.
+
    + +Available simple types are: +
    • anyType, string, boolean, decimal, float, double, duration, dateTime, time, date, gYearMonth, gYear, gMonthDay, gDay, gMonth, hexBinary, base64Binary, anyURI, QName, NOTATION, normalizedString, token, language, NMTOKEN, NMTOKENS, Name, NCName, ID, IDREF, IDREFS, ENTITY, ENTITIES, integer, nonPositiveInteger, negativeInteger, long, int, short, byte, nonNegativeInteger, unsignedLong, unsignedInt, unsignedShort, unsignedByte, positiveInteger
    + + +The typeName may contain the following suffixes: +
      +
    • () : type is an array
      • +
    • ? : type is an optional parameter
      • +
    + +

    Returns : Nothing

    +

    Side-Effects : 

       A procedure named "<ServiceName>::<OperationName>" defined
+   A type name with the name <OperationName>Result is defined.
+
    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : ::WS::Server::Server must have +been called for the ServiceName

    +
    + + +

    Declaring Complex Types

    +

    See: Creating +a Web Service Type from Tcl

    + + + ADDED docs/Creating_a_Web_Service_Type.html Index: docs/Creating_a_Web_Service_Type.html ================================================================== --- /dev/null +++ docs/Creating_a_Web_Service_Type.html @@ -0,0 +1,144 @@ + + +Creating a Web Service Type from Tcl + + + + + + + +

    Creating a Web Service Type from Tcl

    + + + +
    +
    +

    Contents

    +
    +

    + + +

    + + +

    Overview

    +

    Webservice Type declaration is part of the Webservices Utility package.

    +

    When writing a web service it is often requried to write a complex type +definition for an argument containing structured data.

    +

    When calling an operation on a web service it is sometimes convient to define +a complex type to return structured data as an XML fragment even though the +sevice may state that it is only expecting a string.

    + + +

    Loading the Webservices Utility Package

    +

    To load the webservices server package, do: 

     package require WS::Utils
+
    +

    This command will only load the utilities the first time it is used, so it +causes no ill effects to put this in each file using the utilties.

    +
    + + +

    Defining a type

    +

    Procedure Name : ::WS::Utils::ServiceTypeDef

    +

    Description : Define a type for a service.

    +

    Arguments : 

         mode            - Client or Server
+     service         - The name of the service this type definition is for
+     type            - The type to be defined/redefined
+     definition      - The definition of the type's fields.  This consist of one
+                           or more occurance of a field definition.  Each field definition
+                           consist of:  fieldName fieldInfo
+                           Where field info is: {type typeName comment commentString}
+                              typeName can be any simple or defined type.
+                              commentString is a quoted string describing the field.
+
    +

    Returns : Nothing

    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : None

    +
    + + +

    Defining a derived type

    +

    Procedure Name : ::WS::Utils::ServiceSimpleTypeDef

    +

    Description : Define a derived type for a service.

    +

    Arguments : 

         mode            - Client or Server
+     service         - The name of the service this type definition is for
+     type            - The type to be defined/redefined
+     definition      - The definition of the type's fields.  This consist of one
+                           or more occurance of a field definition.  Each field definition
+                           consist of:  fieldName fieldInfo
+                           Where: {type typeName comment commentString}
+                              baseType typeName - any simple or defined type.
+                              comment commentString - a quoted string describing the field.
+                              pattern value
+                              length value
+                              fixed "true"|"false"
+                              maxLength value
+                              minLength value
+                              minInclusive value
+                              maxInclusive value
+                              enumeration value
+
+
    +

    Returns : Nothing

    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : None

    +
    + + +

    Getting a type definition

    +

    Procedure Name : ::WS::Utils::GetServiceTypeDef

    +

    Description : Query for type definitions.

    +

    Arguments : 

         mode            - Client or Server
+     service         - The name of the service this query is for
+     type            - The type to be retrieved (optional)
+
    +

    Returns : 

         If type not provided, a dictionary object describing all of the types
+     for the service.
+     If type provided, a dictionary object describing the type.
+       A definition consist of a dictionary object with the following key/values:
+         xns         - The namespace for this type.
+         definition  - The definition of the type's fields.  This consist of one
+                       or more occurance of a field definition.  Each field definition
+                       consist of:  fieldName fieldInfo
+                       Where field info is: {type typeName comment commentString}
+                         typeName can be any simple or defined type.
+                         commentString is a quoted string describing the field.
+
    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : The service must be defined.

    + +
    + +

    Generating a template dictionary for a type definition

    +

    Procedure Name : ::WS::Utils::GenerateTemplateDict

    +

    Description : Generate a template dictionary object for a given type.

    +

    Arguments : 

         mode            - Client or Server
+     serviceName     - The service name the type is defined in
+     type            - The name of the type
+     arraySize       - Number of elements to generate in an array.  Default is 2.
+
    +

    Returns : 

          A dictionary object for a given type.  If any circular references exist, they will have the value of <** Circular Reference **>
+
    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : The type and service must be defined.

    + + + ADDED docs/Defining_Types.html Index: docs/Defining_Types.html ================================================================== --- /dev/null +++ docs/Defining_Types.html @@ -0,0 +1,134 @@ + + + +Web Services for Tcl (aka tclws): Defining Types + + + + + +
    + +

    Contents

    +
    +

    + +

    + +

    +

    Overview

    +

    Webservice Type declaration is part of the Webservices Utility package.

    +

    When writing a web service it is often requried to write a complex type +definition for an argument containing structured data.

    +

    When calling an operation on a web service it is sometimes convient to define +a complex type to return structured data as an XML fragment even though the +sevice may state that it is only expecting a string.

    + +

    +

    Loading the Webservices Utility Package

    +

    To load the webservices server package, do: 

     package require WS::Utils
+
    +

    This command will only load the utilities the first time it is used, so it +causes no ill effects to put this in each file using the utilties.

    +
    + +

    +

    Defining a type

    +

    Procedure Name : ::WS::Utils::ServiceTypeDef

    +

    Description : Define a type for a service.

    +

    Arguments : 

         mode            - Client or Server
+     service         - The name of the service this type definition is for
+     type            - The type to be defined/redefined
+     definition      - The definition of the type's fields.  This consist of one
+                           or more occurance of a field definition.  Each field definition
+                           consist of:  fieldName fieldInfo
+                           Where field info is: {type typeName comment commentString}
+                              typeName can be any simple or defined type.
+                              commentString is a quoted string describing the field.
+
    +

    Returns : Nothing

    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : None

    +
    + +

    +

    Defining a derived type

    +

    Procedure Name : ::WS::Utils::ServiceSimpleTypeDef

    +

    Description : Define a derived type for a service.

    +

    Arguments : 

         mode            - Client or Server
+     service         - The name of the service this type definition is for
+     type            - The type to be defined/redefined
+     definition      - The definition of the type's fields.  This consist of one
+                           or more occurance of a field definition.  Each field definition
+                           consist of:  fieldName fieldInfo
+                           Where: {type typeName comment commentString}
+                              baseType typeName - any simple or defined type.
+                              comment commentString - a quoted string describing the field.
+                              pattern value
+                              length value
+                              fixed "true"|"false"
+                              maxLength value
+                              minLength value
+                              minInclusive value
+                              maxInclusive value
+                              enumeration value
+
+
    +

    Returns : Nothing

    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : None

    +
    + +

    +

    Getting a type definition

    +

    Procedure Name : ::WS::Utils::GetServiceTypeDef

    +

    Description : Query for type definitions.

    +

    Arguments : 

         mode            - Client or Server
+     service         - The name of the service this query is for
+     type            - The type to be retrieved (optional)
+
    +

    Returns : 

         If type not provided, a dictionary object describing all of the types
+     for the service.
+     If type provided, a dictionary object describing the type.
+       A definition consist of a dictionary object with the following key/values:
+         xns         - The namespace for this type.
+         definition  - The definition of the type's fields.  This consist of one
+                       or more occurance of a field definition.  Each field definition
+                       consist of:  fieldName fieldInfo
+                       Where field info is: {type typeName comment commentString}
+                         typeName can be any simple or defined type.
+                         commentString is a quoted string describing the field.
+
    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : The service must be defined.

    + +
    + +

    Generating a template dictionary for a type definition

    +

    Procedure Name : ::WS::Utils::GenerateTemplateDict

    +

    Description : Generate a template dictionary object for a given type.

    +

    Arguments : 

         mode            - Client or Server
+     serviceName     - The service name the type is defined in
+     type            - The name of the type
+     arraySize       - Number of elements to generate in an array.  Default is 2.
+
    +

    Returns : 

          A dictionary object for a given type.  If any circular references exist, they will have the value of <** Circular Reference **>
+
    +

    Side-Effects : None

    +

    Exception Conditions : None

    +

    Pre-requisite Conditions : The type and service must be defined.

    + + + ADDED docs/Dictionary_Representation_of_XML_Arrays.html Index: docs/Dictionary_Representation_of_XML_Arrays.html ================================================================== --- /dev/null +++ docs/Dictionary_Representation_of_XML_Arrays.html @@ -0,0 +1,66 @@ + + + +Web Services for Tcl (aka tclws): Dictionary Representation of XML Arrays + + + +

    +XML arrays are represented in dictionary format as a list of values. +Lets consider what this looks like for a +simple type and for a +complex type;. +

    + +

    +

    Array of Simple Type

    +

    +Lets assume we have an element with the following definition: +

        <xs:element minOccurs="0" maxOccurs="unbounded" name="Primes" type="xs:integer" />
+
    +Lets also assume that we will have that element in our dictionary with +the first four prime numbers, thus the dictionary representation for +that element would look like: +
        Primes {2 3 5 7}
+
    +Or, if we have are using attributes (i.e. parseInAttr and/or genOutAttr are set), it would look like: +
        Primes {{} {2 3 5 7}}
+
    +

    + +

    +

    Array of Complex Type

    +

    +Lets assume we have the type definition: +

    <xs:element name="Person">
+  <xs:complexType>
+    <xs:sequence>
+      <xs:element name="FristName" type="xs:string"/>
+      <xs:element name="LastName" type="xs:integer"/>
+    </xs:sequence>
+  </xs:complexType>
+</xs:element>
+
    +Lets assume we have the following definition: +
        <xs:element minOccurs="0" maxOccurs="unbounded" name="Attendees" type="Person" />
+
    +Now lets assume the following people are are attending: +
      +
    • John Doe
      • +
    • Jane Doe
      • +
    +Thus the dictionary representation for that element would look like: +
        Attendees {
+        {FirstName {John} LastName {Doe}}
+        {FirstName {Jane} LastName {Doe}}
+    }
+
    +Or, if we have are using attributes (i.e. parseInAttr and/or genOutAttr are set), it would look like: +
        Attendees {
+        {{} {FirstName {{} {John}} LastName {{} {Doe}}}}
+        {{} {FirstName {{} {Jane}} LastName {{} {Doe}}}}
+    }
+
    +

    + + DELETED docs/Embedded Web Service.html Index: docs/Embedded Web Service.html ================================================================== --- docs/Embedded Web Service.html +++ /dev/null @@ -1,95 +0,0 @@ - - -Embeding a Web Service - - - - -

    Embeding a Web Service

    - - - - - -
    -
    -

    Contents

    - -
    - - -

    Loading the Webservices Server Package

    - -

    To load the webservices server package, do: 

     package require WS::Embedded
-
    -

    This command will only load the server the first time it is used, so it -causes no ill effects to put this in each file declaring a service or service -procedure.

    - -
    - - -

    Specify a Port to Receive Request on

    - -

    Procedure Name : ::WS::Embeded::Listen

    -

    Description : Instruct the module to listen on a Port, security information. -

    Arguments : this procedure uses position dependent arguments, -they are:

    -
    -     port     -- Port number to listen on.
-     certfile -- Name of the certificate file. Defaults to {}.
-     keyfile  -- Name of the key file. Defaults to {}.
-     userpwds -- A list of username and passwords. Defaults to {}.
-     realm    -- The seucrity realm. Defaults to {}.
-     logger   -- A logging routines for errors. Defaults to ::WS::Embeded::logger.
-
    -

    Returns : Nothing

    -

    Side-Effects : None

    -

    Exception Conditions :  : None

    -

    Pre-requisite Conditions : None

    -
    - - -

    Start Listening for Requests

    -

    Procedure Name : ::WS::Embeded::Start

    -

    Description : Start listening on all ports (i.e. enter the event loop).

    -

    Arguments : None

    -

    Returns : Value that event loop was exited with.

    -

    Side-Effects : Nothing

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : 

    -
      -

      ::WS::Embeded::Listen should have been called for one or more port.

      -
    - -
    - - -

    Stop Listening for Requests

    -

    Procedure Name : ::WS::Embeded::Start

    -

    Description : Stop listening on all ports (i.e. enter the event loop).

    -

    Arguments :

    -
    -    value -- Value that ::WS::Embedded::Start should return
-
    -

    Returns : Nothing

    -

    Side-Effects : Nothing

    -

    Exception Conditions : None

    -

    Pre-requisite Conditions : 

    -
      -

      ::WS::Embeded::Start should have been called.

      -
    - - - - ADDED docs/Embedded_Web_Service.html Index: docs/Embedded_Web_Service.html ================================================================== --- /dev/null +++ docs/Embedded_Web_Service.html @@ -0,0 +1,122 @@ + + +Embeding a Web Service + + + + + +

    Embeding a Web Service

    + + + + + +
    +
    +

    Contents

    + +
    + + +

    Loading the Webservices Server Package

    + +

    To load the webservices server package, do: 

     package require WS::Embeded
+
    +

    This command will only load the server the first time it is used, so it +causes no ill effects to put this in each file declaring a service or service +procedure.

    + +
    + + +

    Specify a Port to Receive Request on

    + +

    The following command opens a listener socket in the specified port. +The webservice functionality may be added by a call to ::WS::Server::Service with the -mode parameter set to embedded. + +

    Procedure Name : ::WS::Embeded::Listen

    +

    Description : Instruct the module to listen on a Port, security information. +

    Arguments : this procedure uses position dependent arguments, +they are:

    +
    +     port     -- Port number to listen on.
+     certfile -- Name of the certificate file or a pfx archive for twapi.
+                 Defaults to {}.
+     keyfile  -- Name of the key file. Defaults to {}.
+                 To use twapi TLS, specify a list with the following elements:
+                 -- "-twapi": Flag, that TWAPI TLS should be used
+                 -- password: password of PFX file passed by
+                    [::twapi::conceal]. The concealing makes sure that the
+                    password is not readable in the error stack trace
+                 -- ?subject?: optional search string in pfx file, if
+                    multiple certificates are included.
+     userpwds -- A list of username:password. Defaults to {}.
+     realm    -- The seucrity realm. Defaults to {}.
+     timeout  -- A time in ms the sender may use to send the request.
+                 If a sender sends wrong data (Example: TLS if no TLS is
+                 used), the process will just stand and a timeout is required
+                 to clear the connection. Set to 0 to not use a timeout.
+                 Default: 60000 (1 Minuit).
+
    +

    Returns : Handle of socket

    +

    Side-Effects : None

    +

    Exception Conditions :  : None

    +

    Pre-requisite Conditions : None

    +
    + + +

    Run the event queue

    + +

    To serve any requests, the interpreter must run the event queue using. +If this is not anyway the case (Tk present etc.), one may call:

    +
    +     vwait waitVariable
+
    + +

    To stop the event queue after server shutdown, one may execute:

    +
    +     set waitVariable 1
+
    +
    + + +

    Close a port

    + +

    Procedure Name : ::WS::Embeded::Close

    +

    Description : Close a formerly opened listener port and stop all running requests on this port. +

    Arguments : this procedure uses position dependent arguments, +they are:

    +
    +     port     -- Port number to close.
+
    +

    Returns : None

    +

    Side-Effects : None

    +

    Exception Conditions :  : None

    +

    Pre-requisite Conditions : None

    +
    + + +

    Close all ports

    + +

    Procedure Name : ::WS::Embeded::CloseAll

    +

    Description : Close all formerly opened listener port and stop all running requests. +

    Arguments : this procedure uses no arguments

    +

    Returns : None

    +

    Side-Effects : None

    +

    Exception Conditions :  : None

    +

    Pre-requisite Conditions : None

    + + ADDED docs/Rest_flavor_service_response.html Index: docs/Rest_flavor_service_response.html ================================================================== --- /dev/null +++ docs/Rest_flavor_service_response.html @@ -0,0 +1,58 @@ + + +Rest-flavor service reply + + + + +

    Rest-flavor service reply

    + +
    + + + +
    +

    Contents

    +
    +

    + +

    + +

    Overview

    +

    Since TCLWS 2.4, it is possible to return a response in REST style. +This means, that a JSON reply is returned instead of an XML document.

    +

    Our use case has only required us to accept FORM arguments and return JSON responses for everything, so we haven't implemented logic to parse any input arguments that are passed in as JSON serialized data, but this might be an area of future exploration for someone.

    + + +

    Rivet Example

    +

    Here's a bit of code showing how we initially start up this mode in Apache Rivet, which is actually pretty similar to how you'd use tclws in SOAP mode from Apache Rivet:

    +
    +        # Capture the info from the request into an array.
+        load_headers hdrArray
+        set sock [pid];         # an arbitrary value
+        array unset ::Httpd$sock
+
+        # Prepare the CGI style arguments into a list
+        load_response formArray
+        set opname $formArray(call)
+        unset formArray(call)
+        set queryarg [list $opname [array get formArray]]
+
+        # Invoke the the method
+        array set ::Httpd$sock [list query $queryarg ipaddr [env REMOTE_ADDR] headerlist [array get hdrArray]]
+
+        # Invoke the method in REST mode.
+        set result [catch {::WS::Server::callOperation $svcname $sock -rest} error]
+        array unset ::Httpd$sock
+        if {$result} {
+                headers numeric 500
+                puts "Operation failed: $error"
+                abort_page
+        }
+
    + + DELETED docs/Tcl Web Service Example.html Index: docs/Tcl Web Service Example.html ================================================================== --- docs/Tcl Web Service Example.html +++ /dev/null @@ -1,126 +0,0 @@ - - -Tcl Web Service Example - - - - - - - -

    Tcl Web Service Example

    - - -

    Server Side

    - -

    -The following is placed in the httpdthread.tcl: -

    - -
       package require WS::Server
-   package require WS::Utils
-
    - -

    -The following is placed in the a file in the custom directory: -

    - -
    -   ##
-   ## Define the service
-   ##
-   ::WS::Server::Service \
-       -service wsExamples \
-       -description  {Tcl Example Web Services} \
-       -host         $::Config(host):$::Config(port)
-
       ##
-   ## Define any special types
-   ##
-   ::WS::Utils::ServiceTypeDef Server wsExamples echoReply {
-       echoBack     {type string}
-       echoTS       {type dateTime}
-   }
-
       ##
-   ## Define the operations available
-   ##
-   ::WS::Server::ServiceProc \
-       wsExamples \
-       {SimpleEcho {type string comment {Requested Echo}}} \
-       {
-           TestString      {type string comment {The text to echo back}}
-       } \
-       {Echo a string back} {
-
           return [list SimpleEchoResult $TestString]
-   }
-
    -


       ::WS::Server::ServiceProc \
-       wsExamples \
-       {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \
-       {
-           TestString      {type string comment {The text to echo back}}
-       } \
-       {Echo a string and a timestamp back} {
-
           set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes]
-       return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp]  ]
-   }
-
    -


    - - -

    Client Side 

       package require WS::Client
-
       ##
-   ## Get Definition of the offered services
-   ##
-   ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsExamples/wsdl
-
       set testString "This is a test"
-   set inputs [list TestString $testString]
-
       ##
-   ## Call synchronously
-   ##
-   puts stdout "Calling SimpleEcho via DoCalls!"
-   set results [::WS::Client::DoCall wsExamples SimpleEcho $inputs]
-   puts stdout "\t Received: {$results}"
-
       puts stdout "Calling ComplexEcho via DoCalls!"
-   set results [::WS::Client::DoCall wsExamples ComplexEcho $inputs]
-   puts stdout "\t Received: {$results}"
-
    -


       ##
-   ## Generate stubs and use them for the calls
-   ##
-   ::WS::Client::CreateStubs wsExamples
-   puts stdout "Calling SimpleEcho via Stubs!"
-   set results [::wsExamples::SimpleEcho $testString]
-   puts stdout "\t Received: {$results}"
-
       puts stdout "Calling ComplexEcho via Stubs!"
-   set results [::wsExamples::ComplexEcho $testString]
-   puts stdout "\t Received: {$results}"
-
       ##
-   ## Call asynchronously
-   ##
-   proc success {service operation result} {
-       global waitVar
-
           puts stdout "A call to $operation of $service was successful and returned $result"
-       set waitVar 1
-   }
-
       proc hadError {service operation errorCode errorInfo} {
-       global waitVar
-
           puts stdout "A call to $operation of $service was failed with {$errorCode} {$errorInfo}"
-       set waitVar 1
-   }
-
       set waitVar 0
-   puts stdout "Calling SimpleEcho via DoAsyncCall!"
-   ::WS::Client::DoCall wsExamples SimpleEcho $inputs \
-           [list success wsExamples SimpleEcho] \
-           [list hadError wsExamples SimpleEcho]
-   vwait waitVar
-
       puts stdout "Calling ComplexEcho via DoAsyncCall!"
-   ::WS::Client::DoCall wsExamples ComplexEcho $inputs \
-           [list success wsExamples SimpleEcho] \
-           [list hadError wsExamples SimpleEcho]
-   vwait waitVar
-
       exit
-
    -


    - - - DELETED docs/Tcl Web Service Math Example.html Index: docs/Tcl Web Service Math Example.html ================================================================== --- docs/Tcl Web Service Math Example.html +++ /dev/null @@ -1,142 +0,0 @@ - - -Tcl Web Service Math Example - - - - - - - -

    Tcl Web Service Math Example

    - - -

    Server Side

    - -

    -The following is placed in the httpdthread.tcl: -

    - -
    -   package require WS::Server
-   package require WS::Utils
-
    - -

    -The following is placed in the a file in the custom directory: -

    - -
    -    ##
-    ## Define the service
-    ##
-    ::WS::Server::Service \
-        -service wsMathExample \
-        -description  {Tcl Web Services Math Example} \
-        -host         $::Config(host):$::Config(port)
-
-    ##
-    ## Define any special types
-    ##
-    ::WS::Utils::ServiceTypeDef Server wsMathExample Term {
-       `coef         {type float}
-        powerTerms   {type PowerTerm()}
-    }
-    ::WS::Utils::ServiceTypeDef Server wsMathExample PowerTerm {
-        var          {type string}
-        exponet      {type float}
-    }
-    ::WS::Utils::ServiceTypeDef Server wsMathExample Variables {
-        var          {type string}
-        value        {type float}
-    }
-
-   ##
-   ## Define the operations available
-   ##
-   ::WS::Server::ServiceProc \
-        wsMathExample \
-        {EvaluatePolynomial {type float comment {Result of evaluating a polynomial}}} \
-        {
-            varList       {type Variables() comment {The variables to be substitued into the polynomial}}
-            polynomial    {type Term() comment {The polynomial}}
-        } \
-        {Evaluate a polynomial} {
-        set equation {0 }
-        foreach varDict $varList {
-            set var [dict get $varDict var]
-            set val [dict get $varDict value]
-            set vars($var) $val
-        }
-        foreach term $polynomial {
-            if {[dict exists $term coef]} {
-                set coef [dict get $term coef]
-            } else {
-                set coef 1
-            }
-            append equation "+ ($coef"
-            foreach pow [dict get $term powerTerms] {
-                if {[dict exists $pow exponet]} {
-                    set exp [dict get $pow exponet]
-                } else {
-                    set exp 1
-                }
-                append equation [format { * pow($vars(%s),%s} [dict get $pow var] $exp]
-            }
-            append equation ")"
-        }
-        set result [expr $equation]
-        return [list SimpleEchoResult $result]
-    }
-
    -


    - - -

    Client Side

    -
    -    package require WS::Client
-    ##
-    ## Get Definition of the offered services
-    ##
-    ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsMathExamples/wsdl
-
-    dict set term var X
-    dict set term value 2.0
-    dict lappend varList $term
-    dict set term var Y
-    dict set term value 3.0
-    dict lappend varList $term
-
-    set term {}
-    set powerTerm {}
-    dict set powerTerm coef 2.0
-    dict set term var X
-    dict set term pow 2.0
-    dict lappend terms $term
-    dict set term var Y
-    dict set term pow 3.0
-    dict lappend terms $term
-    dict set powerTerm powerTerms $terms
-
-    dict set powerTerm coef -2.0
-    dict set term var X
-    dict set term pow 3.0
-    dict lappend terms $term
-    dict set term var Y
-    dict set term pow 2.0
-    dict lappend terms $term
-    dict set powerTerm powerTerms $terms
-    dict lappend polynomial powerTerms $powerTerm
-
-    dict set input [list varList $varList polynomial $polynomial]
-    ##
-    ## Call service
-    ##
-    puts stdout "Calling EvaluatePolynomial wiht {$input}"
-    set resultsDict [::WS::Client::DoCall wsMathExample EvaluatePolynomial $input]
-    puts stdout "Results are {$resultsDict}"
-
    -


    - - - ADDED docs/Tcl_Web_Service_Example.html Index: docs/Tcl_Web_Service_Example.html ================================================================== --- /dev/null +++ docs/Tcl_Web_Service_Example.html @@ -0,0 +1,126 @@ + + +Tcl Web Service Example + + + + + + + +

    Tcl Web Service Example

    + + +

    Server Side

    + +

    +The following is placed in the httpdthread.tcl: +

    + +
       package require WS::Server
+   package require WS::Utils
+
    + +

    +The following is placed in the a file in the custom directory: +

    + +
    +   ##
+   ## Define the service
+   ##
+   ::WS::Server::Service \
+       -service wsExamples \
+       -description  {Tcl Example Web Services} \
+       -host         $::Config(host):$::Config(port)
+
       ##
+   ## Define any special types
+   ##
+   ::WS::Utils::ServiceTypeDef Server wsExamples echoReply {
+       echoBack     {type string}
+       echoTS       {type dateTime}
+   }
+
       ##
+   ## Define the operations available
+   ##
+   ::WS::Server::ServiceProc \
+       wsExamples \
+       {SimpleEcho {type string comment {Requested Echo}}} \
+       {
+           TestString      {type string comment {The text to echo back}}
+       } \
+       {Echo a string back} {
+
           return [list SimpleEchoResult $TestString]
+   }
+
    +


       ::WS::Server::ServiceProc \
+       wsExamples \
+       {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \
+       {
+           TestString      {type string comment {The text to echo back}}
+       } \
+       {Echo a string and a timestamp back} {
+
           set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes]
+       return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp]  ]
+   }
+
    +


    + + +

    Client Side 

       package require WS::Client
+
       ##
+   ## Get Definition of the offered services
+   ##
+   ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsExamples/wsdl
+
       set testString "This is a test"
+   set inputs [list TestString $testString]
+
       ##
+   ## Call synchronously
+   ##
+   puts stdout "Calling SimpleEcho via DoCalls!"
+   set results [::WS::Client::DoCall wsExamples SimpleEcho $inputs]
+   puts stdout "\t Received: {$results}"
+
       puts stdout "Calling ComplexEcho via DoCalls!"
+   set results [::WS::Client::DoCall wsExamples ComplexEcho $inputs]
+   puts stdout "\t Received: {$results}"
+
    +


       ##
+   ## Generate stubs and use them for the calls
+   ##
+   ::WS::Client::CreateStubs wsExamples
+   puts stdout "Calling SimpleEcho via Stubs!"
+   set results [::wsExamples::SimpleEcho $testString]
+   puts stdout "\t Received: {$results}"
+
       puts stdout "Calling ComplexEcho via Stubs!"
+   set results [::wsExamples::ComplexEcho $testString]
+   puts stdout "\t Received: {$results}"
+
       ##
+   ## Call asynchronously
+   ##
+   proc success {service operation result} {
+       global waitVar
+
           puts stdout "A call to $operation of $service was successful and returned $result"
+       set waitVar 1
+   }
+
       proc hadError {service operation errorCode errorInfo} {
+       global waitVar
+
           puts stdout "A call to $operation of $service was failed with {$errorCode} {$errorInfo}"
+       set waitVar 1
+   }
+
       set waitVar 0
+   puts stdout "Calling SimpleEcho via DoAsyncCall!"
+   ::WS::Client::DoAsyncCall wsExamples SimpleEcho $inputs \
+           [list success wsExamples SimpleEcho] \
+           [list hadError wsExamples SimpleEcho]
+   vwait waitVar
+
       puts stdout "Calling ComplexEcho via DoAsyncCall!"
+   ::WS::Client::DoAsyncCall wsExamples ComplexEcho $inputs \
+           [list success wsExamples SimpleEcho] \
+           [list hadError wsExamples SimpleEcho]
+   vwait waitVar
+
       exit
+
    +


    + + + ADDED docs/Tcl_Web_Service_Math_Example.html Index: docs/Tcl_Web_Service_Math_Example.html ================================================================== --- /dev/null +++ docs/Tcl_Web_Service_Math_Example.html @@ -0,0 +1,142 @@ + + +Tcl Web Service Math Example + + + + + + + +

    Tcl Web Service Math Example

    + + +

    Server Side

    + +

    +The following is placed in the httpdthread.tcl: +

    + +
    +   package require WS::Server
+   package require WS::Utils
+
    + +

    +The following is placed in the a file in the custom directory: +

    + +
    +    ##
+    ## Define the service
+    ##
+    ::WS::Server::Service \
+        -service wsMathExample \
+        -description  {Tcl Web Services Math Example} \
+        -host         $::Config(host):$::Config(port)
+
+    ##
+    ## Define any special types
+    ##
+    ::WS::Utils::ServiceTypeDef Server wsMathExample Term {
+       `coef         {type float}
+        powerTerms   {type PowerTerm()}
+    }
+    ::WS::Utils::ServiceTypeDef Server wsMathExample PowerTerm {
+        var          {type string}
+        exponet      {type float}
+    }
+    ::WS::Utils::ServiceTypeDef Server wsMathExample Variables {
+        var          {type string}
+        value        {type float}
+    }
+
+   ##
+   ## Define the operations available
+   ##
+   ::WS::Server::ServiceProc \
+        wsMathExample \
+        {EvaluatePolynomial {type float comment {Result of evaluating a polynomial}}} \
+        {
+            varList       {type Variables() comment {The variables to be substitued into the polynomial}}
+            polynomial    {type Term() comment {The polynomial}}
+        } \
+        {Evaluate a polynomial} {
+        set equation {0 }
+        foreach varDict $varList {
+            set var [dict get $varDict var]
+            set val [dict get $varDict value]
+            set vars($var) $val
+        }
+        foreach term $polynomial {
+            if {[dict exists $term coef]} {
+                set coef [dict get $term coef]
+            } else {
+                set coef 1
+            }
+            append equation "+ ($coef"
+            foreach pow [dict get $term powerTerms] {
+                if {[dict exists $pow exponet]} {
+                    set exp [dict get $pow exponet]
+                } else {
+                    set exp 1
+                }
+                append equation [format { * pow($vars(%s),%s} [dict get $pow var] $exp]
+            }
+            append equation ")"
+        }
+        set result [expr $equation]
+        return [list SimpleEchoResult $result]
+    }
+
    +


    + + +

    Client Side

    +
    +    package require WS::Client
+    ##
+    ## Get Definition of the offered services
+    ##
+    ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsMathExamples/wsdl
+
+    dict set term var X
+    dict set term value 2.0
+    dict lappend varList $term
+    dict set term var Y
+    dict set term value 3.0
+    dict lappend varList $term
+
+    set term {}
+    set powerTerm {}
+    dict set powerTerm coef 2.0
+    dict set term var X
+    dict set term pow 2.0
+    dict lappend terms $term
+    dict set term var Y
+    dict set term pow 3.0
+    dict lappend terms $term
+    dict set powerTerm powerTerms $terms
+
+    dict set powerTerm coef -2.0
+    dict set term var X
+    dict set term pow 3.0
+    dict lappend terms $term
+    dict set term var Y
+    dict set term pow 2.0
+    dict lappend terms $term
+    dict set powerTerm powerTerms $terms
+    dict lappend polynomial powerTerms $powerTerm
+
+    dict set input [list varList $varList polynomial $polynomial]
+    ##
+    ## Call service
+    ##
+    puts stdout "Calling EvaluatePolynomial wiht {$input}"
+    set resultsDict [::WS::Client::DoCall wsMathExample EvaluatePolynomial $input]
+    puts stdout "Results are {$resultsDict}"
+
    +


    + + + DELETED docs/Using Options.html Index: docs/Using Options.html ================================================================== --- docs/Using Options.html +++ /dev/null @@ -1,139 +0,0 @@ - - -Using Web Service Options - - - -

    Using Web Service Options

    - - - - -
    -

    Contents

    - -

    - -

    - -

    Overview

    -

    -

    The Webservices Client and Server packages make use of the following options: -

    -

    - -

    The attributes can be retrieved and set using ::WS::Utils::SetOption.

    - -
    - -

    Loading the Webservices Client Package

    -

    To load the webservices server package, do: 

     package require WS::Client
-
    -

    This command will only load the utilities the first time it is used, so it -causes no ill effects to put this in each file using the utilties.

    -
    - - - -

    UseNS - put namespaces on field tags

    -

    - The UseNS option, if set to a "true" value, will put a namespace alias on all field tags. -

    -

    - The default value, "1", is for this option to be turned on. -

    -
    - - - -

    StrictMode - WSDL processing mode

    -

    - The StrictMode option determines what happens when an error is detected in parsing a WSDL. The legal values are: -

      -
    • debug
      • -
    • warning
      • -
    • error
      • -
    -

    -

    - If the StrictMode is set to debug or warning, - a message is logged using the ::log package at that level and the error is then ignored. -

    -

    - If the StrictMode is set to any value other than debug or warning, - a message is logged using the ::log package at the error level and exception is generated. -

    -

    - The default value is error. -

    -

    - A major use of this is to ignore namespace imports in a WDSL that do not actually import any definitions. -

    -
    - - - -

    parseInAttr - parse attributes on inbound tags

    -

    - The parseInAttr option, if set to a "true" value, - will convert all attributes of inbound field tags to dictionary entries for that tag. - The key will be the attribute name and the value will be the value of the attribute. - The value of the tag will have an key of the null string (i.e. {}). -

    -

    - The default value, "0", is for this option to be turned off. -

    -
    - - - -

    genOutAttr - generate attributes on outbound tags

    -

    - The genOutAttr option, if set to a "true" value, - will convert all dictionary keys of the entry for a given field tag to attribute value pairs - of the tag in the outbound XML. - The key will be the attribute name and the value will be the value of the attribute. - The value of the tag will have a key of the null string (i.e. {}). -

    -

    - The default value, "0", is for this option to be turned off. -

    -
    - - - -

    Access Routine

    -

    Procedure Name : ::WS::Client::SetOption

    -

    Description : Retrieve or set an option

    -

    Arguments :

    -
    -    option - name of the option
-    value - value of the option (optional)
-
    -

    Returns : The value of the option

    -

    Side-Effects : None

    -

    Exception Conditions :None

    -

    Pre-requisite Conditions : None

    -
    - - - ADDED docs/Using_Options.html Index: docs/Using_Options.html ================================================================== --- /dev/null +++ docs/Using_Options.html @@ -0,0 +1,233 @@ + + +Using Web Service Options + + + + +

    Using Web Service Options

    + + + + +
    +

    Contents

    + +

    + +

    + +

    Overview

    +

    +

    The Webservices Client and Server packages make use of the following options: +

    +

    + +

    The attributes can be retrieved and set using ::WS::Utils::SetOption.

    + +

    If called by the client side, the following options are overwritten and restored on any call: +

      +
    • genOutAttr
      • +
    • nsOnChangeOnly
      • +
    • parseInAttr
      • +
    • suppressNS
      • +
    • UseNS
      • +
    • useTypeNs
      • +
    • valueAttrCompatiblityMode
      • +
    + +

    + +
    + +

    Loading the Webservices Utilities Package

    +

    To load the webservices server package, do: 

     package require WS::Utils
+
    +

    This command will only load the utilities the first time it is used, so it +causes no ill effects to put this in each file using the utilties.

    +
    + + +

    Access Routine

    +

    Procedure Name : ::WS::Utils::SetOption

    +

    Description : Retrieve or set an option

    +

    Arguments :

    +
    +    option - name of the option
+    value - value of the option (optional)
+
    +

    Returns : The value of the option

    +

    Side-Effects : None

    +

    Exception Conditions :None

    +

    Pre-requisite Conditions : None

    +
    + + +

    genOutAttr - generate attributes on outbound tags

    +

    + The genOutAttr option, if set to a "true" value, + will convert all dictionary keys of the entry for a given field tag to attribute value pairs + of the tag in the outbound XML. + For attributes in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name prepended with two colons (e.g. ::type) and the value will be the value of the attribute. + For attributes other than those in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name and the value will be the value of the attribute. + The value of the tag will have a key determined by the valueAttrCompatiblityMode. +

    +

    + The default value, "0", is for this option to be turned off. +

    +
    + +

    +

    includeDirectory - disk directory to use for XSD includes when they can not be accessed via the Web.

    +

    + The includeDirectory option, if set, instructs TclWs to look in the specified directory for any XSD includes that can not be found via the web. +

    +

    + The default value, "{}", is for this option to be turned off. +

    +
    + +

    +

    nsOnChangeOnly - only put namespace prefix when namespaces change

    +

    + The nsOnChangeOnly option, if set to a "true" value, + will only place namespace prefixes when the namespaces change. +

    +

    + This option is only relevant, if the option UseNS is set. +

    +

    + The default value, "0", is for this option to be turned off. +

    +
    + + +

    parseInAttr - parse attributes on inbound tags

    +

    + The parseInAttr option, if set to a "true" value, + will convert all attributes of inbound field tags to dictionary entries for that tag. + For attributes in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name prepended with two colons (e.g. ::type) and the value will be the value of the attribute. + For attributes other than those in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name and the value will be the value of the attribute. + The value of the tag will have a key determined by the valueAttrCompatiblityMode. +

    +

    + The default value, "0", is for this option to be turned off. +

    +
    + +

    +

    queryTimeout - set http(s) query timeout

    +

    + Timeout to any network query in ms. + The client side package has an option with the same functionality, which is used, when there is a call option context. +

    +

    Default value: 60000 (1 minuite).

    +
    + + +

    StrictMode - WSDL processing mode

    +

    + The StrictMode option determines what happens when an error is detected in parsing a WSDL. The legal values are: +

      +
    • debug
      • +
    • warning
      • +
    • error
      • +
    +

    +

    + If the StrictMode is set to debug or warning, + a message is logged using the ::log package at that level and the error is then ignored. +

    +

    + If the StrictMode is set to any value other than debug or warning, + a message is logged using the ::log package at the error level and exception is generated. +

    +

    + The default value is error. +

    +

    + A major use of this is to ignore namespace imports in a WDSL that do not actually import any definitions. +

    +
    + + +

    UseNS - put namespaces on field tags

    +

    + The UseNS option, if set to a "true" value, will put a namespace alias on all field tags. +

    +

    + The default value, "1", is for this option to be turned on. +

    +
    + +

    +

    useTypeNs - use type's namespace prefix as prefix of elements

    +

    + The useTypeNs option, if set to a "true" value, + will use the prefix of the type's namespace instead of the prefix of the element's namespace. +

    +

    + This option is only relevant, if the option UseNS is set. +

    +

    + The default value, "0", is for this option to be turned off. +

    +
    + +

    +

    suppressNS - do not put a given namespace prefix.

    +

    + The suppressNS option, if set, will cause the given namespace + to never be used as a prefix (i.e. tags that would normally have had +the given prefix will not have any prefix). +

    +

    + This option is only relevant, if the option UseNS is set. +

    +

    + The default value, "{}", is for this option to be turned off. +

    +
    + + +

    valueAttrCompatiblityMode - specify dictionary key for value when attributes are in use

    +

    + This option is only meaningful when the + parseInAttr or genOutAttr option is set to a "true" value. + When set to a "true" value, the value of the tag will have a key of the null string (i.e. {}). + When set to a "false" value, the value of the tag will have a key of ::value. +

    +

    + The default value, "0", is for this option to be turned off. +

    +
    + + + Index: docs/index.html ================================================================== --- docs/index.html +++ docs/index.html @@ -2,10 +2,11 @@ Tcl Web Services +

    Tcl Web Services

    @@ -20,16 +21,19 @@ over HTTP Soap transport. Documentation for the package, including examples can be found here.

    The client is known to work with #C and Java based Web Services (your mileage may very). @@ -37,28 +41,51 @@

    License

    Standard BSD. +

    Web Servers

    + +

    + The server side works with the following web servers: +

    Packages Required

    The following packages are used:

      -
    • Tcl 8.4 -
    • tdom 0.8.1 -
    • tls -
    • log from TclLib -
    • uri from TclLib -
    • http from Tcl itself -
    +
  • Tcl 8.6 +
  • tdom 0.8.1 +
  • tcltls or TWAPI 4.4.0 for client and embedded server TLS support +
  • log from TclLib +
  • uri from TclLib +
  • struct::set from TclLib +
  • http from Tcl itself +
  • yajl-tcl from flightaware github (only for rest-flavour requests) +
    • +

    -Additionally, if you are running the TclHttpd on Windows, it is highly recommended that you use the iocpsock extension. +If you are running the TclHttpd on Windows, it is highly recommended that you use the iocpsock extension.

    +

    +The following packages are additionally used in Embedded Server mode: +

      +
    • base64 from TclLib (also channel server) +
    • html from TclLib (also channel server) +
    • ncgi from TclLib +
    • fileutil from TclLib +
    ADDED docs/style.css Index: docs/style.css ================================================================== --- /dev/null +++ docs/style.css @@ -0,0 +1,548 @@ +/* General settings for the entire page */ +body { + margin: 0ex 0ex; + padding: 0px; + background-color: #fef3bc; + font-family: sans-serif; +} + +/* The project logo in the upper left-hand corner of each page */ +div.logo { + display: inline; + text-align: center; + vertical-align: bottom; + font-weight: bold; + font-size: 2.5em; + color: #a09048; +} + +/* The page title centered at the top of each page */ +div.title { + display: table-cell; + font-size: 2em; + font-weight: bold; + text-align: left; + padding: 0 0 0 5px; + color: #a09048; + vertical-align: bottom; + width: 100%; +} + +/* The login status message in the top right-hand corner */ +div.status { + display: table-cell; + text-align: right; + vertical-align: bottom; + color: #a09048; + padding: 5px 5px 0 0; + font-size: 0.8em; + font-weight: bold; +} + +/* The header across the top of the page */ +div.header { + display: table; + width: 100%; +} + +/* The main menu bar that appears at the top of the page beneath +** the header */ +div.mainmenu { + padding: 5px 10px 5px 10px; + font-size: 0.9em; + font-weight: bold; + text-align: center; + letter-spacing: 1px; + background-color: #a09048; + color: black; +} + +/* The submenu bar that *sometimes* appears below the main menu */ +div.submenu, div.sectionmenu { + padding: 3px 10px 3px 0px; + font-size: 0.9em; + text-align: center; + background-color: #c0af58; + color: white; +} +div.mainmenu a, div.mainmenu a:visited, div.submenu a, div.submenu a:visited, +div.sectionmenu>a.button:link, div.sectionmenu>a.button:visited { + padding: 3px 10px 3px 10px; + color: white; + text-decoration: none; +} +div.mainmenu a:hover, div.submenu a:hover, div.sectionmenu>a.button:hover { + color: #a09048; + background-color: white; +} + +/* All page content from the bottom of the menu or submenu down to +** the footer */ +div.content { + padding: 1ex 5px; +} +div.content a { color: #706532; } +div.content a:link { color: #706532; } +div.content a:visited { color: #704032; } +div.content a:hover { background-color: white; color: #706532; } + +/* Some pages have section dividers */ +div.section { + margin-bottom: 0px; + margin-top: 1em; + padding: 3px 3px 0 3px; + font-size: 1.2em; + font-weight: bold; + background-color: #a09048; + color: white; +} + +/* The "Date" that occurs on the left hand side of timelines */ +div.divider { + background: #e1d498; + border: 2px #a09048 solid; + font-size: 1em; font-weight: normal; + padding: .25em; + margin: .2em 0 .2em 0; + float: left; + clear: left; +} + +/* The footer at the very bottom of the page */ +div.footer { + font-size: 0.8em; + margin-top: 12px; + padding: 5px 10px 5px 10px; + text-align: right; + background-color: #a09048; + color: white; +} + +/* Hyperlink colors */ +div.footer a { color: white; } +div.footer a:link { color: white; } +div.footer a:visited { color: white; } +div.footer a:hover { background-color: white; color: #558195; } + +/* blocks */ +pre.verbatim { + background-color: #f5f5f5; + padding: 0.5em; +} + +/* The label/value pairs on (for example) the ci page */ +table.label-value th { + vertical-align: top; + text-align: right; + padding: 0.2ex 2ex; +} + +/* Side-by-side diff */ +table.sbsdiff { + background-color: #ffffc5; + font-family: fixed, Dejavu Sans Mono, Monaco, Lucida Console, monospace; + font-size: 8pt; + border-collapse:collapse; + white-space: pre; + width: 98%; + border: 1px #000 dashed; +} + +table.sbsdiff th.diffhdr { + border-bottom: dotted; + border-width: 1px; +} + +table.sbsdiff tr td { + white-space: pre; + padding-left: 3px; + padding-right: 3px; + margin: 0px; +} + +table.sbsdiff tr td.lineno { + text-align: right; +} + +table.sbsdiff tr td.meta { + background-color: #a09048; + text-align: center; +} + +table.sbsdiff tr td.added { + background-color: rgb(210, 210, 100); +} + +table.sbsdiff tr td.removed { + background-color: rgb(190, 200, 110); +} + +table.sbsdiff tr td.changed { + background-color: rgb(200, 210, 120); +}/* The nomenclature sidebox for branches,.. */ +div.sidebox { + float: right; + background-color: white; + border-width: medium; + border-style: double; + margin: 10px; +} +/* The nomenclature title in sideboxes for branches,.. */ +div.sideboxTitle { + display: inline; + font-weight: bold; +} +/* The defined element in sideboxes for branches,.. */ +div.sideboxDescribed { + display: inline; + font-weight: bold; +} +/* The defined element in sideboxes for branches,.. */ +span.disabled { + color: red; +} +/* The suppressed duplicates lines in timeline, .. */ +span.timelineDisabled { + font-style: italic; + font-size: small; +} +/* the format for the timeline data table */ +table.timelineTable { + border: 0; +} +/* the format for the timeline data cells */ +td.timelineTableCell { + vertical-align: top; + text-align: left; +} +/* the format for the timeline leaf marks */ +span.timelineLeaf { + font-weight: bold; +} +/* the format for the timeline version links */ +a.timelineHistLink { + +} +/* the format for the timeline version display(no history permission!) */ +span.timelineHistDsp { + font-weight: bold; +} +/* the format for the timeline time display */ +td.timelineTime { + vertical-align: top; + text-align: right; +} +/* the format for the grap placeholder cells in timelines */ +td.timelineGraph { +width: 20px; +text-align: left; +vertical-align: top; +} +/* the format for the tag links */ +a.tagLink { + +} +/* the format for the tag display(no history permission!) */ +span.tagDsp { + font-weight: bold; +} +/* the format for wiki errors */ +span.wikiError { + font-weight: bold; + color: red; +} +/* the format for fixed/canceled tags,.. */ +span.infoTagCancelled { + font-weight: bold; + text-decoration: line-through; +} +/* the format for fixed/cancelled tags,.. on wiki pages */ +span.wikiTagCancelled { + text-decoration: line-through; +} +/* format for the file display table */ +table.browser { +/* the format for wiki errors */ + width: 100% ; + border: 0; +} +/* format for cells in the file browser */ +td.browser { + width: 24% ; + vertical-align: top; +} +/* format for the list in the file browser */ +ul.browser { + margin-left: 0.5em; + padding-left: 0.5em; +} +/* table format for login/out label/input table */ +table.login_out { + text-align: left; + margin-right: 10px; + margin-left: 10px; + margin-top: 10px; +} +/* captcha display options */ +div.captcha { + text-align: center; +} +/* format for the layout table, used for the captcha display */ +table.captcha { + margin: auto; + padding: 10px; + border-width: 4px; + border-style: double; + border-color: black; +} +/* format for the label cells in the login/out table */ +td.login_out_label { + text-align: center; +} +/* format for login error messages */ +span.loginError { + color: red; +} +/* format for leading text for notes */ +span.note { + font-weight: bold; +} +/* format for textarea labels */ +span.textareaLabel { + font-weight: bold; +} +/* format for the user setup layout table */ +table.usetupLayoutTable { + outline-style: none; + padding: 0; + margin: 25px; +} +/* format of the columns on the user setup list page */ +td.usetupColumnLayout { + vertical-align: top +} +/* format for the user list table on the user setup page */ +table.usetupUserList { + outline-style: double; + outline-width: 1px; + padding: 10px; +} +/* format for table header user in user list on user setup page */ +th.usetupListUser { + text-align: right; + padding-right: 20px; +} +/* format for table header capabilities in user list on user setup page */ +th.usetupListCap { + text-align: center; + padding-right: 15px; +} +/* format for table header contact info in user list on user setup page */ +th.usetupListCon { + text-align: left; +} +/* format for table cell user in user list on user setup page */ +td.usetupListUser { + text-align: right; + padding-right: 20px; + white-space:nowrap; +} +/* format for table cell capabilities in user list on user setup page */ +td.usetupListCap { + text-align: center; + padding-right: 15px; +} +/* format for table cell contact info in user list on user setup page */ +td.usetupListCon { + text-align: left +} +/* layout definition for the capabilities box on the user edit detail page */ +div.ueditCapBox { + float: left; + margin-right: 20px; + margin-bottom: 20px; +} +/* format of the label cells in the detailed user edit page */ +td.usetupEditLabel { + text-align: right; + vertical-align: top; + white-space: nowrap; +} +/* color for capabilities, inherited by nobody */ +span.ueditInheritNobody { + color: green; +} +/* color for capabilities, inherited by developer */ +span.ueditInheritDeveloper { + color: red; +} +/* color for capabilities, inherited by reader */ +span.ueditInheritReader { + color: black; +} +/* color for capabilities, inherited by anonymous */ +span.ueditInheritAnonymous { + color: blue; +} +/* format for capabilities, mentioned on the user edit page */ +span.capability { + font-weight: bold; +} +/* format for different user types, mentioned on the user edit page */ +span.usertype { + font-weight: bold; +} +/* leading text for user types, mentioned on the user edit page */ +span.usertype:before { + content:"'"; +} +/* trailing text for user types, mentioned on the user edit page */ +span.usertype:after { + content:"'"; +} +/* selected lines of text within a linenumbered artifact display */ +div.selectedText { + font-weight: bold; + color: blue; + background-color: #d5d5ff; + border: 1px blue solid; +} +/* format for missing privileges note on user setup page */ +p.missingPriv { + color: blue; +} +/* format for leading text in wikirules definitions */ +span.wikiruleHead { + font-weight: bold; +} +/* format for labels on ticket display page */ +td.tktDspLabel { + text-align: right; +} +/* format for values on ticket display page */ +td.tktDspValue { + text-align: left; + vertical-align: top; + background-color: #d0d0d0; +} +/* format for ticket error messages */ +span.tktError { + color: red; + font-weight: bold; +} +/* format for example tables on the report edit page */ +table.rpteditex { + float: right; + margin: 0; + padding: 0; + width: 125px; + text-align: center; + border-collapse: collapse; + border-spacing: 0; +} +/* format for example table cells on the report edit page */ +td.rpteditex { + border-width: thin; + border-color: #000000; + border-style: solid; +} +/* format for user color input on checkin edit page */ +input.checkinUserColor { +/* no special definitions, class defined, to enable color pickers, f.e.: +** add the color picker found at http:jscolor.com as java script include +** to the header and configure the java script file with +** 1. use as bindClass :checkinUserColor +** 2. change the default hash adding behaviour to ON +** or change the class defition of element identified by id="clrcust" +** to a standard jscolor definition with java script in the footer. */ +} +/* format for end of content area, to be used to clear page flow(sidebox on branch,.. */ +div.endContent { + clear: both; +} +/* format for general errors */ +p.generalError { + color: red; +} +/* format for tktsetup errors */ +p.tktsetupError { + color: red; + font-weight: bold; +} +/* format for xfersetup errors */ +p.xfersetupError { + color: red; + font-weight: bold; +} +/* format for th script errors */ +p.thmainError { + color: red; + font-weight: bold; +} +/* format for th script trace messages */ +span.thTrace { + color: red; +} +/* format for report configuration errors */ +p.reportError { + color: red; + font-weight: bold; +} +/* format for report configuration errors */ +blockquote.reportError { + color: red; + font-weight: bold; +} +/* format for artifact lines, no longer shunned */ +p.noMoreShun { + color: blue; +} +/* format for artifact lines beeing shunned */ +p.shunned { + color: blue; +} +/* a broken hyperlink */ +span.brokenlink { + color: red; +} +/* List of files in a timeline */ +ul.filelist { + margin-top: 3px; + line-height: 100%; +} +/* side-by-side diff display */ +div.sbsdiff { + font-family: monospace; + font-size: smaller; + white-space: pre; +} +/* context diff display */ +div.udiff { + font-family: monospace; + white-space: pre; +} +/* changes in a diff */ +span.diffchng { + background-color: #c0c0ff; +} +/* added code in a diff */ +span.diffadd { + background-color: #c0ffc0; +} +/* deleted in a diff */ +span.diffrm { + background-color: #ffc8c8; +} +/* suppressed lines in a diff */ +span.diffhr { + color: #0000ff; +} +/* line numbers in a diff */ +span.diffln { + color: #a0a0a0; +} +/* Moderation Pending message on timeline */ +span.modpending { + color: #b03800; + font-style: italic; +} ADDED license.terms Index: license.terms ================================================================== --- /dev/null +++ license.terms @@ -0,0 +1,38 @@ +This software is copyrighted by the Gerald W. Leser and other parties. The following terms apply to all files +associated with the software unless explicitly disclaimed in +individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7014 (b) (3) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. Index: pkgIndex.tcl ================================================================== --- pkgIndex.tcl +++ pkgIndex.tcl @@ -1,19 +1,8 @@ -# Tcl package index file, version 1.1 -# This file is generated by the "pkg_mkIndex" 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::Channel 1.4.0 [list source [file join $dir ChannelServer.tcl]] -package ifneeded WS::CheckAndBuild 0.0.3 [list source [file join $dir CheckAndBuild.tcl]] -package ifneeded WS::Client 1.4.1 [list source [file join $dir ClientSide.tcl]] -package ifneeded WS::Embeded 1.4.0 [list source [file join $dir Embedded.tcl]] -package ifneeded WS::Server 1.4.1 [list source [file join $dir ServerSide.tcl]] -package ifneeded WS::Utils 1.4.1 [list source [file join $dir Utilities.tcl]] -package ifneeded WS::Wub 1.4.0 [list source [file join $dir WubServer.tcl]] -package ifneeded WS::AOLserver 1.4.0 [list source [file join $dir AOLserver.tcl]] -package ifneeded Wsdl 1.0 [list source [file join $dir WubServer.tcl]] +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 3.0.1 [list source [file join $dir ClientSide.tcl]] +package ifneeded WS::Embeded 3.3.1 [list source [file join $dir Embedded.tcl]] +package ifneeded WS::Server 3.4.0 [list source [file join $dir ServerSide.tcl]] +package ifneeded WS::Utils 3.1.0 [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]]