#!/tvbin/tivosh
# $Id: httpd-tt.tcl,v 1.51.2.22 2002/12/12 01:07:44 mbm Exp $
#
# LJ added code to log accesses from outside the local network. 04Jan03 14:32
if {[pool pool0 size] <= 1458176} {
puts "Use the 'tivoweb' script to start tivoweb"
exit
}
setpri fifo 1
catch {EnableTransactionHoldoff true}
set mfsVerboseG 0
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
source $source_dir/util.itcl
puts "$TT_HTTPD::STARTUP_MESSAGE"
proc register_module {url sdesc ldesc} {
global module_list
if { [string first "." $url] == -1 } {
lappend module_list [list "$url/" $sdesc $ldesc]
} else {
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 "
$TT_HTTPD::NAME v$TT_HTTPD::VERSION |
"
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
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 {
set reload $path
# puts "Loading modules..."
puts $chan [html_start "Reload"]
puts $chan "Reload Complete"
puts $chan [html_end]
}
}
proc action_quit {chan dummy env} {
set ::reload "quit"
puts $chan [html_start ""]
puts $chan "Server has terminated."
puts $chan [html_end]
}
proc action_ {chan dummy env} {
puts $chan [html_start ""]
puts $chan "$TT_HTTPD::MAIN_MENU"
puts $chan ""
puts $chan [html_link "http://tivo.lightn.org/" "Official Homepage for TivoWeb"]
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
global tzoffset
global tivoswversion
global startuptime
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]
if {$filename == "$TT_HTTPD::STYLE.css"} {
set secs [expr [clock seconds] + $tzoffset]
if {[clock format $secs -format "%m"] == 10 && [clock format $secs -format "%d"] == 31} {
if {$last_modified != $startuptime} {
print_html_header_200 $chan $mimetype $startuptime
puts $chan $::altcss
return
}
}
}
set fd ""
catch { set fd [open "$directory/$filename" "r"] }
if { $fd != "" } {
set moddate [file mtime "$directory/$filename"]
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
}
}
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 ""
set moddate ""
catch { set fd [open "$source_dir/images/$imagename.png" "r"] }
if { $fd != "" } {
set moddate [file mtime "$source_dir/images/$imagename.png"]
} else {
catch {
RetryTransaction {
set imagefsid [lindex [mfs find "/Resource/Image/$imagename"] 0]
set moddate [mfs moddate $imagefsid]
if {$moddate != $last_modified} {
set obj [db $db openid $imagefsid]
if {$obj != ""} {
set imageid [dbobj $obj get File]
if {$imageid != ""} {
set imagedata [mfs get $imageid]
}
}
} else {
set imagedata "cached"
}
}
}
}
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 decode_upload {chan content_boundary content_length} {
global source_dir
upvar post_data post_data
global block
set boundary "--$content_boundary"
set blen [expr [string length $boundary]+2]
set len $content_length
set block 2048
set fp ""
set key ""
set header ""
fconfigure $chan -translation binary
set buffer ""
while { $len > 0 } {
set rlen $block
if {$len < $rlen} { set rlen $len }
incr len -$rlen
append buffer [read $chan $rlen]
set ret [string first $boundary $buffer]
while { $ret != -1 } {
if {$fp != ""} {
if {$ret > 0} {puts -nonewline $fp "[string range $buffer 0 [expr $ret -1]]"}
close $fp
} elseif {$key != ""} {
if {$post_data != ""} { append post_data "\&" }
append post_data "$key=[string range $buffer 0 [expr $ret -1]]"
}
set fp ""
set key ""
# Crop off the boundary string
# Careful not to bisect headers
# ie "--BOUND Con"
set tmp [expr $ret+$blen]
set ret [string first "\r\n\r\n" $buffer]
if {$ret > $tmp || $ret < 0} {
set buffer [string range $buffer $tmp end]
incr ret -$tmp
set header ""
}
if {$ret > 0} { ;# Parse header
if { $header == "" } {
set filename ""
set name ""
set key ""
set header "[string range $buffer 0 [expr $ret -1]]"
if {[regexp -nocase {^Content-Disposition:.*\ name="([^"]*)\"} $header junk name] ==1} {
if {[regexp -nocase {.*filename="([^"]*)\"} $header junk filename] == 1} {
#some browsers give the full path
#discard path and give just the filename.
regexp -nocase {[\\/]?([^\\/]*)$} $filename dummy filename
}
set key [httpMapReply $name]
if {$filename != ""} {
set fp [open "$source_dir/uploads/$filename" w]
fconfigure $fp -translation binary
if {$post_data != ""} { append post_data "\&" }
append post_data "$key=$filename"
}
} else {
#clear invalid headers
set header ""
}
}
set buffer [string range $buffer [expr $ret+4] end]
}
if {$boundary == "--$content_boundary"} {
set boundary "\r\n--$content_boundary"
set blen [expr [string length $boundary]+2]
}
#setup the whole loop again
set ret [string first $boundary $buffer]
}
set slen [string length $buffer]
# spit out block bytes if possible, otherwise just the remaining bytes
# we need to preserve $blen bytes in the buffer to deal with edge
# conditions
# NOTE: if we aren't writing to a file we just let the buffer fill
if { $fp != "" } {
if {$slen > $block + $blen || $rlen < $block } {
puts -nonewline $fp "[string range $buffer 0 [expr $block -1]]"
set buffer [string range $buffer $block end]
}
}
}
fconfigure $chan -buffering none -blocking 1
}
proc session {chan addr port} {
#global db
#global source_dir
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
#LJ
set ljdata ""
# added by JAKE -
# http_upload - flag indicates if body has multipart form to parse
# content_boundary - holds the boundary text between the parts
set http_upload 0
set content_boundary ""
fconfigure $chan -buffering none -blocking 1
while {[gets $chan line] >= 0} {
if {$line == ""} {
if { $post_req == 1 } {
#added by JAKE - check to see if there is a multipart form
#if so, parse it, if not, handle as TivoWeb always did.
if {$http_upload == 1} {
decode_upload $chan $content_boundary $content_length
} else {
#Just another POST (standard httpd-tt code)
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} {
#LJ
if {$::userpass != "" && $auth == 0} {
append ljdata "$line "
}
#LJ
continue
}
if {[regexp -nocase {^head +([^\?]*)\?*(.*) +http/[0-9]+\.[0-9]+.?$} $line dummy path post_data] == 1} {
# set quit 1
# return
set head_req 1
#LJ
if {$::userpass != "" && $auth == 0} {
append ljdata "$line "
}
#LJ
continue
}
if {[regexp -nocase {^post +([^\?]*)\?*(.*) +http/[0-9]+\.[0-9]+.?$} $line dummy path post_data] == 1} {
set post_req 1
#LJ
if {$::userpass != "" && $auth == 0} {
append ljdata "$line "
}
#LJ
continue
}
if {[regexp -nocase {^Content-length: ([0-9]+)$} $line dummy content_length] == 1} {
#LJ
if {$::userpass != "" && $auth == 0} {
append ljdata "$line "
}
#LJ
continue
}
#Content-type added by JAKE - The content-type header is present
#and has multipart/form data. set the http_upload flag, and
#get the boundary string.
if {[regexp -nocase {^Content-Type: multipart/form-data; boundary=(.*)$} $line junk content_boundary] == 1} {
set http_upload 1
#LJ
if {$::userpass != "" && $auth == 0} {
append ljdata "$line "
}
#LJ
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
} else {
#LJ
append ljdata "$line "
}
#LJ
continue
}
}
if {[regexp -nocase {^If-Modified-Since: ([^;]*).*$} $line dummy if_modified_since] == 1} {
set last_modified [clock scan $if_modified_since]
#LJ
if {$::userpass != "" && $auth == 0} {
append ljdata "$line "
}
#LJ
continue
}
}
if {$::userpass != "" && $auth == 0} {
#LJ
set ifinfo [exec ifconfig -i]
set myaddr [string range $ifinfo [expr [string first "inet addr:" $ifinfo] + 10] end]
set myaddr [string range $myaddr 0 [expr [string first " " $myaddr] - 1]]
scan $myaddr "%d.%d.%d.%d" ma1 ma2 ma3 ma4
set mymask [string range $ifinfo [expr [string first "Mask:" $ifinfo] + 5] end]
set mymask [string trimright [string range $mymask 0 [expr [string first " " $mymask] - 1]]]
scan $mymask "%d.%d.%d.%d" mm1 mm2 mm3 mm4
scan $addr "%d.%d.%d.%d" ad1 ad2 ad3 ad4
if {($ma1 & $mm1) == ($ad1 & $mm1) && \
($ma2 & $mm2) == ($ad2 & $mm2) && \
($ma3 & $mm3) == ($ad3 & $mm3) && \
($ma4 & $mm4) == ($ad4 & $mm4) } {
puts "Access from local net: $addr\:$port"
} else {
if {[catch {set logfile [open "/var/log/httpd" a+ 0666]}]} {
puts $chan "Couldn't open /var/log/httpd to log access from external net!"
} else {
puts $logfile "[clock format [clock seconds] -format "%Y%m%d:%H%M%S"] $addr\:$port $ljdata"
flush $logfile
close $logfile
}
}
#LJ
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 {
regsub -all {\\.} $path {.} path
if {$head_req == 1} {
catch {close $chan}
return
}
if {$::url_prefix != ""} {
if {[regexp "^/$::url_prefix" $path] == 1} {
set path [string range $path [string length $::url_prefix] end]
}
}
if {[regexp {^/([-_A-Za-z0-9]*)(.*)} $path dummy action part] == 1 &&
[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 {eval {::action_$action $chan $part $env}}]} {
print_html_error $chan "action_$action '$part' '$env'" $::errorInfo
puts $chan [html_end]
}
} else {
print_html_header_404 $chan
}
}
catch {flush $chan}
catch {close $chan}
}
proc readconfig {} {
global userpass
global source_dir
global http_port
global url_prefix
global description_hover
global multi_delete
set user ""
set pass ""
set http_port 80
set url_prefix ""
set default_theme "technophobe"
set description_hover 1
set multi_delete 1
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} {
set varname [string tolower $varname]
set value [string trim $value "\"'"]
if {[string compare "username" $varname] == 0} {
set user $value
} elseif {[string compare "password" $varname] == 0} {
set pass $value
} elseif {[string compare "port" $varname] == 0} {
set http_port $value
} elseif {[string compare "prefix" $varname] == 0} {
set url_prefix $value
if {[string range $url_prefix end end] != "/"} {
append url_prefix "/"
}
if {[string index $url_prefix 0] == "/"} {
set url_prefix [string range $url_prefix 1 end]
}
} elseif {[string compare "theme" $varname] == 0} {
regsub ".css$" $value {} value
if { $value != "" } {
catch { set fd2 [open "$source_dir/$value.css" "r"] }
if { $fd2 != "" } {
set default_theme $value
close $fd2
}
}
} elseif {[string compare "descriptionhover" $varname] == 0} {
set value [string tolower $value]
if {[string compare "yes" $value] == 0 ||
[string compare "on" $value] == 0 ||
[string compare "true" $value] == 0 ||
$value == "1"} {
set description_hover 1
} elseif {[string compare "no" $value] == 0 ||
[string compare "off" $value] == 0 ||
[string compare "false" $value] == 0 ||
$value == "0"} {
set description_hover 0
}
} elseif {[string compare "multidelete" $varname] == 0} {
set value [string tolower $value]
if {[string compare "yes" $value] == 0 ||
[string compare "on" $value] == 0 ||
[string compare "true" $value] == 0 ||
$value == "1"} {
set multi_delete 1
} elseif {[string compare "no" $value] == 0 ||
[string compare "off" $value] == 0 ||
[string compare "false" $value] == 0 ||
$value == "0"} {
set multi_delete 0
}
} else {
puts "Config option not recognized: '$line'"
}
}
set line [gets $fd]
}
close $fd
}
if {[string length $user] > 0 && [string length $pass] > 0} {
set userpass "$user:$pass"
} else {
set userpass ""
}
if {$TT_HTTPD::STYLE == "" } {
set TT_HTTPD::STYLE $default_theme
}
}
proc get_tzoffset {mfstz dst} {
if { $mfstz <= 0 } {
set tz $mfstz
} else {
set tzlist "-5 -6 -7 -8 -9 -10 0 1 2 3 4 5 6 7 8 9 10 11 12 -1 -2 -3 -4 -11 -12"
set tz [lindex $tzlist [expr $mfstz - 1]]
}
if { $dst == 2 } {
set date [clock format [clock seconds] -format "%1d %w %1m %1H %1M"]
scan $date "%d %d %d %d %d" dom dow month hour min
set dlsval 0
if {$::uktivo} {
if {$month > 3 && $month < 10} {
set dlsval 1
} elseif {$month == 3 && $dom >= 25 && $dow == 0 && $hour >= 1} {
set dlsval 1
} elseif {$month == 3 && $dom >= 25 && $dow != 0 && ($dom-24-$dow >= 1) } {
set dlsval 1
}
} else {
if {$month > 4 && $month < 10} {
set dlsval 1
} elseif {$month == 4 && $dom > 7} {
set dlsval 1
} elseif {$month == 4 && $dom <= 7 && $dow == 0 && $hour >= 2} {
set dlsval 1
} elseif {$month == 4 && $dom <= 7 && $dow != 0 && ($dom-$dow > 0)} {
set dlsval 1
}
}
if {$dlsval == 0} {
if {$month == 10 && $dom < 25} {
set dlsval 1
} elseif {$month == 10 && $dom >= 25 && $dow == 0 && $hour < 2} {
set dlsval 1
} elseif {$month == 10 && $dom >= 25 && $dow != 0 && ($dom-24-$dow < 1) } {
set dlsval 1
}
}
if {$dlsval == 1} {
return [expr ($tz+1)*60*60]
} else {
return [expr $tz*60*60]
}
} else {
return [expr $tz*60*60]
}
}
global db
global startuptime
global module_list
global reload
global tivoswversion
global content_suffix_list
global content_handler_list
global version3
global dtivo
global uktivo
set dbPoolSize [expr 300 * 1024]
set startuptime [clock seconds]
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]
set setup [db $db open /Setup]
if { [string range $tivoswversion 0 2] >= 3.0 } {
set version3 1
} else {
set version3 0
}
if {[PrefixMatches "2.5.5" $::tivoswversion]} {
set uktivo 1
} else {
set uktivo 0
}
set suffix [string range $tivoswversion [expr [string length $tivoswversion] - 3] end]
if { [lsearch "001 011 031" $suffix] >= 0 } {
set dtivo 1
} else {
set dtivo 0
}
if { [PrefixMatches "2.5-" $tivoswversion] } {
puts "Error: This version is not supported"
exit
}
if {$::version3} {
set lconfig [db $db open /State/LocationConfig]
set setup [db $db open /State/ServiceConfig]
set setuptz [dbobj $lconfig get TimeZoneOld]
set daylightsavings [dbobj $lconfig get DaylightSavingsPolicy]
} else {
set setuptz [dbobj $setup get TimeZone]
set daylightsavings [dbobj $setup get DaylightSavingsPolicy]
} ;[base64dec]
if {$setuptz == ""} {
set setuptz 0
}
if {$daylightsavings == ""} {
set daylightsavings 2
}
}
set tzoffset [get_tzoffset $setuptz $daylightsavings]
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
set sock ""
while { $reload != "quit" } {
source $source_dir/html.itcl
source $source_dir/util.itcl
readconfig
if { $sock != "" } { close $sock }
set sock [socket -server ::session $http_port]
#set tcl_traceExec 1
puts "Loading modules..."
set module_list ""
set modules [glob "$source_dir/modules/*.itcl"]
set modules [lsort $modules]
foreach module $modules {
set errorCode ""
set errorInfo ""
puts [file rootname [file tail $module]]
shaketcl
if {[catch { source $module }]} {
puts "$errorCode $errorInfo"
}
}
make_menu
puts "Accepting Connections"
vwait reload
}
puts "$TT_HTTPD::EXIT_MESSAGE"