# -*- tcl -*- $Id: Access.xotcl,v 1.20 2001/03/09 13:27:10 neumann Exp $
set httpAccessVersion 0.91
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
  }
  regexp {^(.*)\#.*$} $basePath _ basePath
  regexp {^(.*)[?].*$} $basePath _ basePath
  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 1 $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
assert {resolve ../../../../mis2001/folien/081101.ppt  http://wwwi.wu-wien.ac.at/Studium/Abschnitt_2/LVA_ws01/IT/index.html} http://wwwi.wu-wien.ac.at/mis2001/folien/081101.ppt


##############################################################
# 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 {
  foreach i $x { my lappend informObjects $i }
}
Access instproc method x {
  my set method [string toupper $x]
}
Access instproc unknown {m args} {
  error "Method '$m' with args '$args' is unknown for [self class]"
}

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

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

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

Access instproc initialize {} {
  #my showCall
  my set state           0
  my set meta            {}
  my set currentsize     0
  my set totalsize       0
}
Access instproc classify {url} {
  my instvar host path port method
  #my showVars caching
  if {[my 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 {[string compare "" $givenPort]} {set port $givenPort } {set port 80}
    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 {[string compare "" $givenPort]} {set port $givenPort } {set port 443}
    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 }
    my showMsg "*** ldap://<$host>:<$port>/<$path>"
    package require xotcl::comm::ldap
    set access Ldap  
  } else {
    #my set state 0
    my abort "Unsupported URL: '$url'"
    return 0
  }
  my class $access
  #my showMsg "class of request = $access"
  return 1
}
Access instproc revisit {} {
  my class ReAccess
  my initialize
  my [my set method]
}
### dummy stubs for 'close' and 'GET' for error cases
Access instproc close {} {
}
Access instproc GET {} {
  if {[my exists errormsg]} { ;# the error was already reportet
    my finish
  } else {
    my abort "unknown error"
  }
}

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


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


Class File -superclass FileAccess
File instproc GET {} {
  my instvar path
  #puts stderr path=$path,exists=[file exists $path]
  if {![file exists $path]} {
    my abort "No such file '$path'"
    return
  }
  if {![my exists contentType]} {
    my contentType [Mime guessContentType $path]
  }
  my 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 {} {
  my instvar url
  my path         [persistentCache cacheFileName $url]
  my contentType  [persistentCache contentType $url]
  my set meta     [persistentCache meta $url]
  next
}

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



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


#Class NetAccess -superclass Access -parameter {host port}
Class NetAccess -superclass Access
NetAccess instproc initialize args {
  if {![my exists blocksize]} {my set blocksize 512}
  my set readMethod read
  next
}
NetAccess instproc read {} {
  #my instvar S blocksize block
  #set block [::read $S $blocksize]
  my instvar S block blocksize
  set block [::read $S $blocksize]
}
NetAccess instproc gzread {} {
  my 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 {} {
  my instvar Z S readMethod
  requireModules {zipchan libzipchan.so}
  fconfigure $S -translation binary
  set Z [zipchan]
  set readMethod gzread
}
NetAccess instproc close {} {
  #my showMsg "**** close persistent=[my exists persistent]"
  if {![my exists persistent]} {
    foreach stream {S Z} {
      if {[my exists $stream]} {
	::close [my set $stream]
	my unset $stream
      }
    }
  }
  my stop
}
NetAccess instproc hold {} {
  my instvar S
  $S hold
}
NetAccess instproc resume {} {
  my instvar S
  $S resume
}
NetAccess instproc readData {} {
  #my showCall
  if {[catch {
    #puts stderr "??????????????readMethod=[my set readMethod]"
    my [my set readMethod]
    my pushBlock
  } err]} {
    puts stderr ERR=$err
    my set block ""
    my abort $err
  }
}
NetAccess instproc pushBlock {} {
  #my showCall
  my instvar block
  if {[set n [string length $block]]} {
    my instvar currentsize totalsize informObjects sink
    #my showVars n currentsize totalsize
    incr currentsize $n
    if {$currentsize > $totalsize} {
      set totalsize $currentsize
    }
    #my showMsg "total=$totalsize current=$currentsize"
    if {[my exists ignoreBody]} {
      #puts stderr "ignoring: <$block>"
    } else {
      if {[info exists sink]} {
	$sink incCb [self] $totalsize $currentsize
      }
      foreach obj $informObjects {
	#my showMsg "call incbCb $totalsize $currentsize $obj [$obj info class]"
	$obj incCb [self] $totalsize $currentsize
	#my showMsg "done incbCb $totalsize $currentsize"
      }
    }
  } else {
    #my showVars n
    return [my 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} {
  my 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 {![my exists port]}        {my set port 80}
  if {![my exists httpVersion]} {my set httpVersion 1.1}
  next
  #my showMsg "result queried from net"
}
Http instproc GET {} {
  #my showCall
  if {[my exists query]} {
    my instvar query caching
    my append url ?$query
    my append path ?$query
    if {$caching == 2} {set caching 1}
    my showVars caching $query
  }
  my open
}
Http instproc HEAD {} {
  my 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 {[my exists query]} {
    my data [my query]
  }
  my open
}
Http instproc PUT {} {  
  my open
}
# Http1.1
Http instproc OPTIONS {} {
  my showCall
  my open  
}
# Http1.1
Http instproc TRACE {} {
  my showCall
}
# Http1.1
Http instproc DELETE {} {
  #my showCall
  my open  
}
Http instproc openConnection {host port reuse} {
  return [Connection make [self] $host $port $reuse _]
}
Http instproc open {} {
  #my showCall
  my instvar url S state host port path
  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 [my openConnection $useHost $usePort [expr {[my httpVersion]>1.0}]]
  if {[$S exists error]} {
    my abort [$S set error]
    return
  }
  set state 2
  my running
  $S event writable [self] ask
}

Http instproc ask {} {
  my instvar url S state host port path \
      method headers data caching

  $S event writable [self] {}

  if {[pwdManager checkAvailableCredentials $url credentials]} {
    eval lappend headers $credentials
    #my 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}

  #my showMsg "'$method $path HTTP/[my httpVersion]' headers {$headers}"
  $S puts "$method $path HTTP/[my httpVersion]"
  if {[$S  exists error]} {
    my 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]} {
      #my showMsg "+++ <$tag: $value>"
      $S puts "$tag: $value"
    }
  }
  if {[my exists data]} {
    $S puts "Content-Length: [string length $data]"
    $S puts "Content-Type: [my contentType]"
    $S puts ""
    $S translation {auto binary}
    $S puts-nonewline $data
  } else {
    $S puts ""
  }
  $S flush
  if {[$S  exists error]} {
    my instvar host port
    my abort "Connection refused by host '$host' port '$port'\n\
		[$S set error]"
  } else {
    set state 3
    $S event readable [self] headerStart
  }
}

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

  array set v [my 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
      my finish
      set block ""
      set expectBody 0
      return
    }
    301 -
    302 {
      # the request is redirected to another server
      my 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.
      #my method GET 
      
      my showMsg "redirect '[my url]' --> '$v(location)'"
    }
    304 { ;#  Not Modified, use cached version
      my set ignoreBody cacheAccess
      set expectBody 1
      #my showMsg "result comes from cache"
    }
    401 {
      my set ignoreBody \
	  [list resubmitAuthenticated $v(www-authenticate)]
      #my showMsg "resubmitAuthenticated $v(www-authenticate)"
      if {[my exists resubmitAuthenticated]} {
	if {[my set resubmitAuthenticated] > 5} {
	  my abort "Too many wrong passwords given"
	} else {
	  my incr resubmitAuthenticated
	}
      } else {
	my set resubmitAuthenticated 1
      }
      set expectBody 1
    }
    404 {
      my instvar url
      #my showVars
      my set ignoreBody [list abort "File Not Found on Server '$url'"]
      set expectBody 1
    }
    default {
      #my showVars responseCode
    }
  }
  next
  if {![my exists S]} {;# this request was already canceled
    return
  }
  if {[info exists v(transfer-encoding)]} {
    if {$v(transfer-encoding) == "chunked"} {
      $S translation {auto binary}
      my set state 4
      $S event readable [self] readChunkedLength
    } else {
      my 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) )} 
    #my 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
      #my showMsg "setting expectBody 1"
    }

    if {!$expectBody} {
      #$S event readable [self] ""
      #set state eof
      my finish
      set block ""
    } else {
      ### To avoid CRLF problmes we set the translation for 
      ### the body entity  to binary
      $S translation binary
      my 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 [my url]
  #my close
  my class CacheAccess
  #my showMsg "result comes from cache [persistentCache cacheFileName $url]"
  my caching 0 ;# should be really: toCache 0
  my GET
}

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

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


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


Class Https -superclass Http
Https instproc initialize args {
  #my showCall
  package require tls 
  if {![my exists port]} { my 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} {
    #my showMsg "reusing $S"
  } else {
    my 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]
      }
    }
    my 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
  my instvar user area
  upvar [self callinglevel] $password passwd
  if {[my exists pwd($realm)]} {
    #my showMsg "*** reusing password for $realm"
    set passwd [my 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
  my instvar pwd user
  set pwd($realm) $password
  set user($realm) $username
}
pwdManager proc removePasswd {realm} {
  if {[my exists pwd($realm)]} {
    my unset pwd($realm) 
    my unset user($realm) 
  }
}
pwdManager proc requireCredentials {realm url} {
  regexp {^(.*/)[^/]*$} $url _ path
  if {[my exists pwd($realm)]} {
    #my showMsg "*** register url=$url for ther realm=$realm"
    my set area($path) $realm
    return 1
  } else {
    my 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)]} {
      #my showMsg "*** setting password for realm '$realm' url=$path"
      my set area($path) $realm
      return 1
    }
  }
  return 0
}
pwdManager proc encodeCredentials {authMethod realm} {
  #my showCall
  switch $authMethod {
    basic  {set credential [my encodeCredentialsBasic $realm]}
    digest {set credential [my encodeCredentialsDigest $realm]}
  }
  return $credential
}
pwdManager proc encodeCredentialsBasic {realm} {
  my instvar pwd user
  return [list Authorization \
	      "Basic [base64 encode $user($realm):$pwd($realm)]"]
}
pwdManager proc encodeCredentialsDigest {realm} {
  #my showCall
  package require tcu;        #FIXME: noch nicht in distribution
  my instvar digestResponseData
  my 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} {
  #my showCall
  my 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) [my 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
  my instvar digestResponseData pwd requestMethod requestUri
  append A1 $digestResponseData(username)\
      : $digestResponseData(realm) : $pwd($digestResponseData(realm))
  if {![my 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 {[my 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.
  my instvar authMethod
  regexp {^(.*/)[^/]*$} $url _ path
  if {[my exists area($path)]} {
    set realm [my set area($path)]
    upvar [self callinglevel] $returnCredentials credentials
    #my showMsg "*** adding credentials for realm=$realm and $path"
    set credentials [my 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
  #my showCall
  upvar [self callinglevel] $typeVar type $realmVar realm
  my 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}   {
  my set contentLength 0
  next
}
Sink instproc notifyCb      {r}     {
  next
}
Sink instproc incCb         {r t c} {
  my set contentLength $t
  next
}
Sink instproc endCb         {r}     {
  next
  #showCall
}
Sink instproc cancelCb      {r}     {
  next
  #showCall
}
Sink instproc content       {}      {
  next
  #showCall
}
Sink instproc contentLength {}      {
  my set contentLength
  #showCall
}


Class TimeSink -superclass Sink
TimeSink instproc startCb         {r}   {
  my set startTime [clock clicks]
  next
}
TimeSink instproc notifyCb      {r}     {
  my set notifyTime [clock clicks]
  next
}
TimeSink instproc endCb         {r}     {
  my set endTime [clock clicks]
  next
  my reportTimes
}
TimeSink instproc cancelCb      {r}     {
  my set endTime [clock clicks]
  next
}
TimeSink instproc reportTimes {}     {
  my instvar startTime endTime notifyTime
  set bytes [my 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]]
  }
  my 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
  my set running 1
  my set numrequests 0
  my set sumbytes 0
  my set blocked {}
}
ParallelSink instproc startCb r {
  #my showCall
  my incr running
  my incr numrequests
  #puts stderr "... running++ [my set running]"
}
ParallelSink instproc endCb r {
  #my showCall
  my incr sumbytes [$r set currentsize]
  my done $r
}
ParallelSink instproc cancelCb r {
  #my showCall
  my done $r
}
ParallelSink instproc done r {
  #my showCall
  my instvar blocked
  $r shutdown
  my incr running -1
  #puts stderr "... running-- [my set 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]"}
  #puts stderr RUNNING=[my set running]
  if {[llength $blocked] > 0} {
    set newreq [lindex $blocked 0]
    set blocked [lrange $blocked 1 end]
    my scheduleRequest [lindex $newreq 0] [lindex $newreq 1] [lindex $newreq 2]
  } elseif {[my set running] < 1} {
    my set done 1
  }
}


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

ParallelSink instproc requests {urls} {
  my showTimeStart
  foreach url $urls { my scheduleRequest GET $url }
  my wait
  my showTimeEnd
}

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

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

Class FileSink  -superclass Sink -parameter fileName
### write methods
#FileSink instproc startCb         {r}   {
#  next
#}
FileSink instproc notifyCb      {r}     {
  #my showVars
  next
  my 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
    my class ShadowFileSink
    my notifyCb $r
  }
}
FileSink instproc incCb {r t c} {
  next
  if {[my exists file]} {
    if {$r == "req0"} {
      puts stderr "*******************************************************"
      puts stderr [$r block]
      puts stderr "*******************************************************"
    }
    puts -nonewline [my set file] [$r block]
  }
}
FileSink instproc endCb  {r} {
  #my showCall
  next
  my close
}
FileSink instproc cancelCb  {r} {
  next
  my close
}
FileSink instproc close {} {
  if {[my exists file]} {
    ::close [my set file]
    my unset file
  }
}
### read methods
FileSink instproc content {} {
  next
  my instvar file fileName
  set file [::open $fileName r]
  fconfigure $file -translation binary
  set d [read [my set file]]
  my close
  return $d
}
FileSink instproc contentLength {}      {
  next
  if {[my exists fileName]} {
    return [file size [my set fileName]]
  } else {
    return 0
  }
}


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


Class CacheFileSink -superclass FileSink -parameter {{persistent 1}}
CacheFileSink instproc notifyCb req {
  #my showCall
  if {![my exists fileName]} {
    my instvar persistent
    set url [$req set url]
    my set fileName [persistentCache newEntry $url $req $persistent ""]
  }
  # it is important to execute next after setting the fileName...
  next
}
CacheFileSink instproc endCb req {
  #my showCall
  my instvar persistent
  next
  if {$persistent} {
    persistentCache entryDone [$req set url]
  }
}
CacheFileSink instproc cancelCb req {
  next
  if {[my exists fileName]} {
    file delete [my set fileName]
    my unset fileName
  }
}
CacheFileSink instproc destroy {} {
  #my showCall
  if {[my exists fileName] && ![my set persistent]} {
    #my showMsg "file delete $fileName"
    file delete [my set fileName]
    my 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 {
  my set fileName $x
  my set useFileSink 1
}
SimpleRequest instproc init args {
  my instvar useFileSink fileName sink caching token  
  #my 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]
  }
  #my showMsg "class of sink = [$sink info class]"
  if {[my set timing]} {
    $sink mixin TimeSink
  }
  set cmd [list Access createRequest \
	       -url [my url] \
	       -informObject $sink \
	       -blocking [my blocking] \
	       -caching $caching]
  foreach optionalParameter {
    timeout httpVersion method headers data query  
    contentType informObject
  } {
    if {[my exists $optionalParameter]} {
      lappend cmd -$optionalParameter [my set $optionalParameter]
    }
  }
  #my showMsg "cmd=$cmd"
  set token [eval $cmd]
  #if {[my success]} {
  #  $sink reportTimes
  #  #puts stderr <[$sink content]>
  #}
}
SimpleRequest instproc success {} {
  if {[my exists token]} {
    return [expr {[[my set token] set finished] == 1}]
  } 
  return 0
}
SimpleRequest instproc destroy {} {
  if {[my exists token]} {
    [my set token] destroy
  }
  next
}
SimpleRequest instproc getContent {} {
  [my set sink] content
}
SimpleRequest instproc getContentLength {} {
  [my set sink] contentLength
}
#SimpleRequest instproc destroy args { next }

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


