source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/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)]} {
        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]
    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
}

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 == 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 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

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