# -*- 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 0.9
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}
}
Httpd proc Date seconds {clock format $seconds -format {%a, %d %b %Y %T %Z}}
Httpd instproc init args {			
  [self] instvar port listen root logdir logfile
  if {![[self] exists workerMixins]} {
    set [self]::workerMixins {}
    #puts stderr "resetting workermixins of [self]"
  }
  next
  set proto [string trim [[self] 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 {[[self] exists ipaddr]} {set ip "-myaddr [[self] set ipaddr]]"} {set ip ""}
  eval [list socket -server [list [self] accept]] $ip $port
  #set listen [socket -server [list [self] accept] $port]
  set root [string trimright $root /]
  if {![file isdir $logdir]} {file mkdir $logdir}
  set logfile [open $logdir/serverlog-$port a+]
  array set [self]::requiresBody \
      {GET 0 HEAD 0 POST 1 PUT 1 DELETE 0 OPTIONS 0 TRACE 0}
}
Httpd instproc destroy {} {			# destructor
  catch {::close [[self] set listen]}
  catch {::close [[self] set logfile]}
  next
}
Httpd instproc accept {socket ipaddr port} {	# Accept a new connection and set up a handler
  #puts stderr "using workermixins of [self] {[[self] set workerMixins]}"
  [[self] set httpdWrk] newChild -socket $socket -ipaddr $ipaddr \
      -port $port -mixin [[self] set workerMixins]
}


Class Httpd::Wrk -parameter {socket port ipaddr}
Httpd::Wrk array set codes {
  200 {Data follows}          201 {Created}         204 {No Content}
  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 {} {set [self]::formData}
Httpd::Wrk instproc init args {		# Constructor 
  [self] instvar socket port ipaddr
  [self] set formData {}
  next
  [self] makeConnection $socket
  [self] log Connect "$ipaddr $port"
  [self]::c translation {auto crlf}
  [self]::c event readable [self] firstLine
}
Httpd::Wrk instproc makeConnection {socket} {
  Connection create [self]::c -socket $socket -req [self]
}
Httpd::Wrk instproc close {} {		# logical close of a single request
  #[self] showCall
  [self] instvar version timeout meta
  set eof [[self]::c eof]
  if {$version > 1.0 && !$eof} {
    #[self] showMsg "!EOF in http/$version"
    [self]::c flush
    set timeout [after 10000 [self] destroy]
    ### reset parameters, worker will be potentially reused
    if {[::array exists meta]} {
      ::unset meta
      ::array set meta {}
    }
    unset version
    if {[[self] exists user]} {
      [self] unset user
      [self] unset realm
    }
    foreach c [[self] set formData] { $c destroy }
    [self] set formData {}
    #[self] showVars
    [self]::c translation {auto crlf}
    [self]::c event readable [self] firstLine
  } elseif {$eof} {
    #[self] showMsg "Destroy in http/$version"
    # the client side has closed the connection
    [self] destroy
  } else {
    #[self] showMsg "!EOF in http/$version ???"
    # we close the conneciton actively (e.g. forced by an error)
    [self]::c flush
    #puts stderr "DESTROY----this line should never show up"
    [self] destroy
  }
}
Httpd::Wrk instproc destroy {} {
  #[self] showCall
  if {[[self] isobject [self]::c]} {
    [self]::c close
  }
  next
}
Httpd::Wrk instproc freeConnection {} {
}
Httpd::Wrk instproc firstLine {} {	# Read the first line of the request
  #[self] showCall
  [self] instvar method resourceName hasFormData query fileName \
      version timeout 
  if {[info exists timeout]} {
    after cancel $timeout
    unset timeout
  }
  set n [[self]::c 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
      [[self] info parent] instvar root
      set fileName $root/$resourceName
      regsub {/$} $fileName /index.html fileName
      #
      [self] decode-formData $query
      [self] log Query $firstLine
      [self]::c makePersistent [expr {$version > 1.0}]
      [self]::c event readable [self] header
    } else {
      set version 1.0
      set resourceName ???
      set method ???
      [self] log Error "bad first line:$firstLine"
      [self] replyCode 400
      [self] replyErrorMsg
    }
  } elseif {![[self]::c eof]} {
    [self] showMsg "+++ not completed EOF=[[self]::c eof]"
  } else {
    set version 1.0
    #[self] showMsg "+++ n=negativ ($n) EOF=[[self]::c eof] version set to 1.0"
    [self] close
  }
}
Httpd::Wrk instproc header {} {			# Read the header
  #[self] showCall
  [self] instvar method data
  if {[[self]::c gets line] > 0} {
    #puts stderr line=$line
    if {[regexp -nocase {^([^:]+): *(.+)$} $line _ key value]} {
      [self] set meta([string tolower $key]) $value
    }
  } else {
    if {[[self] exists meta(content-length)]} {
	set data ""
	[self]::c translation binary
	[self]::c event readable [self] receive-body
    } elseif {[[self] exists meta(content-type)] &&
	      [regexp -nocase {multipart/form-data; *boundary=} \
		   [[self] set meta(content-type)]]} {
      set data ""
      [self]::c event readable [self] receive-body
    } else {
      [self]::c event readable [self] ""
      [[self] info parent] instvar requiresBody
      if {$requiresBody($method)} {
	[self] replyCode 411
	[self] replyErrorMsg
      } else {
	[self] respond
      }
    }
  }
}
Httpd::Wrk instproc receive-body {} {	;# ... now we have to read the body
  #[self] showCall
  [self] instvar method data meta
  set d [[self]::c read]
  if {[string length $d] > 0} {
    append data $d
    #[self] showMsg "datal=[string length $data], cl=$meta(content-length)"
    if {[string length $data] >= $meta(content-length)} {
      [self]::c event readable [self] ""
      if {$method == "POST"} { [self] decode-POST-query  }
      [self] respond
    }
  } else {   ;# 0 byte, must be eof...
    [self] showMsg "received 0 bytes"
    [self]::c event readable [self] ""
    if {[string length $data] < $meta(content-length)} {
      [self] replyCode 404
      [self] replyErrorMsg
    } else {
      [self] respond
    }
  }
}
Httpd::Wrk instproc unmodified mtime {
  [self] 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 respond {} {			# Respond to the query
  # the request was read completely...   This method is wellsuited for mixins!
  [self] respond-[[self] set method]
}

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

Httpd::Wrk instproc replyErrorMsg {{msg ""} args} {
  [self] instvar replyCode
  [self class] instvar codes
  foreach {tag value} $args {[self]::c puts "$tag: $value"}
  [self] sendText "\n<HTML><title>Status Code: $replyCode</title>\n\
      <BODY>$msg<p>\n\
      Status Code $replyCode: <b>$codes($replyCode)</b><br>\n\
      Resource Name: [[self] set resourceName]</BODY></HTML>\n"
  [self] close  ;# close must be last call
}
Httpd::Wrk instproc replyCode {code args} {
  #[self] showCall
  [self] instvar version
  [self class] instvar codes
  [self] set replyCode $code
  set c [self]::c
  $c puts "HTTP/$version $code $codes($code)"
  $c puts "Date: [Httpd Date [clock seconds]]"
  foreach {tag value} $args {$c puts "$tag: $value"}
  if {$code >= 400} {
    [self] log Error "$code $codes($code)\tmeta: [[self] array get meta]"
  }  else {
    [self] log Done "$code $codes($code)"
  }
}
Httpd::Wrk instproc sendText {response {type text/html}} {
  #[self] showCall
  [self]::c puts "Content-Type: $type"
  # bei einer leeren Responses blockieren Klienten und melden Fehler
  if {$response == ""} { set response " " }
  [self]::c puts "Content-Length: [string length $response]\n"
  if {[[self] set method] != "HEAD"} {
    [self]::c fconfigure -translation {auto binary}
    [self]::c puts-nonewline $response
  } else {
    [self] showMsg HEAD!
  }
}
Httpd::Wrk instproc sendMsg {response {type text/html}} {
  #[self] showCall
  [self] replyCode 200
  [self] sendText $response $type 
  [self] close
}
Httpd::Wrk instproc sendFile {fn {type ""}} {
  #[self] showCall
  if {[file readable $fn]} {
    set mtime [file mtime $fn]
    if {[[self] unmodified $mtime]} { 
      [self] replyCode 304
      [self] replyErrorMsg
      return 
    }
    if {$type == ""} {set type [Mime guessContentType $fn]}
    [self] replyCode 200 \
	Last-Modified [Httpd Date $mtime] \
	Content-Type $type \
	Content-Length [file size $fn]
    [self]::c puts ""
    [self]::c fconfigure -translation binary ;#-buffersize 65536
    set localFile [open $fn]
    fconfigure $localFile -translation binary -buffersize 65536
    fcopy $localFile [set [self]::c::socket] \
	-command [list [self] fcopy-end $localFile]
  } else {
    [self] replyCode 404
    [self] replyErrorMsg
  }
}
Httpd::Wrk instproc fcopy-end {localFile args} {	# End of fcopy
  ::close $localFile
  [self]::c fconfigure -blocking false ;# fconfigure changes blocking in 8.3.2!
  [self] close
}
Httpd::Wrk instproc log {reason arg} {			# trivial logging
  [self] instvar port ipaddr
  if {[[self] exists user]} {
    set user [[self] set user]/[[self] set realm]
  } {set user -}
  [[self] 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 server.pem}
  {keyfile server.key}
  {cafile cacert.pem}
  {infoCb {}}
}
Httpsd instproc init args {
  package require tls
  next
}

Class Httpsd::Wrk -superclass Httpd::Wrk
Httpsd::Wrk instproc makeConnection {socket} {
  Connection create [self]::c -socket $socket -req [self]
  [[self] 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)
  [self]::c 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
  lappend [self]::workerMixins Responder::Wrk
  [self] 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
  [self] actions {^GET cgi[-]bin [?]} respond-CGI
}
Responder instproc actions {regexp method} {
  lappend [self]::respondpatterns $regexp $method
}
Class Responder::Wrk
Responder::Wrk instproc respond {} {
  [self] instvar fileName method resourceName hasFormData
  [[self] info parent] instvar respondpatterns
  ### auch das ist ein kandidat fuer eine chain of responsibility
  foreach {pattern action} $respondpatterns {
    if {[regexp $pattern "$method $resourceName $hasFormData"]} {
      [self] $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 {} {
  [self] instvar fileName method digestChallengeData
  set controller [[self] info parent]
  if {[$controller protectedResource $fileName $method authMethod realm]} {
    #[self] showMsg "*** Protected resource: $fileName $method"
    if {![info exists [self]::meta(authorization)] ||
	[$controller credentialsNotOk [self] \
	     [[self] set meta(authorization)] $authMethod $realm]} {

      [self] unauthorizedAccess $realm
      return
    }
  }
  next
}

###########################################################################
## Basic Access Control
###########################################################################
Class BasicAccessControl -superclass AccessControl
BasicAccessControl instproc init args {
  next
  lappend [self]::workerMixins [self class]::Wrk
}
BasicAccessControl instproc protectedResource {fn method varAuthMethod varRealm} {
  # check whether access to $fn via $method is protected
  upvar $varAuthMethod authMethod $varRealm realm
  # we check only the current directory, not the parent directories
  set path [file dirname $fn]/
  foreach i [list $path $path:$method] {
    #puts stderr "check <$i>"
    if {[info exists [self]::protected($i)]} {
      set realm [set [self]::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)=[[self] exists passwd($realm:$user)]"
  $wrk set user $user
  $wrk set realm $realm
  if {[[self] exists passwd($realm:$user)]} {
    return [expr {[[self] set passwd($realm:$user)] != $pwd}]
  }
  return 1
}

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

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



###########################################################################
## Digest Access Control
###########################################################################
Class DigestAccessControl -superclass BasicAccessControl
DigestAccessControl instproc init args {
  package require tcu
  next
  lappend [self]::workerMixins [self class]::Wrk
}
DigestAccessControl instproc credentialsNotOk {wrk credentials authMethod realm} {
  # check whether $credentials are sufficient for $realm
  [self] 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 [[self] 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} {
  [self] set digestChallengeData(realm) $realm
  [self] replyCode 401 www-authenticate "Digest [[self] digestChallenge]"
  [self] replyErrorMsg "Unauthorized request for realm '$realm'"
}
DigestAccessControl::Wrk instproc digestChallenge {} {
  [self] showCall
  [self] instvar digestChallengeData
  [self] mkDigestChallengeData
  set digestResponse {}
  foreach {t v} [array get digestChallengeData] {
    append digestResponse "$t = \"$v\", "
  }
  regsub {, $} $digestResponse {} digestResponse
  return $digestResponse
}
DigestAccessControl::Wrk instproc mkDigestChallengeData {} {
  [self] showCall
  [self] 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)  [[self] 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 [[self] info parent]::protected]
}

DigestAccessControl::Wrk instproc genNonce {} {
  [self] showCall
  [self] 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 "" {}


