#!/bin/sh
 # 
 # OTM: One Track Mind, a drop dead simple HTTP server that only does one
 # thing (but tries to always do it well! :-)
 #
 # Written by Michael A. Cleverly, 25 June 2005.  This code is dual-licensed
 # under the "One Line License" and the "No Obligation License".
 #
 #     * Get it, use it, share it, improve it, but don't blame me.
 #       https://wiki.tcl-lang.org/oll
 #
 #     * No obligation for you. No obligation for me.
 #       https://wiki.tcl-lang.org/nol
 #
 # Official web page of OTM: http://blog.cleverly.com/permalinks/158.html
 #
 #\
 exec tclsh "$0" ${1+"$@"}
 
 # FIRST, the default configuration settings
 array set defaults {
     url   {}
     log   /dev/null
     file  {}
     mime  "text/html"
     title "One Track Mind" 
     body  "Hello World." 
     text  ""
     http  200 
     port  8080
     interface 0.0.0.0
 }
 array set config [array get defaults]
 
 # SECOND, process command line switches
 while {[llength $argv]} {
     switch -regexp -- [lindex $argv 0] {
         {(?i)^--?u(rl?)?$}                       {set key url}
         {(?i)^--?l(og?)?$}                       {set key log}
         {(?i)^--?f(i(le?)?)?$}                   {set key file}
         {(?i)^--?m(i(me?)?)?$}                   {set key mime}
         {(?i)^--?ti(t(le?)?)?$}                  {set key title}
         {(?i)^--?b(o(dy?)?)?$}                   {set key body}
         {(?i)^--?te(xt?)?$}                      {set key text}
         {(?i)^--?ht(tp?)?$}                      {set key http}
         {(?i)^--?p(o(rt?)?)?$}                   {set key port}
         {(?i)^--?i((n(t(er?)?)?)?f(a(ce?)?)?)?$} {set key interface}
 
         {(?i)^--?h$} {
             puts stderr "Ambiguous switch --h; did you mean --help or --http ?"             exit 1
         }
 
         {(?i)^--?t$} {
             puts stderr "Ambiguous switch --t; did you mean --text or --title ?"
             exit 1
         }
 
         {^--?\?$}                  -
         {(?i)^--?he(lp?)?$}        {
             proc usage text {catch {puts $text}}
             usage "Usage: [file tail $argv0] ?--switch value ...?"
             usage "Where --switch can be:"
             usage ""
             usage "  --url       http://url.to.redirect/to"
             usage "  --log       /file/to/log/to (use - for stdout)"
             usage "  --file      /name/of/file/to/serve/up (use - for stdin)"
             usage "  --mime      mime/type"
             usage "  --title     title"
             usage "  --body      body"
             usage "  --text      message"
             usage "  --http      code"
             usage "  --port      number ?number ...?"
             usage "  --interface ip-address (0.0.0.0 for all on machine)"
             usage ""
             usage "Default values:"
             usage ""
 
             foreach key [lsort -dictionary [array names defaults]] {
                 if {[string length $defaults($key)] == 0} then continue 
 
                 if {[regexp {\s} $defaults($key)]} then {
                     usage "  --$key \"$defaults($key)\"" 
                 } else {
                     usage "  --$key $defaults($key)"
                 }
             }
             exit 0
         }
 
         default {
             puts stderr "Unknown switch: \"[lindex $argv 0]\" (try --help)"
             exit 1
         }
     }
 
     if {[llength $argv] == 1} then {
         puts stderr "No value given for --$key (try --help)"
         exit 2
     }
 
     set config($key) [lindex $argv 1]
     set argv [lrange $argv 2 end]
 }
 
 # THIRD, open the listening socket
 if {[catch {
     foreach port $config(port) {
         if {![string is integer $port] || $port < 0} then {
             error "Invalid port \"$config(port)\" specified"
         } else {
             socket -server conn -myaddr $config(interface) $port
         }
     }
 } problem]} then {
     puts stderr "Unable to open server listening socket on port $port: $problem"
     exit 3
 }
 
 # FOURTH, determine how to respond to requests
 while 1 {
     if {[string length $config(url)]} then {
         set config(RESPOND) redirect
         set config(http) 302
         set config(mime) "text/html"
         set config(title) Redirection
         set config(body) "<a href='$config(url)'>The URL you requested\
             has moved here</a>."
         break
     }
 
     if {[string length $config(file)]} then {
         if {[string equal $config(file) "-"]} then {
             fconfigure stdin -translation binary
             set config(STDIN) [read stdin]
             set config(RESPOND) send-stdin
         } else {
             if {![file exists $config(file)] ||
                 ![file readable $config(file)]} then {
                 puts stderr "Cannot read $config(file)"
                 exit 4
             }
             set config(RESPOND) send-file
         }
         break
     }
 
     if {[string length $config(text)]} then {
         set config(mime) text/plain
         set config(RESPOND) plain-text
         break
     }
 
     set config(RESPOND) templated-response
     break
 }
 
 # FIFTH, open the log file socket
 if {[string equal $config(log) "-"]} then {
     set config(log_fp) stdout
 } else {
     if {[catch {set config(log_fp) [open $config(log) a]} problem]} then {
         puts stderr "Unable to open log file $config(log): $problem"
         exit 5
     }
 }
 
 
 #-------------------------------------------------------------------------------
 #
 # Handle incoming HTTP requests
 
 # FIRST, accept a connection and place it in non-blocking mode
 proc conn {sock peer port} {
     set after_id [after 10000 cancel $sock]
     fconfigure $sock -blocking 0 -buffering line
     
     set state [-> {} sock $sock after_id $after_id peer $peer]
     fileevent  $sock readable [list request $state]
 }
 
 # SECOND, get the first line (we may need this once we implement logging)
 proc request {state} {
     set sock [<- $state sock]
     if {[eof $sock]} then {return [cancel $sock]}
     set request [gets $sock]
     fileevent $sock readable [list ignore [-> $state request $request]]
 }
 
 # THIRD, read the rest of the HTTP headers one at a time, THEN dispatch response
 proc ignore {state} {
     set sock [<- $state sock]
     if {[eof $sock]} then {return [cancel $sock]}
     if {[gets $sock line] <= 0} then {
         after cancel [<- $state after_id]
         after idle [list dispatch $state]
     }
 }
 
 
 #-------------------------------------------------------------------------------
 #
 # Dispatch routines
 
 proc dispatch {state} {
     set state [-> $state [array get ::config]]
 
     # Was the request line syntactically valid?
     set RE {^(\S+) (\S+)(?: (HTTP/1.\d))?$} 
     if {![regexp -- $RE [<- $state request] => type url ver]} then {
         set grok http://www.dict.org/bin/Dict?Form=Dict2&Database=*&Query=grok
         set state [-> $state http 400 title "Bad Request" body "The server
             could not <a href='$grok'>grok</a> your request."]
 
         return [templated-response $state]
     } else {
         set state [-> $state type $type requested_url $url http_ver $ver]
     }
     
     # Is it a method we know how to support?
     if {![string equal $type GET] && ![string equal $type HEAD]} then {
         set state [-> $state http 501 title "Method Not Implemented" body \
             [quote-html "This server can't support $type requests."]]
 
         return [templated-response $state]
     }
 
     # Schedule a response
     after idle [list [<- $state RESPOND] $state]
 }
 
 # FIRST scenario: handle the case of 302 redirects to a specified -url
 proc redirect {state} {
     set sock [<- $state sock]
     catch {
         set html [templated-html $state]
         server-headers $state Location $::config(url) Content-Length \
             [string length $html]
 
         if {[<- $state type] != "HEAD"} then {
             puts $sock $html
         }
     }
     cancel $sock
 }
 
 # SECOND scenario: spit back out whatever we received on stdin (from a | or <)
 proc send-stdin {state} {
     set sock [<- $state sock]
     catch {
         server-headers $state Content-Length [string length [<- $state STDIN]]
 
         if {[<- $state type] != "HEAD"} then {
             fconfigure $sock -buffering full -translation binary
             puts $sock [<- $state STDIN]
         }
     }
     cancel $sock
 }
 
 # THIRD scenario: return a specific file
 proc send-file {state} {
     set sock [<- $state sock]
     set file [<- $state file]
     if {[<- $state type] == "HEAD"} then {
         if {![catch {file size $file} size]} then {
             catch {server-headers $state Content-Length $size}
         } else {
             catch {server-headers $state}
         }
 
         return [cancel $sock]
     }
 
     if {[catch {open $file} fp]} then {
         if {[file exists $file]} then {
             set state [-> $state http 403 title "Permission Denied" body \
                 "You aren't allowed to access this file--sorry."]
         } else {
             set state [-> $state http 404 title "File Not Found" body \
                 "What was once here is no more, alas."]
         }
         return [templated-response $state]
     }
 
     if {[catch {
         set size [file size $file]
         server-headers $state Content-Length $size
         fconfigure $fp   -buffering full -translation binary 
         fconfigure $sock -buffering full -translation binary 
     } problem]} then {
         cancel $sock
         catch {close $fp}
     } else {
         set state [-> $state fp $fp]
         fcopy $fp $sock -command [list fcopied $state]
     }
 }
 
 # FOURTH scenario: just write out some string of plain text
 proc plain-text {state} {
     set sock [<- $state sock]
     catch {
         set text [<- $state text]
         server-headers $state Content-Length [string length $text]
         if {[<- $state type] != "HEAD"} then {
             puts $sock $text
         }
     }
     cancel $sock
 }
 
 # FIFTH scenario: send a templated response made up from -title and -body
 proc templated-response {state} {
     set sock [<- $state sock]
     catch {
         set html [templated-html $state]
         server-headers $state Content-Length [string length $html]
         if {[<- $state type] != "HEAD"} then {
             puts $sock $html
         }
     }
     cancel $sock 
 }
 
 
 #-------------------------------------------------------------------------------
 #
 # Logging
 
 proc log {state} {
     set dateFmt "%e/%b/%Y:%H:%M:%S -0000"
     set message [format {%s - - [%s] "%s %s %s" %d %s} \
         [<- $state peer] \
         [clock format [<- $state now] -format $dateFmt -gmt 1] \
         [<- $state type] \
         [<- $state requested_url] \
         [<- $state http_ver] \
         [<- $state http] \
         [<- $state length "-"]]
 
     catch {puts [<- $state log_fp stderr] $message}
 }
 
 
 #-------------------------------------------------------------------------------
 #
 # Helper/Convenience procedures
 
 proc server-headers {state args} {
     set sock [<- $state sock]
     set state [-> $state now [set now [clock seconds]]]
 
     if {[catch {
         set date [clock format $now -format "%a, %d %b %Y %H:%M:%S %Z"]
         puts $sock "HTTP/1.0 [<- $state http] OTM"
         puts $sock "Content-Type: [<- $state mime]"
         puts $sock "MIME-Version: 1.0"
         puts $sock "Server: OTM = One Track Mind"
         puts $sock "X-PID: [pid]"
         puts $sock "Connection: close"
         puts $sock "Date: $date"
     
         foreach {key val} $args {
             puts $sock [format "%s: %s" $key $val]
             if {[string equal $key "Content-Length"]} then {
                 set state [-> $state length $val]
             }
         }
     
         puts $sock ""
     } problem]} then {
         set state [-> $state http 500]
         log $state
         error $problem
     } else {
         log $state
     }
 }
 
 proc quote-html {html} {
     return [string map [list "&" "&amp;" "<" "&lt;" ">" "&gt;"] $html]
 }
 
 proc templated-html {state} {
     if {[regexp {^[^23]} [<- $state http]]} then {
         set padding [format {
             MSIE is our worst enemy; if this is an error page, and the
             size of the page isn't huge then it will show one of it's 
             so called "friendly" error pages instead.  So we'll include
             a bunch of padding... 
     
             PADDING = %s
         } [string repeat " [pid] " 1500]]
     } else {
         set padding "Generated by OTM, the One Track Mind webserver..."
     }
 
     return [format {
         <html>
         <head>
         <title>%1$s</title>
         </head>
         <body bgcolor='white' text='black'>
         <!-- %3$s -->
         <h1>%1$s</h1>
         %2$s
         </body>
         </html>
     } [quote-html [<- $state title]] [<- $state body] $padding]
 }
 
 proc fcopied {state args} {
     catch {close [<- $state fp]}
     cancel [<- $state sock]
 }
 
 proc cancel {sock} {
     catch {close $sock}
 }
 
 proc -> {state args} {
     array set data $state
     if {[llength $args] == 1} then {set args [lindex $args 0]}
     foreach {key val} $args {
         set data($key) $val
     }
     return [array get data]
 }
 
 proc <- {state key {default {}}} {
     array set data $state
     
     if {[info exists data($key)]} then {
         return $data($key)
     } else {
         return $default
     }
 }
 
 #-------------------------------------------------------------------------------
 #
 # Enter the event loop to begin servicing requests
 
 vwait forever