#!/tvbin/tivosh
# $Id: httpd-tt.tcl,v 1.30 2001/09/20 04:04:46 lightn Exp $

setpri fifo 1

source $tcl_library/tv/log.tcl
source $tcl_library/tv/mfslib.tcl
source $tcl_library/tv/dumpobj.tcl

global source_dir
set source_dir [file dirname [info script]]

source $source_dir/httpd-tt.itcl
namespace import TT_HTTPD::*
source $source_dir/html.itcl
source $source_dir/util.itcl

puts "$TT_HTTPD::STARTUP_MESSAGE"

proc register_module {url sdesc ldesc} {
    global module_list
    lappend module_list [list "$url/" $sdesc $ldesc]
}

proc make_menu {} {
    global module_list

    # set module_list [linsert $module_list 0 [list "" "Main Menu" ""]]
    # lappend $module_list 0 [list "quit" "Quit" "Terminate $TT_HTTPD::NAME"]

    set TT_HTTPD::OPTIONS_MENU "\n"
    append TT_HTTPD::OPTIONS_MENU [html_link "/" "Main Menu"]
    append TT_HTTPD::OPTIONS_MENU " |\n"

    set TT_HTTPD::MAIN_MENU "
<TABLE border=0 cellpadding=0 cellspacing=1>
<TR ALIGN=CENTER><TH COLSPAN=2>$TT_HTTPD::NAME v$TT_HTTPD::VERSION</TD></TR>"
    append TT_HTTPD::MAIN_MENU "\n"

    foreach module $module_list {
        append TT_HTTPD::OPTIONS_MENU [html_link "/[lindex $module 0]" [lindex $module 1]]
        append TT_HTTPD::OPTIONS_MENU " |\n"

        append TT_HTTPD::MAIN_MENU [tr "ALIGN=LEFT" [td [html_link "/[lindex $module 0]" [lindex $module 1]]] [td [lindex $module 2]]]
        append TT_HTTPD::MAIN_MENU "\n"
    }

    append TT_HTTPD::OPTIONS_MENU [html_link "/restart" "Restart"]

    append TT_HTTPD::MAIN_MENU [tr "ALIGN=CENTER" [td "COLSPAN=2" ""]]
    append TT_HTTPD::MAIN_MENU "\n"
    append TT_HTTPD::MAIN_MENU [tr "ALIGN=LEFT" [td [html_link "/quit" "Quit"]] [td "Terminate $TT_HTTPD::NAME"]]
    append TT_HTTPD::MAIN_MENU "\n"
    append TT_HTTPD::MAIN_MENU [html_table_end]

}

proc action_restart {chan path env} {
    global reload
    global source_dir
    global module_list
    global tcl_library

    if {[string index $path 0] == "/"} {
        set path [string range $path 1 end]
    }

    if { $path == "" } {
       puts $chan [html_start "Restart"]
       puts $chan [html_table_start "" "" "ALIGN=TOP"]
       puts $chan [tr "" [th "" "Restart"]]
       puts $chan [tr "" [td [html_link "/restart/1" "Quick Reload"]]]
       puts $chan [tr "" [td [html_link "/restart/0" "Full Reload"]]]
       puts $chan [tr "" [td [html_link "/quit" "Quit"]]]
       puts -nonewline $chan [html_table_end]
       puts $chan [html_end]
    } else {
       shaketcl
       set reload $path
       set module_list ""
       puts "Loading modules..."
       set modules [glob "$source_dir/modules/*.itcl"]
       foreach module $modules {
          puts [file rootname [file tail $module]]
          source $module
       }
       make_menu
       puts $chan [html_start "Reload"]
       puts $chan "<B>Reload Complete</B>"
       puts $chan [html_end]
    }
}

proc action_quit {chan dummy env} {
    global quit

    puts $chan [html_start_2 ""]
    puts $chan "Server has terminated."
    puts $chan [html_end]
    set quit ""
}


proc action_ {chan dummy env} {
    puts $chan [html_start_2 ""]
    puts $chan "$TT_HTTPD::MAIN_MENU"
    puts $chan [html_end]
}

proc action_robots {chan dummy env} {
    puts $chan "User-agent: *"
    puts $chan "Disallow: /"
}

proc serve_image {chan imagename head_req last_modified} {
    global db
    global source_dir

    set fd ""
    set imagedata ""
    catch { set fd [open "$source_dir/images/$imagename.png" "r"] }
    if { $fd == "" } {
       if { $last_modified != 0 } {
          set imagedata "cached"
          set moddate $last_modified
       } else {
       RetryTransaction {
          if {[catch {set obj [db $db open "/Resource/Image/$imagename"]}] != 1} {
             if {[catch {set imageid [dbobj $obj get "File"]}] != 1} {
                set imagedata [ mfs get $imageid "tyFile" ]
                if {[catch {set moddate [mfs moddate $imageid]}]} {
                   set moddate ""
                }
             }
          }
       }
       }
    } else {
       set moddate [file mtime "$source_dir/images/$imagename.png"]
    }
    if { ($fd != "") || ($imagedata != "") } {
        if { $head_req == 1 } {
            print_html_header_200 $chan "image/png" $moddate
        } elseif { $last_modified == $moddate } {
            print_html_header_304 $chan
        } else {
            print_html_header_200 $chan "image/png" $moddate
            fconfigure $chan -translation binary
            if { $fd != "" } {
               fconfigure $fd -translation binary
               fcopy $fd $chan
            } else {
               puts -nonewline $chan $imagedata
            }
        }
        if { $fd != "" } {
           close $fd
        }
    } else {
        print_html_header_404 $chan
    }
}

proc session {chan addr port} {
    global db
    set head_req 0
    set post_req 0
    set post_data ""
    set if_modified_since ""
    set last_modified 0
    set content_length 0
    fconfigure $chan -buffering none -blocking 1
    while {[gets $chan line] >= 0} {
        if {$line == ""} {
           if { $post_req == 1 } {
              append post_data [read $chan $content_length]
           }
           break
        }
        if {[regexp -nocase {^kill} $line]  == 1} {
            set quit "puts killed"
            return
        }
        if {[regexp -nocase {^get +([^\?]*)\?*(.*) +http/[0-9]+\.[0-9]+.?$} $line dummy path post_data] == 1} {
            continue
        }
        if {[regexp -nocase {^head +([^\?]*)\?*(.*) +http/[0-9]+\.[0-9]+.?$} $line dummy path post_data] == 1} {
            set quit 1
            return
            set head_req 1
            continue
        }
        if {[regexp -nocase {^post +([^\?]*)\?*(.*) +http/[0-9]+\.[0-9]+.?$} $line dummy path post_data] == 1} {
            set post_req 1
            continue
        }
        if {[regexp -nocase {^Content-length: ([0-9]+)$} $line dummy content_length] == 1} {
            continue
        }
        if {[regexp -nocase {^If-Modified-Since: ([^;]*).*$} $line dummy if_modified_since] == 1} {
            set last_modified [clock scan $if_modified_since]
            continue
        }
    }
    flush $chan
    if {$path == ""} {
        close $chan
        return
    }

    set path [url_decode $path]
    if {[regexp -nocase {/([^/]+)\.png$} $path dummy imagename] == 1} {
        if {[catch [serve_image $chan $imagename $head_req $last_modified] error]} {
            print_html_error $chan "serve_image '$imagename' '$head_req' '$last_modified'" $error
            puts $chan [html_end]
        }
    } elseif {[regexp -nocase {/([^/]+)\.css$} $path dummy stylesheet] == 1} {
        if {[catch [serve_stylesheet $chan $stylesheet $head_req $last_modified] error]} {
            print_html_error $chan "serve_stylesheet '$stylesheet' '$head_req' '$last_modified'" $error
            puts $chan [html_end]
        }
    } else {

        if {$head_req == 1} {
                close $chan
                return
        }

        if {[regexp {^/([-_A-Za-z0-9]*)(.*)} $path dummy action part] == 1} {
            if {[info procs "action_$action"] == "action_$action"} {
                   print_html_header_200 $chan "text/html; charset=iso-8859-1" ""
                   set env [parse_post $post_data]
                   if {[catch [action_$action $chan $part $env] error]} {
                      print_html_error $chan "action_$action '$part' '$env'" $error
                      puts $chan [html_end]
                   }
            } else {
                print_html_header_404 $chan
            }
        } else {
            print_html_header_404 $chan
        }
    }
    catch {flush $chan}
    catch {close $chan}
}

global quit
global db
global startuptime
global module_list
global reload

set dbPoolSize [expr 100 * 1024]
set startuptime [clock seconds]
set quit 0
set db [dbopen $dbPoolSize]
set module_list ""
set reload 0

puts "Loading modules..."
set modules [glob "$source_dir/modules/*.itcl"]
set modules [lsort $modules]

foreach module $modules {
   puts [file rootname [file tail $module]]
   source $module
}

make_menu

# set tcl_traceExec 1
socket -server session 80
puts "Accepting Connections"
vwait quit

puts "$TT_HTTPD::EXIT_MESSAGE"