#!/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.
#       http://wiki.tcl.tk/oll
#
#     * No obligation for you. No obligation for me.
#       http://wiki.tcl.tk/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