# -*- tcl -*- $Id: Httpd.xotcl,v 1.9 2007/08/14 16:38:26 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 1 #package require xotcl::comm::httpAccess package require -exact xotcl::comm::connection 1.0 package require -exact xotcl::trace 0.91 package require -exact xotcl::comm::mime 0.9 namespace eval ::xotcl::comm::httpd { namespace import ::xotcl::* 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 GMT} -gmt true} 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 } proc ! string { set f [open [::xotcl::tmpdir]log w+]; puts $f "[clock format [clock seconds]] $string" close $f} 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 [namespace tail [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 {$d ne ""} { 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 eq "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
\n\
Status Code $replyCode: $codes($replyCode)
\n\
Resource Name: [my set resourceName]\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 eq ""} { set response " " }
my connection puts "Content-Length: [string length $response]\n"
if {[my set method] ne "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 "
"$pname" | \ "" $size | \ "" [clock format [file mtime $full]] | \