#!/usr/bin/tclsh
# OpenVerse Server Program
# Modified by Andy Goth <unununium@openverse.org>
# Now it runs a GothChess room!
# 
#
# Module Name		- OpenVerse standard server procs
# Current Maintainter 	- Andy Goth <unununium@openverse.org>
# Sourced By		- gothchess.tcl
#
# Copyright (C) 1999 David Gale <cruise@openverse.org>
# For more information visit http://OpenVerse.org/
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307,
# USA.

global MVS tcl_interactive

#
# Setup some server variables. Please see the bottom of this document for
# a complete list of variables which the server will use.
#
set MVS(waiter) 1
set MVS(serving) 1
set MVS(users) 0
set MVS(socks) {}
set MVS(entry_registry) {}
set MVS(submit_registry) {}
set MVS(registry.servers) {}

if {!$tcl_interactive} {
    # Stuff for commandline-only mode
    set MVS(standalone) 1
    global argv0 argv
    set app "$argv0"
    set app "./gothchess.tcl"
    catch {set app [file readlink $app]}
    set MVS(homedir) "[file dirname $app]"
    set MVS(configfile) "$MVS(homedir)/$argv"
    unset app
    # Path sanity checker.
    #
    # Usage: is_path "pathname"
    #
    # Checks a path to be sure it passed sane rules. It will return 1
    # if this path passes or else it will return 0 if it does not
    # pass.
    #
    # Only defined if running standalone. (command line daemon)
    #
    # Checked for maximum memory efficiency 12/09/1999 13:59
    #
    proc is_path {what} {
	if {[string first "../" $what] != -1} {
	    unset what
	    return 0
	}
	if {[string first "//" $what] != -1} {
	    unset what
	    return 0
	}
	if {[string first "~/" $what] != -1} {
	    unset what
	    return 0
	}
	if {[string range $what 0 0] == "/"} {
	    unset what
	    return 0
	} else { 
	    unset what
	    return 1
	}
    }
} else {
    # Stuff for GUI
    set MVS(standalone) 0
    set MVS(homedir) $homedir
    set MVS(configfile) "$MVS(homedir)/pserver.cfg"
    set argv "Sourced!"
}

#
# Central Logging Facility
#
# Usage: log_it "Text To Log"
#
# Everything uses this so we must define it first.
#
# Checked for maximum Memmory Efficiency on 12/09/1999 13:33
#
proc log_it {text} {
    global MVS

    if $MVS(standalone) {
	# We are running from a command line
	puts $text
    } else {
	# We are running from a gui
	if {[winfo exists .ovserver]} {
	    .ovserver.log insert end "$text\n"
	    .ovserver.log see end
	    # TODO (6) Check for number of lines and trim.
	}
    }
    unset text
}

#
# Send text to ALL users.
#
# Usage: Send_to_all_users "Text To Send"
#
# This function will send the provided text to all connected users. The
# text should be pre-formated and ready to go.
#
# Checked for maximum memory efficiency 12/09/1999 13:36
#
proc send_to_all_users {what} {
    global MVS
	
    foreach sckt $MVS(socks) {
	if [string compare $MVS($sckt.name) "*"] {
	    log_it "($sckt) <-- $what"
	    catch {puts $sckt "$what"}
	}
    }
    unset what
}

# Send Text To a Connected User
#
# Usage: send_to_user socket "text to send"
#
# This function will send the provided text to the user specified
# It should be pre-formated and ready to go.
#
proc send_to_user {who what} {
    log_it "($who) <-- $what"
    catch {puts $who "$what"}
    unset who what
}

# Disconnect users from the system.
#
# Usage: disconnect_user socket announce_disconnect
#
# This function is used to disconnect a user from the system.
# A general cleanup will be done with the variables the user was
# consuming and an annoucement will be made to all connected users if it
# is requested with the announce_disconnect parameter (set to 1)
#
# Checked for maximum memmory efficiency 12/09/1999 19:20
#
proc disconnect_user {who announce} {
    global MVS
	
    if {[lsearch -exact $MVS(socks) $who] == -1} {return}

    log_it "($who) <-> Disconnected! $MVS($who.address):$MVS($who.port)"
    incr MVS(users) -1
    if !$MVS(standalone) {
	.ovserver.buttons.info.v configure -text $MVS(users)
    }
    catch {close $who}
    log_it "(!) --- SOCKET_CLOSE $who"
    set which [lsearch -exact $MVS(socks) $who]
    set MVS(socks) [lreplace $MVS(socks) $which $which]

    if $announce {
	foreach sckt $MVS(socks) {
	    send_to_user $sckt "NOMORE $MVS($who.name)"
	}

	# GothChess cleanup
	on_part $who
    }
    #
    # Clean up the mess this user made!
    #
    catch {
	uplevel #0 unset MVS($who.name) MVS($who.address) MVS($who.port) \
	    MVS($who.ping) MVS($who.ping_response) MVS($who.x) \
	    MVS($who.y) MVS($who.avatar) MVS($who.av_head_x) \
	    MVS($who.av_head_y) MVS($who.av_baloon_x) \
	    MVS($who.av_baloon_y) MVS($who.downloads)
    }
    #
    # TODO (7) Downloads in progress should be canceled!
    #
    unset which who announce
}

# (re)Load the server config file.
#
# Usage: load_config
#
# This function will (re)load the server config file. Any changes will
# take effect at the time of reload.
#
# Checked for maximum memory efficiency 12/09/1999 15:35
#
proc load_config {} {
    global MVS

    log_it "------------ Loading Config File -----------"

    set MVS(port) "7000"
    set MVS(timeout) 120
    set MVS(roomname) "GothChess"
    set MVS(avatars) "$MVS(homedir)/simages"
    set MVS(sobjects) "$MVS(homedir)/sobjects"
    set MVS(tickler) "$MVS(homedir)/TickleMe"
    set MVS(images) "$MVS(homedir)/images"
    set MVS(icons) "$MVS(homedir)/icons"
    set MVS(maxwidth) "150"
    set MVS(maxheight) "150"
    set MVS(roomdir) "$MVS(homedir)/rooms"
    set MVS(roomfile) "gothchess.gif"
    set MVS(sendbuffer) 4096
    set MVS(maxmsglen) 256
    set MVS(locations) {}
    # Create required directories.

    if ![file exists $MVS(avatars)] {file mkdir "$MVS(avatars)"}
    if ![file exists $MVS(sobjects)] {file mkdir "$MVS(sobjects)"}
    if ![file exists $MVS(images)] {file mkdir "$MVS(images)"}
    if ![file exists $MVS(roomdir)] {file mkdir "$MVS(roomdir)"}
    if ![file exists $MVS(icons)] {file mkdir "$MVS(icons)"}

    if [file exists "$MVS(configfile)"] {source $MVS(configfile)}
    if [file exists "$MVS(tickler)"] {
	catch {file delete -force "$MVS(tickler)"}
    }
    send_to_all_users "ROOMNAME $MVS(roomname)"
    send_to_all_users "ROOM $MVS(roomfile) [file size "$MVS(roomdir)/$MVS(roomfile)"]"
}

# No named configuration file
if {![string compare $argv ""]} {
    log_it "Usage: gothchess.tcl <Config File>"
    exit
}

# Load the configuration file
load_config

# Initialize server socket
set MVS(server_socket) [socket -server new_connect $MVS(port)]
log_it "(!) --- SOCKET_OPEN $MVS(server_socket)"

# Accept New Connections.
#
# Usage: new_connect socket address port
#
# This function will accept a new connection and setup some initial
# variables for the user. It will also set a trigger on the incoming
# socket which will read data on the socket.
#
# checked for maximum memory efficiency 12/09/1999 18:07
#
proc new_connect {sck address port} {
    global MVS

    log_it "($sck) <-> New Connection! $address:$port"

    fconfigure $sck -blocking 0 -buffering line
    fileevent $sck readable "server_read_from $sck"
    if {$MVS(users) >= 2} {
	send_to_user $sck "ROOMFULL"
	close $sck
	unset sck address port
	return
    }
    if {[lsearch $MVS(socks) $sck] == -1} {
	lappend MVS(socks) $sck
    } else {
	close $sck
	unset sck address port
	return
    }

    set MVS($sck.name) "*"
    set MVS($sck.address) "$address"
    set MVS($sck.port) "$port"
    set MVS($sck.ping) 0
    set MVS($sck.ping_response) [clock seconds]
    set MVS($sck.x) -1
    set MVS($sck.y) -1
    set MVS($sck.avatar) "*connecting*"
    set MVS($sck.av_head_x) "-1"
    set MVS($sck.av_head_y) "-1"
    set MVS($sck.downloads) {}
    incr MVS(users)
    if !$MVS(standalone) {
	# If running in a GUI, display how many users are connected
	.ovserver.buttons.info.v configure -text $MVS(users)
    }

    unset sck address port
}

#
# Check name validity.
#
# Usage: is_name "NickName"
#
# this function will check a given nickname to be sure it is allowed. Some
# nicknames are not allowed if they contain special characters.
#
# Checked for maximum memory efficiency 12/09/1999 18:20
#
proc is_name {name} {
    if {[string trim $name] == "" || \
	    [string trim $name] == "*" || \
	    [string trim $name] == "." || \
	    [string range $name 0 0] == "-"} {
	unset name
	return 0
    } else {
	unset name
	return 1
    }
}

# Read Incomming Text
# 
# Usage: serv_read_from socket
#
# This function will read text from a socket and process it. If the user
# is not authenticated, it will authenticate them. If the user is just
# requesting a number of connected users, this function will process the
# request. If it has nothing to do other than to read the text, it will
# pass this text off to the server_process_input function for processing.
#
# Checked for maximum memmory efficience on 12/09/1999 18:27
#
proc server_read_from {who} {
    global MVS chess
	
    set input ""
    catch {gets $who input}
    # Update before we process anything!
    if {[eof $who] == 1} {
	if {![string compare $MVS($who.name) "*"]} {
	    disconnect_user $who 0
	} else {
	    disconnect_user $who 1
	}
	unset input who
	return
    }

    if {![string compare $MVS($who.name) "*"]} {
	# User is not logged in yet.
	log_it "(?) --> $input"
	set srv_cmd [lindex [split $input " "] 0]
	switch -- $srv_cmd {
	    "USERS" {
		# Tell how many users are connected
		send_to_user $who "USERS $MVS(users)"
		disconnect_user $who 0
		return
	    }
	    "AUTH" {
		# For now allow it to just pass through.
		# User auth needs to be broken out of this
		# function and sent to its own function.
	    }
	    default {
		# No authorization
		send_to_user $who "AUTH REQD"
		disconnect_user $who 0
	    }
	}
	# Check authorization validity
	set parms [split [string range $input 5 end] " "]
	if {[is_num [lindex $parms 1]] || \
		[is_num [lindex $parms 2]] || \
		[is_num [lindex $parms 4]] || \
		[is_num [lindex $parms 5]] || \
		[is_num [lindex $parms 6]] || \
		[is_num [lindex $parms 7]] || \
		[is_num [lindex $parms 8]] } {
	    send_to_user $who "AUTH FAILED (Non Numeric)"
	    disconnect_user $who 0
	    unset input who
	    return
	}
	if {[string length [lindex $parms 1]] > 3 || \
		[string length [lindex $parms 2]] > 3 || \
		[string length [lindex $parms 4]] > 4 || \
		[string length [lindex $parms 5]] > 4 || \
		[string length [lindex $parms 6]] > 6 || \
		[string length [lindex $parms 7]] > 4 || \
		[string length [lindex $parms 8]] > 4 || \
		[lindex $parms 1] < 0 || \
		[lindex $parms 2] < 0 || \
		[lindex $parms 6] < 0} {
	    send_to_user $who "AUTH FAILED (String Lengths)"
	    disconnect_user $who 0
	    unset input who
	    return
	}

	# Parse authorization
	set MVS($who.name) [string range [lindex $parms 0] 0 12]
	set MVS($who.x) [lindex $parms 1]
	set MVS($who.y) [lindex $parms 2]
	set MVS($who.avatar) [lindex $parms 3]
	set MVS($who.av_head_x) [lindex $parms 4]
	set MVS($who.av_head_y) [lindex $parms 5]
	set MVS($who.av_baloon_x) [lindex $parms 7]
	set MVS($who.av_baloon_y) [lindex $parms 8]
	set size [lindex $parms 6]
	# Check name
	if ![is_name $MVS($who.name)] {
	    send_to_user $who "BADNAME"
	    disconnect_user $who 0
	    unset input parms size who
	    return
	}
	# Check to see if name is unique
	foreach sckt $MVS(socks) {
	    if {![string compare $MVS($sckt.name) $MVS($who.name)] && [string compare $sckt $who]} {
		send_to_user $who "NAMEINUSE"
		disconnect_user $who 0
		unset input parms size sckt who
		return
	    }
	}

	# Tell user he is connected
	send_to_user $who "ROOMNAME $MVS(roomname)"
	send_to_user $who "ROOM $MVS(roomfile) 0 [file size $MVS(roomdir)/$MVS(roomfile)]"

	# Tell other users about the new guy
	if ![file exists $MVS(avatars)/$MVS($who.avatar)] {
	    # Get avatar image
	    send_to_all_users "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
	    log_it "($who) $MVS($who.avatar) does not exist"
	    get_binary_file $who $MVS($who.avatar) $size AVATAR
	} else {
	    if {[file size $MVS(avatars)/$MVS($who.avatar)] != $size} {
		# Update avatar image
		send_to_all_users "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
		log_it "($who) $MVS($who.avatar) $size != [file size $MVS(avatars)/$MVS($who.avatar)]"
		get_binary_file $who $MVS($who.avatar) $size AVATAR
	    } else {
		if [is_gif "$MVS(avatars)/$MVS($who.avatar)"] {
		    # Use avatar image
		    send_to_all_users "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) $MVS($who.avatar) $MVS($who.av_head_x) $MVS($who.av_head_y) [file size $MVS(avatars)/$MVS($who.avatar)] $MVS($who.av_baloon_x) $MVS($who.av_baloon_y)"
		} else {
		    # Use default (invalid image)
		    send_to_all_users "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
		    send_to_user $who "TOOBIG"
		    set MVS($who.avatar) "default.gif"
		}
	    }
	}

	# Tell the new guy about all the other users
	foreach sckt $MVS(socks) {
	    if [string compare $MVS($sckt.name) "*"] {
		if {[string compare $MVS($sckt.name) $MVS($who.name)]} {
		    if [file exists $MVS(avatars)/$MVS($sckt.avatar)] {
			send_to_user $who "NEW $MVS($sckt.name) $MVS($sckt.x) $MVS($sckt.y) $MVS($sckt.avatar) $MVS($sckt.av_head_x) $MVS($sckt.av_head_y) [file size $MVS(avatars)/$MVS($sckt.avatar)] $MVS($sckt.av_baloon_x) $MVS($sckt.av_baloon_y)"
		    } else {
			send_to_user $who "NEW $MVS($sckt.name) $MVS($sckt.x) $MVS($sckt.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
		    }
		}
	    }
	}

	# Do GothChess initialization
	on_join $who

	# Leave proc without processing input
	unset input who
	return
    }
    server_process_input $who $input

    unset input who
}

# Process Input from users.
#
# Usage: server_process_input socket "text to process"
#
# This function is the root of the protocol. It processes all of the
# things which a client can send to the server. If the client sends
# something it does not understand... it will ignore it. Please see the
# protocol documentation within the technical documentation for a complete
# descritption of the logic within this function.
#
# Checked for maximum memmory efficiency 12/09/1999 22:05
#
proc server_process_input {who what} {
    global MVS

    log_it "($who) --> $what"
    if {[string first " " $what] != -1} {
	set cmd [string range $what 0 [expr [string first " " $what] -1]]
	set rest [string range $what [expr [string first " " $what] +1] end]
	set parms [split $rest " "]
    } else {
	set cmd $what
	set rest ""
	set parms {}
    }
    switch -exact -- $cmd {
	"QUERY" {
	    # I don't know what this is...
	    switch -- [lindex $parms 0] {
		"POS_ALL" {
		    foreach person $MVS(socks) {
			send_to_user $who "MOVE $MVS($person.name) $MVS($person.x) $MVS($person.y) 50"
		    }
		}
	    }
	}
	"SEND" {
	    # Send a file
	    if ![is_path [lindex $parms 0]] {return}
	    send_binary_file $who [lindex $parms 0]
	}
	"DCCSENDAV" {
	    # Send an avatar
	    if ![is_path [lindex $parms 0]] {return}
	    server_dcc_send $who [lindex $parms 0] AVATAR
	}
	"DCCSENDOB" {
	    # Send an object
	    if ![is_path [lindex $parms 0]] {return}
	    server_dcc_send $who [lindex $parms 0] OBJECT
	}
	"DCCSENDROOM" {
	    # Send a room image
	    if ![is_path [lindex $parms 0]] {return}
	    server_dcc_send $who [lindex $parms 0] ROOM
	}
	"EFFECT" {
	    # Do an effect
	    send_to_all_users "EFFECT $MVS($who.name) [lindex $parms 0]"
	}
	"USERS" {
	    # Tell how many users there are
	    send_to_user $what "USERS $MVS(users)"
	}
	"SUB" {
	    # Send text on the sub channel
	    if {[lindex $parms 0] == ""} {return}
	    set stuff [string range $rest [expr [string first " " $rest] +1] end]
	    if {[string length $stuff] > $MVS(maxmsglen)} {
		set stuff [string range $stuff 0 $MVS(maxmsglen)]
	    }
	    foreach s $MVS(socks) {
		if {![string compare $MVS($s.name) [lindex $parms 0]] || ![string compare [lindex $parms 0] "*"]} {
		    send_to_user $s "SUB $MVS($who.name) $stuff"
		}
	    }
	    unset stuff
	}
	"URL" {
	    # Send a URL
	    if {[lindex $parms 0] == ""} {return}
	    set stuff [string range $rest [expr [string first " " $rest] +1] end]
	    if {[string length $stuff] > $MVS(maxmsglen)} {
		set stuff [string range $stuff 0 $MVS(maxmsglen)]
	    }
	    foreach s $MVS(socks) {
		if {![string compare $MVS($s.name) [lindex $parms 0]] || ![string compare [lindex $parms 0] "*"]} {
		    send_to_user $s "URL $MVS($who.name) $stuff"
		}
	    }
	    unset stuff
	}
	"PONG" {
	    # Respond to a ping
	    set MVS($who.ping_response) [clock seconds]
	}
	"RSEND" {
	    # Send a room
	    if ![is_path [lindex $parms 0]] {return}
	    SendRoomFile $who [lindex $parms 0]
	}
	"CHAT" {
	    # Send text
	    if {[string compare $rest ""]} {
		send_to_all_users "CHAT $MVS($who.name) [string range $rest 0 $MVS(maxmsglen)]"
	    }
	    on_chat $who $rest
	}
	"SCHAT" {
	    # Send text but with a smiley or something like that
	    set parms [split $rest " "]
	    set rest [string range $rest [expr [string first " " $rest] +1] end]
	    if {[string compare $rest ""]} {
		send_to_all_users "SCHAT [lindex $parms 0] $MVS($who.name) [string range $rest 0 $MVS(maxmsglen)]"
	    }
	}
	"AVATAR" {
	    # Change avatar
	    # First test for validity
	    if {[is_num [lindex $parms 1]] || \
		    [is_num [lindex $parms 2]] || \
		    [is_num [lindex $parms 3]] || \
		    [is_num [lindex $parms 4]] || \
		    [is_num [lindex $parms 5]]} {
		send_to_user $who "BAD AVATAR"
		unset cmd rest parms
		return
	    }
	    # Check validity some more
	    set retflag 0
	    if {[string length [lindex $parms 1]] > 4} {set retflag 1}
	    if {[string length [lindex $parms 2]] > 4} {set retflag 1}
	    if {[string length [lindex $parms 3]] > 6} {set retflag 1}
	    if {[string length [lindex $parms 4]] > 4} {set retflag 1}
	    if {[string length [lindex $parms 5]] > 4} {set retflag 1}
	    if {[lindex $parms 3] < 0} {set retflag 1}
	    if $retflag {
		unset cmd rest parms retflag
		return
	    }
	    # Change avatar
	    server_change_avatar $who [lindex $parms 0] [lindex $parms 1] [lindex $parms 2] [lindex $parms 3] [lindex $parms 4] [lindex $parms 5]
	}
	"WHOIS" {
	    # Ask for IP
	    if {[lindex $parms 0] == ""} {return}
	    foreach s $MVS(socks) {
		if {![string compare $MVS($s.name) [lindex $parms 0]] || ![string compare [lindex $parms 0] "*"]} {
		    send_to_user $who "WHOIS $MVS($s.name) $MVS($s.name)@$MVS($s.address)"
		}
	    }
	}
	"PRIVMSG" {
	    # Send private text
	    if {[lindex $parms 0] == ""} {return}
	    set stuff [string range $rest [expr [string first " " $rest] +1] end]
	    if {[string length $stuff] > $MVS(maxmsglen)} {
		set stuff [string range $stuff 0 $MVS(maxmsglen)]
	    }
	    foreach s $MVS(socks) {
		if {![string compare $MVS($s.name) [lindex $parms 0]] || ![string compare [lindex $parms 0] "*"]} {
		    send_to_user $s "PRIVMSG $MVS($who.name) $stuff"
		}
	    }
	    unset stuff
	}
	"NICK" {
	    # Change nickname
	    if {![string compare $MVS($who.name) [lindex $parms 0]] || ![string compare $MVS($who.name) "*"]} {
		unset cmd rest parms
		return
	    }
	    # See if the name is valid
	    if ![is_name [lindex $parms 0]] {
		send_to_user $who "NAMEINUSE"
		unset cmd rest parms
		return
	    }
	    # See if the name is available
	    foreach sckt $MVS(socks) {
		if {![string compare $MVS($sckt.name) [lindex $parms 0]]} {
		    send_to_user $who "NAMEINUSE"
		    disconnect_user $what 1
		    unset cmd rest parms
		    return
		}
	    }
	    # Tell all users about the change of nickname
	    send_to_all_users "NOMORE $MVS($who.name)"
	    set MVS($who.name) [string range [lindex $parms 0] 0 12]
	    send_to_all_users "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
	    send_to_all_users "AVATAR $MVS($who.name) $MVS($who.avatar) $MVS($who.av_head_x) $MVS($who.av_head_y) [file size $MVS(avatars)/$MVS($who.avatar)] $MVS($who.av_baloon_x) $MVS($who.av_baloon_y)"

	    # Have GothChess pick up on the nick change
	    on_nick $who
	}
	"TELL" {
	    # Object Interaction. (tell)
	    foreach tell $MVS(tell_registry) {
		set reg [split $tell " "]
		if {[lindex $parms 0] == [lindex $reg 0]} {
		    [lindex $reg 1] $who
		}
	    }
	}
	"SUBMIT" {
	    # Object Interaction. (submit)
	    foreach submit $MVS(submit_registry) {
		set reg [split $submit " "]
		if {[lindex $parms 0] == [lindex $reg 0]} {
		    [lindex $reg 1] $who
		}
	    }
	}
	"ENTRY" {
	    # Object Interaction.
	    set text [string range $rest [expr [string first " " $rest] +1] end]
	    if {![string compare $text $rest]} {set text ""}
	    foreach entry $MVS(entry_registry) {
		set reg [split $entry " "]
		if {[lindex $parms 0] == [lindex $reg 0]} {
		    [lindex $reg 1] $who $text
		}
	    }
	}
    }
    unset cmd rest parms
}

#
# Change a user's avatar.
#
# Usage: server_change_avatar who avatar_name nametag_x nametag_y size
#		balloon_x balloon_y
#
# This function is used to change a user's avatar. It will announce the
# change to all connected users.
#
# Checked for maximum memory efficiency 12/09/1999 22:14
#
proc server_change_avatar {who what x y size bx by} {
    global MVS

    # Set the user's avatar information
    set MVS($who.avatar) $what
    set MVS($who.av_head_x) $x
    set MVS($who.av_head_y) $y
    set MVS($who.av_baloon_x) $bx
    set MVS($who.av_baloon_y) $by
    # The user wants the default
    if {![string compare $what "default.gif"]} {
	send_to_all_users "AVATAR $MVS($who.name) $what $MVS($who.av_head_x) $MVS($who.av_head_y) [file size $MVS(icons)/$what] $bx $by"
	return
    }
    if ![file exists $MVS(avatars)/$what] {
	# Get new avatar
	log_it "($who) $what does not exist"
	get_binary_file $who $MVS($who.avatar) $size AVATAR
    } else {
	if {[file size $MVS(avatars)/$what] != $size} {
	    # Update avatar
	    log_it "($who) $what $size != [file size $MVS(avatars)/$what]"
	    get_binary_file $who $MVS($who.avatar) $size AVATAR
	} else {
	    if [is_gif "$MVS(avatars)/$what"] {
		# Use avatar image
		send_to_all_users "AVATAR $MVS($who.name) $what $MVS($who.av_head_x) $MVS($who.av_head_y) [file size $MVS(avatars)/$what] $bx $by"
	    } else {
		# Use default (invalid image)
		send_to_all_users "AVATAR $MVS($who.name) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
		send_to_user $who "TOOBIG"
		set MVS($who.avatar) "default.gif"
	    }
	}
    }
}

#
# Check various timeouts and events.
#
# Usage: server_check_timeouts
#
# This function should be run only ONCE when the server is started. It
# should never be run multiple times within a given instance. Once it is
# run, it will re-spawn iteself later and check again, add infinitium.
# What it does is check timeouts. Download Timeouts, Ping Timeouts and it
# also checks for the existance of a tickler file which, when it exists,
# will cause the server to reload it's config file.
#
# Checked for maximum memmory efficiency 12/09/1999 23:31
#
proc server_check_timeouts {} {
    global MVS

    # Check user ping times
    set tme [clock seconds]
    set disco {}
    foreach who $MVS(socks) {
	if {[expr $tme - $MVS($who.ping_response)] > 320} {
	    # Hasn't ponged back in a while...
	    log_it "($who) --- Ping Timeout!"
	    lappend disco $who
	} else {
	    if {[expr $tme - $MVS($who.ping)] > 150} {
		# Ping 'em
		set MVS($who.ping) [clock seconds]
		send_to_user $who "PING"
	    }
	}
    }
    # Disconnect everyone who timed out
    foreach who $disco {
	disconnect_user $who 1
    }

    # Check active downloads
    set tme [clock seconds]
    foreach idx $MVS(dcc_list) {
	if {[expr $tme - $MVS(DCC.$idx.time)] > $MVS(timeout)} {
	    if {$MVS(DCC.$idx.server) > 0} {
		catch {close $MVS(DCC.$idx.server)}
	    }
	    server_end_dcc Timer $idx 0 "Connection timed out $MVS(DCC.$idx.file)"
	}
    }
    
    # Check for tickler file
    if [file exists "$MVS(tickler)"] {load_config}

    # If we're serving, run this function again in 5 seconds
    if $MVS(serving) {
	after 5000 server_check_timeouts
    }
    unset disco tme
}

# Error Logging Routine.
#
# Usage: Used internally when an error occurs.
#
# Will print out information on errors
# and continue running (we hope)
#
# checked for maximum memory efficiency 12/10/1999 08:12
#
proc bgerror {stuff} {
    global errorInfo
    global errorCode
	
    log_it "-------------------------------------"
    log_it "BG_ERROR Begin"
    log_it "-------------------------------------"
    log_it "Error Code: $stuff"
    log_it "-------------------------------------"
    log_it $errorInfo
    log_it "-------------------------------------"
    log_it "BG_ERROR End"
    log_it "-------------------------------------"
}

set MVS(dcc_list) {}
set MVS(dcc_num) 0

# Check for duplicate downloads.
#
# Usage: is_duplicate_dcc socket filename
#
# This function will check to see if the
# user is already getting the file named.
#
# checked for maximum memmory efficiency 12/10/1999 08:15
#
proc is_duplicate_dcc {who what} {
    global MVS


    foreach idx $MVS(dcc_list) {
	if {![string compare $MVS(DCC.$idx.sender) $who] && ![string compare "[file tail $MVS(DCC.$idx.file)]" $what]} {
	    return 0
	}
    }
    return 1
}

#
# Send a file
#
# Usage: server_dcc_send socket filename transfer_type
#
# This function will initiate a file transfer. It is used for rooms and
# avatars and object images. This is a passive dcc transfer so things work
# better through modern firewalls.
#
# Checked for maximum memmory efficiency 12/10/1999 21:38
#
proc server_dcc_send {who what type} {
    global MVS

    if ![is_duplicate_dcc $who $what] {
	log_it "($who) --- Already getting $what"
	return
    }

    # Determine which type is being sent
    switch -exact -- $type {
	"AVATAR" {
	    if {![string compare $what "default.gif"]} {
		set file "$MVS(icons)/default.gif"
	    } else {
		set file "$MVS(avatars)/$what"
	    }
	    set GETCMD "DCCGETAV"
	}
	"OBJECT" {
	    set file "$MVS(images)/$what"
	    set GETCMD "DCCGETOB"
	}
	"ROOM" {
	    set file "$MVS(roomdir)/$what"
	    set GETCMD "DCCGETROOM"
	}
	default {return}
    }

    if {[file exists $file]} {
	# Check file readability
	if {![file readable $file]} {
	    log_it "($who) --- (server_dcc_send) Cannot read file $file."
	    return
	}

	set size [file size $file]
	set idx [incr MVS(dcc_num)]
	set sock [socket -server "server_accept_send $idx" 0]

	if {[catch {fconfigure $sock -sockname} port]} {
	    log_it "($who) --- (server_dcc_send) Cannot get port for server - $port"
	}

	# Put DCC information in the list
	lappend MVS(dcc_list) $idx
	set MVS(DCC.$idx.sender) $who
	set MVS(DCC.$idx.file) "$file"
	set MVS(DCC.$idx.size) $size
	set MVS(DCC.$idx.posn) 0
	set MVS(DCC.$idx.type) "AVATAR"
	set MVS(DCC.$idx.time) [clock seconds]
	set MVS(DCC.$idx.server) $sock
	set MVS(DCC.$idx.sock) -1
	set MVS(DCC.$idx.port) [lindex $port 2]
	set MVS(DCC.$idx.remote) "0.0.0.0"
	set MVS(DCC.$idx.av_head_x) 0
	set MVS(DCC.$idx.av_head_y) 0
	set MVS(DCC.$idx.av_baloon_x) 0
	set MVS(DCC.$idx.av_baloon_y) 0

	send_to_user $who "$GETCMD [lindex $port 2] $what $size"
	unset size idx sock
    } else {
	log_it "($who) --- (server_dcc_send) File $file does not exist."
    }
    unset file GETCMD
}

#
# Accept pending outbout transfers.
#
# Usage: server_accept_send index socket host port
#
# This function is not called directly, it is instead called by the
# opening of the server socket. It accepts the connection, closes the
# server socket and starts the sending of the file to the user.
#
# checked for maximum memmory efficiency 12/10/1999 21:40
#
proc server_accept_send {index chan hst port} {
    global MVS

    catch {close $MVS(DCC.$index.server)}
    uplevel set MVS(DCC.$index.server) -1
    uplevel #0 set MVS(DCC.$index.sock) $chan
	
    set msg ""

    if {[ catch {open $MVS(DCC.$index.file) RDONLY} infile]} {
	server_end_dcc Send $index 0 "Cannot read $MVS(DCC.$index.file) : $infile"
	unset infile
	return 0
    }

    if {[set posn $MVS(DCC.$index.posn)] != {} && $posn > 0} {
	if {[catch {seek $infile $posn start} msg]} {
	    server_end_dcc Send $index 0 "Cannot seek $MVS(DCC.$index.file) : $msg"
	    close $infile
	    unset infile posn msg
	    return 0
	}
	uplevel #0 incr MVS(DCC.$index.size) -$posn
    } 

    if {$MVS(DCC.$index.size) == 0} {
	close $infile
	after 50 "server_end_dcc Send $index 1 \"Transfer completed.\""
	unset infile posn msg
	return 1
    }

    set st [clock seconds]
    fconfigure $infile -translation binary

    if {[catch {set buffer [read $infile $MVS(sendbuffer)]} msg]} {
	server_end_dcc Send $index 0 "Error reading $file : $msg"
	close $infile
	unset infile posn msg st buffer
	return 0
    }

    global tl
    set tl($chan) [string length $buffer]
    fconfigure $chan -blocking 0 -buffering none -translation binary
    if {[catch {puts -nonewline $chan $buffer} msg]} {
	server_end_dcc Send $index 0 "Write error : $msg"
	close $infile
	unset infile posn msg st buffer
	return 0
    }
    log_it "($MVS(DCC.$index.sender)) --- Accepted server_dcc_send"
    fileevent $chan readable "server_dcc_send_event $index $st $infile"
    unset infile posn msg st buffer
}

#
# The file send event (read trigger) for sending files.
#
# Usage: server_dcc_send_event index start_time file_stream_descriptor 
#
# This function is triggered each time the remote client sends a response
# announcing the number of bytes the server has sent to it. It will send
# some more bytes if the client has received all of what we've sent so
# far. It will end the transfer when the client informs us that it has all
# of the data we've sent.
#
# checked for maximum memmory efficiency 12/10/1999 21:47
#
proc server_dcc_send_event {index st fd} {
    global MVS
	
    set sk $MVS(DCC.$index.sock)
    uplevel #0 set MVS(DCC.$index.time) [clock seconds]
    set msg ""

    if {[eof $sk]} {
	after 50 "server_end_dcc Send $index 0 \"Transfer interrupted\""
	close $fd
	unset sk
	return
    }

    if {[catch {set l [read $sk 4]} msg]} {
	server_end_dcc Send $index 0 "Read error : $msg"
	catch {unset sk msg l} 
	close $fd
	return
    }

    if {[string length $l] == 0} {
	server_end_dcc Send $index 0 "Sync read error"
	catch {unset sk msg l}
	close $fd
	return
    }

    global tl
    set cl 0
    binary scan $l I1 cl
    if {$cl != $tl($sk)} {
	catch {unset sk msg cl l}
	return
    }

    log_it "($MVS(DCC.$index.sender)) --- Got check (OK)"
    if [eof $fd] {
	if {[set st [expr {[clock seconds] - $st}]] == 0} {
	    set st 1
	}
	catch {unset sk msg cl st l}
	close $fd		
	after 50 "server_end_dcc Send $index 1 \"Transfer completed\""
	return
    }

    log_it "($MVS(DCC.$index.sender)) --- Got check (OK Not EOF)"

    if {[catch {set buffer [read $fd $MVS(sendbuffer)]} msg]} {
	server_end_dcc Send $index 0 "Error reading $MVS(DCC.$index.file) : $msg"
	catch {unset sk msg cl st buffer l}
	close $fd
	return
    }

    if {[set lng [string length $buffer]] == 0} {
	if {[set st [expr {[clock seconds] - $st}]] == 0} {
	    set st 1
	}
	catch {unset sk msg cl st buffer lng l}
	close $fd
	after 50 "server_end_dcc Send $index 1 \"Transfer completed.\""
	return
    }
    incr tl($sk) $lng
    log_it "($MVS(DCC.$index.sender)) --- Sent $lng bytes ($tl($sk) total)"
    if {[catch {puts -nonewline $sk $buffer} msg]} {
	server_end_dcc Send $index 0 "Write error : $msg"
	catch {unset sk msg cl st buffer lng l}
	close $fd
	return
    }

    if {[set dt [expr {[clock seconds] - $st}]] == 0} {
	set elt 0
    } else {
	set elt [expr {($MVS(DCC.$index.size) - $tl($sk)) / ($tl($sk) /([clock seconds] - $st))}]
    }
    catch {unset sk msg cl st buffer lng dt elt l}
}

# DCC Get Code (Passive)
#
# Usage: get_binary_file socket filename file size
#
# This function initializes a passive DCC transfer between a connected
# user and the server. It will set up the listening connection and tell
# the user where to connect to. It will then set up an event to accep the
# connection and transfer the file.
#
# This is our central location for DOWNLOADING files.
# 
# checked for maximum memmory efficiency 12/10/1999 22:28
#
proc get_binary_file {who what size type} {
    global MVS
	
    if ![is_path "$what"] {
	log_it "(!) $what fails is_path"
	return
    }
    if ![is_duplicate_dcc $who $what] {
	log_it "($who) --- Already getting $what from this user"
	return
    }

    set file "$MVS(avatars)/$what"	
	
    set idx [incr MVS(dcc_num)]
    set sock [socket -server "server_accept_get $idx" 0]
    if {[catch {fconfigure $sock -sockname} port]} {
	log_it "($who) (server_dcc_send) Cannot get port for server - $port"
    }
    lappend MVS(dcc_list) $idx
    set MVS(DCC.$idx.sender) $who
    set MVS(DCC.$idx.file) "$file"
    set MVS(DCC.$idx.size) $size
    set MVS(DCC.$idx.type) $type
    set MVS(DCC.$idx.posn) 0
    set MVS(DCC.$idx.time) [clock seconds]
    set MVS(DCC.$idx.server) $sock
    set MVS(DCC.$idx.sock) -1
    set MVS(DCC.$idx.port) [lindex $port 2]
    set MVS(DCC.$idx.remote) $MVS($who.address)
    set MVS(DCC.$idx.av_head_x) $MVS($who.av_head_x)
    set MVS(DCC.$idx.av_head_y) $MVS($who.av_head_y)
    set MVS(DCC.$idx.av_baloon_x) $MVS($who.av_baloon_x)
    set MVS(DCC.$idx.av_baloon_y) $MVS($who.av_baloon_y)
    send_to_user $who "DCCSENDAV [lindex $port 2] $what"
    unset file idx sock port
}	

#
# Accept pending inbound transfers.
#
# Usage: server_accept_get index socket host port
#
# This function is not called directly, it is instead called by the
# opening of the server socket. It accepts the connection, closes the
# server socket and starts the getting of the file to the user.
#
# checked for maximum memmory efficiency 12/10/1999 22:35
#
proc server_accept_get {index chan hst port} {
    global MVS

    catch {close $MVS(DCC.$index.server)}
    uplevel set MVS(DCC.$index.server) -1
    uplevel #0 set MVS(DCC.$index.sock) $chan

    set file $MVS(DCC.$index.file)
    set posn $MVS(DCC.$index.posn)
    fconfigure $MVS(DCC.$index.sock) -buffering none -blocking 0 -translation binary -buffersize 4096
    set flags [list WRONLY CREAT]
    set msg ""
    if {$posn == 0} { lappend flags TRUNC }
    if {![catch {open $file $flags 0600} outfile]} {
	if {$posn != 0} {
	    if {[catch {seek $outfile $posn start} msg]} {
		close $outfile
		server_end_dcc Get $index 0 "Cannot seek on $file : $msg"
		unset file posn flags outfile msg
		return 0
	    }
	    uplevel #0 incr MVS(DCC.$index.size) -$posn
	}
	uplevel #0 set tl($MVS(DCC.$index.sock)) 0
	fconfigure $outfile -translation binary 
	fileevent $MVS(DCC.$index.sock) readable "server_dcc_get_event $index [clock seconds] $outfile"
    } else {
	server_end_dcc Get $index 0 "Cannot write $file : $outfile"
	unset file posn flags outfile msg
	return 0
    }
    unset file posn flags outfile msg
    return 1
}


#
# The file get event (read trigger) for getting files.
#
# Usage: server_dcc_get_event index start_time file_stream_descriptor 
#
# This function is triggered each time the remote client sends a response
# announcing the number of bytes the server has sent to it. It will send
# some more bytes if the client has received all of what we've sent so
# far. It will end the transfer when the client informs us that it has all
# of the data we've sent.
#
# checked for maximum memmory efficiency 12/10/1999 21:47
#
proc server_dcc_get_event {index st out} {
    global tl MVS

    set xc 0
    set in $MVS(DCC.$index.sock)
    set leng $MVS(DCC.$index.size)
    uplevel #0 set MVS(DCC.$index.time) [clock seconds]
    set fail_type 0
    if {[eof $in]} {
	if {$tl($in) < $leng} {
	    set msg "Transfer interrupted"
	    set fail_type 0
	} elseif {$tl($in) > $leng} {
	    set msg "Too much data transferred!!"
	    set fail_type 0
	} else {
	    set sx s
	    if {[set st [expr {[clock seconds] - $st}]] == 0} {
		set st 1
		set sx {}
	    }
	    set xc 1
	    set msg "Transfer completed. [expr {$leng / ($st * 1024.0)}] Kbytes/sec"
	    set fail_type 1
	}
	unset sx st
    } else {
	if {![catch {set buffer [read $in]} msg]} {
	    incr tl($in) [set l [string length $buffer]]
	    log_it "downloaded $l bytes ($tl($in) total)"
	    if {[set dt [expr {[clock seconds] - $st}]] == 0 || $tl($in) == 0} {
		set elt 0
	    } else {
		set elt [expr {($leng - $tl($in)) / ($tl($in) /([clock seconds] - $st))}]
	    }
	    if {$leng == 0} {
		set xt 0
	    } else {
		set xt [expr {($tl($in) * 100.0) / $leng}]
	    }
	    
	    if {![catch {puts -nonewline $out $buffer} msg]} {
		if {![catch {puts -nonewline $in [binary format I1 $tl($in)]} msg]} {
		    flush $in
		    unset xc in leng fail_type dt elt xt
		    return
		}
	    } else {
		set fail_type 0
	    }
	} else {
	    set fail_type 0
	}
    }
    catch {close $out} 
    server_end_dcc Get $index $fail_type $msg
    catch {unset xc in leng fail_type l dt elt xt}
}

#
# End a DCC Transfer
#
# Usage: server_end_dcc transfer_type index fail_type debug_info
#
# This function will end a user's DCC transfer. If it is a failure, it
# will print information about the transfer out to the log, if it is
# successful and the transfer is an incoming avatar, it will announce the
# avatar to all connected users. Once it's done ending the transfer, it
# will cleanup the mess made.
#
# checked for maximum memmory efficiency 12/10/199 22:58
#
proc server_end_dcc {type index fail_type debug} {
    global MVS tl

    if !$fail_type {
	log_it "($MVS(DCC.$index.sender)) --- (DCC$type) - $debug"
    }
    catch {close $MVS(DCC.$index.sock)}
    set idx [lsearch -exact $MVS(dcc_list) $index]
    set MVS(dcc_list) [lreplace $MVS(dcc_list) $idx $idx]
    if {![string compare $type "Get"] && $fail_type} {
	switch -- $MVS(DCC.$index.type) {
	    "ORT" {
	    }
	    default {
		if [is_gif "$MVS(DCC.$index.file)"] {
		    send_to_all_users "AVATAR $MVS($MVS(DCC.$index.sender).name) [file tail $MVS(DCC.$index.file)] $MVS(DCC.$index.av_head_x) $MVS(DCC.$index.av_head_y) $MVS(DCC.$index.size) $MVS(DCC.$index.av_baloon_x) $MVS(DCC.$index.av_baloon_y)"
		} else {
		    set MVS($MVS(DCC.$index.sender).avatar) "default.gif"
		    send_to_all_users "AVATAR $MVS($MVS(DCC.$index.sender).name) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
		    send_to_user $MVS(DCC.$index.sender) "TOOBIG"
		}
	    }
	}
    }
    catch {
	unset idx tl($MVS(DCC.$index.sock))
	unset MVS(DCC.$index.time) MVS(DCC.$index.server) \
	    MVS(DCC.$index.file) MVS(DCC.$index.sender) MVS(DCC.$index.size) \
	    MVS(DCC.$index.posn) MVS(DCC.$index.server) MVS(DCC.$index.sock) \
	    MVS(DCC.$index.port) MVS(DCC.$index.remote) \
	    MVS(DCC.$index.av_head_x) MVS(DCC.$index.av_head_y) \
	    MVS(DCC.$index.av_baloon_x) MVS(DCC.$index.av_baloon_y)
    }
}

#
# Check gif file size
#
# Usage: is_gif "filename"
#
# This will read in the GIF File header and determine it's size. It will
# comare the size against the server limits and report back if the file is
# good or bad.
#
# checked for maximum memmory efficiency 12/10/1999 23:00
#
proc is_gif {file} {
    global MVS

    set infile [open $file r]
    fconfigure $infile -translation binary
    set bits [read $infile 10]
    close $infile
    if {[string range $bits 0 2] != "GIF"} {
	log_it "(is_gif) Failed! Not a GIF"
	unset infile bits
	return 0
    }
    binary scan $bits s* var
    if {[lindex $var 4] <= $MVS(maxheight) && [lindex $var 3] <= $MVS(maxwidth)} {
	log_it "(is_gif) Passed! [lindex $var 3] X [lindex $var 4]"
	unset infile bits var
	return 1
    } else {
	log_it "(is_gif) Failed! [lindex $var 3] X [lindex $var 4]"
	unset infile bits var
	return 0
    }
}

#
# Call our recursing functions.
# These functions call themselves over time to perform routine repetetive
# tasks.
#
server_check_timeouts

#
# Thats it! If we are in stand alone mode then use the vwait command to 
# create a means for events to trigger wile waiting forever for a variable
# which will never be changed.
#
if $MVS(standalone) {
    vwait MVS(waiter)
}