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