#!/tvbin/tivosh
# $Id: httpd-tt.tcl,v 1.38.2.1 2001/12/05 08:53:55 lightn Exp $

setpri fifo 1
EnableTransactionHoldoff true

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 "/restart" "Restart"]] [td "Reload or Quit $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
    global db

    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 {
       dbclose $db
       shaketcl
       set db [dbopen]
       set reload $path
       set module_list ""
       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
       readconfig
       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 ""]
    puts $chan "Server has terminated."
    puts $chan [html_end]
    set quit ""
}


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

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

proc register_content_handler {suffix mimetype directory binary function} {
    global content_suffix_list
    global content_handler_list

    lappend content_suffix_list $suffix
    lappend content_handler_list [list $mimetype $directory $binary $function]
}

proc serve_file {chan filename head_req last_modified} {
    global db
    global source_dir
    global content_suffix_list
    global content_handler_list

    set suffix [file extension $filename]
    if {[string index $suffix 0] == "."} {
        set suffix [string range $suffix 1 end]
    }
    set index [lsearch $content_suffix_list $suffix]
    set clist [lindex $content_handler_list $index]
    set mimetype [lindex $clist 0]
    set directory [lindex $clist 1]
    set binary [lindex $clist 2]

    set fd ""
    set filedata ""
    catch { set fd [open "$directory/$filename" "r"] }
    if { $fd == "" } {
       if { $last_modified != 0 } {
          set filedata "cached"
          set moddate $last_modified
       }
    } else {
       set moddate [file mtime "$directory/$filename"]
    }
    if { ($fd != "") || ($filedata != "") } {
        if { $head_req == 1 } {
            print_html_header_200 $chan $mimetype $moddate
        } elseif { $last_modified == $moddate } {
            print_html_header_304 $chan
        } else {
            print_html_header_200 $chan $mimetype $moddate
            if { $binary == 1 } {
               fconfigure $chan -translation binary
            }
            if { $fd != "" } {
               if { $binary == 1 } {
                  fconfigure $fd -translation binary
               }
               fcopy $fd $chan
            } else {
               puts -nonewline $chan $filedata
            }
        }
        if { $fd != "" } {
           close $fd
        }
    } else {
        print_html_header_404 $chan
    }
}

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

    set imagename [file rootname $imagename]
    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
    global userpass
    global content_suffix_list
    global content_handler_list

    set auth 0
    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 {$userpass != ""} {
            if {[regexp -nocase {^Authorization: +Basic +([A-Za-z0-9+/=]+)$} $line dummy authcode] == 1} {
                set authdecode [base64dec $authcode]
                if { $authdecode == $userpass } {
                   set auth 1
                }
	        continue
            }
        }
        if {[regexp -nocase {^If-Modified-Since: ([^;]*).*$} $line dummy if_modified_since] == 1} {
            set last_modified [clock scan $if_modified_since]
            continue
        }
    }
    catch {flush $chan}
    if {$path == ""} {
        catch {close $chan}
        return
    }

    if {$userpass != "" && $auth == 0} {
        print_html_header_401 $chan
        catch {flush $chan}
        catch {close $chan}
        return
    }

    set path [url_decode $path]
    if {[regexp -nocase {/([^/]+)\.([A-Z0-9]+)$} $path dummy filename suffix] == 1} {
        set index [lsearch $content_suffix_list $suffix]
        if { $index >= 0 } {
            set function [lindex [lindex $content_handler_list $index] 3]
            if {[catch [$function $chan "$filename.$suffix" $head_req $last_modified] error]} {
                print_html_error $chan "$function '$filename.$suffix' '$head_req' '$last_modified'" $error
                puts $chan [html_end]
            }
        } else {
            print_html_header_404 $chan
        }
    } else {
        if {$head_req == 1} {
            catch {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}
}

proc readconfig {} {
    global userpass
    global source_dir

    set user ""
    set pass ""
    if {[catch {set fd [open "$source_dir/tivoweb.cfg" "r"]}]} {
        puts "Error opening configuration file 'tivoweb.cfg'"
    } else {
        set line [gets $fd]
        while { ![eof $fd] } {
            if {[regexp -nocase {^([^ ]+) *= *(.*)$} $line dummy varname value] == 1} {
                if {[string compare "UserName" $varname] == 0} {
                    set user $value
                }
                if {[string compare "Password" $varname] == 0} {
                    set pass $value
                }
            }
            set line [gets $fd]
        }
        close $fd
    }

    if {[string length $user] > 0 && [string length $pass] > 0} {
        set userpass "$user:$pass"
    } else {
        set userpass ""
    }
}

global quit
global db
global startuptime
global module_list
global reload
global tivoswversion
global content_suffix_list
global content_handler_list

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

RetryTransaction {
   set swsystem [db $db open /SwSystem/ACTIVE]
   set tivoswversion [dbobj $swsystem get Name]
}

readconfig

register_content_handler "js" "text/javascript" "$source_dir" 0 serve_file
register_content_handler "css" "text/css" "$source_dir" 0 serve_file
register_content_handler "png" "image/png" "$source_dir/images" 1 serve_image

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"