tcllib 1.14-dfsg-1 / usr / share / tcltk / tcllib1.14 / nns / server.tcl

# -*- tcl -*-
# ### ### ### ######### ######### #########
## Name Service - Server (Singleton)

# ### ### ### ######### ######### #########
## Requirements

package require Tcl 8.4
package require comm             ; # Generic message transport
package require interp           ; # Interpreter helpers.
package require logger           ; # Tracing internal activity
package require nameserv::common ; # Common/shared utilities

namespace eval ::nameserv::server {}

# ### ### ### ######### ######### #########
## API: Start, Stop

proc ::nameserv::server::start {} {
    variable comm
    variable port
    variable localonly

    log::debug "start"
    if {$comm ne ""} return

    log::debug "start /granted"

    set     interp [interp::createEmpty]
    foreach msg {
	Bind
	Release
	Search
	Search/Continuous/Start
	Search/Continuous/Stop
	ProtocolVersion
	ProtocolFeatures
    } {
	interp alias $interp $msg {} ::nameserv::server::$msg
    }

    set comm [comm::comm new ::nameserv::server::COMM \
		  -interp $interp \
		  -port   $port \
		  -listen 1 \
		  -local  $localonly]

    $comm hook lost ::nameserv::server::LOST

    log::debug "UP @$port local-only $localonly"
    return
}

proc ::nameserv::server::stop {} {
    variable comm
    variable names
    variable data

    log::debug "stop"
    if {$comm eq ""} return

    log::debug "stop /granted"

    # This kills all existing connection and destroys the configured
    # -interp as well.

    $comm destroy
    set comm ""

    array unset names *
    array unset data  *

    log::debug "DOWN"
    return
}

proc ::nameserv::server::active? {} {
    variable comm
    return [expr {$comm ne ""}]
}

# ### ### ### ######### ######### #########
## INT: Protocol operations

proc ::nameserv::server::ProtocolVersion  {} {return 1}
proc ::nameserv::server::ProtocolFeatures {} {return {Core Search/Continuous}}

proc ::nameserv::server::Bind {name cdata} {
    variable comm
    variable names
    variable data

    set id [$comm remoteid]

    log::debug "bind ([list $name -> $cdata]), for $id"

    if {[info exists data($name)]} {
	log::debug "bind failed, \"$name\" is already bound"
	return -code error "Name \"$name\" is already bound"
    }

    lappend names($id)  $name
    set     data($name) $cdata

    Search/Continuous/NotifyAdd $name $cdata
    return
}

proc ::nameserv::server::Release {} {
    variable comm
    ReleaseId [$comm remoteid]
    return
}

proc ::nameserv::server::Search {pattern} {
    variable data
    return [array get data $pattern]
}

proc ::nameserv::server::ReleaseId {id} {
    variable names
    variable data
    variable searchi

    log::debug "release id $id"

    # Two steps. Release all searches the client may have open, then
    # all names it may have bound. That last step may trigger
    # notifications for searches by other clients. It must not trigger
    # searches from the client just going away, hence their release
    # first.

    foreach k [array names searchi [list $id *]] {
	Search/Release $k
    }

    if {[info exists names($id)]} {
	set gone {}
	foreach n $names($id) {
	    lappend gone $n $data($n)
	    catch {unset data($n)}

	    log::debug "release name <$n>"
	}
	unset names($id)

	Search/Continuous/NotifyRelease $gone
    }
    return
}

# ### ### ### ######### ######### #########
## Support for continuous and async searches

proc ::nameserv::server::Search/Continuous/Start {tag pattern} {
    variable data
    variable searchi
    variable searchp
    variable comm

    set id [$comm remoteid]

    # Register the search, then generate the initial response.
    # Non-unique tags are silently discarded. Clients will wait
    # forever.

    set k [list $id $tag]

    log::debug "search <$k>"

    if {[info exists searchi($k)]} {
	log::debug "search already known"
	return
    }

    log::debug "search added"

    set searchi($k) $pattern
    lappend searchp($pattern) $k

    $comm send -async $id [list Search/Continuous/Change \
			       $tag add [array get data $pattern]]
    return
}

proc ::nameserv::server::Search/Continuous/Stop {tag} {
    Search/Release [list [$comm remoteid] $tag]
    return
}

proc ::nameserv::server::Search/Release {k} {
    variable searchi
    variable searchp

    # Remove search information from the data store

    if {![info exists searchi($k)]} return

    log::debug "release search <$k>"

    set pattern $searchi($k)
    unset searchi($k)

    set pos [lsearch -exact $searchp($pattern) $k]
    if {$pos < 0} return
    set new [lreplace $searchp($pattern) $pos $pos]
    if {[llength $new]} {
	# Shorten the callback list.
	set searchp($pattern) $new
    } else {
	# Nothing monitors that pattern anymore, remove it completely.
	unset searchp($pattern)
    }
    return
}

proc ::nameserv::server::Search/Continuous/NotifyAdd {name val} {
    variable searchp

    # Abort quickly if there are no searches waiting.
    if {![array size searchp]} return

    foreach p [array names searchp] {
	if {![string match $p $name]} continue
	Notify $p add [list $name $val]
    }
    return
}

proc ::nameserv::server::Search/Continuous/NotifyRelease {gone} {
    variable searchp

    # Abort quickly if there are no searches waiting.
    if {![array size searchp]} return

    array set m $gone
    foreach p [array names searchp] {
	set response [array get m $p]
	if {![llength $response]} continue
	Notify $p remove $response
    }
    return
}

proc ::nameserv::server::Notify {p type response} {
    variable searchp
    variable comm

    foreach item $searchp($p) {
	foreach {id tag} $item break
	$comm send -async $id \
	    [list Search/Continuous/Change $tag $type $response]
    }
    return
}

# ### ### ### ######### ######### #########
## Initialization - In-memory database

namespace eval ::nameserv::server {
    # Database
    # search = list (id tag) : Searches are identified by client and a tag.
    #
    # array (id   -> list (name))      : Names under which a connection is known.
    # array (name -> data)             : Data associated with a name.
    #
    # array (pattern -> list (search)) : Per pattern the list of searches using it.
    # array (search -> pattern)        : Pattern per active search.
    #
    # searchp <~~> names
    # searchi <~~> data

    variable names   ; array set names {}
    variable data    ; array set data  {}
    variable searchp ; array set searchp {}
    variable searchi ; array set searchi {}
}

# ### ### ### ######### ######### #########
## INT: Connection management

proc ::nameserv::server::LOST {args} {
    # Currently just to see when a client goes away.

    upvar 1 id id chan chan reason reason
    ReleaseId $id
    return
}

# ### ### ### ######### ######### #########
## Initialization - System state

namespace eval ::nameserv::server {
    # Object command of the communication channel of the server.
    # If present re-configuration is not possible.

    variable comm {}
}

# ### ### ### ######### ######### #########
## API: Configuration management (host, port)

proc ::nameserv::server::cget {option} {
    return [configure $option]
}

proc ::nameserv::server::configure {args} {
    variable localonly
    variable port
    variable comm

    if {![llength $args]} {
	return [list -localonly $localonly -port $port]
    }
    if {[llength $args] == 1} {
	# cget
	set opt [lindex $args 0]
	switch -exact -- $opt {
	    -localonly { return $localonly }
	    -port      { return $port }
	    default {
		return -code error "bad option \"$opt\", expected -localonly, or -port"
	    }
	}
    }

    # Note: Should -port be made configurable after communication has
    # started it might be necessary to provide code to re-initialize
    # the connections to all known clients using the new
    # configuration.

    while {[llength $args]} {
	set opt [lindex $args 0]
	switch -exact -- $opt {
	    -localonly {
		if {[llength $args] < 2} {
		    return -code error "value for \"$opt\" is missing"
		}
		# Todo: Check boolean 
		set new  [lindex $args 1]
		set args [lrange $args 2 end]

		if {$new == $localonly} continue
		set localonly $new
		if {$comm eq ""} continue
		$comm configure -local $localonly
	    }
	    -port {
		if {$comm ne ""} {
		    return -code error "Unable to configure an active server"
		}
		if {[llength $args] < 2} {
		    return -code error "value for \"$opt\" is missing"
		}
		# Todo: Check non-zero unsigned short integer
		set port [lindex $args 1]
		set args [lrange $args 2 end]
	    }
	    default {
		return -code error "bad option \"$opt\", expected -localonly, or -port"
	    }
	}
    }
    return
}

# ### ### ### ######### ######### #########
## Initialization - Tracing, Configuration

logger::initNamespace ::nameserv::server
namespace eval        ::nameserv::server {
    # Port the server will listen on, and boolean flag determining
    # acceptance of non-local connections.

    variable port      [nameserv::common::port]
    variable localonly 1
}

# ### ### ### ######### ######### #########
## Ready

package provide nameserv::server 0.3.2

##
# ### ### ### ######### ######### #########