http-server.tcl

来自「一款用来进行网络模拟的软件」· TCL 代码 · 共 551 行 · 第 1/2 页

# Copyright (c) Xerox Corporation 1998. All rights reserved.
#
# 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.,
# 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
# 
# Linking this file statically or dynamically with other modules is making
# a combined work based on this file.  Thus, the terms and conditions of
# the GNU General Public License cover the whole combination.
# 
# In addition, as a special exception, the copyright holders of this file
# give you permission to combine this file with free software programs or
# libraries that are released under the GNU LGPL and with code included in
# the standard release of ns-2 under the Apache 2.0 license or under
# otherwise-compatible licenses with advertising requirements (or modified
# versions of such code, with unchanged license).  You may copy and
# distribute such a system following the terms of the GNU GPL for this
# file and the licenses of the other code concerned, provided that you
# include the source code of that other code when and as the GNU GPL
# requires distribution of source code.
# 
# Note that people who make modified versions of this file are not
# obligated to grant this special exception for their modified versions;
# it is their choice whether to do so.  The GNU General Public License
# gives permission to release a modified version without this exception;
# this exception also makes it possible to release a modified version
# which carries forward this exception.
#
# Implementation of an HTTP server
#
# $Header: /cvsroot/nsnam/ns-2/tcl/webcache/http-server.tcl,v 1.11 2005/08/26 05:05:30 tomh Exp $


#
# PagePool
#

# Generage a new page, including size, age, and flags. Do NOT generate 
# modification time. That's the job of web servers.
PagePool instproc gen-page { pageid thismod } {
	set size [$self gen-size $pageid]
	# If $thismod == -1, we set age to -1, which means this page
	# never changes
	if {$thismod >= 0} {
		set age [expr [$self gen-modtime $pageid $thismod] - $thismod]
	} else {
		set age -1
	}
	return "size $size age $age modtime $thismod"
}

#
# Compound pagepool with a non-cacheable main page
#
Class PagePool/CompMath/noc -superclass PagePool/CompMath

PagePool/CompMath/noc instproc gen-page { pageid thismod } {
	set res [eval $self next $pageid $thismod]
	if {$pageid == 0} {
		return "$res noc 1"
	} else {
		return $res
	}
}


#
# web server codes
#
Http/Server instproc init args {
	eval $self next $args
	$self instvar node_ stat_
	$node_ color "HotPink"
	array set stat_ [list hit-num 0 mod-num 0 barrival 0]
}

Http/Server instproc set-page-generator { pagepool } {
	$self instvar pgtr_
	set pgtr_ $pagepool
}

Http/Server instproc gen-init-modtime { id } {
	$self instvar pgtr_ ns_
	if [info exists pgtr_] {
		return [$pgtr_ gen-init-modtime $id]
	} else {
		return [$ns_ now]
	}
}

# XXX 
# This method to calculate staleness time isn't scalable!!! We have to have
# a garbage collection method to release unused portion of modtimes_ and 
# modseq_. That's not implemented yet because it requires the server to know
# the oldest version held by all other clients.
Http/Server instproc stale-time { pageid modtime } {
	$self instvar modseq_ modtimes_ ns_
	for {set i $modseq_($pageid)} {$i >= 0} {incr i -1} {
		if {$modtimes_($pageid:$i) <= $modtime} {
			break
		}
	}
	if {$i < 0} {
		error "Non-existent modtime $modtime for page $pageid"
	}
	set ii [expr $i + 1]
	set t1 [expr abs($modtimes_($pageid:$i) - $modtime)]
	set t2 [expr abs($modtimes_($pageid:$ii) - $modtime)]
	if {$t1 > $t2} {
		incr ii
	}
	return [expr [$ns_ now] - $modtimes_($pageid:$ii)]
}

Http/Server instproc modify-page { pageid } {
	# Set Last-Modified-Time to current time
	$self instvar ns_ id_ stat_ pgtr_

	incr stat_(mod-num)
	set id [lindex [split $pageid :] end]

	# Change modtime and lifetime only, do not change page size
	set modtime [$ns_ now]
	if [info exists pgtr_] {
		set pginfo [$pgtr_ gen-page $id $modtime]
	} else {
		set pginfo "size 2000 age 50 modtime $modtime"
	}
	array set data $pginfo
	set age $data(age)
	$self schedule-nextmod [expr [$ns_ now] + $age] $pageid
	eval $self enter-page $pageid $pginfo

	$ns_ trace-annotate "S $id_ INV $pageid"
	$self evTrace S MOD p $pageid m [$ns_ now] n [expr [$ns_ now] + $age]

	$self instvar modtimes_ modseq_
	incr modseq_($pageid)
	set modtimes_($pageid:$modseq_($pageid)) $modtime
}

Http/Server instproc schedule-nextmod { time pageid } {
	$self instvar ns_
	$ns_ at $time "$self modify-page $pageid"
}

Http/Server instproc gen-page { pageid } {
	set pginfo [$self gen-pageinfo $pageid]
	eval $self enter-page $pageid $pginfo
	return $pginfo
}

# XXX Assumes page doesn't exists before. 
Http/Server instproc gen-pageinfo { pageid } {
	$self instvar ns_ pgtr_ 

	if [$self exist-page $pageid] {
		error "$self: shouldn't use gen-page for existing pages"
	}

	set id [lindex [split $pageid :] end]

	# XXX If a page never changes, set modtime to -1 here!!
	set modtime [$self gen-init-modtime $id]
	if [info exists pgtr_] {
		set pginfo [$pgtr_ gen-page $id $modtime]
	} else {
		set pginfo "size 2000 age 50 modtime $modtime"
	}
	array set data $pginfo
	set age $data(age)
	if {$modtime >= 0} {
		$self schedule-nextmod [expr [$ns_ now] + $age] $pageid
	}
	$self evTrace S MOD p $pageid m [$ns_ now] n [expr [$ns_ now] + $age]

	$self instvar modtimes_ modseq_
	set modseq_($pageid) 0
	set modtimes_($pageid:0) $modtime

	return [join $pginfo]
}

Http/Server instproc disconnect { client } {
	$self instvar ns_ clist_ node_
	set pos [lsearch $clist_ $client]
	if {$pos >= 0} {
		lreplace $clist_ $pos $pos
	} else { 
		error "Http/Server::disconnect: not connected to $server"
	}
	set tcp [[$self get-cnc $client] agent]
	$self cmd disconnect $client
	$tcp proc done {} "$ns_ detach-agent $node_ $tcp; delete $tcp"
	$tcp close
	#puts "server [$self id] disconnect"
}

Http/Server instproc alloc-connection { client fid } {
	Http instvar TRANSPORT_
	$self instvar ns_ clist_ node_ fid_

	lappend clist_ $client
	set snk [new Agent/TCP/$TRANSPORT_]
	$snk set fid_ $fid
	$ns_ attach-agent $node_ $snk
	$snk listen
	set wrapper [new Application/TcpApp $snk]
	$self cmd connect $client $wrapper
	return $wrapper
}

Http/Server instproc handle-request-GET { pageid args } {
	$self instvar ns_

	if [$self exist-page $pageid] {
		set pageinfo [$self get-page $pageid]
	} else {
		set pageinfo [$self gen-page $pageid]
	}

	lappend res [$self get-size $pageid]
	eval lappend res $pageinfo
}

Http/Server instproc handle-request-IMS { pageid args } {
	array set data $args
	set mt [$self get-modtime $pageid]
	if {$mt <= $data(modtime)} {
		# Send a not-modified since
		set size [$self get-invsize]
		# We don't need other information for a IMS of a 
		# valid page
		set pageinfo \
		  "size $size modtime $mt time [$self get-cachetime $pageid]"
		$self evTrace S SND p $pageid m $mt z $size t IMS-NM
	} else {
		# Page modified, send the new one
		set size [$self get-size $pageid]
		set pageinfo [$self get-page $pageid]
		$self evTrace S SND p $pageid m $mt z $size t IMS-M
	}

	lappend res $size
	eval lappend res $pageinfo
	return $res
}

Http/Server instproc get-request { client type pageid args } {
	$self instvar ns_ id_ stat_

	incr stat_(hit-num)
	array set data $args
	incr stat_(barrival) $data(size)
	unset data

	# XXX Here maybe we want to wait for a random time to model 
	# server response delay, it could be easily added in a derived class.

	set res [eval $self handle-request-$type $pageid $args]
	set size [lindex $res 0]
	set pageinfo [lrange $res 1 end]

	$self send $client $size \
		"$client get-response-$type $self $pageid $pageinfo"
}