1# -*- tcl -*-
2# ### ### ### ######### ######### #########
3## Name Service - Client side connection monitor
4
5# ### ### ### ######### ######### #########
6## Requirements
7
8package require nameserv 0.4.1 ; # Name service client-side core
9package require uevent   ; # Watch for connection-loss
10
11namespace eval ::nameserv::auto {}
12
13# ### ### ### ######### ######### #########
14## API: Write, Read, Search
15
16proc ::nameserv::auto::bind {name data} {
17    # See nameserv::bind. Remembers the information, for re-binding
18    # when the connection was lost, and later restored.
19
20    # Note: Enter has a return value we do not want, bind has no
21    # return value. Otherwise 'Enter' would not be necessary and
22    # simply be 'bind'.
23
24    Enter $name $data normal
25    return
26}
27
28proc ::nameserv::auto::release {} {
29    # Releases all names the application has registered at the
30    # configured name service.
31    variable bindings
32    variable timer
33
34    array unset bindings *
35    if {$timer ne ""} {
36	# Actually release the data only if the connection is
37	# currently not lost. Otherwise they are gone already, and
38	# just forgetting them here (see above) was enough.
39	nameserv::release
40    }
41    return
42}
43
44proc ::nameserv::auto::search {args} {
45    variable searches
46
47    # Note: Here we are using a semi-public command of 'nameserv' to
48    # parse the search arguments on our own to determine if we need
49    # the persistence or not.
50
51    array set a [nameserv::search-parseargs $args]
52    upvar 0 a(oneshot)    oneshot
53    upvar 0 a(continuous) continuous
54    upvar 0 a(pattern)    pattern
55
56    if {!$continuous} {
57	# Result is direct result of the search, pass through to
58	# caller, nothing to persist.
59
60	return [eval [linsert $args 0 ::nameserv::search]]
61	# 8.5: return [nameserv::search {*}$args]
62    }
63
64    # Continuous or async search. The result we got is a receiver
65    # object. Wrap our own persistent receiver around it so that it
66    # can handle a loss of connection while we are waiting for the
67    # search result.
68
69    return [receiver %AUTO% $oneshot $args]
70}
71
72proc ::nameserv::auto::protocol {} {
73    return [nameserv::protocol]
74}
75
76proc ::nameserv::auto::server_protocol {} {
77    return [nameserv::server_protocol]
78}
79
80proc ::nameserv::auto::server_features {} {
81    return [nameserv::server_features]
82}
83
84# ### ### ### ######### ######### #########
85## Internal helper commands.
86
87proc ::nameserv::auto::Reconnect {args} {
88    # args = <>|<tags event details>
89    # <tag,event> = <'nameserv','lost'>
90    #     details = dict ('reason' -> string)
91
92    StopReconnect
93
94    if {![catch {
95	::nameserv::server_features
96    }]} {
97	# Note: Reloss of connection during Rebind will also
98	# StartReconnect
99	Rebind
100	return
101    }
102
103    StartReconnect
104    return
105}
106
107proc ::nameserv::auto::Rebind {} {
108    variable bindings
109    variable searches
110
111    foreach {name data} [array get bindings] {
112	if {![Enter $name $data restore]} return
113    }
114
115    foreach receiver [array names searches] {
116	if {![$receiver restore]} return
117    }
118
119    # Fully restored, time to notify interested parties
120    uevent::generate nameserv re-connection {}
121    return
122}
123
124proc ::nameserv::auto::Enter {name data how} {
125    variable bindings
126
127    # Remember locally for possible loss of connection ...
128    set bindings($name) $data
129
130    # ... then forward to name server
131    if {[catch {
132	nameserv::bind $name $data
133    } msg]} {
134	# Problem with server while (re)binding a name.
135
136	if {[string match {*No name server*} $msg]} {
137	    # Lost the server (again), while (re)binding a name. Abort
138	    # and restart the watcher waiting for the server to come
139	    # back.
140	    StartReconnect
141	    return 0
142	}
143
144	# Other error => (name already bound). This means that someone
145	# else took the name while we were not connected to the
146	# service, or the name was bound before the call anyway. The
147	# reaction depends on our entry point. For regular bind we
148	# return the error as is to keep API compatibility. During
149	# restoration OTOH the best effort we can do is to deliver a
150	# note about the total loss of this binding to all interested
151	# observers via event. Additionally remove the lost item from
152	# the set of names to remember. Note that there is no need to
153	# restart the watcher, the server was _not_ lost.
154
155	unset bindings($name)
156	if {$how eq "normal"} {
157	    return -code $msg
158	} else {
159	    uevent::generate nameserv lost-name [list name $name data $data]
160	    return 1
161	}
162    }
163
164    # Success, nothing further to do.
165    return 1
166}
167
168# ### ### ### ######### ######### #########
169## Management of the reconnect timer.
170
171proc ::nameserv::auto::StartReconnect {} {
172    variable timer
173    variable delay
174    if {$timer ne ""} return
175    set timer [after $delay ::nameserv::auto::Reconnect]
176    return
177}
178
179proc ::nameserv::auto::StopReconnect {} {
180    variable timer ""
181    return
182}
183
184# ### ### ### ######### ######### #########
185## Persistent receiver for continuous and async searches.
186
187snit::type ::nameserv::auto::receiver {
188
189    option -command -default {}
190
191    constructor {once search} {
192	set mysingleshot $once
193	set mysearch     $search
194	$self restore ; # Create internal volatile receiver.
195	return
196    }
197
198    destructor {
199	if {$myreceiver ne ""} { $myreceiver destroy }
200	if {$mysingleshot} return
201	Callback stop {}
202	return
203    }
204
205    method restore {} {
206	set nameserv::auto::searches($self) .
207
208	if {[catch {
209	    set result [eval [linsert $mysearch 0 ::nameserv::search]]
210	    # 8.5: set result [nameserv::search {*}$mysearch]
211	} msg]} {
212	    # Problem with server while restoring a search.
213
214	    if {[string match {*No name server*} $msg]} {
215		# Lost the server (again), while restoring the search.
216		# Abort and restart the watcher waiting for the server
217		# to come back.
218		::nameserv::auto::StartReconnect
219		return 0
220	    }
221
222	    # Rethrow other problems.
223	    return -code error $msg
224	}
225
226	# Restored, prepare ourselves
227	set myreceiver $result
228	set myclear    1       ; # Have to clear previous data when
229				 # the new set comes in.
230	$myreceiver configure -command [mymethod DATA]
231	return 1
232    }
233
234    method get {k} {
235	if {![info exists mycurrent($k)]} {return -code error "Unknown key \"$k\""}
236	return $current($k)
237    }
238
239    method names {} {
240	return [array names mycurrent]
241    }
242
243    method size {} {
244	return [array size mycurrent]
245    }
246
247    method getall {{pattern *}} {
248	return [array get mycurrent $pattern]
249    }
250
251    method filled {} {
252	return $myfilled
253    }
254
255    # Handler for events coming from the breakable search.
256
257    method {DATA stop} {args} {
258	# Ignore the response dict, it is empty anyway.
259	# Get rid of the volatile receiver.
260	if {$myreceiver ne ""} { $myreceiver destroy }
261	#  Oneshot handling happened already.
262	return
263    }
264
265    method {DATA add} {response} {
266	# New entries to handle
267	set myfilled 1
268	if {$mysingleshot} {
269	    # The search was async and is now done, therefore we can
270	    # get rid of the volatile receiver and do not have to care
271	    # about the loss of the connection any longer.
272	    $myreceiver destroy
273	    set myreceiver ""
274	    unset ::nameserv::auto::searches($self)
275	}
276	if {$myclear} {
277	    # Handle a refill after a connection loss, the new data
278	    # overwrites everything known before.
279	    array unset mycurrent *
280	    set myclear 0
281	}
282	array set mycurrent $response
283	Callback add $response
284	if {$mysingleshot} {
285	    Callback stop {}
286	}
287	return
288    }
289
290    method {DATA remove} {response} {
291	set myfilled 1
292	foreach {k v} $response {
293	    unset -nocomplain mycurrent($k)
294	}
295	Callback remove $response
296	return
297    }
298
299    # Run our own callback.
300
301    proc Callback {type response} {
302	upvar 1 options options
303	if {$options(-command) eq ""} return
304	# Defer execution to event loop
305	after 0 [linsert $options(-command) end $type $response]
306	return
307    }
308
309    # Search state
310
311    variable mysingleshot     0  ; # Bool flag, set if search is
312				   # async, not continous.
313    variable mycurrent -array {} ; # Current state of search results
314    variable myfilled         0  ; # Bool flag, set when result has arrived.
315
316    variable mysearch         "" ; # Copy of search definition, for
317				   # its restoration after our
318				   # connection to the service was
319				   # restored.
320    variable myclear          0  ; # Bool flag, set when state has to
321				   # be cleared before adding new
322				   # data, for refill after a
323				   # connection has been restored.
324    variable myreceiver       "" ; # Volatile breakable regular search
325				   # receiver.
326}
327
328# ### ### ### ######### ######### #########
329## Initialization - System state
330
331namespace eval ::nameserv::auto {
332    # In-memory database of bindings to restore after connection was
333    # lost and restored.
334
335    variable bindings ; array set bindings {}
336
337    # In-memory database of continuous and unfulfilled async searches
338    # to restore after the connection was lost and restored.
339
340    variable searches ; array set searches {}
341
342    # Handle of the timer used to periodically try to reconnect with
343    # the server in the case it was lost.
344
345    variable timer ""
346}
347
348# ### ### ### ######### ######### #########
349## API: Configuration management (host, port)
350
351proc ::nameserv::auto::cget {option} {
352    return [configure $option]
353}
354
355proc ::nameserv::auto::configure {args} {
356    variable delay
357
358    if {![llength $args]} {
359	# Merge the underlying configuration with the local settings
360	# before returning.
361	return [linsert [nameserv::configure] 0 -delay $delay]
362    }
363    if {[llength $args] == 1} {
364	# cget
365	set opt [lindex $args 0]
366	switch -exact -- $opt {
367	    -delay { return $delay }
368	    default {
369		# Not a local option, check with underlying package
370		# before throwing an error.
371		if {![catch {
372		    nameserv::cget $opt
373		} v]} {
374		    return $v
375		}
376		return -code error "[string map {{expected } {expected -delay, }} $v]"
377	    }
378	}
379    }
380
381    while {[llength $args]} {
382	set opt [lindex $args 0]
383	switch -exact -- $opt {
384	    -delay {
385		if {[llength $args] < 2} {
386		    return -code error "value for \"$opt\" is missing"
387		}
388		set delay [lindex $args 1]
389		set args  [lrange $args 2 end]
390
391		# Using the 'incr' hack instead of 'string is integer'
392		# allows delays larger than 32bit in Tcl 8.5.
393		if {[catch {incr delay 0}]} {
394		    return -code error "bad value for \"$opt\", expected integer, got \"$delay\""
395		} elseif {$delay <= 0} {
396		    return -code error "bad value for \"$opt\", is not greater than zero"
397		}
398	    }
399	    default {
400		# Not a local option, check with underlying package
401		# before throwing an error.
402		if {[catch {
403		    nameserv::configure $opt [lindex $args 1]
404		} v]} {
405		    if {[string match {bad option*} $v]} {
406			# Fix list of options in error before rethrowing.
407			return -code error "[string map {{expected } {expected -delay, }} $v]"
408		    } else {
409			# Rethrow error unchanged
410			return -code error $v
411		    }
412		}
413		# No error, option is processed, continue after it.
414		set args [lrange $args 2 end]
415	    }
416	}
417    }
418    return
419}
420
421# ### ### ### ######### ######### #########
422## Initialization - Tracing, Configuration
423
424logger::initNamespace ::nameserv::auto
425namespace eval        ::nameserv::auto {
426    # Interval between reconnection attempts when connection was lost.
427
428    variable delay 1000 ; # One second
429
430    namespace export bind release search protocol \
431	server_protocol server_features configure cget
432}
433
434# Watch the base client for the loss of the connection.
435uevent::bind nameserv lost-connection ::nameserv::auto::Reconnect
436
437# ### ### ### ######### ######### #########
438## Ready
439
440package provide nameserv::auto 0.3
441
442##
443# ### ### ### ######### ######### #########
444