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