# -*- tcl -*- $Id: Access.xotcl,v 1.20 2001/03/09 13:27:10 neumann Exp $
set httpAccessVersion 0.9
package provide xotcl::comm::httpAccess $httpAccessVersion

package require xotcl::comm::pcache
package require xotcl::comm::mime
package require xotcl::comm::connection
package require xotcl::trace

if {[catch {set os [exec uname -sr]}]} {
  if {[catch {set os [exec uname -a]}]} { set os unknownOS }
}
if {![info exists VERSION]} { set VERSION 1.0 }


# assert is used only for invariants in the source
proc assert {f r} {
  set got [eval $f]
  if {$got != $r} {
    puts stderr "assertion failed: \[$f\] == $r (got $got)"
  }
}


# resolve and checkUrl implement URL handling (primarily completion)
proc checkUrl {url} {
  #puts stderr "checkUrl: <$url>"
  if {![regexp {^([^:]+:/)/([^/]+)(/.*)?$} $url _ scheme network path]} {
    regexp {^([^:]+:)(/.*)?$} $url _ scheme path
  }
  if {![info exists path]} {
    # no access scheme provided, try some heuristics...
    if {[regexp {^[./]} $url]} {
      # expand leading "." to pwd
      if {[regexp {^\.(.*)$} $url _ url]} { set url [pwd]$url }
      return file:$url
    } else {
      set url http://$url
      regsub {///$} $url // url
      return $url
    }
  }
  if {$path == ""} {set path /}
  return [expr {[info exists network] ?
		"$scheme/$network$path" : "$scheme$path"}]
}
# resolving a relative url with respect to a base url (based on rfc 1808)
proc resolve {rel base {childTagName ""}} {
  if {$base == ""}    { return [checkUrl $rel] }
  if {$rel == ""}     { return $base }
  if {[regexp {^[^:]+:/} $rel _]} { return [checkUrl $rel] }
  if {![regexp {^([^:]+:/)/([^/]+)(/.*)$} $base _ baseScheme baseNetwork basePath]} {
    regexp {^([^:]+:)(/.*)$} $base _ baseScheme basePath
  } elseif {[regexp {^[^:/]+:} $rel]} {
    return $rel
  }
  if {[regexp {^//([^/]+)/(.*)$} $rel _ relNetwork relPath]} {
    return $baseScheme/$relNetwork/$relPath
  }
  if {[info exists baseNetwork]} {
    append baseScheme /$baseNetwork
  }
  #puts stderr rel=<$rel>
  if {![string match /* $rel]} {
    #puts stderr rel<$rel>base<$basePath>
    if {[string match \#* $rel]} {
      set r $basePath$rel
    } elseif {![regsub {/([^/]*)$} $basePath /$rel r]} {
      set r /$rel
    }
    while {[regsub -all {/\./} $r / r]} {}
    regsub {/\.$} $r / r
    while {[regsub -all {/[^/]+/\.\./} $r / r]} {}
    # remove leading /../ (netscapes navigator does this)
    while {[regsub {^/\.\./} $r / r]} {}
    set rel $r
    #puts stderr finalrel<$r>
  }
  #if {$childTagName != ""}
  if {1} {
    upvar $childTagName childTag 
    catch {unset childTag}
    if {[regexp {^(.+)\#(.+)$} $rel _ rel childTag]} {
      #puts stderr childTag=$childTag,url=$baseScheme$rel.
    }
  }
  return $baseScheme$rel
}
assert {resolve "" http://mohegan/} http://mohegan/
assert {resolve http://mohegan/ ""} http://mohegan/
assert {resolve http://mohegan ""} http://mohegan/
assert {resolve http://mohegan/ http://nestroy} http://mohegan/
assert {resolve test.html http://127.0.0.1/} http://127.0.0.1/test.html
assert {resolve test http://nestroy/} http://nestroy/test
assert {resolve test file:/u/neumann/old} file:/u/neumann/test
assert {resolve /test http://nestroy/} http://nestroy/test
assert {resolve //mohegan/index.html http://nestroy/} http://mohegan/index.html
assert {resolve //mohegan/index.html http://nestroy/} http://mohegan/index.html
assert {resolve index.html http://nestroy/dir/} http://nestroy/dir/index.html
assert {resolve ./index.html http://nestroy/dir/} http://nestroy/dir/index.html
assert {resolve ././index.html http://nestroy/dir/} http://nestroy/dir/index.html
assert {resolve ../index.html http://nestroy/dir/} http://nestroy/index.html
assert {resolve ../../index.html http://nestroy/dir/} http://nestroy/index.html
assert {resolve ../../../test file:/u/neumann/old} file:/test
assert {resolve newdir/  http://nestroy/dir/} http://nestroy/dir/newdir/
assert {resolve /newdir/  http://nestroy/dir/} http://nestroy/newdir/
assert {resolve file:/u/neumann/ice.html ""} file:/u/neumann/ice.html
assert {resolve \#label http://nestroy/h.html} http://nestroy/h.html
assert {resolve mailto:user@host http://nestroy/h.html} mailto:user@host


##############################################################
# Every object of class Access informs the (possibly empty) list of 
# informObjects during its lifecycle with the following messages
#   
#   startCb:   when the request for the object is created
#              and was classified and initialized
#
#   notifyCb:  when the type of the incming data is dertermined
#              (typically after parsing the http header)
#
#   incCb:     when new data is available
#
#   endCb:     when the request is finished sucessfully and the object
#              is going to be destroyed
#
#   cancelCb:  when the request is finished nonsucessfully and the object
#              is going to be destroyed
#
# All these messages receive the name of the Access object
# as first parameter, incCb has two more arguments (totalsize 
# and currentsize) 

# caching:
# 0 no caching
# 1 volatile cache (does not check cache, keeps spool file for back button)
# 2 persistent cache

Class Access -parameter {
  {method GET} {blocking 0} {httpVersion 1.1} {headers {}} 
  url query data contentType path caching sinkClass parentUrl
}
Access instproc informObject x {
  [self] instvar informObjects
  foreach i $x { lappend informObjects $i }
}
Access instproc method x {
  set [self]::method [string toupper $x]
}
Access instproc unknown {m args} {
  error "Method '$m' with args '$args' is unknown for [self class]"
}

Access proc checkRunning {} {
  [self] instvar running
  foreach u [array names running] {
    puts stderr "... running: $u"
  }
  puts stderr "... -----------"
}
Access proc createRequest args {
  #[self] showCall
  [self] instvar running
  set informobject {}
  set allowJoin 1
  set nargs {}
  foreach {a v} $args {
    switch -exact -- $a {
      -url           {set url $v;          lappend nargs $a $v}
      -informObject  {set informobject $v; lappend nargs $a $v}
      -parentRequest {set parentRequest $v}
      -allowJoin     {set allowJoin $v}
      default        {lappend nargs $a $v}
    }
  }
  #if {[array exists running]} {parray running}
  if {[info exists running($url)] && $allowJoin} {
    [self] showMsg "we can join running($url)=$running($url)"
    # we can join the request.
    # requests are joined by adding the informobjects to
    # the existing request
    set token $running($url)
    # delegation to a different request works only so easy
    # when loading to a file...
    $token informObject $informobject
    return $token
  } else {
    set token [[self] autoname ::req]
    if {[info exists parentRequest]} {
      set token ${parentRequest}$token
    } 
    return [eval [self] create $token $nargs]
  }
}
Access instproc running {} {
  #[self] showCall
  [self] instvar url
  [self class] set running($url) [self]
}
Access instproc stop {} {
  #showCall
  [self] instvar url
  [self class] instvar running
  if {[[self class] exists running($url)]} {
    #puts stderr "[self] unset [[self class] set running($url)]
    [self class] unset running($url)
    #if {[[self] array exists running]} { parray [self class]::running }
  } else {
    #puts stderr "not running($url)"
    #if {[[self] array exists running]} { parray [self class]::running }
  }
}
Access instproc init args {
  #[self] showCall
  [self] instvar blocking method url
  [self] cset informObjects {}
  next
  if {![[self] exists caching]} { 
    if {$method == "GET"} {
      set defaultCaching 2
    } else {
      set defaultCaching 1
    }
    [self] set caching $defaultCaching
  }
  #[self] showVars

  set url [string trim $url]
  [self] classify $url
  [self] initialize

  # now inform all interested objects that we have the object
  [self] doCallbacks startCb
  #[self] showVars blocking
  # trigger the transfer... (might be blocking or not)
  [self] $method
  if {![[self] exists finished]} {
    # the request is not finished
    if {$blocking} {
      #[self] showMsg "waiting"
      [self] vwait finished
      #[self] showMsg "waiting DONE"
    }
  }
}
Access instproc getContent {} {
  [[self] set sink] content
}

#########################################
Access instproc timeout t {
  [self] set timeout [::after $t [self] timeoutOccured]
}
Access instproc timeoutOccured {} {
  #[self] showCall
  [self] unset timeout
  [self] abort "timeout exceeded"
}
Access instproc timeoutFinish {} {
  if {[[self] exists timeout]} {
    after cancel [[self] set timeout]
    [self] unset timeout
  }
}
#########################################

Access instproc initialize {} {
  #[self] showCall
  set [self]::state           0
  set [self]::meta            {}
  set [self]::currentsize     0
  set [self]::totalsize       0
}
Access instproc classify {url} {
  [self] instvar host path port method caching
  #[self] showVars caching
  if {$caching > 1 && [persistentCache isValidated $url]} {
    #puts stderr "*** cacheable && validated"
    #showVars
    #persistentCache dump
    set access CacheAccess
  } elseif {[regexp -nocase {^http://([^/:]+)(:([0-9]+))?(/.*)?$} $url \
		 _ host y givenPort path]} {
    if {$givenPort != ""} { set port $givenPort }
    switch -exact $method {
      PROPFIND -
      PROPPATCH -
      COPY -
      MKCOL -
      MOVE -
      LOCK -
      UNLOCK {
	package require xotcl::comm::dav
	set access Dav
      }
      default {set access Http}
    }
  } elseif {[regexp -nocase {^https://([^/:]+)(:([0-9]+))?(/.*)$} $url \
		 _ host y givenPort path]} {
    if {$givenPort != ""} { set port $givenPort }
    set access Https
  } elseif {[regexp -nocase {^file:(.*)$} $url _ path]} {
    set access File
  } elseif {[regexp -nocase {^ftp://([^/]+)/(.*)$} $url _ host path]} {
    package require xotcl::comm::ftp
    set access Ftp
  } elseif {[regexp -nocase {^imap://([^/]+)/(.*)$} $url _ host path]} {
    package require xotcl::comm::imap
    set access Imap
  } elseif {[regexp -nocase {^cmd:/(.*)$} $url _ path]} {
    set access xotcl::Cmd    
  } elseif {[regexp -nocase {^ldap://([^/:]+)?(:([0-9]+))?(/.*)$} \
		 $url _ host y givenPort path]} {
    if {$givenPort != ""} { set port $givenPort }
    [self] showMsg "*** ldap://<$host>:<$port>/<$path>"
    package require xotcl::comm::ldap
    set access Ldap  
  } else {
    [self] abort "Unsupported URL: '$url'"
    return
  }
  [self] class $access
  #[self] showMsg "class of request = $access"
}
Access instproc revisit {} {
  [self] instvar method
  [self] class ReAccess
  [self] initialize
  [self] $method
}
### dummy stubs for 'close' and 'GET' for error cases
Access instproc close {} {
}
Access instproc GET {} {
  if {[[self] exists errormsg]} { ;# the error was already reportet
    [self] finish
  } else {
    [self] abort "unknown error"
  }
}
# Access instproc altInformObjects {} {
#   [self] instvar children altInformObjects informObjects
#   set altInformObjects $informObjects
#   set informObjects {}
#   foreach c $children { $c destroy }
#   set children {}
# }

Access instproc headerDone {} {
  [self] instvar caching sink
  if {[[self] exists ignoreBody]} return
  if {[[self] exists sinkClass] && $caching>0 } {
    error "can´t set both sinkclass and caching"
  }
  switch $caching {
    2 {
      set sink [CacheFileSink create [self]::cfs]
      #[self] showMsg "[self class] result goes to cache"
      $sink notifyCb [self]
    }
    1 {
      set sink [CacheFileSink create [self]::cfs -persistent 0]
      #[self] showMsg "result goes to volatile cache"
      $sink notifyCb [self]
    }
    0 {
      if {[[self] exists sinkClass]} {
	set sink [[[self] set sinkClass] create [self]::s]
      }
    }
  }
  [self] doCallbacks notifyCb
}
Access instproc mkSpoolFile {{name ""}} {
  if {![[self] exists fileName]} {
    [self] instvar url caching
    [self] set fileName [persistentCache newEntry $url [self] $caching $name]
  }
}
Access instproc block {} {
  [self] instvar block
  return $block
}
Access instproc kill {} {
  [self] showCall
  [self] set state -1; #interrupted
  [self] finish
}
Access instproc abort {msg} {
  #[self] showCall
  #[self] showVars
  [self] instvar state errormsg caching
  if {[catch {::printError "[self] ($state): $msg"} err]} {
    puts stderr "\n$err\nERROR [self] ($state): $msg\n"
  }
  #[self] set error [list $msg $::errorInfo $::errorCode]
  set caching 0
  if {[[self] exists ignoreBody]} {
    [self] unset ignoreBody
  }
  set state -2 ;# error
  set errormsg $msg
  [self] finish
}
Access instproc finish {} {
  #[self] showCall
  [self] timeoutFinish
  [self] close
  #[self] showVars state ignoreBody
  # state is "interrupted" or "error"
  if {[[self] set state] < 0} {
    set action cancelCb
    set success 0
  } else {
    set action endCb
    #set state ok
    set success 1
  }
  if {[[self] exists ignoreBody]} {
    [self] stop
    #[self] set finished $success
    set cmd [[self] set ignoreBody]
    [self] unset ignoreBody
    #[self] showMsg "executing... <$cmd>"
    eval [self] $cmd
  } else {
    if {[[self] exists sink]} {
      [[self] set sink] $action [self]
    }
    #catch {after cancel $after} ;# ????

    [self] doCallbacks $action
    [self] stop 
    [self] set finished $success
  }
}
Access instproc eof {} {
  #[self] showCall
  #[self] showMsg "c [[self] set currentsize]== t [[self set totalsize]]"
  #[self] set state eof
  [self] finish
}
Access instproc doCallbacks {cb} {
  #[self] showCall
  if {[[self] exists ignoreBody]} {
    [self] showMsg "ignoring callback"
  } else {
    foreach obj [[self] set informObjects] {
      #[self] showMsg "*** $obj $cb [self]"
      #puts stderr "------------ calling: $obj $cb [self]"
      if {[catch {$obj $cb [self]} errormsg]} {
	puts stderr "--------------$cb:errormsg=$errormsg, \
		     errorInfo=$::errorInfo, \
		     errorCode=$::errorCode."
      }
      #puts stderr "------------ calling DONE: $obj $cb [self]"
    }
  }
}
Access instproc shutdown {} {
  if {[[self] set state] > 3} {
    [self] set mustDestroy 1
  } else {
    #[self] showVars
    [self] destroy
  }
}


Class FileAccess -superclass Access
FileAccess instproc initialize args {
  set [self]::caching 0
  next
}
FileAccess instproc close {} {
}
FileAccess instproc block {} {
  [self] showTimeStart
  [self] instvar fileName
  set S [::open $fileName r]
  fconfigure $S -translation binary
  set block [::read $S]
  ::close $S
  [self] showTimeEnd
  return $block
}
FileAccess instproc GET {} {
  [self] instvar path response totalsize currentsize \
      fileName informObjects
  set fileName $path
  set totalsize [file size $path]
  set response "file 200 OK"
  [self] headerDone
  [self] set state 4
  set currentsize $totalsize
  #[self] showVars informObjects 
  foreach obj $informObjects {
    $obj incCb [self] $totalsize $currentsize
  }
  [self] eof
}


Class File -superclass FileAccess
File instproc GET {} {
  [self] instvar path sink
  #puts stderr path=$path,exists=[file exists $path]
  if {![file exists $path]} {
    [self] abort "No such file '$path'"
    return
  }
  if {![[self] exists contentType]} {
    [self] set contentType [Mime guessContentType $path]
  }
  set sink [FileSink create [self]::fas -fileName $path]
  #puts stderr ****sink=$sink,[$sink info class]
  #puts stderr "*** before next ([self class])"
  next
  #puts stderr "*** after next ([self class])"
}

Class CacheAccess -superclass File
CacheAccess instproc GET {} {
  [self] instvar url path contentType meta
  set path        [persistentCache cacheFileName $url]
  set contentType [persistentCache contentType $url]
  set meta        [persistentCache meta $url]
  next
}

Class ReAccess -superclass File
ReAccess instproc GET {} {
  [self] instvar fileName sink
  set [self]::block       ""
  set [self]::currentsize 0
  set [self]::caching     0
  if {![info exists fileName]} {
    set fileName [$sink set fileName]
  }
  set [self]::path $fileName
  next
}



Class Cmd -superclass Access
Cmd instproc init args {
  [self] cset [self]::caching 0
  next
}
Cmd instproc GET {} {
  [self] instvar path contentType block totalsize currentsize \
      response informObjects state
  if {[catch {set block [eval $path]} error]} {
    set contentType text/plain
    set block $error
  } else {
    set contentType text/html
  }
  set totalsize [string length $block]
  set response "cmd 200 OK"
  [self] headerDone
  [self] set state 4
  set currentsize $totalsize
  foreach obj $informObjects {
    $obj incCb [self] $totalsize $currentsize
    #$obj endCb [self]
  }
  #set state eof
  [self] finish
}
Cmd instproc block args {
  [self] instvar block
  return $block
}


#Class NetAccess -superclass Access -parameter {host port}
Class NetAccess -superclass Access
NetAccess instproc initialize args {
  if {![[self] exists blocksize]} {[self] set blocksize 512}
  [self] set readMethod read
  next
}
NetAccess instproc read {} {
  #[self] instvar S blocksize block
  #set block [::read $S $blocksize]
  [self] instvar S block blocksize
  set block [::read $S $blocksize]
}
NetAccess instproc gzread {} {
  [self] instvar S Z blocksize block
  puts -nonewline $Z [::read $S $blocksize]
  set block [::read $Z]
  #puts stderr len=[string length $block],block=<$block>
}
NetAccess instproc gzopen {} {
  [self] instvar Z S readMethod
  requireModules {zipchan libzipchan.so}
  fconfigure $S -translation binary
  set Z [zipchan]
  set readMethod gzread
}
NetAccess instproc close {} {
  #[self] showMsg "**** close persistent=[[self] exists persistent]"
  if {![[self] exists persistent]} {
    foreach stream {S Z} {
      if {[[self] exists $stream]} {
	::close [[self] set $stream]
	[self] unset $stream
      }
    }
  }
  [self] stop
}
NetAccess instproc hold {} {
  [self] instvar S
  $S hold
}
NetAccess instproc resume {} {
  [self] instvar S
  $S resume
}
NetAccess instproc readData {} {
  #[self] showCall
  [self] instvar readMethod
  if {[catch {
    #puts stderr "??????????????readMethod=$readMethod"
    [self] $readMethod
    [self] pushBlock
  } err]} {
    puts stderr ERR=$err
    [self] set block ""
    [self] abort $err
  }
}
NetAccess instproc pushBlock {} {
  #[self] showCall
  [self] instvar block
  if {[set n [string length $block]]} {
    [self] instvar currentsize totalsize informObjects sink
    #[self] showVars n currentsize totalsize
    incr currentsize $n
    if {$currentsize > $totalsize} {
      set totalsize $currentsize
    }
    #[self] showMsg "total=$totalsize current=$currentsize"
    if {[[self] exists ignoreBody]} {
      #puts stderr "ignoring: <$block>"
    } else {
      if {[info exists sink]} {
	$sink incCb [self] $totalsize $currentsize
      }
      foreach obj $informObjects {
	#[self] showMsg "call incbCb $totalsize $currentsize $obj [$obj info class]"
	$obj incCb [self] $totalsize $currentsize
	#[self] showMsg "done incbCb $totalsize $currentsize"
      }
    }
  } else {
    #[self] showVars n
    return [ [self] eof ]
  }
}

Class Http -superclass NetAccess  ;###  -parameter {query {httpVersion 1.0}}
Http set proxyfilter  httpProxyRequired
Http set proxyhost    {}
Http set proxyport    {}
Http set accept       */*
if {[info exists argv0]} {
  Http set useragent    "[file tail $argv0] httpAccess/$httpAccessVersion xotcl/$::xotcl::version ($os)"
}
Http proc proxyfilter {host phostv pportv} {
  [self] instvar proxyfilter proxyhost proxyport
  upvar \#1 $phostv phost $pportv pport
  switch -- proxyfilter {
    httpProxyRequired {
      if {[string length $proxyhost]} {
	if {![string length $proxyport]} { set proxyport 8080 }
	set phost $proxyhost
	set pport $proxyport
      }
    }
  }
}

Http instproc initialize args {
  if {![[self] exists port]}        {[self] set port 80}
  if {![[self] exists httpVersion]} {[self] set httpVersion 1.1}
  next
  #[self] showMsg "result queried from net"
}
Http instproc GET {} {
  #[self] showCall
  if {[[self] exists query]} {
    [self] instvar query caching
    [self] append url ?$query
    [self] append path ?$query
    if {$caching == 2} {set caching 1}
    [self] showVars caching $query
  }
  [self] open
}
Http instproc HEAD {} {
  [self] open
}
Http instproc POST {} {
  # we have query and data only for a uniform interface for
  # forms that cann pass the attribute value pairs always via
  # query.
  if {[[self] exists query]} {
    [self] set data [[self] set query]
  }
  [self] open
}
Http instproc PUT {} {  
  #[self] instvar query 
  #set [self]::data $query
  [self] open
}
# Http1.1
Http instproc OPTIONS {} {
  [self] showCall
  [self] open  
}
# Http1.1
Http instproc TRACE {} {
  [self] showCall
}
# Http1.1
Http instproc DELETE {} {
  #[self] showCall
  [self] open  
}
Http instproc openConnection {host port reuse} {
  return [Connection make [self] $host $port $reuse _]
}
Http instproc open {} {
  #[self] showCall
  [self] instvar url S state host port path httpVersion
  if {$state > 0} {
    puts stderr "... [self]:$proc ignoring request in state $state"
    return
  }
  Http proxyfilter $host phost pport
  if {[info exists phost] && [string length $phost]} {
    set usePort $pport
    set useHost $phost
    set path $url
  } else {
    set usePort $port
    set useHost $host
  }

  set S [[self] openConnection $useHost $usePort [expr {$httpVersion>1.0}]]
  if {[$S exists error]} {
    [self] abort [$S set error]
    return
  }
  set state 2
  [self] running
  $S event writable [self] ask
}

Http instproc ask {} {
  [self] instvar url S state host port path \
      method headers data contentType caching

  $S event writable [self] {}

  if {[pwdManager checkAvailableCredentials $url credentials]} {
    eval lappend headers $credentials
    #[self] showMsg "*** new headers = <$headers>"
  }
  if {$caching==2 && [persistentCache ifModifiedHeader $url ifModified]} {
    eval lappend headers $ifModified
    #puts stderr "new headers = <$headers>"
  }
  # Send data in cr-lf format, but accept any line terminators
  $S translation {auto crlf}

  [self] instvar httpVersion
  #[self] showMsg "'$method $path HTTP/$httpVersion' headers {$headers}"
  $S puts "$method $path HTTP/$httpVersion"
  if {[$S  exists error]} {
    [self] instvar host port
    [self] abort "Connection refused by host '$host' port '$port'\n\
    	[$S set error]"
    return
  }

  $S puts "Accept: [Http set accept]"
  $S puts "Host: $host"
  $S puts "User-Agent: [Http set useragent]"
  foreach {tag value} $headers {
    regsub -all \[\n\r\] $value {} value
    set tag [string trim $tag]
    if {[string length $tag]} {
      #[self] showMsg "+++ <$tag: $value>"
      $S puts "$tag: $value"
    }
  }
  if {[[self] exists data]} {
    $S puts "Content-Length: [string length $data]"
    $S puts "Content-Type: $contentType"
    $S puts ""
    $S translation {auto binary}
    $S puts-nonewline $data
  } else {
    $S puts ""
  }
  $S flush
  if {[$S  exists error]} {
    [self] instvar host port
    [self] abort "Connection refused by host '$host' port '$port'\n\
		[$S set error]"
  } else {
    set state 3
    $S event readable [self] headerStart
  }
}

Http instproc headerStart {} {
  #[self] showCall
  [self] instvar S response
  set n [$S gets response]
  #[self] showVars n response
  if {[$S  exists error]} {
    [self] instvar host port
    [self] abort "Error on connection to host '$host' port '$port'\n\
		[$S set error]"
    return
  }
  #[self] showMsg "n=$n, eof=[$S eof]"
  if {$n == -1 && ![$S eof]} {
    #[self] showMsg "******************************input pending, no full line"
    return
  }
  [self] instvar responseCode responseHttpVersion
  if {[regexp {^HTTP/([0-9.]+) +([0-9]+) *} $response _ \
	   responseHttpVersion responseCode]} {
    #[self] showMsg "response valid: '$response'"
    $S event readable [self] header
  } else {
    [self] instvar host port
    [self] abort "Unexpected response from $host:$port\n    $n: '$response'"
  }
}
Http instproc header {} {
  #[self] showCall
  [self] instvar S contentType meta totalsize
  if {[$S gets line]} {
    #[self] showMsg "line=$line"
    if {[regexp -nocase {^content-type:(.+)$} $line _ type]} {
      set contentType [string trim $type]
    } elseif {[regexp -nocase {^content-length:(.+)$} $line _ length]} {
      set totalsize [string trim $length]
    }
    if {[regexp -nocase {^([^:]+): *(.+)$} $line _ key value]} {
      lappend meta [string tolower $key] $value
    }
  } else {
    [self] headerDone
  }
}
Http array set expectsBody \
      {GET 1 HEAD 0 POST 1 PUT 0 DELETE 1 OPTIONS 0 TRACE 1}
Http instproc headerDone {} {
  #[self] showVars meta
  [self] instvar S meta method responseCode responseHttpVersion
  [self class] instvar expectsBody
  set expectBody $expectsBody($method)

  array set v [[self] set meta]
  if {([info exists v(connection)] && $v(connection) == "close") || \
	  $responseHttpVersion < 1.1} {
    $S makePersistent 0
  } else {
    $S makePersistent 1
  }
  
  switch $responseCode {
    200 {}
    204 {
      #set state empty
      [self] finish
      set block ""
      set expectBody 0
      return
    }
    301 -
    302 {
      # the request is redirected to another server
      [self] set ignoreBody [list redirect $v(location)]
      
      # RFC2068 Note: When automatically redirecting a POST request after
      # receiving a 302 status code, some existing HTTP/1.0 user agents
      # will erroneously change it into a GET request.
      #set [self]::method GET 
      
      [self] showMsg "redirect '[[self] set url]' --> '$v(location)'"
    }
    304 { ;#  Not Modified, use cached version
      [self] set ignoreBody cacheAccess
      set expectBody 1
      #[self] showMsg "result comes from cache"
    }
    401 {
      [self] set ignoreBody \
	  [list resubmitAuthenticated $v(www-authenticate)]
      #[self] showMsg "resubmitAuthenticated $v(www-authenticate)"
      if {[[self] exists resubmitAuthenticated]} {
	if {[[self] set resubmitAuthenticated] > 5} {
	  [self] abort "Too many wrong passwords given"
	} else {
	  [self] incr resubmitAuthenticated
	}
      } else {
	[self] set resubmitAuthenticated 1
      }
      set expectBody 1
    }
    404 {
      [self] instvar url
      #[self] showVars
      [self] set ignoreBody [list abort "File Not Found on Server '$url'"]
      set expectBody 1
    }
    default {
      #[self] showVars responseCode
    }
  }
  next
  if {![[self] exists S]} {;# this request was already canceled
    return
  }
  if {[info exists v(transfer-encoding)]} {
    if {$v(transfer-encoding) == "chunked"} {
      $S translation {auto binary}
      [self] set state 4
      $S event readable [self] readChunkedLength
    } else {
      [self] abort "Unexpected Transfer encoding '$v(transfer-encoding)'"
    }
  } else {
    # yahoo does not send a content length for a get request
    #if {$totalsize == 0 && ($responseCode > 300 || !$expectsBody($method) )} 
    #[self] showVars method totalsize expectsBody($method) expectBody
    # the following is used currently for Actiweb-Agents:
    # the reponse of a PUTS contains a BODY!
    if {!$expectBody && 
	[::info exists v(content-length)] &&
	$v(content-length) > 0} {
      set expectBody 1
      [self] showMsg "setting expectBody 1"
    }

    if {!$expectBody} {
      #$S event readable [self] ""
      #set state eof
      [self] finish
      set block ""
    } else {
      ### To avoid CRLF problmes we set the translation for 
      ### the body entity  to binary
      $S translation binary
      [self] set state 4
      $S event readable [self] readData
    }
  }
}

Http instproc cacheAccess {} {
  # there is an actual version of the document in the cache
  #showCall
  persistentCache validated [[self] set url]
  #[self] close
  [self] class CacheAccess
  #[self] showMsg "result comes from cache [persistentCache cacheFileName $url]"
  [self] set caching 0 ;# should be really: toCache 0
  [self] GET
}

Http instproc redirect location {
  # the request is redirected to another server
  [self] classify $location
  [self] initialize
  [self] [[self] set method]
}
Http instproc resubmitAuthenticated headerField {
  #[self] showCall
  # the server requires authentification
  [self] instvar path method
  if {[pwdManager checkRequestedAuthentification $method $path $headerField \
	   type realm]} {
    [self] instvar url caching method headers
    array set v $headers
    #[self] showVars
    catch {unset v(Authorization)}
    set headers [array get v]
    pwdManager removePasswd $realm
    [self] close
    if {[pwdManager requireCredentials $realm $url]} {
      [self] initialize
      if {$caching == 2} {set caching 1}
      [self] $method
    }
  } else {
    [self] abort "unknown authentication method '$headerField'"
  }
}
Http instproc readChunkedLength {} {
  #[self] showCall
  [self] instvar S chunkLength totalsize
  set length [$S gets lengthString]
  if {$length > 0} {
    set chunkLength [expr 0x$lengthString]
    #[self] showVars lengthString chunkLength
    if {$chunkLength == 0} {
      $S event readable [self] readChunkedTrailer
    } else {
      incr totalsize $chunkLength
      $S translation {binary}
      $S event readable [self] readChunkedData
    }
  }
}
Http instproc readChunkedTrailer {} {
  #[self] showCall
  [self] instvar S state block
  set size [$S gets line]
  if {$size != 0} {
    showObj [self]
    [self] abort "expected trailer size 0, got size $size"
  } else {
    #set state eof
    [self] finish
    set block ""
    #showObj [self]
  }
}
Http instproc readChunkedData {} {
  #[self] showCall
  [self] instvar S block totalsize currentsize chunkLength
  set block [$S readSize $chunkLength]
  set received [string length $block]
  #[self] showVars block
  #[self] showVars currentsize totalsize chunkLength received
  if {$chunkLength == $received} {
    $S translation {auto binary}
    $S event readable [self] readChunkedLength
  } else {
    incr chunkLength -$received
  }
  [self] pushBlock
}

Http instproc readData {} {
  #[self] showCall
  [self] instvar S block totalsize currentsize
  set block [$S read]
  #puts stderr "????? bl=[string length $block]"
  if {[$S exists error]} {
    set block ""
    [self] abort [$S set error]
    return
  }
  [self] pushBlock
  #[self] showMsg "c [[self] set currentsize]== t [[self set totalsize]]"
  if {$currentsize == $totalsize && 
      [[self] exists S] && [$S exists persistent]} {
    #[self] showMsg "PERSITENT, end of entity reached"
    #[self] set state eof
    [self] finish
    set block ""
    #showObj [self]
  }
  if {[[self] exists mustDestroy]} {
    #[self] showMsg "mustDestroy was set"
    [self] destroy
  }
}
Http instproc close {} {
  #[self] showCall
  if {[[self] exists S]} {
    [[self] set S] close
    #unset S
  }
  #next
}
Http instproc freeConnection {} {
  #showCall
  [self] instvar S
  #::puts stderr "[self] freeing $S !!!!!!!!!!!!!!!!!!!!!!!"
  unset S
}


#Access instproc makeZombie {} {
#  [self] showMsg "procs= [[self] info procs], i [Object info instcommands]"
#  [self] class Zombie
#}
#Class Zombie
#Zombie instproc unknown {m args} {
#  [self] showMsg "+++ zombie method '$m' called"
#}


Class Https -superclass Http
Https instproc initialize args {
  #[self] showCall
  package require tls 
  if {![[self] exists port]} { [self] set port 443}
  next
  ### temporary solution, FIXME: 
  ### zur zeit muss man den secure-webserver.xotcl und 
  ### secure-webclient.xotcl jedenfalls aus dem xotcl/apps/xocomm-apps
  ### verzeichnis starten, da haben wir mal die cfg files in unserem
  ### baum....
  source .ssl/ssl-configuration.xotcl
  ###
}
Https instproc openConnection {host port reuse} {
  set S [Connection make [self] $host $port $reuse reused]
  if {$reused} {
    #[self] showMsg "reusing $S"
  } else {
    [self] showMsg "make the socket ([$S socket]) secure ..."    
    set cmd [list $S importSSL]
    foreach attr {cafile cadir certfile cipher command keyfile \
                      model request require ssl2 ssl3 tls1} {
      if {[sslClientConfig exists $attr]} {
        lappend cmd -$attr [sslClientConfig set $attr]
      }
    }
    [self] showMsg "the assembled command is... ´$cmd´"    
    eval $cmd
    puts stderr "CHANNELS= [file channels]"
  }
  return $S
}



#######################################################################
Object pwdManager
pwdManager proc requirePasswd {realm username password} {
  # used by ftp and imap
  [self] instvar user area
  upvar $password passwd
  if {[[self] exists pwd($realm)]} {
    #[self] showMsg "*** reusing password for $realm"
    set passwd [[self] set pwd($realm)]
    return 1
  } else {
    userPwd user $username
    if {[userPwd show $realm user($realm) passwd]} {
      set area($realm/$username) $realm
      return 1
    }
  }
  return 0
}
pwdManager proc storePasswd {realm username password} {
  # used by ftp and imap
  [self] instvar pwd user
  set pwd($realm) $password
  set user($realm) $username
}
pwdManager proc removePasswd {realm} {
  if {[[self] exists pwd($realm)]} {
    [self] unset pwd($realm) 
    [self] unset user($realm) 
  }
}
pwdManager proc requireCredentials {realm url} {
  regexp {^(.*/)[^/]*$} $url _ path
  if {[[self] exists pwd($realm)]} {
    #[self] showMsg "*** register url=$url for ther realm=$realm"
    [self] set area($path) $realm
    return 1
  } else {
    [self] instvar pwd user
    if {[info exists ::env(USER)]} {
      set USER $::env(USER)
    } elseif {[info exists ::env(USERNAME)]} {
      set USER $::env(USERNAME)
    } else {
      set USER unknown
    }

    userPwd user $USER
    if {[userPwd show $realm user($realm) pwd($realm)]} {
      #[self] showMsg "*** setting password for realm '$realm' url=$path"
      [self] set area($path) $realm
      return 1
    }
  }
  return 0
}
pwdManager proc encodeCredentials {authMethod realm} {
  #[self] showCall
  switch $authMethod {
    basic  {set credential [[self] encodeCredentialsBasic $realm]}
    digest {set credential [[self] encodeCredentialsDigest $realm]}
  }
  return $credential
}
pwdManager proc encodeCredentialsBasic {realm} {
  [self] instvar pwd user
  return [list Authorization \
	      "Basic [base64 encode $user($realm):$pwd($realm)]"]
}
pwdManager proc encodeCredentialsDigest {realm} {
  #[self] showCall
  package require tcu;        #FIXME: noch nicht in distribution
  [self] instvar digestResponseData
  [self] mkDigestResponseData $realm
  set digestResponse {}
  foreach {t v} [array get digestResponseData] {
    append digestResponse " $t = \"$v\","
  }
  return [list Authorization "Digest [string trimright $digestResponse ,]"] 
}
pwdManager proc mkDigestResponseData {realm} {
  #[self] showCall
  [self] instvar pwd user digestResponseData requestUri
  # RFC 2617
  #   credentials      = "Digest" digest-response
  #   digest-response  = 1#( username | realm | nonce | digest-uri
  #                                | response | [ algorithm ] | [cnonce] |
  #                                [opaque] | [message-qop] |
  #                                    [nonce-count]  | [auth-param] )
  #   username         = "username" "=" username-value
  #   username-value   = quoted-string
  #   digest-uri       = "uri" "=" digest-uri-value
  #   digest-uri-value = request-uri   ; As specified by HTTP/1.1
  #   message-qop      = "qop" "=" qop-value
  #   cnonce           = "cnonce" "=" cnonce-value
  #   cnonce-value     = nonce-value
  #   nonce-count      = "nc" "=" nc-value
  #   nc-value         = 8LHEX
  #   response         = "response" "=" request-digest
  #   request-digest = <"> 32LHEX <">
  #   LHEX             =  "0" | "1"| ...| "e" | "f"  
  set digestResponseData(username) $user($realm)
  set digestResponseData(uri) $requestUri
  set digestResponseData(cnonce) "TEST"
  set digestResponseData(nc) 00000001
  set digestResponseData(response) [[self] mkRequestDigest]
  #parray digestResponseData
}
pwdManager proc mkRequestDigest {} {
  # returns a string of 32 hex digits, which proves that the user
  # knows a password
  
  #A1 = unq(username-value) ":" unq(realm-value) ":" passwd
  [self] instvar digestResponseData pwd requestMethod requestUri
  append A1 $digestResponseData(username)\
      : $digestResponseData(realm) : $pwd($digestResponseData(realm))
  if {![[self] exists digestResponseData(qop)] || 
      $digestResponseData(qop) == "auth"} {
    append A2 $requestMethod : $requestUri
  } elseif {$digestResponseData(qop) == "auth-int"} {
    #A2 = Method ":" digest-uri-value ":" H(entity-body)
    append A2 $requestMethod : $requestUri: ""
  }
  if {[[self] exists digestResponseData(qop)]} {
    append reqDigest $digestResponseData(nonce) : \
	$digestResponseData(nc) : \
	$digestResponseData(cnonce): \
	$digestResponseData(qop)
    set reqDigest [md5 [md5 $A1]:$reqDigest:[md5 $A2]]
  } else {    
    set reqDigest [md5 [md5 $A1]:$digestResponseData(nonce):[md5 $A2]]
  }  
  return $reqDigest 
}

pwdManager proc checkAvailableCredentials {url returnCredentials} {
  # we start a fresh request and check, whether we have sent for this url
  # (directory) already some credentials in an earlier reqhest.
  [self] instvar authMethod
  regexp {^(.*/)[^/]*$} $url _ path
  if {[[self] exists area($path)]} {
    set realm [[self] set area($path)]
    upvar $returnCredentials credentials
    #[self] showMsg "*** adding credentials for realm=$realm and $path"
    set credentials [[self] encodeCredentials $authMethod $realm]
    return 1
  }
  return 0
}
pwdManager proc checkRequestedAuthentification {reqMethod path headerField 
						typeVar realmVar} {
  # check for which realm with which authentification method the
  # server wants an authentification
  #[self] showCall
  upvar $typeVar type $realmVar realm
  [self] instvar authMethod digestResponseData requestUri requestMethod
  set requestUri $path
  set requestMethod $reqMethod
  if {[regexp {^Basic realm="(.*)"$} $headerField _ realm]} {
    set type basic;#    FD: musste da lassen wg. call by reference
    set authMethod $type
    return 1
  } elseif {[regsub {^Digest } $headerField _ headerField]} {
    set type digest ;# FD: musste da lassen wg. call by reference
    set authMethod $type
    foreach pair [split $headerField ,] {      
      if {[regexp {^(.*) *= *(".*")$} $pair _ n v]} {
	set digestResponseData([string trim $n]) [string trim [string trim $v] \"]
      }
    }
    set realm $digestResponseData(realm)
    return 1
  }
  return 0
}

#######################################################################
# test classes
Class Sink
Sink instproc startCb         {r}   {
  [self] set contentLength 0
  next
}
Sink instproc notifyCb      {r}     {
  next
}
Sink instproc incCb         {r t c} {
  [self] set contentLength $t
  next
}
Sink instproc endCb         {r}     {
  next
  #showCall
}
Sink instproc cancelCb      {r}     {
  next
  #showCall
}
Sink instproc content       {}      {
  next
  #showCall
}
Sink instproc contentLength {}      {
  [self] set contentLength
  #showCall
}


Class TimeSink -superclass Sink
TimeSink instproc startCb         {r}   {
  set [self]::startTime [clock clicks]
  next
}
TimeSink instproc notifyCb      {r}     {
  set [self]::notifyTime [clock clicks]
  next
}
TimeSink instproc endCb         {r}     {
  set [self]::endTime [clock clicks]
  next
  [self] reportTimes
}
TimeSink instproc cancelCb      {r}     {
  set [self]::endTime [clock clicks]
  next
}
TimeSink instproc reportTimes {}     {
  [self] instvar startTime endTime notifyTime
  set bytes [[self] contentLength]
  set grossSecs		[expr {($endTime-$startTime)/1000000.0}]
  set grossKbps		[expr {($bytes/1000.0)/$grossSecs}]
  set netSecs		[expr {($endTime-$notifyTime)/1000000.0}]
  set netKbps [expr {($bytes/1000.0)/$netSecs}]
  #if {[catch {set netKbps [expr {($bytes/1000.0)/$netSecs}]}]} {
  #  set netKbps 0
  #}
  set headSecs		[expr {$grossSecs-$netSecs}]
  foreach v {grossSecs grossKbps netSecs netKbps headSecs} {
    set $v [format %.2f [set $v]]
  }
  [self] showMsg "got $bytes bytes in $grossSecs ($headSecs+$netSecs) seconds,\
	$grossKbps ($netKbps) KB/S"
}


Class ParallelSink -superclass Sink -parameter {
  {httpVersion 1.1}
  {sinkClass TimeSink}
  {maxsimultaneous 20}
}
ParallelSink instproc init args {
  next
  set [self]::running 0
  set [self]::numrequests 0
  set [self]::sumbytes 0
  set [self]::blocked {}
}
ParallelSink instproc startCb r {
  #[self] showCall
  incr [self]::running
  incr [self]::numrequests
  #puts stderr "... running++ [[self] set running]"
}
ParallelSink instproc endCb r {
  incr [self]::sumbytes [$r set currentsize]
  [self] done $r
}
ParallelSink instproc cancelCb r {
  #[self] showCall
  [self] done $r
}
ParallelSink instproc done r {
  [self] instvar running blocked
  $r shutdown
  incr running -1
  #puts stderr "... running-- $running [llength [Http info instances]]"
  #puts stderr [Http info instances]
  #foreach i [Http info instances] {puts stderr "\t$i: [$i set method] [$i set url]"}
  if {[llength $blocked] > 0} {
    set newreq [lindex $blocked 0]
    set blocked [lrange $blocked 1 end]
    [self] scheduleRequest [lindex $newreq 0] [lindex $newreq 1] [lindex $newreq 2]
  } elseif {$running < 1} {
    [self] set done 1
  }
}


ParallelSink instproc scheduleRequest {method url {parentUrl ""}} {
  [self] instvar httpVersion requests blocked \
      sinkClass running maxsimultaneous
  if {$running > $maxsimultaneous} {
    lappend blocked [list $method $url $parentUrl]
  } else {
    set cmd [list Access createRequest -url $url \
		 -sinkClass $sinkClass \
		 -informObject [self] \
		 -method $method \
		 -caching 0 -allowJoin 0 -httpVersion $httpVersion]
    if {$parentUrl != ""} {
      lappend cmd -parentUrl $parentUrl
    }
    set r [eval $cmd]
  }
}

ParallelSink instproc requests {urls} {
  [self] showTimeStart
  foreach url $urls { [self] scheduleRequest GET $url }
  [self] wait
  [self] showTimeEnd
}

ParallelSink instproc wait {} {
  [self] instvar  running
  if {$running > 0} {
    set savedValue $running
    #[self] showMsg ".......... waiting for initially $running requests"
    if {[catch {[self] vwait done} err]} {
      [self] showMsg "vwait returned: $err "
    }
    #[self] showMsg "$savedValue requests FINISHED "
  }
}

Class MemorySink -superclass Sink
MemorySink instproc incCb         {r t c} {
  [self] append d [$r block]
  next
}
MemorySink instproc content       {}      {
  return [[self] set d]
}
MemorySink instproc contentLength {}      {
  if {[[self] exists d]} {
    return [string length [[self] set d]]
  } else {
    return 0
  }
}

Class FileSink  -superclass Sink -parameter fileName
### write methods
#FileSink instproc startCb         {r}   {
#  next
#}
FileSink instproc notifyCb      {r}     {
  #[self] showVars
  next
  [self] instvar file fileName
  if {[info exists fileName]} {
    set file [::open $fileName w]
    fconfigure $file -translation binary
  } else {
    # we have no filename; we assume the sink must be a dummy sink
    # that deletgates its work to some other FileSink
    [self] class ShadowFileSink
    [self] notifyCb $r
  }
}
FileSink instproc incCb {r t c} {
  next
  if {[[self] exists file]} {
    if {$r == "req0"} {
      puts stderr "*******************************************************"
      puts stderr [$r block]
      puts stderr "*******************************************************"
    }
    puts -nonewline [[self] set file] [$r block]
  }
}
FileSink instproc endCb  {r} {
  #[self] showCall
  next
  [self] close
}
FileSink instproc cancelCb  {r} {
  next
  [self] close
}
FileSink instproc close {} {
  [self] instvar fileName
  #[self] showVars fileName
  if {[[self] exists file]} {
    ::close [[self] set file]
    [self] unset file
  }
}
### read methods
FileSink instproc content {} {
  next
  [self] instvar file fileName
  set file [::open $fileName r]
  fconfigure $file -translation binary
  set d [read [[self] set file]]
  [self] close
  return $d
}
FileSink instproc contentLength {}      {
  next
  if {[[self] exists fileName]} {
    return [file size [[self] set fileName]]
  } else {
    return 0
  }
}


Class ShadowFileSink -superclass Sink
ShadowFileSink instproc notifyCb      {r} {
  next
  [self] set token $r
}
ShadowFileSink instproc content       {} {
  next
  return [[$token set sink] content]
}
ShadowFileSink instproc contentLength {} {
  next
  return [[$token set sink] contentLength]
}


Class CacheFileSink -superclass FileSink -parameter {{persistent 1}}
CacheFileSink instproc notifyCb req {
  #[self] showCall
  if {![[self] exists fileName]} {
    [self] instvar persistent
    set url [$req set url]
    [self] set fileName [persistentCache newEntry $url $req $persistent ""]
  }
  # it is important to execute next after setting the fileName...
  next
}
CacheFileSink instproc endCb req {
  #[self] showCall
  [self] instvar persistent
  next
  if {$persistent} {
    persistentCache entryDone [$req set url]
  }
}
CacheFileSink instproc cancelCb req {
  next
  if {[[self] exists fileName]} {
    file delete [[self] set fileName]
    [self] unset fileName
  }
}
CacheFileSink instproc destroy {} {
  #[self] showCall
  if {[[self] exists fileName] && ![[self] set persistent]} {
    #[self] showMsg "file delete $fileName"
    file delete [[self] set fileName]
    [self] unset fileName
  }
  next
}


#===========================================================

Class SimpleRequest -parameter {
  {caching 0} 
  {useFileSink 0} 
  {blocking 1} 
  {timing 0} 
  url fileName 
  timeout httpVersion method headers data query contentType informObject
}
SimpleRequest instproc fileName x {
  [self] set fileName $x
  [self] set useFileSink 1
}
SimpleRequest instproc init args {
  [self] instvar useFileSink fileName sink caching token  
  #[self] showMsg "Starting Request"
  next
  if {[info exists fileName]} {
    set sink [FileSink create [self]::sink -fileName $fileName]
  } elseif {$useFileSink || $caching > 0} {
    set sink [FileSink create [self]::sink]
  } else {
    set sink [MemorySink create [self]::sink]
  }
  #[self] showMsg "class of sink = [$sink info class]"
  if {[[self] set timing]} {
    $sink mixin TimeSink
  }
  set cmd [list Access createRequest \
	       -url [[self] set url] \
	       -informObject $sink \
	       -blocking [[self] set blocking] \
	       -caching $caching]
  foreach optionalParameter {
    timeout httpVersion method headers data query  
    contentType informObject
  } {
    if {[[self] exists $optionalParameter]} {
      lappend cmd -$optionalParameter [[self] set $optionalParameter]
    }
  }
  #[self] showMsg "cmd=$cmd"
  set token [eval $cmd]
  #if {[[self] success]} {
  #  $sink reportTimes
  #  #puts stderr <[$sink content]>
  #}
}
SimpleRequest instproc success {} {
  if {[[self] exists token]} {
    return [expr {[[[self] set token] set finished] == 1}]
  } 
  return 0
}
SimpleRequest instproc destroy {} {
  if {[[self] exists token]} {
    [[self] set token] destroy
  }
  next
}
SimpleRequest instproc getContent {} {
  [[self] set sink] content
}
SimpleRequest instproc getContentLength {} {
  [[self] set sink] contentLength
}
#SimpleRequest instproc destroy args { next }

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


