# -*- tcl -*- $Id: Httpd.xotcl,v 1.26 2001/03/09 13:27:33 neumann Exp $
#
# The XOTcl class Httpd implements an HTTP/1.0 and HTTP/1.1 server with  
# basic functionality.
#
#  Gustaf Neumann (neumann@wu-wien.ac.at)

set VERSION 1.1
package provide xotcl::comm::httpd $VERSION

#package require xotcl::comm::httpAccess
package require xotcl::comm::mime
package require xotcl::comm::connection
package require xotcl::trace

Class Httpd -parameter {
  {port 80} 
  ipaddr 
  {root ./} 
  {logdir $::xotcl::logdir} 
  {httpdWrk Httpd::Wrk}
  {redirects [list]}
  {workerTimeout 10000}
}
Httpd proc Date seconds {clock format $seconds -format {%a, %d %b %Y %T %Z}}
Httpd instproc checkRoot {} {
  my instvar root
  set root [string trimright $root /]
  if {![file isdir $root]} {
    puts stderr "Warning: create root directory '$root'"
    file mkdir $root
  } 
  # make directory absolute
  set currentdir [pwd]
  cd $root
  set root [pwd]
  #puts stderr "[self] root=$root"
  cd $currentdir
}
Httpd instproc init args {
  my instvar port logdir logfile redirects
  if {![my exists workerMixins]} {
    my set workerMixins {}
    #puts stderr "resetting workermixins of [self]"
  }
  next
  set proto [string trim [my info class] :d]
  puts stderr "Starting XOTcl [string toupper $proto] server $::VERSION\
	[string tolower $proto]://[info hostname]:$port/"

  # Start a server by listening on the port
  if {[my exists ipaddr]} {set ip "-myaddr [my set ipaddr]"} {set ip ""}
  my set listen [eval [list socket -server [list [self] accept]] $ip $port]
  #my set listen [socket -server [list [self] accept] $port]

  my checkRoot
  if {![file isdir $logdir]} {file mkdir $logdir}
  set logfile [open $logdir/serverlog-$port a+]
  my array set requiresBody \
      {GET 0 HEAD 0 POST 1 PUT 1 DELETE 0 OPTIONS 0 TRACE 0}
}
Httpd instproc destroy {} {			# destructor
  catch {close [my set listen]}
  catch {close [my set logfile]}
  next
}
Httpd instproc accept {socket ipaddr port} {	# Accept a new connection and set up a handler
  #puts stderr "using workermixins of [self] {[my set workerMixins]}"
  [my set httpdWrk] new -childof [self] -socket $socket -ipaddr $ipaddr \
      -port $port -mixin [my set workerMixins]
}
Httpd instproc redirect list {
  foreach {pattern hostport} $list {
    my lappend redirects $pattern $hostport
  }
}


Class Httpd::Wrk -parameter {socket port ipaddr}
Httpd::Wrk array set codes {
  200 {Data follows}          201 {Created}         204 {No Content}
  302 {Moved Temporarily}     304 {Not Modified}
  400 {Bad Request}           401 {Unauthorized}    402 {Payment Required}
  403 {Forbidden}             404 {Not Found}       405 {Method Not Allowed}
  406 {Not Acceptable}        408 {Request Timeout} 411 {Length Required}
  500 {Internal Server Error} 503 {Service Unavailable}  504 {Service Temporarily Unavailable}
}
Httpd::Wrk instproc formData {} {my set formData}
Httpd::Wrk instproc init args {		# Constructor 
  my instvar socket port ipaddr
  my set formData [list]
  my set replyHeaderFields [list]
  next
  my makeConnection $socket
  my log Connect "$ipaddr $port"
  my connection translation {auto crlf}
  my connection event readable [self] firstLine
}
Httpd::Wrk instproc makeConnection {socket} {
  Connection create [self]::connection -socket $socket -req [self]
}
Httpd::Wrk instproc close {} {		# logical close of a single request
  #my showCall
  my instvar version timeout meta
  set eof [my connection eof]
  if {$version > 1.0 && !$eof} {
    #my showMsg "!EOF in http/$version"
    my connection flush
    set timeout [after [[my info parent] workerTimeout] [self] destroy]
    ### reset parameters, worker will be potentially reused
    if {[array exists meta]} {
      unset meta
      array set meta {}
    }
    unset version
    if {[my exists user]} {
      my unset user
      my unset realm
    }
    foreach c [my set formData] { $c destroy }
    my set replyHeaderFields [list]
    my set formData {}
    #my showVars
    my connection translation {auto crlf}
    my connection event readable [self] firstLine
  } elseif {$eof} {
    #my showMsg "Destroy in http/$version"
    # the client side has closed the connection
    my destroy
  } else {
    #my showMsg "!EOF in http/$version ???"
    # we close the conneciton actively (e.g. forced by an error)
    my connection flush
    #puts stderr "DESTROY----this line should never show up"
    my destroy
  }
}
Httpd::Wrk instproc destroy {} {
  #my showCall
  if {[my isobject [self]::connection]} {
    my connection close
  }
  next
}
Httpd::Wrk instproc freeConnection {} {
}
Httpd::Wrk instproc firstLine {} {	# Read the first line of the request
  #my showCall
  my instvar method resourceName hasFormData query fileName \
      version timeout 
  if {[info exists timeout]} {
    after cancel $timeout
    unset timeout
  }
  my lappend replyHeaderFields Date [Httpd Date [clock seconds]]
  set n [my connection gets firstLine]
  if {$n > 0} {
    #::puts stderr "[self] firstline=<$firstLine>"
    # parse request line, ignore HTTP version for now
    if {[regexp {^(POST|GET|PUT|HEAD|OPTIONS) ([^?]+)(\??)([^ ]*) *HTTP/(.*)$} \
	     $firstLine _ method resourceName hasFormData query version]} {
      set resourceName [string trimright [string trimleft $resourceName ./] " "]
      # construct filename
      [my info parent] instvar root
      set fileName $root/[url decodeName $resourceName]
      #puts stderr ---[encoding convertfrom utf-8 $fileName]----
      set fileName [encoding convertfrom utf-8 $fileName]
      #
      my decode-formData $query
      my log Query $firstLine
      if {[my exists forceVersion1.0]} {
	set version 1.0
      }
      my connection makePersistent [expr {$version > 1.0}]
      my connection event readable [self] header
    } else {
      set version 1.0
      set resourceName ???
      set method ???
      my log Error "bad first line:$firstLine"
      my replyCode 400
      my replyErrorMsg
    }
  } elseif {![my connection eof]} {
    #my showMsg "+++ not completed EOF=[my connection eof]"
  } else {
    set version 1.0
    #my showMsg "+++ n=negative ($n) EOF=[my connection eof] version set to 1.0"
    my close
  }
}
Httpd::Wrk instproc header {} {			# Read the header
  #my showCall
  my instvar method data
  if {[my connection gets line] > 0} {
    #puts stderr line=$line
    if {[regexp -nocase {^([^:]+): *(.+)$} $line _ key value]} {
      my set meta([string tolower $key]) $value
    }
  } else {
    #puts stderr line-EMPTY
    if {[my exists meta(content-length)] && [my set meta(content-length)]>0} {
      #puts stderr "we have content-length [my set meta(content-length)]"
      set data ""
      my connection translation binary
      my connection event readable [self] receive-body
    } elseif {[my exists meta(content-type)] &&
	      [regexp -nocase {multipart/form-data; *boundary=} \
		   [my set meta(content-type)]]} {
      #puts stderr "formdata"
      set data ""
      my connection event readable [self] receive-body
    } else {
      #puts stderr "no-content-length, triggering respond"
      my connection event readable [self] ""
      [my info parent] instvar requiresBody
      if {$requiresBody($method)} {
	my replyCode 411
	my replyErrorMsg
      } else {
	my check-redirect
      }
    }
  }
}
Httpd::Wrk instproc receive-body {} {	;# ... now we have to read the body
  #my showCall
  my instvar method data meta
  set d [my connection read]
  if {[string length $d] > 0} {
    append data $d
    #my showMsg "datal=[string length $data], cl=$meta(content-length)"
    if {[string length $data] >= $meta(content-length)} {
      my connection event readable [self] ""
      if {$method == "POST"} { my decode-POST-query  }
      my check-redirect
    }
  } else {   ;# 0 byte, must be eof...
    my showMsg "received 0 bytes"
    my connection event readable [self] ""
    if {[string length $data] < $meta(content-length)} {
      my replyCode 404
      my replyErrorMsg
    } else {
      my check-redirect
    }
  }
}
Httpd::Wrk instproc unmodified mtime {
  my instvar meta
  if {[info exists meta(if-modified-since)]} {
    set ms $meta(if-modified-since)
    regexp {^([^;]+);(.*)$} $ms _ ms options
    if {[catch {set mss [clock scan $ms]}]} {
      regsub -all -- {-} $ms " " ms
      if {[catch {set mss [clock scan $ms]}]} {
	set ms [lreplace $ms end end]
	set mss [clock scan $ms]
      }
    }
    return [expr {$mtime <= $mss}]
  }
  return 0
}
Httpd::Wrk instproc check-redirect {} {	
  [my info parent] instvar redirects
  my instvar resourceName hasFormData query
  set resource $resourceName$hasFormData$query
  foreach {pattern hostport} $redirects {
    #puts stderr "match <$pattern> <$resource> [regexp $pattern $resource]"
    if {[regexp $pattern $resource]} {
      #puts stderr "do redirect to $hostport/$resource"
      my replyCode 302 location $hostport/$resource
      my replyErrorMsg
      return
    }
  }
  my respond
}
Httpd::Wrk instproc respond {} {			# Respond to the query
  # the request was read completely...   This method is wellsuited for mixins!
  my respond-[my set method]
}

Httpd::Wrk instproc respond-GET {} {
  #my showCall
  my instvar fileName
  my sendFile $fileName
}
Httpd::Wrk instproc respond-HEAD {} {			# Respond to the query
  my instvar fileName
  if {[file readable $fileName]} {
    my replyCode 200 \
	Last-Modified [Httpd Date [file mtime $fileName]] \
	Content-Type [Mime guessContentType $fileName] \
	Content-Length [file size $fileName]
    my connection puts ""
    #my log Done "$fileName [Mime guessContentType $fileName]"
    my close
  } else {
    my replyCode 404
    my replyErrorMsg
  }
}
Httpd::Wrk instproc respond-OPTIONS {} {			# Respond to the query
  my replyCode 200 \
      Allow "OPTIONS, GET, HEAD, POST" \
      Public "OPTIONS, GET, HEAD, POST"
  my connection puts ""
  my close
}
Httpd::Wrk instproc respond-PUT {} {
  my instvar data method fileName
  my replyCode [expr {[file writable $fileName] ? 200 : 201}]
  my connection puts ""
  set out [open $fileName w]
  fconfigure $out -translation binary
  puts -nonewline $out $data
  my log Done "$fileName [Mime guessContentType $fileName]"
  close $out
  my close
}
Httpd::Wrk instproc respond-CGI {} {
  my instvar fileName
  if {[file executable $fileName]} {
    my replyCode 200
    my connection puts [exec $fileName]      ;# no parameter handling yet
    my close
  } else {
    my replyCode 403
    my replyErrorMsg
  }
}
Httpd::Wrk instproc new-formData {} {
  set arg [Object create [self]::[my autoname formData]]
  my lappend formData $arg
  return $arg
}
Httpd::Wrk instproc decode-formData {query} {
  #my showCall
  foreach pair [split [string trimleft $query \n] &] {
    set arg [my new-formData]
    if {[regexp {^(.+)=(.*)$} $pair _ name content]} {
      $arg set name [url decodeItem $name]
      $arg set content [url decodeItem $content]
    } else {
      $arg set content [url decodeItem $pair]
    }
  }
}
Httpd::Wrk instproc decode-POST-query {} {
  if {[my exists meta(content-type)]} {
    set ct [my set meta(content-type)]
    if {[regexp -nocase {application/x-www-form-urlencoded} $ct]} {
      #my showMsg "ordinary FORM"
      my decode-formData [my set data]
      return
    } elseif {[regexp -nocase {multipart/form-data; *boundary=(.*)$} $ct \
		   _ boundary]} {
      #my showMsg "multipart FORM"
      set parts [my set data]
      set bl [expr {[string length $boundary]+2}]
      while {[set endIDX [string first --$boundary $parts]] > -1} {
	set part [string range $parts $bl [expr {$endIDX-1}]]
	if {[set endHD [string first \r\n\r\n $part]] > -1} {
	  set arg [my new-formData]
	  if {[catch {Mime multipart-decode-header \
			  [string range $part 0 [expr {$endHD-1}]] \
			  $arg} msg]} {
	    my replyCode 406
	    my replyErrorMsg $msg
	    return 0
	  }
	  $arg set content [string range $part \
				[expr {$endHD + 4}] \
				[expr {[string length $part] -3}]]
	  #$arg showVars
	}
	set parts [string range $parts [expr {$endIDX+2}] end]
      }
    }
  }
}
Httpd::Wrk instproc respond-POST {} {
  my replyCode 405
  my replyErrorMsg
  #my respond-CGI
}

Httpd::Wrk instproc replyErrorMsg {{msg ""} args} {
  my instvar replyCode
  [self class] instvar codes
  foreach {tag value} $args {my connection puts "$tag: $value"}
  my sendText "\n<HTML><title>Status Code: $replyCode</title>\n\
      <BODY>$msg<p>\n\
      Status Code $replyCode: <b>$codes($replyCode)</b><br>\n\
      Resource Name: [my set resourceName]</BODY></HTML>\n"
  my close  ;# close must be last call
}
Httpd::Wrk instproc replyCode {code args} {
  #my showCall
  my instvar version
  [self class] instvar codes
  my set replyCode $code
  my connection puts "HTTP/$version $code $codes($code)"
  foreach {tag value} [my set replyHeaderFields] {my connection puts "$tag: $value"}
  foreach {tag value} $args {my connection puts "$tag: $value"}
  if {$code >= 400} {
    my log Error "$code $codes($code)\tmeta: [my array get meta]"
  }  else {
    my log Done "$code $codes($code)"
  }
}
Httpd::Wrk instproc sendText {response {type text/html}} {
  #my showCall
  my connection puts "Content-Type: $type"
  # bei einer leeren Responses blockieren Klienten und melden Fehler
  if {$response == ""} { set response " " }
  my connection puts "Content-Length: [string length $response]\n"
  if {[my set method] != "HEAD"} {
    my connection fconfigure -translation {auto binary}
    my connection puts-nonewline $response
  } else {
    my showMsg HEAD!
  }
}
Httpd::Wrk instproc sendMsg {response {type text/html}} {
  # my showCall
  my replyCode 200
  my sendText $response $type 
  my close
}
Httpd::Wrk instproc sendDir {dirName} {
  [my info parent] instvar root
  set title "Directory listing"
  set reply "<HTML><TITLE>$title</TITLE><BODY><H1>$title</H1>\n<TABLE>\n"
  set oldpwd [pwd]
  cd $root
  set dirs ""; set files ""
  foreach f [lsort -dictionary [glob -nocomplain ./$dirName/*]] {
    set full [file join $root $f]
    set pname [string trimleft $f ./]
    if {[file isdir $full]} {
      append pname /
    }
    if {![catch {set size [file size $full]}]} {
      # it is not a broken link
      set entry ""
      append entry <tr> \
	  <td> "<A href='/$pname'>$pname</a>"    </td> \
	  "<td align='right'>" $size </td> \
	  "<td align='right'>" [clock format [file mtime $full]] </td> \
	  </tr>\n
      if {[string match */ $pname]} {append dirs $entry} else {append files $entry}
    }
  }
  append reply $dirs $files "</TABLE></HTML>\n"
  cd $oldpwd
  my sendMsg $reply
  return
}

Httpd::Wrk instproc sendFile {fn {type ""}} {
  #my showCall
  if {[file isdirectory $fn]} {
    set full [file join $fn index.html]
    if {[file readable $full]} {
      set fn $full
    } else {
      my sendDir [my set resourceName]
      return
    }
  }
  #puts stderr "readable '$fn' [file readable $fn]"
  if {[file readable $fn]} {
    set mtime [file mtime $fn]
    if {[my unmodified $mtime]} { 
      my replyCode 304
      my replyErrorMsg
      return 
    }
    if {$type == ""} {set type [Mime guessContentType $fn]}
    my replyCode 200 \
	Last-Modified [Httpd Date $mtime] \
	Content-Type $type \
	Content-Length [file size $fn]
    my connection puts ""
    my connection fconfigure -translation binary ;#-buffersize 65536
    set localFile [open $fn]
    fconfigure $localFile -translation binary -buffersize 65536
    fcopy $localFile [my connection set socket] \
	-command [list [self] fcopy-end $localFile]
  } else {
    my replyCode 404
    my replyErrorMsg
  }
}
Httpd::Wrk instproc fcopy-end {localFile args} {	# End of fcopy
  close $localFile
  my connection fconfigure -blocking false ;# fconfigure changes blocking in 8.3.2!
  my close
}
Httpd::Wrk instproc log {reason arg} {			# trivial logging
  my instvar port ipaddr
  if {[my exists user]} {
    set user [my set user]/[my set realm]
  } {set user -}
  [my info parent] instvar logfile
  puts $logfile "[clock format [clock seconds]] $user $ipaddr:$port\t$reason\t$arg"
  flush $logfile
}


#########################################################################
Class Httpsd -superclass Httpd -parameter {
  {port 443}
  {httpdWrk Httpsd::Wrk}
  {requestCert 0}
  {requireValidCert 0}
  {certfile filename.crt}
  {keyfile filename.key}
  {cafile cacert.pem}
  {infoCb {}}
}
Httpsd instproc init args {
  package require tls
  proc tls::password {} {
    puts stderr "getting passwd"
    return pemp
  }
  next
}

Class Httpsd::Wrk -superclass Httpd::Wrk
Httpsd::Wrk instproc firstLine {} {
  my set forceVersion1.0 1
  my lappend replyHeaderFields Connection close
  next
}
Httpsd::Wrk instproc makeConnection {socket} {
  Connection create [self]::connection -socket $socket -req [self]
  [my info parent] instvar \
      keyfile certfile cafile infoCb requestCert requireValidCert
  # SSL-enable a regular Tcl channel - it need not be a socket, but
  # must provide bi-directional flow. Also setting session parameters
  # for SSL handshake. www.sensus.org/tcl/tls.htm
  
  # -request bool --> Request a certificate from peer during SSL
  # handshake. (default: true)
  
  # -require bool --> Require a valid certificate from peer during SSL
  # handshake. If this is set to true then -request must also be set
  # to true. (default: false)
       
  # -server bool --> Handshake as server if true, else handshake as
  # client.(default: false)
  my connection importSSL -server 1 \
       -certfile  $certfile \
      -keyfile  $keyfile \
      -cafile    $cafile \
      -request   $requestCert \
      -require   $requireValidCert \
      -command   $infoCb
}
#########################################################################



###
### Mixin-Classes for respond patterns
### mixes into Http and Httpd::Wrk 
###
Class Responder
Responder instproc init args {
  next
  my lappend workerMixins Responder::Wrk
  my set respondpatterns {}
  # Example how to register new methods: regexp is matched with the triple
  # (HTTP-METHOD URL HASFORMDATA) where HASFORMDATA is empty when no
  # parameters are given. The parsed components of the url etc. are
  # available as instvars
  my actions {^GET cgi[-]bin [?]} respond-CGI
}
Responder instproc actions {regexp method} {
  my lappend respondpatterns $regexp $method
}
Class Responder::Wrk
Responder::Wrk instproc respond {} {
  my instvar fileName method resourceName hasFormData
  [my info parent] instvar respondpatterns
  ### auch das ist ein kandidat fuer eine chain of responsibility
  foreach {pattern action} $respondpatterns {
    if {[regexp $pattern "$method $resourceName $hasFormData"]} {
      my $action
      return
    }
  }
  next
}

###
### Mixin-Classes for Access Control
### mixes into Http and Httpd::Wrk
###
Class AccessControl
AccessControl abstract instproc protectedResource {fn method varAuthMethod varRealm}
AccessControl abstract instproc credentialsNotOk {wrk credentials authMethod realm}
AccessControl abstract instproc addRealmFile {realm authFile}
AccessControl abstract instproc addRealmEntry {realm passwds}
AccessControl abstract instproc protectDir {realm path methods}

Class AccessControl::Wrk
AccessControl::Wrk instproc respond {} {
  my instvar fileName method digestChallengeData
  set controller [my info parent]
  if {[$controller protectedResource $fileName $method authMethod realm]} {
    #my showMsg "*** Protected resource: $fileName $method"
    if {![my exists meta(authorization)] ||
	[$controller credentialsNotOk [self] \
	     [my set meta(authorization)] $authMethod $realm]} {
      my unauthorizedAccess $realm
      return
    }
  }
  next
}

###########################################################################
## Basic Access Control
###########################################################################
Class BasicAccessControl -superclass AccessControl

BasicAccessControl instproc initWorkerMixins {} {
  my lappend workerMixins [self class]::Wrk
}

BasicAccessControl instproc init args {
  next
  my initWorkerMixins
}

BasicAccessControl instproc protectedResource {fn method varAuthMethod varRealm} {
  #my showCall
  # check whether access to $fn via $method is protected
  upvar [self callinglevel] $varAuthMethod authMethod $varRealm realm
  # we check only the current directory, not the parent directories
  if {[string match */ $fn]} {
    set path $fn
  } else {
    set path [file dirname $fn]/
  } 
  foreach i [list $path $path:$method] {
    if {[my exists protected($i)]} {
      set realm [my set protected($i)]
      set authMethod Basic
      return 1
    }
  }
  return 0
}

BasicAccessControl instproc credentialsNotOk {wrk credentials authMethod realm} {
  # check whether $credentials are sufficient for $realm
  regexp {^(.*):(.*)$} [base64 decode [lindex $credentials 1]] _ user pwd
  #puts stderr "passwd($realm:$user)=[my exists passwd($realm:$user)]"
  $wrk set user $user
  $wrk set realm $realm
  if {[my exists passwd($realm:$user)]} {
    return [expr {[my set passwd($realm:$user)] != $pwd}]
  }
  return 1
}

BasicAccessControl instproc addRealmEntry {realm passwds} {
  if {[llength $passwds] == 1} {
    my addRealmFile [lindex $passwds 0]
  } else {
    foreach {name pwd} $passwds {
      #puts stderr "realm='$realm' adding user: $name pw: $pwd"
      my set passwd($realm:$name) $pwd
    }
  }
}
BasicAccessControl instproc addRealmFile {realm authFile} {
  set FILE [open $authFile r]
  while {![eof $FILE]} {
    foreach {name pwd} [split [gets $FILE] :] {
      my addRealmEntry $realm [list $name $pwd]
    }
  }
  close $FILE
}

BasicAccessControl instproc protectDir {realm path methods} {
  my instvar root
  my checkRoot
  set resource $root/$path      ;# resources are currently directories
  if {$methods == {}} {
    my set protected($resource) $realm       ;#for every method
  } else {
    foreach m $methods {
      my set protected($resource:$m) $realm  ;#for selected methods
    }
  }
}
Class BasicAccessControl::Wrk -superclass AccessControl::Wrk
BasicAccessControl::Wrk instproc unauthorizedAccess {realm} {
  my set digestChallengeData(realm) $realm
  my replyCode 401 www-authenticate "Basic realm=\"$realm\""
  my replyErrorMsg "Unauthorized request for realm '$realm'" 
}



###########################################################################
## Digest Access Control
###########################################################################
Class DigestAccessControl -superclass BasicAccessControl
DigestAccessControl instproc init args {
  package require tcu
  next
  my lappend workerMixins [self class]::Wrk
}
DigestAccessControl instproc credentialsNotOk {wrk credentials authMethod realm} {
  # check whether $credentials are sufficient for $realm
  my showMsg "Digest Authentication ..."
  # HELP FD: hier muss ich noch überprüfen, ob die digest-header
  # (credentials) ok sind. Hier habe ich probleme auf die sachen,
  # die der worker gesendet (bspw. nonce) hat zu kommen. Ich
  # weiß, man kann mit [my info children] daran kommen. Aber,
  # was ist, wenn man mehrere Worker hat?

  ## Fredj, das sollte kein Problem sein: das credentialsNotOk wird
  ## vom aktuellen worker (respond) aufgerufen. man kann dem *NotOk
  ## den worker mitgeben, oder die beiden Methoden etwas umorganisieren.
  return
}
Class DigestAccessControl::Wrk -superclass BasicAccessControl::Wrk
DigestAccessControl::Wrk instproc unauthorizedAccess {realm} {
  my set digestChallengeData(realm) $realm
  my replyCode 401 www-authenticate "Digest [my digestChallenge]"
  my replyErrorMsg "Unauthorized request for realm '$realm'"
}
DigestAccessControl::Wrk instproc digestChallenge {} {
  my showCall
  my instvar digestChallengeData
  my mkDigestChallengeData
  set digestResponse {}
  foreach {t v} [array get digestChallengeData] {
    append digestResponse "$t = \"$v\", "
  }
  regsub {, $} $digestResponse {} digestResponse
  return $digestResponse
}
DigestAccessControl::Wrk instproc mkDigestChallengeData {} {
  my showCall
  my instvar digestChallengeData

  # RFC 2617
  #   challenge         =  "Digest" digest-challenge
  #   digest-challenge  = 1#( realm | [ domain ] | nonce |
  #                       [ opaque ] |[ stale ] | [ algorithm ] |
  #                       [ qop-options ] | [auth-param] )
  #   domain            = "domain" "=" <"> URI ( 1*SP URI ) <">
  #   URI               = absoluteURI | abs_path
  #   nonce             = "nonce" "=" nonce-value
  #   nonce-value       = quoted-string
  #   opaque            = "opaque" "=" quoted-string
  #   stale             = "stale" "=" ( "true" | "false" )
  #   algorithm         = "algorithm" "=" ( "MD5" | "MD5-sess" | token )
  #   qop-options       = "qop" "=" <"> 1#qop-value <">
  #   qop-value         = "auth" | "auth-int" | token

  # FD: hier würde man die nötigen parametern (nonce,domain,opaque,
  # etc.) berechnen und in dem asso. Array speichern.
  # FD: minimale Anforderung
  set digestChallengeData(nonce)  [my genNonce]
  set digestChallengeData(opaque) [base64 encode [self]:my-self-spcified-string]
  set digestChallengeData(algorithm) "MD5" ;#default
  set digestChallengeData(qop) "auth"
  set digestChallengeData(domain) [array names [my info parent]::protected]
}

DigestAccessControl::Wrk instproc genNonce {} {
  my showCall
  my instvar digestChallengeData
  set timeStamp [clock seconds]
  set nonce [base64 encode [md5 $timeStamp:[self]]]
  return $nonce
}

#Httpd h1 -port 8081 -root [glob ~/wafe]
#Httpd h2 -port 9086 -root $root \
    -mixin {Responder BasicAccessControl} \
    -addRealmEntry test {test test} -protectDir test "" {} \
    -redirect {^(mailman|pipermail|cgi-bin) http://alice.wu-wien.ac.at:80}


