#!/usr/bin/tclsh8.4
# A very simple multi-threaded Webserver with a thread-pool in XOTcl. 
# It implements only the HTTP GET method with conditional 
# requests (if-modified-since))
# -gustaf neumann            Jan 2003

package require Thread 2.5
package require XOTcl  1.0
namespace import xotcl::*
package require xotcl::serializer

array set opt {-port 8081 -root ./html}
array set opt $argv

#####
##### Definition of the Server Class 
#####
Class Httpd -parameter { {port 80} {root /home/httpd/html/} {maxworkers 8}}
Httpd instproc init args {		;# constructor
  puts stderr "Starting Server; url= http://[info hostname]:[my port]/"
  my set listen [socket -server [list after idle [list [self] accept]] [my port]]
  append initcmd \
    "package require XOTcl 1.0\n" \
    "namespace import xotcl::*\n" \
    [Serializer deepSerialize ::HttpdWrk]
  my set tpid [tpool::create -maxworkers [my maxworkers] -initcmd $initcmd]
}
Httpd instproc destroy {} {		;# destructor
  close [my set listen]			;# close listening port
  tpool::release [my set tpid]
  next
}
Httpd instproc accept {sock ipaddr port} {	;# est. new connection
  thread::detach $sock
  tpool::post -detached [my set tpid] [list \
    HttpdWrk w1 -socket $sock -ipaddr $ipaddr -port $port -root [my root]]
}

#####
##### Definition of the Worker Class 
#####
Class HttpdWrk -parameter {socket port ipaddr root}
HttpdWrk array set codes {		;# we treat these status codes
  200 "Data follows"  304 "Not Modified"  400 "Bad Request"  404 "Not Found"
}
HttpdWrk instproc Date secs {clock format $secs -format {%a, %d %b %Y %T %Z}}
HttpdWrk instproc log {msg} {
  set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"]
  puts stderr "$stamp thread[thread::id]: $msg"
}
HttpdWrk instproc guessContentType fn {# derive content type from ext.
  switch [file extension $fn] {
    .gif {return image/gif}   .jpg  {return image/jpeg}
    .htm {return text/html}   .html {return text/html} 
    .css {return text/css}    .ps   {return application/postscript}
    default {return text/plain}
  }
}
HttpdWrk instproc replyCode {code} {
  my set code $code
  set msg [[self class] set codes($code)]
  puts [my socket] "HTTP/1.0 $code $msg\r\n\Date: [my Date [clock seconds]]"
  if {$code >= 300} {
    set p [expr {[my exists path] ? [my set path] : "-unknown-" }]
    my sendDynamicString "\n<title>Error: $code</title>\n\
      Error $code: <b>$msg</b><br>\nUrl: $p\r\n"
  }
}
HttpdWrk instproc init args {
  my set startTime [clock clicks -milliseconds]
  thread::attach [my socket]
  if {[catch {my processRequest} errMsg]} {
    puts stderr "error=$errMsg\n$::errorInfo"
  }
}
HttpdWrk instproc processRequest {} {
  set n [gets [my socket] line]
  my instvar method path fileName 
  #my log $line
  if {[regexp {^(GET) +([^ ]+) +HTTP/.*$} $line _ method path]} {
    set fileName [my root]/$path   ;# construct filename
    regsub {/$} $fileName /index.html fileName
    my header
  } elseif {$n<0} {
    set code -1
    my close
  } else { 
    my replyCode 400 
  }
}
HttpdWrk instproc header {} {	;# process the header
  while 1 {
    set n [gets [my socket] line]
    if {$n == 0} break
    if {[regexp {^([^:]+): *(.+)$} $line _ key value]} {
      my set meta([string tolower $key]) $value
    }
  }
  my response
}
HttpdWrk instproc response {} {  ;# Respond to the GET-query
  my instvar fileName
  if {[file readable $fileName]} {
    if {[my unmodified [file mtime $fileName]]} { 
      my replyCode 304
    } else { 
      my replyCode 200
      my sendFile
    }
  } else {
    my replyCode 404
  }
}
HttpdWrk instproc unmodified mtime {
  if {[my exists meta(if-modified-since)]} {
    set ms [my set meta(if-modified-since)]
    regexp {^([^;]+);} $ms _ ms
    if {![catch {set mss [clock scan $ms]}]} {return [expr {$mtime <= $mss}]}
  }
  return 0
}
HttpdWrk instproc sendFile {} {
  my instvar fileName socket
  puts $socket "Last-Modified: [my Date [file mtime $fileName]]\r\n\
     Content-Type: [my guessContentType $fileName]\r\n\
     Content-Length: [file size $fileName]\r\n"
  set localFile [open $fileName r]
  fconfigure $socket -translation binary -buffersize 16000
  fconfigure $localFile -translation binary -buffersize 16000
  fcopy $localFile $socket -command [list [self] sendFile-end $localFile]
  my vwait done
}
HttpdWrk instproc sendFile-end {localFile args} {
  close $localFile
  my close
  my set done 1
}
HttpdWrk instproc sendDynamicString {content {contentType text/html}} {
  puts [my socket] "Content-Type: $contentType\r\n\
     Content-Length: [string length $content]\r\n"
  fconfigure [my socket] -translation lf
  puts -nonewline [my socket] $content
  my close
}
HttpdWrk instproc close {} {		;# close a request
  set elapsed [expr {[clock clicks -milliseconds]-[my set startTime]}]
  my log "close ($elapsed ms) [my set code]"
  close [my socket]
}
proc bgerror {args} {
  puts stderr "$::argv0 background error: $args"
  puts stderr "\t$::errorInfo\nerrorCode = $::errorCode"
}

Httpd h1 -port $opt(-port) -root $opt(-root)
vwait forever