#!/usr/bin/env tclsh
# DustMote HTTP server originally developed by Harold Kaplan
# (http://wiki.tcl.tk/4333). Modified by Danyil Bohdan.
# This code is in the public domain.
package require Tcl 8.5
package require fileutil
package require snit 2

namespace eval ::dmsnit {
    variable version 0.5.2
}

::snit::type ::dmsnit::httpd {
    # Basic web server configuration.
    option -root \
            -default "" \
            -configuremethod Set-normalized
    option -host localhost
    option -port 8080
    option -default "index.html"
    option -verbose 1
    option -dirlists 1

    # TLS options.
    option -certfile \
            -default public.pem \
            -configuremethod Set-normalized \
            -validatemethod File-exists

    option -keyfile \
            -default private.pem \
            -configuremethod Set-normalized \
            -validatemethod File-exists

    option -tls \
            -default 0 \
            -configuremethod Set-tls

    # The "done" variable. Whoever creates the server object can vwait on this
    # variable using [vwait [$obj wait-var-name]] until a handler changes it to
    # signal that the server's work is done. Setting the variable to a true
    # value does not stop the server. It needs to be explicitly destroyed with
    # [$obj destroy] for that.
    variable done 0
    # Custom route handlers.
    variable handlers {}
    # The command used to create a new server socket.
    variable socketCommand socket
    # The server socket channel. Does not itself transfer data but can be closed
    # to stop accepting new connections.
    variable socketChannel

    constructor {} {}

    destructor {
        variable socketChannel
        close $socketChannel
    }

    # Private methods.

    method File-exists {option value} {
        if {![file isfile $value]} {
            error "file \"$value\" used for option $option doesn't exist"
        }
    }

    method Set-normalized {option value} {
        set options($option) [::fileutil::fullnormalize $value]
    }

    method Set-tls {option value} {
        if {$option ne "-tls"} {
            error "Set-tls is only for setting the option -tls"
        }
        if {$value} {
            package require tls
            ::tls::init \
                    -certfile [$self cget -certfile] \
                    -keyfile  [$self cget -keyfile] \
                    -ssl2 0 \
                    -ssl3 0 \
                    -tls1 1 \
                    -require 0 \
                    -request 1
            set socketCommand ::tls::socket
        } else {
            set socketCommand socket
        }
        set options(-tls) $value
    }

    # Public methods.

    # Create a server socket and start accepting connections.
    method serve {} {
        variable socketCommand
        variable socketChannel

        set root [$self cget -root]
        set host [$self cget -host]
        set port [$self cget -port]
        set tls [$self cget -tls]

        if {$root eq ""} {
            error "no root set"
        }

        set message "serving path $root on $host port $port"
        if {$tls} {
            append message " with TLS"
        }
        $self log $message

        set socketChannel [$socketCommand \
                -server "$self answer" \
                -myaddr $host $port]
    }

    # Print $message to standard output if logging is enabled.
    method log {message} {
        variable verbose
        if {[$self cget -verbose]} {
            puts $message
        }
    }

    # Handle a new connection.
    method answer {connectChannel host2 port2} {
        fileevent $connectChannel readable \
                [list $self read-request $connectChannel]
    }

    method return-file {connectChannel filename} {
        set fileChannel [open $filename RDONLY]
        fconfigure $fileChannel -translation binary
        fconfigure $connectChannel -translation binary -buffering full
        puts $connectChannel "HTTP/1.0 200 OK"
        puts $connectChannel "Content-Type: [::mime::type $filename]"
        puts $connectChannel ""
        fcopy $fileChannel $connectChannel \
                -command [list $self close-channels \
                        $fileChannel $connectChannel]
    }

    method return-404 {connectChannel} {
        puts $connectChannel "HTTP/1.0 404 Not found"
        puts $connectChannel "Content-Type: text/html"
        puts $connectChannel ""
        puts $connectChannel "<!DOCTYPE html>"
        puts $connectChannel "<html><head><title>No such URL</title></head>"
        puts $connectChannel "<body><h1>"
        puts $connectChannel "The URL you requested does not exist."
        puts $connectChannel "</h1></body></html>"
        close $connectChannel
    }

    method return-dir-list {connectChannel path} {
        puts $connectChannel "HTTP/1.0 200 OK"
        puts $connectChannel "Content-Type: text/html"
        puts $connectChannel ""
        puts $connectChannel "<!DOCTYPE html>"
        puts $connectChannel "<html><head><title>Directory listing for\
                [::fileutil::relative [$self cget -root] $path]\
                </title></head>"
        puts $connectChannel "<body>"
        puts $connectChannel {<a href="..">Up a level</a>}
        puts $connectChannel "<ul>"
        foreach filename [glob -nocomplain [file join $path *]] {
            puts $connectChannel [format {<li><a href="%s">%s</a></li>} \
                    /[::fileutil::relative [$self cget -root] $filename] \
                    [file tail $filename]]
        }
        puts $connectChannel "</ul></body></html>"
        close $connectChannel
    }

    # Read an HTTP request from a channel and respond once it can be processed.
    method read-request {connectChannel} {
        variable handlers

        fconfigure $connectChannel -blocking 0

        # Parse the request to extract the filename.
        set gotLine [gets $connectChannel]
        if { [fblocked $connectChannel] } {
            return
        }
        fileevent $connectChannel readable ""
        set shortName "/"
        regexp {GET (/[^ ]*)} $gotLine _ shortName
        set wholeName [::fileutil::jail [$self cget -root] $shortName]

        # Return data.
        if {[dict exists $handlers $shortName]} {
            $self log "Hnd $shortName"
            apply [dict get $handlers $shortName] $connectChannel
        } else {
            # Default file.
            if {[file isdir $wholeName]} {
                set defaultFile [file join $wholeName [$self cget -default]]
                if {[file isfile $defaultFile]} {
                    set $wholeName $defaultFile
                }
            }

            if {[file isfile $wholeName]} {
                $self log "200 $shortName"
                $self return-file $connectChannel $wholeName
            } elseif {[$self cget -dirlists] && [file isdir $wholeName]} {
                $self log "200 $shortName"
                $self return-dir-list $connectChannel $wholeName
            } else {
                    $self log "404 $shortName"
                    $self return-404 $connectChannel
            }
        }
    }

    # Called from read-request to clean up when a file request is completed.
    method close-channels {inChan outChan args} {
        close $inChan
        close $outChan
    }

    # Add a new handler $lambda to be called when a client requests the URL
    # $route. $lambda should be an [apply]-style anonymous function that takes a
    # channel name as its only argument. It is up to the handler to close the
    # channel.
    method add-handler {route lambda} {
        variable handlers
        dict set handlers $route $lambda
    }

    # Return the fully qualified name of the "done" variable for the current
    # object.
    method wait-var-name {} {
        return "${selfns}::done"
    }
}

namespace eval ::mime {
    variable mimeDataInverted {
        text/plain {
            makefile
            COPYING
            LICENSE
            README
            Makefile
            .c
            .conf
            .h
            .log
            .md
            .sh
            .tcl
            .terms
            .tm
            .txt
            .wiki
            .LICENSE
            .README
        }
        text/css                .css
        text/csv                .csv
        image/gif               .gif
        application/gzip        .gz
        text/html {
            .htm
            .html
        }
        image/jpeg {
            .jpg
            .jpeg
        }
        application/javascript  .js
        application/json        .json
        application/pdf         .pdf
        image/png               .png
        application/postscript  .ps
        application/xhtml       .xhtml
        application/xml         .xml
        application/zip         .zip
    }

    variable byFilename {}
    variable byExtension {}
    foreach {mimeType files} $mimeDataInverted {
        foreach file $files {
            if {[string index $file 0] eq "."} {
                lappend byExtension $file $mimeType
            } else {
                lappend byFilename $file $mimeType
            }
        }
    }
    unset mimeDataInverted

    proc ::mime::type {filename} {
        variable byFilename
        variable byExtension
        set tail [file tail $filename]
        set ext [file extension $filename]
        if {[dict exists $byFilename $tail]} {
            return [dict get $byFilename $tail]
        } elseif {[dict exists $byExtension $ext]} {
            return [dict get $byExtension $ext]
        } else {
            return application/octet-stream
        }
    }
}

# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    set httpd [::dmsnit::httpd create %AUTO%]

    # Process command line arguments.
    if {$argv eq ""} {
        set usageString "usage: $argv0"
        foreach option [$httpd info options] {
            set defaultValue [$httpd cget $option]
            if {$defaultValue eq ""} {
                append usageString " $option value"
            } else {
                append usageString " ?$option $defaultValue?"
            }
        }
        puts $usageString
        exit 0
    }

    # # A sample custom handler.
    # $httpd add-handler /bye {
    #     {connectChannel} {
    #         upvar 1 self self
    #         set [$self wait-var-name] 1
    #         close $connectChannel
    #     }
    # }
    $httpd configure {*}$argv
    $httpd serve
    vwait [$httpd wait-var-name]
    $httpd destroy
}