#!/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 "
<TABLE border=0 cellpadding=0 cellspacing=0>
<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

    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 "<B>Reload Complete</B>"
       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 "<P>"
	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<EOF>"
            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"