1# -*- tcl -*-
2# ### ### ### ######### ######### #########
3## Name Service - Client side access
4
5# ### ### ### ######### ######### #########
6## Requirements
7
8package require Tcl 8.4
9package require comm             ; # Generic message transport
10package require interp           ; # Interpreter helpers.
11package require logger           ; # Tracing internal activity
12package require nameserv::common ; # Common/shared utilities
13package require snit             ; # OO support, for streaming search class
14package require uevent           ; # Generate events for connection-loss
15
16namespace eval ::nameserv {}
17
18# ### ### ### ######### ######### #########
19## API: Write, Read, Search
20
21proc ::nameserv::bind {name data} {
22    # Registers this application at the configured name service under
23    # the specified name, and provides a value.
24    #
25    # Note: The application is allowed register multiple names.
26    #
27    # Note: A registered name is automatically removed by the server
28    #       when the connection to it collapses.
29
30    DO Bind $name $data
31    return
32}
33
34proc ::nameserv::release {} {
35    # Releases all names the application has registered at the
36    # configured name service.
37
38    DO Release
39    return
40}
41
42proc ::nameserv::search {args} {
43    # Searches the configured name service for applications whose name
44    # matches the given pattern. Returns a dictionary mapping from the
45    # names to the data they provided at 'bind' time.
46
47    # In continuous and async modes it returns an object whose
48    # contents reflect the current set of matching entries.
49
50    array set a [search-parseargs $args]
51    upvar 0 a(oneshot)    oneshot
52    upvar 0 a(continuous) continuous
53    upvar 0 a(pattern)    pattern
54
55    if {$continuous} {
56	variable search
57	# This client uses the receiver object as tag for the search
58	# in the service. This is easily unique, and makes dispatch of
59	# incoming results later easy too.
60
61	set receiver [receiver %AUTO% $oneshot]
62	if {[catch {
63	    ASYNC Search/Continuous/Start $receiver $pattern
64	} err]} {
65	    # Release the allocated object to prevent a leak, then
66	    # rethrow the error.
67	    $receiver destroy
68	    return -code error $err
69	}
70
71	set search($receiver) .
72	return $receiver
73    } else {
74	return [DO Search $pattern]
75    }
76}
77
78proc ::nameserv::protocol {} {
79    return 1
80}
81
82proc ::nameserv::server_protocol {} {
83    return [DO ProtocolVersion]
84}
85
86proc ::nameserv::server_features {} {
87    return [DO ProtocolFeatures]
88}
89
90# ### ### ### ######### ######### #########
91## semi-INT: search argument processing.
92
93proc ::nameserv::search-parseargs {arguments} {
94    # This command is semi-public. It is not documented for public
95    # use, however the package nameserv::auto uses as helper in its
96    # implementation of the search command.
97
98    switch -exact [llength $arguments] {
99	0 {
100	    set oneshot    0
101	    set continuous 0
102	    set pattern    *
103	}
104	1 {
105	    set opt [lindex $arguments 0]
106	    if {$opt eq "-continuous"} {
107		set oneshot    0
108		set continuous 1
109		set pattern    *
110	    } elseif {$opt eq "-async"} {
111		set oneshot    1
112		set continuous 1
113		set pattern    *
114	    } else {
115		set oneshot    0
116		set continuous 0
117		set pattern    $opt
118	    }
119	}
120	2 {
121	    set opt [lindex $arguments 0]
122	    if {$opt eq "-continuous"} {
123		set oneshot    0
124		set continuous 1
125		set pattern    [lindex $arguments 1]
126	    } elseif {$opt eq "-async"} {
127		set oneshot    1
128		set continuous 1
129		set pattern    [lindex $arguments 1]
130	    } else {
131		return -code error "wrong\#args: Expected ?-continuous|-async? ?pattern?"
132	    }
133	}
134	default {
135	    return -code error "wrong\#args: Expected ?-continuous|-async? ?pattern?"
136	}
137    }
138
139    return [list oneshot $oneshot continuous $continuous pattern $pattern]
140}
141
142# ### ### ### ######### ######### #########
143## INT: Communication setup / teardown / use
144
145proc ::nameserv::DO {args} {
146    variable sid
147    log::debug [linsert $args end @ $sid]
148
149    if {[catch {
150	[SERV] send $sid $args
151	#eval [linsert $args 0 [SERV] send $sid] ;# $args
152    } msg]} {
153	if {[string match "*refused*" $msg]} {
154	    return -code error "No name server present @ $sid"
155	} else {
156	    return -code error $msg
157	}
158    }
159    # Result of the call
160    return $msg
161}
162
163proc ::nameserv::ASYNC {args} {
164    variable sid
165    log::debug [linsert $args end @ $sid]
166
167    if {[catch {
168	[SERV] send -async $sid $args
169	#eval [linsert $args 0 [SERV] send $sid] ;# $args
170    } msg]} {
171	if {[string match "*refused*" $msg]} {
172	    return -code error "No name server present @ $sid"
173	} else {
174	    return -code error $msg
175	}
176    }
177    # No result to return
178    return
179}
180
181proc ::nameserv::SERV {} {
182    variable comm
183    variable sid
184    variable host
185    variable port
186    if {$comm ne ""} {return $comm}
187
188    # NOTE
189    # -local 1 means that clients can only talk to a local
190    #          name service. Might make sense to auto-force
191    #          -local 0 for host ne "localhost".
192
193    set     interp [interp::createEmpty]
194    foreach msg {
195	Search/Continuous/Change
196    } {
197	interp alias $interp $msg {} ::nameserv::$msg
198    }
199
200    set sid  [list $port $host]
201    set comm [comm::comm new ::nameserv::CSERV \
202		  -interp $interp \
203		  -local  1 \
204		  -listen 1]
205
206    $comm hook lost ::nameserv::LOST
207
208    log::debug [list SERV @ $sid : $comm]
209    return $comm
210}
211
212proc ::nameserv::LOST {args} {
213    upvar 1 id id chan chan reason reason
214    variable comm
215    variable sid
216    variable search
217
218    log::debug [list LOST @ $sid - $reason]
219
220    $comm destroy
221
222    set comm {}
223    set sid  {}
224
225    # Notify async/cont search of the loss.
226    foreach r [array names search] {
227	$r DATA stop
228	unset search($r)
229    }
230
231    uevent::generate nameserv lost-connection [list reason $reason]
232    return
233}
234
235# ### ### ### ######### ######### #########
236## Initialization - System state
237
238namespace eval ::nameserv {
239    # Object command of the communication channel to the server.
240    # If present re-configuration is not possible. Also the comm
241    # id of the server.
242
243    variable comm {}
244    variable sid  {}
245
246    # Table of active async/cont searches
247
248    variable search ; array set search {}
249}
250
251# ### ### ### ######### ######### #########
252## API: Configuration management (host, port)
253
254proc ::nameserv::cget {option} {
255    return [configure $option]
256}
257
258proc ::nameserv::configure {args} {
259    variable host
260    variable port
261    variable comm
262
263    if {![llength $args]} {
264	return [list -host $host -port $port]
265    }
266    if {[llength $args] == 1} {
267	# cget
268	set opt [lindex $args 0]
269	switch -exact -- $opt {
270	    -host { return $host }
271	    -port { return $port }
272	    default {
273		return -code error "bad option \"$opt\", expected -host, or -port"
274	    }
275	}
276    }
277
278    if {$comm ne ""} {
279	return -code error "Unable to configure an active connection"
280    }
281
282    # Note: Should -port/-host be made configurable after
283    # communication has started it will be necessary to provide code
284    # which retracts everything from the old server and re-initializes
285    # the new one.
286
287    while {[llength $args]} {
288	set opt [lindex $args 0]
289	switch -exact -- $opt {
290	    -host {
291		if {[llength $args] < 2} {
292		    return -code error "value for \"$opt\" is missing"
293		}
294		set host [lindex $args 1]
295		set args [lrange $args 2 end]
296	    }
297	    -port {
298		if {[llength $args] < 2} {
299		    return -code error "value for \"$opt\" is missing"
300		}
301		set port [lindex $args 1]
302		# Todo: Check non-zero unsigned short integer
303		set args [lrange $args 2 end]
304	    }
305	    default {
306		return -code error "bad option \"$opt\", expected -host, or -port"
307	    }
308	}
309    }
310    return
311}
312
313# ### ### ### ######### ######### #########
314## Receiver for continuous and async searches
315
316proc ::nameserv::Search/Continuous/Change {tag type response} {
317
318    # Ignore messages for searches which were canceled already.
319    #
320    # Due to the async nature of the messages for cont/async search
321    # the client may have canceled the receiver object already, sent
322    # the stop message already, but still has to process search
323    # results which were already in flight. We ignore them.
324
325    if {![llength [info commands $tag]]} return
326
327    # This client uses the receiver object as tag, dispatch the
328    # received notification to it.
329
330    $tag DATA $type $response
331    return
332}
333
334snit::type ::nameserv::receiver {
335    option -command -default {}
336
337    constructor {{once 0}} {
338	set singleshot $once
339	return
340    }
341
342    destructor {
343	if {$singleshot} return
344	::nameserv::ASYNC Search/Continuous/Stop $self
345	Callback stop {}
346	return
347    }
348
349    method get {k} {
350	if {![info exists current($k)]} {return -code error "Unknown key \"$k\""}
351	return $current($k)
352    }
353
354    method names {} {
355	return [array names current]
356    }
357
358    method size {} {
359	return [array size current]
360    }
361
362    method getall {{pattern *}} {
363	return [array get current $pattern]
364    }
365
366    method filled {} {
367	return $filled
368    }
369
370    method {DATA stop} {} {
371	if {$filled && $singleshot} return
372	set singleshot 1 ; # Prevent 'stop' again during destruction.
373	Callback stop {}
374	return
375    }
376
377    method {DATA add} {response} {
378	set filled 1
379	if {$singleshot} {
380	    ASYNC Search/Continuous/Stop $self
381	}
382	array set current $response
383	Callback add $response
384	if {$singleshot} {
385	    Callback stop {}
386	}
387	return
388    }
389
390    method {DATA remove} {response} {
391	set filled 1
392	foreach {k v} $response {
393	    unset -nocomplain current($k)
394	}
395	Callback remove $response
396	return
397    }
398
399    proc Callback {type response} {
400	upvar 1 options options
401	if {$options(-command) eq ""} return
402	# Defer execution to event loop
403	after 0 [linsert $options(-command) end $type $response]
404	return
405    }
406
407    variable singleshot 0
408    variable current -array {}
409    variable filled 0
410}
411
412# ### ### ### ######### ######### #########
413## Initialization - Tracing, Configuration
414
415logger::initNamespace ::nameserv
416namespace eval        ::nameserv {
417    # Host and port to connect to, to get access to the nameservice.
418
419    variable host localhost
420    variable port [nameserv::common::port]
421
422    namespace export bind release search protocol \
423	server_protocol server_features configure cget
424}
425
426# ### ### ### ######### ######### #########
427## Ready
428
429package provide nameserv 0.4.2
430
431##
432# ### ### ### ######### ######### #########
433