Posted to tcl by hypnotoad at Thu Feb 01 22:02:46 GMT 2018view pretty

###
# send_listen.tcl
# Run this from the examples/httpd folder in tcllib
###

###
# "Simple" webserver example
###

set DIR [file dirname [file normalize [info script]]]
set DEMOROOT [file join $DIR htdocs]
set tcllibroot  [file normalize [file join $DIR .. ..]]
set auto_path [linsert $auto_path 0 [file normalize [file join $tcllibroot modules]]]
package require httpd 4.1
###
# This script creates two toplevel domains:
# * Hosting the tcllib embedded documentation as static content
# * Hosting a local fossil mirror of the tcllib repository
###
package require httpd

proc ::fossil-list {} {
  return [::fossil all list]
}
proc ::fossil args {
  if {![info exists ::fossil_exe]} {
    set ::fossil_exe fossil
  }
  if {[llength $args]==0} {
    return $::fossil_exe
  }
  return [exec ${::fossil_exe} {*}$args]
}

tool::class create httpd::content::fossil_root {

  method content {} {
    my reset
    my puts "<HTML><HEAD><TITLE>Local Fossil Repositories</TITLE></HEAD><BODY>"
    global recipe
    my puts "<UL>"
    set dbfiles [::fossil-list]
    foreach file [lsort -dictionary $dbfiles]  {
      dict set result [file rootname [file tail $file]] $file
    }
    foreach {module dbfile} [lsort -dictionary -stride 2 $result] {
      my puts "<li><a HREF=/fossil/$module>$module</a>"
    }
    my puts {</UL></BODY></HTML>}
  }
}

###
# This driver for fossil is not a standard SCGI module
# it's more or less cargo culted from a working prototype
# developed for the GORT project. You'll note it does some
# things that are non-standard for SCGI, and that's to work
# around quirks in Fossil SCGI implementation.
#
# (Either that or my reading of SCGI specs is way, way off.
# I'm 75% sure I'm doing something wrong.)
#
# Actually, according to DRH we should really be using CGI
# because that is better supported. So until we get the
# CGI functions fleshed out, here's FOSSIL...
#
# --Sean "The Hypnotoad" Woods
###
tool::class create httpd::content::fossil_node_scgi {

  superclass httpd::content::scgi
  method scgi_info {} {
    set uri    [my http_info get REQUEST_URI]
    set prefix [my http_info get prefix]
    set module [lindex [split $uri /] 2]
    file mkdir ~/tmp
    if {![info exists ::fossil_process($module)]} {
      package require processman
      package require nettool
      set port [::nettool::allocate_port 40000]
      set handle fossil:$port
      set dbfiles [::fossil-list]
      foreach file [lsort -dictionary $dbfiles]  {
        dict set result [file rootname [file tail $file]] $file
      }
      set dbfile [dict get $result $module]
      if {![file exists $dbfile]} {
        tailcall my error 400 {Not Found}
      }
      set mport [my <server> port_listening]
      set cmd [list [::fossil] server $dbfile --port $port --localhost --scgi 2>~/tmp/$module.err >~/tmp/$module.log]

      dict set ::fossil_process($module) port $port
      dict set ::fossil_process($module) handle $handle
      dict set ::fossil_process($module) cmd $cmd
      dict set ::fossil_process($module) SCRIPT_NAME $prefix/$module
    }
    dict with ::fossil_process($module) {}
    if {![::processman::running $handle]} {
      set process [::processman::spawn $handle {*}$cmd]
      my varname paused
      after 500
    }
    return [list localhost $port $SCRIPT_NAME]
  }
}

tool::class create ::docserver::server {
  superclass ::httpd::server

  method log args {
    puts [list {*}$args]
  }

}

tool::define ::docserver::dynamic {

  method content {} {
    my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
    my puts "<TABLE width=100%>"
    foreach {f v} [my request dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><td colspan=10><hr></td></tr>"
    foreach {f v} [my http_info dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><th>File Size</th><td>[my http_info get CONTENT_LENGTH]</td></tr>"
    my puts </TABLE>
    my puts </BODY></HTML>
  }

}

tool::define ::docserver::upload {
  superclass ::docserver::dynamic

  method content {} {
    my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
    my puts "<TABLE width=100%>"
    set FORMDAT [my FormData]
    foreach {f v} [my FormData] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><td colspan=10><hr></td></tr>"
    foreach {f v} [my http_info dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><td colspan=10><hr></td></tr>"
    foreach part [dict getnull $FORMDAT MIME_PARTS] {
      my puts "<tr><td colspan=10><hr></td></tr>"
      foreach f [::mime::getheader $part -names] {
        my puts "<tr><th>$f</th><td>[mime::getheader $part $f]</td></tr>"
      }
      my puts "<tr><td colspan=10>[::mime::getbody $part -decode]</td></tr>"
    }
    my puts "<tr><th>File Size</th><td>[my http_info get CONTENT_LENGTH]</td></tr>"
    my puts </TABLE>
    my puts </BODY></HTML>
  }

}

###
# A test suggested by
#
tool::define ::docserver::listen {

  method content {} {
    while {![info exists ::MESSAGE]} {
      puts "[info coroutine] WAITING"
      ::cron::sleep 6000
    }
    my variable reply_body
    my reply set Content-Type $::MESSAGE_TYPE
    set reply_body $::MESSAGE
    unset ::MESSAGE
  }

}

tool::define ::docserver::send {

  method content {} {
    set length 0
    if {[my request exists Content-Length]} {
      set length [my request get Content-Length]
    }
    if {$length>0} {
      puts "MESSAGE RCVD"
      set ::MESSAGE_TYPE [my request get Content-Type]
      set ::MESSAGE      [my PostData $length]
      puts "MESSAGE $::MESSAGE"
      my puts "<HTML><BODY><h1>Sent</h1><pre>$::MESSAGE</PRE></BODY></HTML>"
    } else {
      my puts {
<HTML><BODY><FORM action=/send method=POST><TEXTEAREA name=text rows="4" cols="50">
</TEXTEAREA>
<input name=foo>
<input type=submit /></FORM></BODY></HTML>
      }
    }
  }

}


set opts [::tool::args_to_options {*}$argv]
set serveropts {}
set optinfo [::docserver::server meta getnull option]
foreach {f v} $opts {
  if {[dict exists $optinfo $f]} {
    dict set serveropts $f $v
  }
}
puts $serveropts
set fossilopts {}
set optinfo [::httpd::content::fossil_root meta getnull option]
foreach {f v} $opts {
  if {[dict exists $optinfo $f]} {
    dict set fossilopts $f $v
  }
}
if {[dict exists $opts fossil]} {
  set ::fossil_exe [dict get $opts fossil]
}
puts "Server Options: $serveropts"
puts "Fossil Options: $fossilopts"


::docserver::server create appmain doc_root $DEMOROOT {*}$argv
appmain add_uri /tcllib* [list mixin httpd::content::file path [file join $tcllibroot embedded www]]
appmain add_uri /fossil [list mixin httpd::content::fossil_root {*}$fossilopts]
appmain add_uri /fossil/* [list mixin httpd::content::fossil_node_scgi {*}$fossilopts]
appmain add_uri /upload [list mixin ::docserver::upload]
appmain add_uri /dynamic [list mixin ::docserver::dynamic]
appmain add_uri /listen [list mixin ::docserver::listen]
appmain add_uri /send   [list mixin ::docserver::send]
puts [list LISTENING]
tool::main