Index: AOLserver.tcl ================================================================== --- AOLserver.tcl +++ AOLserver.tcl @@ -110,6 +110,6 @@ } } } } -package provide WS::AOLserver 2.0.0 +package provide WS::AOLserver 2.4.0 Index: ChannelServer.tcl ================================================================== --- ChannelServer.tcl +++ ChannelServer.tcl @@ -52,11 +52,11 @@ package require uri package require base64 package require html -package provide WS::Channel 2.0.0 +package provide WS::Channel 2.4.0 namespace eval ::WS::Channel { array set portInfo {} array set dataArray {} Index: ClientSide.tcl ================================================================== --- ClientSide.tcl +++ ClientSide.tcl @@ -45,14 +45,14 @@ package require tdom 0.8 package require http 2 package require log package require uri -package provide WS::Client 2.3.9 +package provide WS::Client 2.4.0 namespace eval ::WS::Client { - # register https only if not jet registered + # 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 [list ::tls::socket -ssl2 no -ssl3 no -tls1 yes] @@ -311,11 +311,11 @@ lappend validOptionList location targetNamespace if {[lsearch -exact $validOptionList $item] == -1} { return -code error "Uknown option '$item' -- must be one of: [join $validOptionList {, }]" } - if {![string equal $value {}]} { + if {$value ne {}} { dict set serviceInfo $item $value set serviceArr($serviceName) $serviceInfo } return [dict get $serviceInfo $item] @@ -470,17 +470,17 @@ } 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 {} } @@ -563,11 +563,11 @@ dict lappend serviceInfo imports $url ::WS::Utils::ProcessImportXml Client $url $xml $serviceName serviceInfo tnsCount set serviceArr($serviceName) $serviceInfo set result {} foreach {result target} [dict get $serviceArr($serviceName) targetNamespace] { - if {[string equal $target $url]} { + if {$target eq $url} { break } } return $result } @@ -609,11 +609,11 @@ # ########################################################################### proc ::WS::Client::GetOperationList {serviceName {object {}}} { variable serviceArr - if {[string equal $object {}]} { + if {$object eq {}} { return [dict get $serviceArr($serviceName) operList] } else { return [list $object [dict get $serviceArr($serviceName) operation $object inputs] [dict get $serviceArr($serviceName) operation $object outputs]] } @@ -842,11 +842,11 @@ if {[dict exists $serviceInfo types]} { foreach {typeName partList} [dict get $serviceInfo types] { set definition [dict get $partList definition] set xns [dict get $partList xns] set isAbstarct [dict get $partList abstract] - if {[string equal [lindex [split $typeName {:}] 1] {}]} { + if {[lindex [split $typeName {:}] 1] eq {}} { ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition tns1 $isAbstarct } else { #set typeName [lindex [split $typeName {:}] 1] ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition $xns $isAbstarct } @@ -854,11 +854,11 @@ } if {[dict exists $serviceInfo simpletypes]} { foreach partList [dict get $serviceInfo simpletypes] { lassign $partList typeName definition - if {[string equal [lindex [split $typeName {:}] 1] {}]} { + 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 $definition $xns @@ -931,11 +931,11 @@ set token [::WS::Utils::geturl_followRedirects $url -headers $headers] } else { set token [::WS::Utils::geturl_followRedirects $url] } ::http::wait $token - if {![string equal [::http::status $token] ok] || + if {[::http::status $token] ne {ok} || [::http::ncode $token] != 200} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set errorInfo [FormatHTTPError $token] ::http::cleanup $token return \ @@ -1175,16 +1175,16 @@ } 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 @@ -1194,11 +1194,11 @@ set inputFields [dict keys [dict get $inputMsgTypeDefinition definition]] } else { ::log::log 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 { @@ -1309,12 +1309,12 @@ ## ## Check for errors ## set body [::http::data $token] ::log::log info "\nReceived: $body" - if {![string equal [::http::status $token] ok] || - ([::http::ncode $token] != 200 && [string equal $body {}])} { + if {[::http::status $token] ne {ok} || + ( [::http::ncode $token] != 200 && $body eq {} )} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set errorInfo {} set results [FormatHTTPError $token] set hadError 1 } else { @@ -1433,23 +1433,23 @@ ## ## Check for errors ## set httpStatus [::http::status $token] - if {[string equal $httpStatus ok] && [::http::ncode $token] == 500} { + if {$httpStatus eq {ok} && [::http::ncode $token] == 500} { set body [::http::data $token] ::log::log debug "\tReceived: $body" set outTransform [dict get $serviceInfo outTransform] - if {![string equal $outTransform {}]} { + 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 {[string equal $mainError WSCLIENT] && [string equal $subError NOSOAP]} { + if {$mainError eq WSCLIENT && $subError eq NOSOAP} { ::log::log debug "\tHTTP error $body" set results $body set errorCode [list WSCLIENT HTTPERROR $body] set errorInfo {} set hadError 1 @@ -1457,21 +1457,21 @@ ::log::log debug "Reply was $body" set errorCode $::errorCode set errorInfo $::errorInfo } } - } elseif {![string equal $httpStatus ok] || [::http::ncode $token] != 200} { + } elseif {$httpStatus ne {ok} || [::http::ncode $token] != 200} { ::log::log debug "\tHTTP error [array get $token]" set results [FormatHTTPError $token] set errorCode [list WSCLIENT HTTPERROR [::http::code $token]] set errorInfo {} set hadError 1 } else { set body [::http::data $token] ::log::log debug "\tReceived: $body" set outTransform [dict get $serviceInfo outTransform] - if {![string equal $outTransform {}]} { + if {$outTransform ne {}} { SaveAndSetOptions $serviceName catch {set body [$outTransform $serviceName $operationName REPLY $body]} RestoreSavedOptions $serviceName } SaveAndSetOptions $serviceName @@ -1535,11 +1535,11 @@ # 1 06/02/2015 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Client::FormatHTTPError {token} { - if {[string equal [::http::status $token] ok]} { + if {[::http::status $token] eq {ok}} { if {[::http::size $token] == 0} { return "HTTP failure socket closed" } return "HTTP failure code [::http::ncode $token]" } else { @@ -1718,25 +1718,25 @@ } 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] - if {![string equal $inputMsgType {}]} { + 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 {![string equal $inputFields {}]} { + if {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } } } set argList [join $argList] @@ -1803,22 +1803,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" @@ -1878,12 +1878,12 @@ ## Check for errors ## set body [::http::data $token] ::log::log info "\nReceived: $body" set results {} - if {![string equal [::http::status $token] ok] || - ([::http::ncode $token] != 200 && [string equal $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 [FormatHTTPError $token] } else { SaveAndSetOptions $serviceName @@ -1998,22 +1998,22 @@ set rootNode [$body childNodes] ::log::log debug "Have [llength $rootNode] node under Body" if {[llength $rootNode] > 1} { foreach tmp $rootNode { #puts "\t Got {[$tmp localName]} looking for {$expectedMsgTypeBase}" - if {[string equal [$tmp localName] $expectedMsgTypeBase] || - [string equal [$tmp nodeName] $expectedMsgTypeBase] || - [string equal [$tmp localName] Fault] || - [string equal [$tmp nodeName] Fault]} { + if {[$tmp localName] eq $expectedMsgTypeBase || + [$tmp nodeName] eq $expectedMsgTypeBase || + [$tmp localName] eq Fault || + [$tmp nodeName] eq Fault} { set rootNode $tmp break } } } - if {([llength $rootNode] == 1) && ![string equal $rootNode {}]} { + if {([llength $rootNode] == 1) && $rootNode ne {}} { set rootName [$rootNode localName] - if {[string equal $rootName {}]} { + if {$rootName eq {}} { set rootName [$rootNode nodeName] } } else { set rootName {} } @@ -2020,20 +2020,20 @@ ::log::log debug "root name is {$rootName}" ## ## See if it is a standard error packet ## - if {[string equal $rootName {Fault}]} { + if {$rootName eq {Fault}} { set faultcode {} set faultstring {} set detail {} foreach item {faultcode faultstring detail} { set tmpNode [$rootNode selectNodes ENV:$item] - if {[string equal $tmpNode {}]} { + if {$tmpNode eq {}} { set tmpNode [$rootNode selectNodes $item] } - if {![string equal $tmpNode {}]} { + if {$tmpNode ne {}} { if {[$tmpNode hasAttribute href]} { set tmpNode [GetReferenceNode $top [$tmpNode getAttribute href]] } set $item [$tmpNode asText] } @@ -2047,11 +2047,11 @@ } ## ## Validated that it is the expected packet type ## - if {![string equal $rootName $expectedMsgTypeBase]} { + if {$rootName ne $expectedMsgTypeBase} { $doc delete return \ -code error \ -errorcode [list WS CLIENT BADREPLY [list $rootName $expectedMsgTypeBase]] \ "Bad reply type, received '$rootName; but expected '$expectedMsgTypeBase'." @@ -2062,11 +2062,11 @@ ## set results {} set headerRootNode [$top selectNodes ENV:Header] if {[llength $headerRootNode]} { foreach outHeaderType [dict get $serviceInfo operation $operationName soapReplyHeader] { - if {[string equal $outHeaderType {}]} { + if {$outHeaderType eq {}} { continue } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $outHeaderType] xns] set node [$headerRootNode selectNodes $outHeaderType] if {![llength $node]} { @@ -2082,11 +2082,11 @@ ::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 {}]} { + if {$rootName ne {}} { set bodyData [::WS::Utils::convertTypeToDict \ Client $serviceName $rootNode $expectedMsgType $body] if {![llength $bodyData] && ([dict get $serviceInfo skipLevelWhenActionPresent] || [dict get $serviceInfo skipLevelOnReply])} { ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $rootNode $expectedMsgType $body] -- skipLevelWhenActionPresent was set" set bodyData [::WS::Utils::convertTypeToDict \ @@ -2170,11 +2170,11 @@ } } ::WS::Utils::SetOption suppressNS $inSuppressNs 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::buildCallquery with {$xml}" return $xml @@ -2257,11 +2257,11 @@ #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) @@ -2381,11 +2381,11 @@ $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] if {$firstHeader} { $env appendChild [$doc createElement "SOAP-ENV:Header" header] @@ -2716,11 +2716,11 @@ 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 @@ -2729,22 +2729,22 @@ #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 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 WS CLIENT UNSMODE $use] \ "Unsupported mode: $style/$use" @@ -2800,11 +2800,11 @@ 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 lappend serviceInfo operList $operName dict set serviceInfo operation $operName cloneList {} @@ -2828,11 +2828,11 @@ ## 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 WS CLIENT MIXUSE $use $tmp] \ "Mixed usageage not supported!'" @@ -2852,11 +2852,11 @@ ## 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 WS CLIENT MIXUSE $use $tmp] \ "Mixed usageage not supported!'" @@ -2875,11 +2875,11 @@ 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 WS CLIENT MIXUSE $use $tmp] \ "Mixed usageage not supported!'" @@ -2894,11 +2894,11 @@ if {[dict exists $serviceInfo inputMessages $inMessage] } { set operList [dict get $serviceInfo inputMessages $inMessage] } else { set operList {} } - lappend operList $operName + lappend operList $operName dict set serviceInfo inputMessages $inMessage $operList ## ## Handle target namespace defined at WSDL level for older RPC/Encoded ## @@ -2966,35 +2966,35 @@ set inType {} set outType {} #set portQuery [format {w:portType[attribute::name='%s']} $portName] #set portNode [lindex [$wsdlNode selectNodes $portQuery] 0] - if {[string equal $inName {}]} { + 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 {[string equal $operNode {}] && ![string equal $inName {}]} { + 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 inputMsgNode [$operNode selectNodes {w:input}] - if {![string equal $inputMsgNode {}]} { + if {$inputMsgNode ne {}} { set inputMsgPath [$inputMsgNode getAttribute message] set inputMsg [lindex [split $inputMsgPath {:}] end] set inType [messageToType $wsdlNode $serviceName $operName $inputMsg serviceInfo $style] } set outputMsgNode [$operNode selectNodes {w:output}] - if {![string equal $outputMsgNode {}]} { + if {$outputMsgNode ne {}} { set outputMsgPath [$outputMsgNode getAttribute message] set outputMsg [lindex [split $outputMsgPath {:}] end] set outType [messageToType $wsdlNode $serviceName $operName $outputMsg serviceInfo $style] } @@ -3053,17 +3053,17 @@ #puts "Message to Type $serviceName $operName $msgName" set msgQuery [format {w:message[attribute::name='%s']} $msgName] set msg [$wsdlNode selectNodes $msgQuery] - if {[string equal $msg {}] && + 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 {[string equal $msg {}]} { + if {$msg eq {}} { return \ -code error \ -errorcode [list WS CLIENT BADMSGSEC $msgName] \ "Can not find message '$msgName'" } @@ -3200,11 +3200,11 @@ 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] } SaveAndSetOptions $serviceName @@ -3228,12 +3228,12 @@ ## ## Check for errors ## set body [::http::data $token] - if {![string equal [::http::status $token] ok] || - ([::http::ncode $token] != 200 && [string equal $body {}])} { + if {[::http::status $token] ne {ok} || + ( [::http::ncode $token] != 200 && $body eq {} )} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set errorInfo {} set results [FormatHTTPError $token] set hadError 1 } else { @@ -3325,11 +3325,11 @@ 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] } SaveAndSetOptions $serviceName @@ -3357,12 +3357,12 @@ set body [::http::data $token] ::log::log info "\tReceived: $body" set httpStatus [::http::status $token] set hadError 0 set results {} - if {![string equal $httpStatus ok] || - ([::http::ncode $token] != 200 && [string equal $body {}])} { + if {$httpStatus ne {ok} || + ( [::http::ncode $token] != 200 && $body eq {} )} { ::log::log debug "\tHTTP error [array get $token]" set results [FormatHTTPError $token] set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set errorInfo {} set hadError 1 @@ -3588,11 +3588,11 @@ #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}" @@ -3652,11 +3652,11 @@ 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] dom parse $inXML doc $doc documentElement top @@ -3669,11 +3669,11 @@ 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 @@ -3690,14 +3690,14 @@ 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 {}]} { + 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 WS CLIENT BADRESPONSE [list $objectName $nodeName]] \ -errorinfo {} \ "Unexpected message type {$nodeName}, expected {$objectName}" @@ -3763,12 +3763,12 @@ ## ## Check for errors ## set body [::http::data $token] ::log::log info "\nReceived: $body" - if {![string equal [::http::status $token] ok] || - ([::http::ncode $token] != 200 && [string equal $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 [FormatHTTPError $token] } else { SaveAndSetOptions $serviceName Index: Embedded.tcl ================================================================== --- Embedded.tcl +++ Embedded.tcl @@ -42,11 +42,11 @@ package require uri package require base64 package require html package require log -package provide WS::Embeded 2.3.0 +package provide WS::Embeded 2.4.0 namespace eval ::WS::Embeded { array set portInfo {} Index: ServerSide.tcl ================================================================== --- ServerSide.tcl +++ ServerSide.tcl @@ -37,16 +37,16 @@ ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require Tcl 8.4 -package require WS::Utils 2.3.7 ; # provides dict +package require WS::Utils 2.4 ; # provides dict package require html package require log package require tdom -package provide WS::Server 2.3.7 +package provide WS::Server 2.4.0 namespace eval ::WS::Server { array set ::WS::Server::serviceArr {} set ::WS::Server::procInfo {} set ::WS::Server::mode {} @@ -126,10 +126,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 @@ -173,10 +179,14 @@ -mode {tclhttpd} -ports {80} -traceEnabled {Y} -docFormat {text} -stylesheet {} + -beautifyJson {N} + -errorCallback {} + -verifyUserArgs {N} + -enforceRequired {N} } array set defaults $args if {[string equal $defaults(-mode) channel]} { set defaults(-ports) {stdin stdout} array set defaults $args @@ -198,23 +208,23 @@ if {![info exists defaults(-prefix)]} { set defaults(-prefix) /service/$service } # find default host if {![info exists defaults(-host)]} { - switch -exact -- $defaults(-mode) { - embedded { - set me [socket -server garbage_word -myaddr [info hostname] 0] - set defaults(-host) [lindex [fconfigure $me -sockname] 0] - close $me - if {0 !=[llength $defaults(-ports)] && 80 != [lindex $defaults(-ports) 0]} { - append defaults(-host) ":[lindex $defaults(-ports) 0]" - } - } - default { - set defaults(-host) localhost - } - } + switch -exact -- $defaults(-mode) { + embedded { + set me [socket -server garbage_word -myaddr [info hostname] 0] + set defaults(-host) [lindex [fconfigure $me -sockname] 0] + close $me + if {0 !=[llength $defaults(-ports)] && 80 != [lindex $defaults(-ports) 0]} { + append defaults(-host) ":[lindex $defaults(-ports) 0]" + } + } + default { + set defaults(-host) localhost + } + } } set defaults(-uri) $service namespace eval ::$service {} set serviceArr($service) [array get defaults] @@ -242,11 +252,11 @@ } wub { package require WS::Wub } aolserver { - package require WS::AOLserver + package require WS::AOLserver } rivet { package require Rivet } wibble { @@ -728,15 +738,15 @@ "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 @@ -773,11 +783,11 @@ set xml [GetWsdl $serviceName] ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } rivet { set xml [GetWsdl $serviceName] - headers type text/xml + headers type "text/xml; charset=UTF-8" headers numeric 200 puts $xml } aolserver { set xml [GetWsdl $serviceName] @@ -840,10 +850,155 @@ array set serviceData $serviceArr($serviceName) set targetNamespace "http://$serviceData(-host)$serviceData(-prefix)" return [::WS::Utils::GenerateScheme $mode $serviceName $doc $parent $targetNamespace] } + + +########################################################################### +# +# 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 - not used +# +# 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 +# +# +########################################################################### +# NOTE: This proc only works with Rivet +# TODO: Update to handle jsonp? +proc ::WS::Server::generateJsonInfo { service sock args } { + variable serviceArr + variable procInfo + + ::log::log debug "Generating JSON Documentation for $service on $sock with {$args}" + set serviceInfo $serviceArr($service) + array set serviceData $serviceInfo + set doc [yajl create #auto -beautify $serviceData(-beautifyJson)] + + $doc map_open + + $doc string operations array_open + ::log::log debug "\tDisplay Operations (json)" + + foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] { + $doc map_open + + # operation name + $doc string name string $oper + + # description + set description [dict get $procInfo $service op$oper docs] + $doc string description string $description + + # parameters + if {[llength [dict get $procInfo $service op$oper argOrder]]} { + $doc string inputs array_open + + foreach arg [dict get $procInfo $service op$oper argOrder] { + ::log::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 {} + } + + set type [dict get $procInfo $service op$oper argList $arg type] + + $doc map_open string name string $arg string type string $type string comment string $comment map_close + } + + $doc array_close + } else { + $doc string inputs array_open array_close + } + + $doc string returns map_open + + if {[dict exists $procInfo $service op$oper returnInfo comment]} { + set comment [dict get $procInfo $service op$oper returnInfo comment] + } else { + set comment {} + } + + set type [dict get $procInfo $service op$oper returnInfo type] + + $doc string comment string $comment string type string $type + $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 $service] + foreach type [lsort -dictionary [dict keys $localTypeInfo]] { + ::log::log debug "\t\tDisplaying '$type'" + + $doc map_open + $doc string name string $type + $doc string fields array_open + + set typeDetails [dict get $localTypeInfo $type definition] + foreach part [lsort -dictionary [dict keys $typeDetails]] { + ::log::log debug "\t\t\tDisplaying '$part'" + set subType [dict get $typeDetails $part type] + set comment {} + if {[dict exists $typeDetails $part comment]} { + set comment [dict get $typeDetails $part comment] + } + $doc map_open string field string $part string type string $subType string comment string $comment map_close + } + + $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. @@ -989,11 +1144,11 @@ channel { ::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 } @@ -1044,11 +1199,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] @@ -1117,10 +1272,16 @@ default { upvar #0 Httpd$sock data set inXML $data(query) } } + + # decide if SOAP or REST mode should be used. + set flavor "soap" + if {[lsearch -exact $args "-rest"] != -1} { + set flavor "rest" + } ::log::log debug "In ::WS::Server::callOperation {$service $sock $args}" array set serviceInfo $serviceArr($service) ::log::log debug "\tDocument is {$inXML}" @@ -1128,83 +1289,121 @@ set ::errorCode {} set ns $service set inTransform $serviceInfo(-intransform) set outTransform $serviceInfo(-outtransform) - set first [string first {<} $inXML] - if {$first > 0} { - set inXML [string range $inXML $first end] - } + # set first [string first {<} $inXML] + # if {$first > 0} { + # set inXML [string range $inXML $first end] + # } if {![string equal $inTransform {}]} { set inXML [$inTransform REQUEST $inXML] } - 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 - } - + + # Get a reference to the error callback + set errorCallback $serviceInfo(-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) FlightXmlCallback + } + set contentType "text/javascript" + } + } + soap { + # parse the XML request + 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 + + # 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::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 + } + set contentType "text/xml" + } + default { + if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} "UnknownMethod" $flavor } + error "bad flavor" + } + } ## ## Check that the method exists. ## if {![dict exists $procInfo $service op$operation argList]} { set msg "Method $operation not found" ::log::log error $msg set ::errorInfo {} set ::errorCode [list Server UNKNOWN_METHOD $operation] - set xml [generateError \ + set response [generateError \ $serviceInfo(-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::log 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; charset=UTF-8" $xml 500 + ::WS::Embeded::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 { - ::WS::Wibble::ReturnData responseDict text/xml $xml 500 + ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus } default { ## Do nothing } } @@ -1217,112 +1416,174 @@ ## ## 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 -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 - ## - 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 - } - default { - ## Do nothing - } - } - } - ::log::log debug "gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode" - if {$gotAnyArgs || !$legacyRpcMode} break + # Check that all supplied arguments are valid + set methodArgs [dict get $procInfo $ns $cmdName argOrder] + if {$serviceInfo(-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 { + set argType [string trim [dict get $argInfo $argName type]] + set typeInfoList [::WS::Utils::TypeInfo Server $service $argType] + + if {![info exists rawargs($argName)]} { + ::log::log 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 $service $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 $service $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 $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 -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 $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 + } + default { + ## Do nothing + } + } + } + ::log::log debug "gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode" + if {$gotAnyArgs || !$legacyRpcMode} break + } + } + default { + if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} $operation $flavor } + error "invalid flavor" + } } ::log::log debug "finalargs $tclArgList" } errMsg]} { ::log::log error $errMsg set localerrorCode $::errorCode set localerrorInfo $::errorInfo - set xml [generateError \ + set response [generateError \ $serviceInfo(-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::log 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; charset=UTF-8" $xml 500 + ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } channel { - ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $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 { - ::WS::Wibble::ReturnData responseDict text/xml $xml 500 + ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus } default { ## Do nothing } } @@ -1373,44 +1634,54 @@ } } 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 {![string equal $outTransform {}]} { - set xml [$outTransform REPLY $xml $operation $results] + set response [$outTransform REPLY $response $operation $results] } 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" + ::log::log debug "Leaving ::WS::Server::callOperation $response" switch -exact -- $mode { tclhttpd { - ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 200 + ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response 200 } embedded { - ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 + ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response 200 } channel { - ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 + ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response 200 } rivet { - headers type text/xml + headers type "$contentType; charset=UTF-8" headers numeric 200 - puts $xml + puts $response } aolserver { - ::WS::AOLserver::ReturnData $sock text/xml $xml 200 + ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response 200 } wibble { - ::WS::Wibble::ReturnData responseDict text/xml $xml 200 + ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response 200 } default { ## Do nothing } } @@ -1424,37 +1695,50 @@ [string length $serviceInfo(-postmonitor)]} { set precmd $serviceInfo(-postmonitor) lappend precmd POST $service $operation ERROR $msg catch $precmd } - set xml [generateError \ + set response [generateError \ $serviceInfo(-traceEnabled) \ CLIENT \ $msg \ - [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo]] + [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \ + $flavor] catch {$doc delete} - ::log::log debug "Leaving @ error 2::WS::Server::callOperation $xml" + set httpStatus 500 + if {$errorCallback ne {}} { $errorCallback $msg httpStatus $operation $flavor } + ::log::log debug "Leaving @ error 2::WS::Server::callOperation $response" + + # wrap in JSONP + if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} { + set response "$rawargs(jsonp_callback)($response)" + } + switch -exact -- $mode { 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; charset=UTF-8" $xml 500 + ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } channel { - ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $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 { - ::WS::Wibble::ReturnData responseDict text/xml $xml 500 + ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus } default { ## Do nothing } } @@ -1477,10 +1761,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 # @@ -1500,11 +1785,11 @@ # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### -proc ::WS::Server::generateError {includeTrace faultcode faultstring detail} { +proc ::WS::Server::generateError {includeTrace faultcode faultstring detail flavor} { ::log::log debug "Entering ::WS::Server::generateError $faultcode $faultstring {$detail}" set code [lindex $detail 1] switch -exact -- $code { "VersionMismatch" { set code "SOAP-ENV:VersionMismatch" @@ -1520,46 +1805,60 @@ } default { ## Do nothing } } - 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 xml \ - {} \ - "\n" \ - [$doc asXML -indent none -doctypeDeclaration 0] - $doc delete - ::log::log debug "Leaving (error) ::WS::Server::generateError $xml" - return $xml + + 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::log debug "Leaving (error) ::WS::Server::generateError $response" + return $response } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure @@ -1573,10 +1872,11 @@ # # 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" # # # Returns : The results as an XML formatted packet. # # Side-Effects : None @@ -1597,57 +1897,75 @@ # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### -proc ::WS::Server::generateReply {serviceName operation results} { +proc ::WS::Server::generateReply {serviceName operation results flavor} { ::log::log 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 ${serviceName}:${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 + + switch -exact -- $flavor { + rest { + set doc [yajl create #auto -beautify $serviceData(-beautifyJson)] + + $doc map_open + ::WS::Utils::convertDictToJson Server $serviceName $doc $results ${serviceName}:${operation}Results $serviceData(-enforceRequired) + $doc map_close + + set output [$doc get] + $doc delete + } + soap { + 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 0 $serviceData(-enforceRequired) + } + } + $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 $serviceData(-enforceRequired) + + append output \ + {} \ + "\n" \ + [$doc asXML -indent none -doctypeDeclaration 0] + #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] $replaceText xml + $doc delete + } + default { + error "Unsupported flavor" + } + } + + ::log::log debug "Leaving ::WS::Server::generateReply $output" + return $output } ########################################################################### # @@ -1915,26 +2233,31 @@ 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] + + if {[llength [dict get $procInfo $service op$oper argOrder]]} { + append msg [::html::openTag {table} {border="2"}] + append msg [::html::hdrRow Name Type Description] + foreach arg [dict get $procInfo $service op$oper argOrder] { + ::log::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] + } else { + append msg "No inputs." + } append msg [::html::closeTag] ::log::log debug "\t\tReturns" append msg [::html::h4 {Returns}] "\n" @@ -2018,20 +2341,27 @@ 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 href_type [lindex [split $type :] end] set typeOverloadArray($type) 1 - append msg [::html::h3 "$type"] + 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] + append msg [::html::hdrRow Field Type Comment] foreach part [lsort -dictionary [dict keys $typeDetails]] { ::log::log 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]] + [displayType $service [dict get $typeDetails $part type]] \ + $comment ] } append msg [::html::closeTag] } Index: Utilities.tcl ================================================================== --- Utilities.tcl +++ Utilities.tcl @@ -57,11 +57,11 @@ package require log package require tdom 0.8 package require struct::set -package provide WS::Utils 2.3.10 +package provide WS::Utils 2.4.0 namespace eval ::WS {} namespace eval ::WS::Utils { set ::WS::Utils::typeInfo {} @@ -70,10 +70,32 @@ set nsList { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ xs http://www.w3.org/2001/XMLSchema } + + # 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 @@ -127,11 +149,11 @@ valueAttrCompatiblityMode 1 includeDirectory {} suppressNS {} useTypeNs 0 nsOnChangeOnly 0 - anyType string + anyType string } set ::WS::Utils::standardAttributes { baseType comment @@ -217,11 +239,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 @@ -563,11 +585,11 @@ ########################################################################### proc ::WS::Utils::GetServiceTypeDef {mode service {type {}}} { variable typeInfo variable simpleTypes - set type [string trimright $type {()}] + set type [string trimright $type {()?}] set results {} if {[string equal $type {}]} { ::log::log debug "@1" set results [dict get $typeInfo $mode $service] } else { @@ -653,11 +675,11 @@ # ########################################################################### proc ::WS::Utils::GetServiceSimpleTypeDef {mode service {type {}}} { variable simpleTypes - set type [string trimright $type {()}] + 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 {} @@ -913,11 +935,11 @@ #>>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, possibly with a () to specify it is an array # # Returns : A list of two elements, as follows: @@ -943,15 +965,20 @@ # 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 @@ -960,10 +987,13 @@ } #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] } ########################################################################### @@ -1272,19 +1302,22 @@ # ########################################################################### 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 xs:[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 } @@ -1382,10 +1415,11 @@ set partsList [dict keys [dict get $typeDefInfo definition]] ::log::log 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 } @@ -1467,15 +1501,15 @@ switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## - if {[dict exists $tmpTypeInfo base]} { - set baseType [dict get $tmpTypeInfo base] - } else { - set baseType string - } + if {[dict exists $tmpTypeInfo base]} { + set baseType [dict get $tmpTypeInfo base] + } else { + set baseType string + } if {$options(parseInAttr)} { foreach attrList [$item attributes] { catch { lassign $attrList attr nsAlias nsUrl if {[string equal $nsUrl $xsiNsUrl]} { @@ -1505,15 +1539,15 @@ } {0 1} { ## ## Simple array ## - if {[dict exists $tmpTypeInfo base]} { - set baseType [dict get $tmpTypeInfo base] - } else { - set baseType string - } + 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 attrList [$row attributes] { @@ -1708,29 +1742,30 @@ # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### -proc ::WS::Utils::convertDictToType {mode service doc parent dict type {forceNs 0}} { +proc ::WS::Utils::convertDictToType {mode service doc parent dict type {forceNs 0} {enforceRequired 0}} { ::log::log debug "Entering ::WS::Utils::convertDictToType $mode $service $doc $parent {$dict} $type" # ::log::log debug " Parent xml: [$parent asXML]" variable typeInfo variable simpleTypes variable options variable standardAttributes variable currentNs if {!$options(UseNS)} { - return [::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent $dict $type] + return [::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent $dict $type $enforceRequired] } if {$options(valueAttrCompatiblityMode)} { set valueAttr {} } else { set valueAttr {::value} } set typeInfoList [TypeInfo $mode $service $type] + set type [string trimright $type {?}] ::log::log debug "\t typeInfoList = {$typeInfoList}" if {[dict exists $typeInfo $mode $service $service:$type]} { set typeName $service:$type } else { set typeName $type @@ -1775,22 +1810,26 @@ foreach {itemName itemDef} $itemList { set baseName [lindex [split $itemName {:}] end] 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] + set typeInfoList [TypeInfo $mode $service $itemType 1] ::log::log debug "Expr [list ![dict exists $dict $itemName] && ![dict exists $dict $baseName]]" if {![dict exists $dict $itemName] && ![dict exists $dict $baseName]} { ::log::log 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 {()}]] + 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]} { @@ -1805,15 +1844,17 @@ ::log::log debug "key = {$key} standardAttributes = {$standardAttributes}" } } ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} itemXns = {$itemXns} tmpInfo = {$tmpInfo} attrList = {$attrList}" set isAbstract false - set baseType [string trimright $itemType ()] + 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::log notice "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} isAbstract = {$isAbstract}" + ::log::log 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 ## @@ -1922,13 +1963,13 @@ 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 + convertDictToType $mode $service $doc $retNode $resultValue $itemType $forceNs $enforceRequired } else { - convertDictToType $mode $service $doc $retNode $resultValue $itemType + convertDictToType $mode $service $doc $retNode $resultValue $itemType $forceNs $enforceRequired } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } @@ -1935,11 +1976,10 @@ {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $useName] - set tmpType [string trimright $itemType ()] #::log::log debug "\t\t [llength $dataList] rows {$dataList}" foreach row $dataList { if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { $parent appendChild [$doc createElement $itemName retNode] } else { @@ -1965,16 +2005,21 @@ } } } else { set resultValue $row } + 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 + convertDictToType $mode $service $doc $retNode $resultValue $tmpType $forceNs $enforceRequired } else { - convertDictToType $mode $service $doc $retNode $resultValue $tmpType + convertDictToType $mode $service $doc $retNode $resultValue $tmpType $forceNs $enforceRequired } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } @@ -1994,10 +2039,155 @@ } set currentNs $entryNs ::log::log 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 +# +# 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 +# +# +########################################################################### +proc ::WS::Utils::convertDictToJson {mode service doc dict type {enforceRequired 0}} { + ::log::log debug "Entering ::WS::Utils::convertDictToJson $mode $service $doc {$dict} $type" + 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 + } + 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::log debug "\titemList is {$itemList}" + 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 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::log 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 + $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 + $doc map_close + } + $doc array_close + } + } + } + return; +} ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. @@ -2035,11 +2225,11 @@ # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### -proc ::WS::Utils::convertDictToTypeNoNs {mode service doc parent dict type} { +proc ::WS::Utils::convertDictToTypeNoNs {mode service doc parent dict type {enforceRequired 0}} { ::log::log debug "Entering ::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent {$dict} $type" # ::log::log debug " Parent xml: [$parent asXML]" variable typeInfo variable simpleTypes variable options @@ -2067,16 +2257,19 @@ ::log::log debug "\titemList is {$itemList}" foreach {itemName itemDef} $itemList { ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef}" set itemType [dict get $itemDef type] set isAbstract false - set baseType [string trimright $itemType ()] + 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] + 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 && $key ne "isList" && $key ne "xns"} { @@ -2083,10 +2276,11 @@ lappend attrList $key [dict get $itemDef $key] ::log::log debug "key = {$key} standardAttributes = {$standardAttributes}" } } ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}" + set typeInfoList [lrange $typeInfoList 0 1] switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## @@ -2169,18 +2363,18 @@ 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 } {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] if {$options(genOutAttr)} { set dictList [dict keys $row] set resultValue {} @@ -2202,11 +2396,11 @@ 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 } } default { ## ## Placed here to shut up tclchecker @@ -2265,10 +2459,11 @@ variable options set typeInfoList [TypeInfo $mode $service $type] ::log::log 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)]} { @@ -2293,11 +2488,11 @@ set itemList [list $type {type string}] } } ::log::log 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::log debug "\t\t Looking for {$itemName} in {$dict}" if {![dict exists $dict $itemName]} { ::log::log debug "\t\t Not found, skipping" continue @@ -2369,11 +2564,11 @@ if {![string match {*:*} $itemType]} { set attrType $xns:$itemType } else { set attrType $itemType } - set attrType [string trim $attrType {()}] + 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 { @@ -2671,11 +2866,10 @@ ::log::log $options(StrictMode) "Found $lastUnknownRefCount forward type references: [join [array names unkownRef] {,}]" } error - default { set ::WS::Utils::targetNs $tmpTargetNs - set ofd [open full.xsd w];puts $ofd [$schemaNode asXML];close $ofd return \ -code error \ -errorcode [list WS $mode UNKREFS [list $lastUnknownRefCount]] \ "Found $lastUnknownRefCount forward type references: [join [array names unkownRef] {,}]" } @@ -2912,11 +3106,11 @@ "Missing Schema Location in '$baseUrl'" } } set urlTail [$importNode getAttribute $attrName] set url [::uri::resolve $baseUrl $urlTail] - ::log::log info "Including $url" + ::log::log debug "Including $url" set lastPos [string last / $url] set testUrl [string range $url 0 [expr {$lastPos - 1}]] if { [info exists ::WS::Utils::redirectArray($testUrl)] } { set newUrl $::WS::Utils::redirectArray($testUrl) @@ -3131,11 +3325,11 @@ -errorcode [list WS $mode UNKREF [list $typeName $partType]] \ "Unknown forward type reference {$partType} in {$typeName}" } } else { set partName [$middleNode getAttribute name] - set partType [getQualifiedType $results [$middleNode getAttribute type string:string] $tns] + set partType [string trimright [getQualifiedType $results [$middleNode getAttribute type string:string] $tns] {?}] 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] @@ -3198,11 +3392,11 @@ catch {set attrArr($name) [$element getAttribute $ref]} } set partName item set partType [getQualifiedType $results $attrArr(arrayType) $tns] set partType [string map {{[]} {()}} $partType] - lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment allowAny 1] + lappend partList $partName [list type [string trimright ${partType} {()?}]() comment $comment allowAny 1] set nodeFound 1 } extension { ::log::log debug "Calling partList for $contentType of $typeName" if {[catch {set tmp [partList $mode $child $serviceName results $tns]} msg]} { @@ -3327,11 +3521,11 @@ ## } element { catch { set partName [$node getAttribute name] - set partType [getQualifiedType $results [$node getAttribute type string] $tns] + set partType [string trimright [getQualifiedType $results [$node getAttribute type string] $tns] {?}] set partMax [$node getAttribute maxOccurs 1] if {$partMax <= 1} { set partList [list $partName [list type $partType comment {}]] } else { set partList [list $partName [list type [string trimright ${partType} {()}]() comment {}]] @@ -3403,11 +3597,11 @@ } set partName [$element getAttribute $attrName] if {$isRef} { set partType {} set partTypeInfo {} - set partType [getQualifiedType $results $partName $tns] + set partType [string trimright [getQualifiedType $results $partName $tns] {?}] set partTypeInfo [::WS::Utils::GetServiceTypeDef $mode $serviceName $partType] set partName [lindex [split $partName {:}] end] ::log::log 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] @@ -3452,11 +3646,11 @@ set partMax [$element getAttribute maxOccurs 1] } if {$partMax <= 1} { lappend partList $partName [concat [list type $partType comment $comment] $additional_defininition_elements] } else { - lappend partList $partName [concat [list type [string trimright ${partType} {()}]() comment $comment] $additional_defininition_elements] + lappend partList $partName [concat [list type [string trimright ${partType} {()?}]() comment $comment] $additional_defininition_elements] } } msg]} { ::log::log error "\tError processing {$msg} for [$element asXML]" if {$isRef} { ::log::log error "\t\t Was a reference. Additionally information is:" @@ -3488,11 +3682,11 @@ catch {set attrArr($name) [$element getAttribute $ref]} } set partName item set partType [getQualifiedType $results $attrArr(arrayType) $tns] set partType [string map {{[]} {()}} $partType] - set partList [list $partName [list type [string trimright ${partType} {()}]() comment {} allowAny 1]] + set partList [list $partName [list type [string trimright ${partType} {()?}]() comment {} allowAny 1]] } extension { set extension [$node selectNodes -namespaces $nsList xs:extension] set partList [partList $mode $extension $serviceName results $tns] } @@ -3681,11 +3875,11 @@ 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 @@ -3734,11 +3928,11 @@ 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]} { ::WS::Utils::ServiceTypeDef $mode $serviceName $tns:$typeName $partList $tns $isAbstractType } else { @@ -3911,11 +4105,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} { @@ -4104,12 +4299,13 @@ 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 typeName [string trimright $typeName {?}] set xns [dict get $typeInfo $mode $service $type xns] foreach {field fieldDef} [dict get $typeInfo definition] { ## ## Get info about this field and its type @@ -4116,11 +4312,11 @@ ## 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] @@ -4374,10 +4570,11 @@ 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] @@ -4407,11 +4604,11 @@ set typeDefInfo [dict create definition [dict create $type $typeDefInfo]] } set partsList [dict keys [dict get $typeDefInfo definition]] ::log::log debug "\t partsList is {$partsList}" foreach partName $partsList { - set partType [dict get $typeDefInfo definition $partName type] + 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] @@ -4596,10 +4793,12 @@ set lastPos [string last / $finalUrl] set finalUrlDir [string range $finalUrl 0 [expr {$lastPos - 1}]] ::log::log debug "initialUrlDir = $initialUrlDir, finalUrlDir = $finalUrlDir" set ::WS::Utils::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)]} { Index: Wub.tcl ================================================================== --- Wub.tcl +++ Wub.tcl @@ -46,11 +46,11 @@ } package require uri package require base64 package require html -package provide WS::Wub 2.2.1 +package provide WS::Wub 2.4.0 namespace eval ::WS::Wub { array set portInfo {} Index: WubServer.tcl ================================================================== --- WubServer.tcl +++ WubServer.tcl @@ -9,12 +9,12 @@ package require OO package require Direct package require Debug Debug off wsdl 10 -package provide WS::Wub 2.0.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] } Index: pkgIndex.tcl ================================================================== --- pkgIndex.tcl +++ pkgIndex.tcl @@ -1,20 +1,18 @@ # Tcl package index file, version 1.1 -# This file is generated by the "pkg_mkIndex" command +# This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded WS::Client 2.3.9 [list source [file join $dir ClientSide.tcl]] -package ifneeded WS::Server 2.3.7 [list source [file join $dir ServerSide.tcl]] -package ifneeded WS::Utils 2.3.10 [list source [file join $dir Utilities.tcl]] - -package ifneeded WS::Embeded 2.3.0 [list source [file join $dir Embedded.tcl]] -package ifneeded WS::AOLserver 2.0.0 [list source [file join $dir AOLserver.tcl]] -package ifneeded WS::Channel 2.0.0 [list source [file join $dir ChannelServer.tcl]] - -package ifneeded WS::Wub 2.2.1 [list source [file join $dir WubServer.tcl]] -package ifneeded Wsdl 2.0.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 2.4.0 [list source [file join $dir ClientSide.tcl]] +package ifneeded WS::Embeded 2.4.0 [list source [file join $dir Embedded.tcl]] +package ifneeded WS::Server 2.4.0 [list source [file join $dir ServerSide.tcl]] +package ifneeded WS::Utils 2.4.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]]