package provide xotcl::soap 0.9

package require xotcl::xml::parser
package require xotcl::xml::printVisitor
package require xotcl::xml::recreatorVisitor

package require xotcl::comm::httpAccess

#delete later!!!
#PrintVisitor pv

Object soap
#
# Meta-class for soap::Request & soap::Worker
#
Class soap::Class -superclass Class
soap::Class instproc init args {
  XMLParser create [self]::soapParser
  soap::CommInterpreter create [self]::soapInterp
  next
}

### uwe:: wofuer steht da ueberall das "Comm"?
### uwe:: sollte nicht der "interpreter" den XMLParser
###       enthalten (aggregation, oder subclass)
###       das sollte soch eine konzeptionelle einheit sein,
###       die bspw. per metaclass oder ander eingefügt wird.
Class soap::CommInterpreter -parameter {
  {soapEnvelopeNS http://schemas.xmlsoap.org/soap/envelope/}
  {xsdNS http://www.w3.org/1999/XMLSchema}
  {xsiNS http://www.w3.org/1999/XMLSchema-instance}
}

soap::CommInterpreter instproc getOneXMLEltChild {node} {
  set countElts 0
  foreach c [$node info children] {
    if {[$c istype XMLElement]} {
      incr countElts
      set result $c
    }
  }
  if {$countElts != 1} {
    error "SOAP request has more children than Body in Envelope"
  }
  return $result
}

soap::CommInterpreter instproc checkBody {envelope soapENV} {
  set c [[self] getOneXMLEltChild $envelope]
  if {[regexp "^$soapENV:Body$" [$c set content]]} {
    return $c
  } else {
    error "SOAP request has no Body in Envelope"
  }
  return ""
}

soap::CommInterpreter instproc getArgs {methodNode sr} {
  foreach c [$methodNode info children] {
    if {[$c istype XMLElement]} {
      # determine arg type
      set typeName [$sr set xsi]type
      if {[$c exists attributes($typeName)]} {
	set type [$c set attributes($typeName)]
	set xsd [$sr set xsd]
	if {![regexp "^${xsd}(.*)" $type _ typeval]} {
	  error "Type value $type not ok"
	}
      } else {
	error "No type attribute in ${c}::attributes"
	
      }
      $sr appendArgs [$c set content] $typeval [$c getFirstPCData]
    }
  }
}

soap::CommInterpreter instproc getFaults {methodNode sr} {
  foreach c [$methodNode info children] {
    if {[$c istype XMLElement]} {
      switch [$c content] {
	faultcode   {$sr set faultcode [$c getFirstPCData]}
	faultstring {$sr set faultstring [$c getFirstPCData]}
      }
    }	    
  }
}

soap::CommInterpreter instproc getResult {methodNode sr} {
  foreach c [$methodNode info children] {
    if {[$c istype XMLElement] && [$c content] == "Result"} {
      set typeName [$sr set xsi]type
      if {[$c exists attributes($typeName)]} {
	set type [$c set attributes($typeName)]
	set xsd [$sr set xsd]
	if {![regexp "^${xsd}(.*)" $type _ typeval]} {
	  error "Type value $type not ok"
	}
	$sr set type $typeval
      }
      $sr set value [$c getFirstPCData]
    }
  }
}

soap::CommInterpreter instproc checkForEnvelopeAndBody {topNode sr} {
  [self] instvar soapEnvelopeNS xsdNS xsiNS
  if {[regexp {^(.*):Envelope$} [$topNode set content] _ namespace]} {
    # this could be the envelope
    set soapENV [[$topNode set namespace] searchFullName $soapEnvelopeNS]
    if {$soapENV != ""} {
      # ok, we have it --> check for BODY
      set xsd [[$topNode set namespace] searchFullName $xsdNS]
      if {$xsd != ""} {append xsd :}
      set xsi [[$topNode set namespace] searchFullName $xsiNS]
      if {$xsi != ""} {append xsi :}
      $sr set xsd $xsd
      $sr set xsi $xsi
      $sr set soapENV $soapENV

      # return the body
      return [[self] checkBody $topNode $soapENV]
    }
  }
  return ""
}

soap::CommInterpreter instproc buildRequest {topNode} {
  set sr [soap::Request [[self class] autoname sr]]

  set body [[self] checkForEnvelopeAndBody $topNode $sr]
  if {$body != ""} {
    set c [[self] getOneXMLEltChild $body]
    if {[regexp {([^:]*)$} [$c set content] _ methodName]} {
      $sr name $methodName
      [self] getArgs $c $sr
    }
  }
  return $sr
}

soap::CommInterpreter instproc buildResponse {topNode responseCode} {
  set sr [soap::Response [[self class] autoname sr]]
  $sr responseCode $responseCode
  
  set body [[self] checkForEnvelopeAndBody $topNode $sr]
  if {$body != ""} {
    set c [[self] getOneXMLEltChild $body]
    if {$responseCode == "200" &&
	[regexp {([^:]*)Response$} [$c set content] _ methodName]} {
      $sr name $methodName
      [self] getResult $c $sr
    } elseif {$responseCode >= 500 &&
	      [string match [$sr set soapENV]:Fault [$c set content]]} {
      $sr name ""
      [self] getFaults $c $sr
    }
  }
  return $sr
}



Class soap::Value -parameter {
  {name ""}
  type
  value
}
soap::Value instproc print {} {
  [self] instvar name type value
  puts "     SOAPVALUE NAME=$name, TYPE=$type, VALUE=$value"
}


Class soap::Comm -parameter {
  name
}
# A central parser and creator for SOAP communcation types
XMLParser soap::Comm::xmlParser
XMLRecreatorVisitor soap::Comm::xmlCreator

soap::Comm instproc appendArgs args {
  foreach {n t v} $args {
    soap::Value create [self]::[[self] autoname arg%04d] \
	-name $n -type $t -value $v
    #puts "***soap::Value n=$n, t=$n, v=$n"
  }
}
soap::Comm abstract instproc createCommSpecificXML {parser}

#
# add envelope and body
#
soap::Comm instproc createXML {} {
  set parser [self class]::xmlParser
  set creator [self class]::xmlCreator
  #
  # build up the XML tree
  #
  $parser start SOAP-ENV:Envelope {
    SOAP-ENV:encodingStyle http://schemas.xmlsoap.org/soap/encoding/ 
    xmlns:SOAP-ENC http://schemas.xmlsoap.org/soap/encoding/ 
    xmlns:SOAP-ENV http://schemas.xmlsoap.org/soap/envelope/ 
    xmlns:xsd http://www.w3.org/1999/XMLSchema
    xmlns:xsi http://www.w3.org/1999/XMLSchema-instance
  }
  $parser start SOAP-ENV:Body ""

  [self] createCommSpecificXML $parser

  $parser end SOAP-ENV:Body
  $parser end SOAP-ENV:Envelope
  #pv interpretAll $parser
  #
  set xmlText [$creator interpretAll $parser]
  $parser reset

  #puts "[self]-[self proc] returns '$xmlText'"
  return $xmlText
}

soap::Class soap::Request -superclass {soap::Comm MemorySink}
soap::Request instproc createCommSpecificXML {parser} {
  [self] instvar name
  if {$name != ""} {
    $parser start m:$name "xmlns:m http://www.soapware.org/"
    foreach c [lsort [[self] info children]] {
      if {[$c istype soap::Value]} {
	$parser start [$c set name] "xsi:type xsd:[$c set type]"
	$parser pcdata [$c set value]
	$parser end [$c set name]
      }
    }
    $parser end m:$name
  }
}
soap::Request instproc print {} {
  [self] instvar name
  puts "*********************************"
  puts " soap::Request NAME=$name,"
  puts "   ARGS:"
  foreach c [lsort [[self] info children]] {
    if {[$c istype soap::Value]} {
      $c print
    }
  }
  puts "*********************************"
}

soap::Request instproc doCall {url endCmd} {
  [self] set soapEndCmd $endCmd
  return [Access createRequest -url $url \
	      -httpVersion 1.0 \
	      -caching 0 -informObject [self] \
	      -method POST -contentType "text/xml; charset=utf-8" \
	      -data [[self] createXML]]
}

soap::Request instproc endCb {soapRequest} {
  next
  #[self] showVars
  set p [self class]::soapParser
  $soapRequest instvar responseCode
  $p parse [[self] content]
  set soapResponse [[self class]::soapInterp buildResponse \
			${p}::topNode0 $responseCode]
  $p reset
  if {[[self] exists soapEndCmd]} {
    ::eval [[self] lappend soapEndCmd $responseCode $soapResponse]
  }
}


Class soap::Response -superclass {soap::Comm soap::Value} -parameter {
  {responseCode 200}
  {faultcode ""}
  {faultstring ""}
}
soap::Response instproc createCommSpecificXML {parser} {
  [self] instvar name responseCode type value faultcode faultstring
  if {$responseCode == "200"} {
    $parser start m:${name}Response "xmlns:m http://www.soapware.org/"
    $parser start Result "xsi:type xsd:$type"
    $parser pcdata $value
    $parser end $name
    $parser end m:${name}Response
  } else {
    $parser start SOAP-ENV:Fault
    $parser start faultcode
    $parser pcdata $faultcode
    $parser end faultcode
    $parser start faultstring
    $parser pcdata $faultstring
    $parser end faultstring
    $parser end SOAP-ENV:Fault
  }
}

soap::Response instproc print {} {
  [self] instvar name type responseCode faultcode faultstring value
  puts "*********************************"
  #[self] showVars
  puts " soap::Response NAME=$name,"

  if {$responseCode == "200"} {
    puts "   TYPE= $type"
    puts "   VALUE= $value"
  } else {
    puts "   FAULTCODE= $faultcode"
    puts "   FAULTSTRING= $faultstring"
  }
  puts "*********************************"
}

soap::Request instproc eval {} {
  [self] instvar name
  set argList ""
  #
  # wrong: order unimportant -> names mit info body vgl???
  #
  foreach c [lsort [[self] info children]] {
    lappend argList [$c set value]
  }

  puts "EVAL: $name $argList"
  set result [::eval $name $argList]
  puts "RESULT: $result"

  #check result conforms to return type
  return $result
}
