/[tcldrop]/tcldrop/modules/conn.tcl
ViewVC logotype

Diff of /tcldrop/modules/conn.tcl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11 by fireegl, Wed Dec 3 03:39:41 2003 UTC revision 1.12 by uid66278, Wed Dec 24 05:58:49 2003 UTC
# Line 33  namespace eval ::tcldrop::conn { Line 33  namespace eval ::tcldrop::conn {
33          variable version {0.7}          variable version {0.7}
34          package provide tcldrop::conn $version          package provide tcldrop::conn $version
35          variable rcsid {$Id$}          variable rcsid {$Id$}
36            ::tcldrop::SetDefault my-hostname {}
37            ::tcldrop::SetDefault my-ip {}
38            ::tcldrop::SetDefault ident-timeout 13
39          variable Defaults          variable Defaults
         if {![info exists ::my-ip]} { set ::my-ip {} }  
40          set Defaults(global) [list {async} {1} {buffering} {line} {myaddr} ${::my-ip} {blocking} {0} {timeout} {237}]          set Defaults(global) [list {async} {1} {buffering} {line} {myaddr} ${::my-ip} {blocking} {0} {timeout} {237}]
41          # Export all the commands that should be available to 3rd-party scripters:          # Export all the commands that should be available to 3rd-party scripters:
42          namespace export connect control config controlsock          namespace export listen connect control config controlsock addlistentype
43  }  }
44    
45  # This sets defaults for outgoing connections (they can be overridden by connect):  # This sets defaults for outgoing connections (they can be overridden by connect):
# Line 53  proc ::tcldrop::conn::Config {{type {-}} Line 55  proc ::tcldrop::conn::Config {{type {-}}
55                  {GLOBAL} - {DEFAULTS} - {DEFAULT} - {*} - {} { set type {global} }                  {GLOBAL} - {DEFAULTS} - {DEFAULT} - {*} - {} { set type {global} }
56                  {default} { set type [string tolower $type] }                  {default} { set type [string tolower $type] }
57          }          }
58          # Then override the global defaults with          # Then override the global defaults with the previously saved defaults for $type:
         # the previously saved defaults for $type:  
59          if {[info exists Defaults($type)]} { array set options $Defaults($type) }          if {[info exists Defaults($type)]} { array set options $Defaults($type) }
60          # Finally override those with the ones provided in $connoptions:          # Finally override those with the ones provided in $connoptions:
61          set proxynum 0          set proxynum 0
# Line 81  proc ::tcldrop::conn::Config {{type {-}} Line 82  proc ::tcldrop::conn::Config {{type {-}}
82  proc ::tcldrop::conn::config {{type {-}} args} { Config $type $args }  proc ::tcldrop::conn::config {{type {-}} args} { Config $type $args }
83    
84  proc ::tcldrop::conn::connect {address port args} {  proc ::tcldrop::conn::connect {address port args} {
         set idx [::tcldrop::idx::Assign]  
         ::tcldrop::idx::Register $idx [list idx $idx timestamp [unixtime]]  
85          array set options [Config - $args]          array set options [Config - $args]
         ::tcldrop::idx::ChInfo $idx [array get options]  
86          if {$options(async)} { set async {-async} } else { set async {} }          if {$options(async)} { set async {-async} } else { set async {} }
87          if {[info exists options(myaddr)] && $options(myaddr) != {}} {          if {[info exists options(myaddr)] && $options(myaddr) != {}} { set myaddr "-myaddr $options(myaddr)" } else { set myaddr {} }
88                  set fail [catch { eval {socket} $async {-myaddr} {$options(myaddr)} {$address} {$port} } sock]          if {![catch { eval {socket} $async $myaddr {$address} {$port} } sock]} {
         } else {  
                 set fail [catch { eval {socket} $async {$address} {$port} } sock]  
         }  
         if {!$fail} {  
89                  fconfigure $sock -buffering $options(buffering) -blocking $options(blocking)                  fconfigure $sock -buffering $options(buffering) -blocking $options(blocking)
90                    set idx [assignidx]
91                    registeridx $idx [concat [array get options] [list idx $idx timestamp [clock seconds] sock $sock connecttimer [utimer $options(timeout) [list ::tcldrop::conn::ConnectTimeout $idx]]]]
92                  fileevent $sock writable [list ::tcldrop::conn::Write $idx]                  fileevent $sock writable [list ::tcldrop::conn::Write $idx]
93                  fileevent $sock readable [list ::tcldrop::conn::Read $idx]                  fileevent $sock readable [list ::tcldrop::conn::Read $idx]
                 ::tcldrop::idx::ChInfo $idx [list sock $sock connecttimer [utimer $options(timeout) [list ::tcldrop::conn::ConnectTimeout $idx]]]  
94                  return $idx                  return $idx
95          } else {          } else {
                 killidx $idx  
96                  return -code error $sock                  return -code error $sock
97          }          }
98  }  }
99    
100  proc ::tcldrop::conn::controlsock {sock args} {  proc ::tcldrop::conn::controlsock {sock args} {
101          if {![eof $sock]} {          if {![eof $sock]} {
                 set idx [::tcldrop::idx::Assign]  
                 ::tcldrop::idx::Register $idx [list idx $idx timestamp [unixtime]]  
102                  array set options [Config - $args]                  array set options [Config - $args]
                 ::tcldrop::idx::ChInfo $idx [array get options]  
                 ::tcldrop::idx::ChInfo $idx [list sock $sock]  
103                  fconfigure $sock -buffering $options(buffering) -blocking $options(blocking)                  fconfigure $sock -buffering $options(buffering) -blocking $options(blocking)
104                    set idx [assignidx]
105                    registeridx $idx [concat [array get options] [list sock $sock idx $idx timestamp [unixtime] connecttimer [utimer $options(timeout) [list ::tcldrop::conn::ConnectTimeout $idx]]]]
106                  fileevent $sock writable [list ::tcldrop::conn::Write $idx]                  fileevent $sock writable [list ::tcldrop::conn::Write $idx]
107                  fileevent $sock readable [list ::tcldrop::conn::Read $idx]                  fileevent $sock readable [list ::tcldrop::conn::Read $idx]
                 ::tcldrop::idx::ChInfo $idx [list connecttimer [utimer $options(timeout) [list ::tcldrop::conn::ConnectTimeout $idx]]]  
108                  return $idx                  return $idx
109          } else {          } else {
110                  return -code error $sock                  return -code error $sock
# Line 121  proc ::tcldrop::conn::controlsock {sock Line 112  proc ::tcldrop::conn::controlsock {sock
112  }  }
113    
114  # Note that you can tell connect what command to use with the -control option.  # Note that you can tell connect what command to use with the -control option.
115  proc ::tcldrop::conn::control {idx command} {  proc ::tcldrop::conn::control {idx command} { setidxinfo $idx [list control $command] }
         ::tcldrop::idx::ChInfo $idx [list control $command]  
 }  
116    
117  proc ::tcldrop::conn::Read {idx} {  proc ::tcldrop::conn::Read {idx} {
118          foreach {a d} [::tcldrop::idx::Info $idx] { array set idxinfo $d }          array set idxinfo [getidxinfo $idx]
119          if {[set error [fconfigure $idxinfo(sock) -error]] != {}} {          if {[set error [fconfigure $idxinfo(sock) -error]] != {} || [eof $idxinfo(sock)]} {
120                  putloglev d * "net: error!(connect) idx $idx  (${error})"                  if {$error != {}} {
121                  catch { killutimer $idxinfo(connecttimer) }                          putloglev d * "net: error!(connect) idx $idx  (${error})"
122                  # Send {} to the control proc and kill the sock/idx.  Note, A check on valididx (from the control proc) is one way to tell wether or not an EOF has actually been received.                          catch { killutimer $idxinfo(connecttimer) }
123                  $idxinfo(control) $idx {}                  } else {
124                            putloglev d * "net: eof!(read) idx $idx"
125                            set error {EOF}
126                    }
127                    if {[info exists idxinfo(errors)]} { $idxinfo(errors) $idx $error }
128                  killidx $idx                  killidx $idx
         } elseif {[eof $idxinfo(sock)]} {  
                 putloglev d * "net: eof!(read) idx $idx"  
129                  # Send {} to the control proc and kill the sock/idx.  Note, A check on valididx (from the control proc) is one way to tell wether or not an EOF has actually been received.                  # Send {} to the control proc and kill the sock/idx.  Note, A check on valididx (from the control proc) is one way to tell wether or not an EOF has actually been received.
130                  $idxinfo(control) $idx {}                  if {[info exists idxinfo(control)]} { $idxinfo(control) $idx {} }
                 killidx $idx  
131          } elseif {[info exists idxinfo(control)]} {          } elseif {[info exists idxinfo(control)]} {
132                  # For speed, we process all available lines.  (This is absolutely necessary when running inside an Eggdrop, because Eggdrop's event loops are 1 second apart)                  # For speed, we process all available lines.  (This is absolutely necessary when running inside an Eggdrop, because Eggdrop's event loops are 1 second apart)
133                  while {[gets $idxinfo(sock) line] >= 1} { $idxinfo(control) $idx $line }                  while {[gets $idxinfo(sock) line] >= 0} {
134                            set starttime [clock clicks]
135                            $idxinfo(control) $idx $line
136                            putloglev d * "conn: process time: [expr {[clock clicks] - $starttime}]"
137                    }
138          } else {          } else {
139                  putloglev d * "net: control!(read) idx $idx  (no control proc defined!)"                  putloglev d * "net: control!(read) idx $idx  (no control proc defined!)"
140                  killidx $idx                  # killidx $idx
141          }          }
142  }  }
143    
144  proc ::tcldrop::conn::Write {idx} {  proc ::tcldrop::conn::Write {idx} {
145          foreach {a d} [::tcldrop::idx::Info $idx] { array set idxinfo $d }          array set idxinfo [getidxinfo $idx]
146          catch { killutimer $idxinfo(connecttimer) }          catch { killutimer $idxinfo(connecttimer) }
147          catch { fileevent $idxinfo(sock) writable {} }          # Note, I don't know if it's possible to get an error or EOF from here, but just in case:
148          if {[info exists idxinfo(writable)]} { $idxinfo(writable) $idx }          if {[set error [fconfigure $idxinfo(sock) -error]] != {} || [eof $idxinfo(sock)]} {
149                    putloglev d * "net: error!(write) idx $idx  ${error}"
150                    if {[info exists idxinfo(errors)]} { $idxinfo(errors) $idx $error }
151                    killidx $idx
152                    # Send {} to the control proc and kill the sock/idx.  Note, A check on valididx (from the control proc) is one way to tell wether or not an EOF has actually been received.
153                    if {[info exists idxinfo(control)]} { $idxinfo(control) $idx {} }
154            } elseif {[info exists idxinfo(writable)]} {
155                    catch { fileevent $idxinfo(sock) writable {} }
156                    $idxinfo(writable) $idx
157            }
158  }  }
159    
160  proc ::tcldrop::conn::ConnectTimeout {idx} {  proc ::tcldrop::conn::ConnectTimeout {idx} {
161          putloglev d * "net: timeout!(connect) idx $idx"          putloglev d * "net: timeout!(connect) idx $idx"
162          foreach {a d} [::tcldrop::idx::Info $idx] { array set idxinfo $d }          array set idxinfo [getidxinfo $idx]
163          catch { killutimer $idxinfo(connecttimer) }          catch { killutimer $idxinfo(connecttimer) }
164          catch { fileevent $idxinfo(sock) writable {} }          if {[info exists idxinfo(errors)]} { $idxinfo(errors) $idx {Connect Timeout} }
165          killidx $idx          killidx $idx
166            if {[info exists idxinfo(control)]} { $idxinfo(control) $idx {} }
167  }  }
168    
169    
170    # code from dcc.tcl follows:
171    
172    
173    #  listen <port> <type> [options] [flag]
174    #    Description: opens a listening port to accept incoming telnets; type
175    #      must be one of "bots", "all", "users", "script", or "off":
176    
177    #        listen <port> bots [mask]
178    #          Description: accepts connections from bots only; the optional mask
179    #            is used to identify permitted bot names. If the mask begins with
180    #            '@', it is interpreted to be a mask of permitted hosts to accept
181    #            connections from.
182    #          Returns: port number
183    
184    #        listen <port> users [mask]
185    #          Description: accepts connections from users only (no bots); the
186    #            optional mask is used to identify permitted nicknames. If the
187    #            mask begins with '@', it is interpreted to be a mask of permitted
188    #            hosts to accept connections from.
189    #          Returns: port number
190    
191    #        listen <port> all [mask]
192    #          Description: accepts connections from anyone; the optional mask
193    #            is used to identify permitted nicknames/botnames. If the mask
194    #            begins with '@', it is interpreted to be a mask of permitted
195    #            hosts to accept connections from.
196    #          Returns: port number
197    
198    #        listen <port> script <proc> [flag]
199    #          Description: accepts connections which are immediately routed to
200    #            a proc. The proc is called with one parameter: the idx of the
201    #            new connection. Flag may currently only be 'pub', which makes
202    #            the bot allow anyone to connect.
203    #          Returns: port number
204    
205    #        listen <port> off
206    #          Description: stop listening on a port
207    #          Returns: nothing
208    #    Module: core
209    
210    # Note/FixMe: tcldrop does not support flag or mask in the above.  But should if somebody requests it.
211    
212    # $type should be eggdrop1.7 types, and allow for compatibility with eggdrop1.6.
213    # Note: Since at this time (December 2003), we don't know what eggdrop1.7 calls them, we'll guess, and make changes later if needed.
214    # The possible types for eggdrop1.6 should be:
215    # all, users, bots, script, and off.
216    # The possible types for eggdrop1.7 may be:
217    # dccparty, telnetparty, ircparty, and obots.
218    
219    proc ::tcldrop::conn::listen {port type args} {
220            # First make sure we're not already listening on $port:
221            foreach {a d} [idxlist] {
222                    array set idxinfo $d
223                    if {[info exists idxinfo(port)] && [string equal $port $idxinfo(port)]} {
224                            if {[string equal -nocase {off} $type]} {
225                                    catch { close $idxinfo(sock) }
226                            } else {
227                                    putlog "already listening on port $port"
228                            }
229                            return $port
230                    }
231            }
232            switch -- [set type [string tolower $type]] {
233                    {all} { return -code error {Tcldrop doesn't support "listen <port> all"; please use a separate port for bots and users.} }
234                    {script} { array set options [concat [list type $type ident 0 ssl 0 connect [lindex $args 0]] [lrange $args 1 end]] }
235                    {off} { return 0 }
236                    {default} {
237                            # Support for types that modules may provide goes here.
238                            variable ListenTypes
239                            if {[info exists ListenTypes($type)]} {
240                                    array set options [concat [list type $type ident 0 ssl 0 connect {}] $ListenTypes($type) $args]
241                            } else {
242                                    return -code error "No such listen type: $type"
243                            }
244                    }
245            }
246            if {$options(ssl)} {
247                    if {![catch { package require tls }]} {
248                            set socket {::tls::socket}
249                    } else {
250                            return -code error {SSL not supported, because the "tls" package is not installed.}
251                    }
252            } else {
253                    set socket {socket}
254            }
255            if {![catch { $socket -server [list ::tcldrop::conn::Connect [array get options]] $port } sock]} {
256                    fconfigure $sock -buffering line -blocking 0
257                    set idx [assignidx]
258                    registeridx $idx [list idx $idx sock $sock handle ($type) remote {*} hostname * port $port type $type other "lstn  $port" timestamp [clock seconds]]
259                    putlog "Listening at telnet port $port ($type)"
260                    return $port
261            } else {
262                    return -code error "error while trying to listen on port: $sock"
263            }
264    }
265    
266    # Adds new listen types (so that the [listen] command can know what to do with them):
267    # $args should contain the following:
268    # ident 1/0
269    # connect <procname>
270    proc ::tcldrop::conn::addlistentype {type args} {
271            variable ListenTypes
272            set ListenTypes([string tolower $type]) $args
273    }
274    
275    # This is a callback to the ::ident::ident command,
276    # it simply updates the idx info to show the ident responce.
277    proc ::tcldrop::conn::Ident {idx options id status response} {
278            array set idxinfo [getidxinfo $idx]
279            if {$status == {ok}} {
280                    setidxinfo $idx [list ident $response remote $response@$idxinfo(hostname)]
281            } else {
282                    setidxinfo $idx [list ident -telnet remote -telnet@$idxinfo(hostname)]
283            }
284            # Run the connect proc:
285            array set optinfo $options
286            if {$optinfo(connect) != {}} {
287                    $optinfo(connect) $idx
288                    fileevent $idxinfo(sock) writable [list ::tcldrop::conn::Write $idx]
289                    fileevent $idxinfo(sock) readable [list ::tcldrop::conn::Read $idx]
290            }
291    }
292    
293    proc ::tcldrop::conn::Connect {options sock ip port} {
294            array set optinfo $options
295            set idx [assignidx]
296            putloglev d * "net: connect! idx $idx (socket $sock)"
297            registeridx $idx [list idx $idx sock $sock handle * ident {-telnet} hostname [set hostname [lindex [fconfigure $sock -peername] 1]] ip $ip remote -telnet@$hostname port $port type $optinfo(type) ssl $optinfo(ssl) other "$optinfo(type)-in" timestamp [unixtime] traffictype misc]
298            # Depending on the ident option, do an ident lookup and then run the connect proc:
299            # 0 means don't do an ident at all.
300            # 1 means do an ident, and wait until it completes before calling the connect proc.
301            # 2 means do an ident, but call the connect proc without waiting for the ident lookup to complete.
302            switch -- $optinfo(ident) {
303                    {0} {
304                            $optinfo(connect) $idx
305                            fileevent $sock writable [list ::tcldrop::conn::Write $idx]
306                            fileevent $sock readable [list ::tcldrop::conn::Read $idx]
307                    }
308                    {1} { ::ident::ident -sock $sock -timeout [expr { ${::ident-timeout} * 1000 }] -command [list ::tcldrop::conn::Ident $idx $options] }
309                    {2} - {default} {
310                            $optinfo(connect) $idx
311                            fileevent $sock writable [list ::tcldrop::conn::Write $idx]
312                            fileevent $sock readable [list ::tcldrop::conn::Read $idx]
313                            set optinfo(connect) {}
314                            ::ident::ident -sock $sock -timeout [expr { ${::ident-timeout} * 1000 }] -command [list ::tcldrop::conn::Ident $idx [array get optinfo]]
315                    }
316            }
317    }

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26