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): |
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 |
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 |
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 |
|
} |