Version 17 of Playing CGI

Updated 2011-06-22 10:17:45 by RLE

Richard Suchenwirth 2006-09-17 - CGI is a mighty complex protocol for web servers to provide active content (i.e. the results of a script). The following is just a poor subset of CGI, but then again, it's not much code either. And testing it was great fun :^)

I started from DustMote, a web server for static content in 41 lines of code, and added the following features:

  • Content-type: text/html was added, so that my phone could receive the pages :)
  • %20 in URLs was mapped to " " to allow spaces in path names
  • URL suffixes of the pattern ?a=1&b=2 are parsed off and dumped into the environment variable QUERY_STRING
  • URLs ending in .tcl are executed by a tclsh, its stdout being served

Here's my extended version of DustMote, still short at 42 lines of code:

 # DustMotePlus - with a subset of CGI support
 set root      c:/html
 set default   index.htm
 set port      80
 set encoding  iso8859-1
 
 proc bgerror msg {puts stdout "bgerror: $msg\n$::errorInfo"}
 proc answer {socketChannel host2 port2} {
   fileevent $socketChannel readable [list serve $socketChannel]
 }
 proc serve sock {
     fconfigure $sock -blocking 0
     gets $sock line
     if {[fblocked $sock]} return
     fileevent $sock readable ""
     set tail /
     regexp {(/[^ ?]*)(\?[^ ]*)?} $line -> tail args
     if {[string match */ $tail]} {append tail $::default}
     set name [string map {%20 " "} $::root$tail]
     if {[file readable $name]} {
         puts $sock "HTTP/1.0 200 OK"
         if {[file extension $name] eq ".tcl"} {
             set ::env(QUERY_STRING) [string range $args 1 end]
             set name [list |tclsh $name]
         } else {
            puts $sock "Content-Type: text/html;charset=$::encoding\n"
         }
         set inchan [open $name]
         fconfigure $inchan -translation binary
         fconfigure $sock   -translation binary
         fcopy $inchan $sock -command [list done $inchan $sock]
     } else {
         puts $sock "HTTP/1.0 404 Not found\n"
         close $sock
     }
 }
 proc done {file sock bytes {msg {}}} {
     close $file
     close $sock
 }
 socket -server answer $port
 puts "Server ready..."
 vwait forever

And here's a little "CGI" script I tested it with (save as time.tcl):

 # time.tcl - tiny CGI script.
 if ![info exists env(QUERY_STRING)] {set env(QUERY_STRING) " "}
 puts "Content-type: text/html\n"
 puts "<html><head><title>Tiny CGI time server</title></head>
 <body><h1>Time server</h1>
 Time now is: [clock format [clock seconds]]<br>
 Query was: $env(QUERY_STRING)
 <hr>
 <a href=index.htm>Index</a>
 </body></html>"

MS prefers to use fcopy (so that the output proceeds in the background and the server is responsive to new queries while the cgi script is running). - RS: thanks - integrated in the above code :^)


DDG I prefere to use namespaces and I was adding some more MimeTypes because I like and need CSS and JavaScript.

 # DustMotePlusPlus - now about 120 lines of code 
 # with a subset of CGI support
 # namespace dmhttpd and more MimeTypes
 # I borrowed some code from jcw (from the nice wiki webserver)
 # and implemented url2procedure mappings as well
 # try something like /monitor?arg1=1&arg2=2
 # ddg 

 namespace eval dmhttpd {
    variable root      /home/dgroth/html
    variable default   index.htm
    variable port      8088
    variable encoding  iso8859-1
    variable MimeTypes
    array set MimeTypes {
        {}   "text/plain"
        .txt "text/plain"
        .css "text/css"
        .js "text/javascript"
        .htm "text/html;charset=$encoding"
        .html "text/html;charset=$encoding"
        .tml "text/html;charset=$encoding"
        .gif "image/gif"
        .jpg "image/jpeg"
        .ico "image/ico"
        .png "image/png"
    }
 } 
 proc dmhttpd::answer {socketChannel host2 port2} {
    fileevent $socketChannel readable [list ::[namespace current]::serve $socketChannel]
 }

 proc dmhttpd::serve {sock} {
    variable root
    variable MimeTypes
    variable default
    fconfigure $sock -blocking 0
    gets $sock line
    if {[fblocked $sock]} return
    fileevent $sock readable ""
    set tail /
    regexp {(/[^ ?]*)(\?[^ ]*)?} $line -> tail args
    if {[string match */ $tail]} {append tail $default}
    set name [string map {%20 " "} $root$tail]
    if {[info proc $tail] eq "$tail" && $tail ne ""} {
        # Service URL-procedure
        if {[catch {set res [eval {$tail} [QueryMap [string range $args 1 end]]]} err]} {
            puts [format "Error: %s: %s" $tail $err]
        } else {
            # Emit headers
            #
            puts $sock "HTTP/1.0 200 OK"
            puts $sock "Content-Type: text/html\n"
            puts $sock $res
            close $sock
            #cleanupChannel $channel
        }
    } elseif {[file readable $name]} {
        puts $sock "HTTP/1.0 200 OK"
        if {[file extension $name] eq ".tcl"} {
            set ::env(QUERY_STRING) [string range $args 1 end]
            set name [list |tclsh $name]
        } else {
            set ext [string tolower [file extension $name]]
            puts $sock "Content-Type: $MimeTypes($ext)\n"
        }
        set inchan [open $name]
        fconfigure $inchan -translation binary
        fconfigure $sock   -translation binary
        fcopy $inchan $sock -command [list ::[namespace current]::done $inchan $sock]
    } else {
        puts $sock "HTTP/1.0 404 Not found\n"
        close $sock
    }
 }
 proc dmhttpd::done {file sock bytes {msg {}}} {
    close $file
    close $sock
 }
 proc dmhttpd::/monitor {args} {
    # Emit body
    #
    append res [subst {
                <html>
                <body>
                <h3>[clock format [clock seconds]]</h3>
            }]
        
    after 1 ; # Simulate blocking call
    append res "Args: $args [llength $args]"
    
    append res {
        </body>
        </html>
    }
    return $res
 }
 proc dmhttpd::CgiMap {data} {
    # jcw wiki webserver
    # @c Decode url-encoded strings
    
    regsub -all {\+} $data { } data
    regsub -all {([][$\\])} $data {\\\1} data
    regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
    
    return [subst $data]
 }
 proc dmhttpd::QueryMap {query} {
    # jcw wiki webserver
    # @c Decode url-encoded query into key/value pairs
    
    set res [list]
    
    regsub -all {[&=]} $query { }    query
    regsub -all {  }   $query { {} } query; # Othewise we lose empty values
    
    foreach {key val} $query {
        lappend res [CgiMap $key] [CgiMap $val]
    }
    return $res
 } 
 if {[info script] eq $argv0} {
    proc bgerror msg {puts stdout "bgerror: $msg\n$::errorInfo"}
    if {[llength $argv] == 1} {
        set port [lindex $argv 0]
    } else {
        set port 8088
    }
    socket -server ::dmhttpd::answer $port
    puts "Server ready on port $port ..."
    vwait forever
 }