modules/nns/server.tcl

Go to the documentation of this file.

/*  -*- 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 ::nameserv::server {}

/*  ### ### ### ######### ######### #########*/
/*  API: Start, Stop*/

ret  ::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
}

ret  ::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
}

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

/*  ### ### ### ######### ######### #########*/
/*  INT: Protocol operations*/

ret  ::nameserv::server::ProtocolVersion  () {return 1}
ret  ::nameserv::server::ProtocolFeatures () {return {Core Search/Continuous}}

ret  ::nameserv::server::Bind (type name , type cdata) {
    variable comm
    variable names
    variable data

    set id [$comm remoteid]

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

    if {[info exists data($name)]} {
    return -code error "Name \"$name\" is already bound"
    }

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

    Search/Continuous/NotifyAdd $name $cdata
    return
}

ret  ::nameserv::server::Release () {
    variable comm
    ReleaseId [$comm remoteid]
    return
}

ret  ::nameserv::server::Search (type pattern) {
    variable data
    return [array get data $pattern]
}

ret  ::nameserv::server::ReleaseId (type 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*/

ret  ::nameserv::server::Search/Continuous/Start (type tag , type 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]
    if {[info exists searchi($k)]} return

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

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

ret  ::nameserv::server::Search/Continuous/Stop (type tag) {
    Search/Release [list [$comm remoteid] $tag]
    return
}

ret  ::nameserv::server::Search/Release (type 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
}

ret  ::nameserv::server::Search/Continuous/NotifyAdd (type name , type 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
}

ret  ::nameserv::server::Search/Continuous/NotifyRelease (type 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
}

ret  ::nameserv::server::Notify (type p , type type , 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 ::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  names =  {}
    variable data    ; array  data =   {}
    variable searchp ; array  searchp =  {}
    variable searchi ; array  searchi =  {}
}

/*  ### ### ### ######### ######### #########*/
/*  INT: Connection management*/

ret  ::nameserv::server::LOST (type 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 ::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)*/

ret  ::nameserv::server::cget (type option) {
    return [configure $option]
}

ret  ::nameserv::server::configure (type 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 == 1} {
            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 == 1} {
            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        ::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

/** 
 * ### ### ### ######### ######### #########