Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: code/branches/wagnis_HS18/data/tcl/telnet_server.tcl @ 12227

Last change on this file since 12227 was 5781, checked in by rgrieder, 15 years ago

Reverted trunk again. We might want to find a way to delete these revisions again (x3n's changes are still available as diff in the commit mails).

  • Property svn:eol-style set to native
File size: 7.3 KB
Line 
1 #!/usr/bin/env tclsh
2 # Pseudo-telnet server.  Includes basic auth, but no separate identities
3 # or proper multi-threaded operation, so whoever runs this had better
4 # trust those he gives identities/passwords to and they had better trust
5 # each other too.  Note this script does not support command-line arguments.
6
7 ## The names of this array are IP addresses of hosts that are not permitted
8 ## to connect to any of our services.  Admin account(s) can change this
9 ## at run-time, though this info is not maintained across whole-server shutdowns.
10 array set denyHosts {}
11
12 ## Keep the Tcl-thread busy
13 proc every {ms body} { eval $body; after $ms [list every $ms $body] }
14 every 200 {}
15
16 ## Create a server on the given port with the given name/password map
17 ## and the given core interaction handler.
18 proc telnetServer {port {passmap} {handlerCmd remoteCommand}} {
19     if {$port == 0} {
20         return -code error "Only non-zero port numbers are supported"
21     }
22     set server [socket -server [list connect $port $handlerCmd] $port]
23     global passwords services
24     foreach {id pass} $passmap {set passwords($port,$id) $pass}
25     set services($server) $handlerCmd
26     return $server
27 }
28
29 ## Removes the server on the given port, cleaning up the extra state too.
30 proc closedownServer {server} {
31     global services passwords connections auth
32     set port [lindex [fconfigure $server -sockname] 2]
33     catch {close $server}
34     unset services($server)
35     foreach passmap [array names passwords $port,*] {
36         unset passwords($passmap)
37     }
38     # Hmph!  Have to remove unauthorized connections too, though any
39     # connection which has been authorized can continue safely.
40     foreach {client data} [array get connections] {
41         if {$port == [lindex $data 0] && !$auth($client)} {
42             disconnect $client
43         }
44     }
45 }
46
47 ## Handle an incoming connection to the given server
48 proc connect {serverport handlerCmd client clienthost clientport} {
49     global auth cmd denyHosts connections
50     if {[info exist denyHosts($clienthost)]} {
51         puts stdout "${clienthost}:${clientport} attempted connection"
52         catch {puts $client "Connection denied"}
53         catch {close $client}
54         return
55     }
56     puts stdout "${clienthost}:${clientport} connected on $client"
57     fileevent $client readable "handle $serverport $client"
58     set auth($client) 0
59     set cmd($client) $handlerCmd
60     set connections($client) [list $serverport $clienthost $clientport]
61     fconfigure $client -buffering none
62     catch {puts -nonewline $client "Login: "}
63 }
64
65 ## Disconnect the given client, cleaning up any connection-specific data
66 proc disconnect {client} {
67     catch {close $client}
68     global auth cmd connections
69     unset auth($client)
70     unset cmd($client)
71     unset connections($client)
72     puts stdout "$client disconnected"
73 }
74
75 ## Handle data sent from the client.  Log-in is handled directly by this
76 ## procedure, and requires the name and password on the same line
77 proc handle {serverport client} {
78     global passwords auth cmd
79     if {[gets $client line] < 0} {
80         disconnect $client
81         return
82     }
83     if {[string equal $line "logout"] || [string equal $line "quit"]} {
84         disconnect $client
85         return
86     }
87     if {[string equal $line "exit"]} {
88         set ::termination 1
89         return
90     }
91     if {$auth($client)} {
92         eval $cmd($client) [list $client $line 0]
93         eval $cmd($client) [list $client $line 1]
94         return
95     }
96     foreach {id pass} [split $line] {break}
97     if {![info exist pass]} {
98         catch {puts -nonewline $client "Login: "}
99         return
100     }
101     if {
102         [info exist passwords($serverport,$id)] &&
103         [string equal $passwords($serverport,$id) $pass]
104     } then {
105         set auth($client) 1
106         puts stdout "$id logged in on $client"
107         catch {puts $client "Welcome, $id!"}
108         eval $cmd($client) [list $client $line 1]
109         return
110     }
111     puts stdout "AUTH FAILURE ON $client"
112     catch {puts $client "Unknown name or password"}
113     disconnect $client
114 }
115
116 ## Standard handler for logged-in conversations and prompt-generation.
117 proc execCommand {client line prompt} {
118     global tcl_platform
119     if {$prompt} {
120         catch {puts -nonewline $client "\$ "}
121         return
122     }
123     switch $tcl_platform(platform) {
124         unix {
125             catch {exec sh -c $line <@$client >@$client 2>@$client}
126         }
127         default {
128             catch {exec $line} data
129             puts $client $data
130         }
131     }
132 }
133
134 ## Administration service handler.  Chains to the normal handler for
135 ## everything it doesn't recognise itself.
136 proc admin {client line prompt} {
137     if {$prompt} {
138         catch {puts -nonewline $client "# "}
139         return
140     }
141     set cmd [split $line]
142     global denyHosts connections services
143     if {[string equal $line "shutdown"]} {
144         set ::termination 1
145         puts stdout "Shutdown requested on $client"
146         catch {puts $client "System will shut down as soon as possible"}
147         return -code return "SHUTTING DOWN"
148     } elseif {[string equal [lindex $cmd 0] "deny"]} {
149         set denyHosts([lindex $cmd 1]) 1
150     } elseif {[string equal [lindex $cmd 0] "allow"]} {
151         catch {unset denyHosts([lindex $cmd 1])}
152     } elseif {[string equal $line "denied"]} {
153         foreach host [array names denyHosts] {
154             catch {puts $client $host}
155         }
156     } elseif {[string equal $line "connections"]} {
157         set len 0
158         foreach conn [array names connections] {
159             if {$len < [string length $conn]} {
160                 set len [string length $conn]
161             }
162         }
163         foreach {conn details} [array get connections] {
164             catch {puts $client [format "%-*s = %s" $len $conn $details]}
165         }
166     } elseif {[string equal [lindex $cmd 0] "close"]} {
167         set sock [lindex $cmd 1]
168         if {[info exist connections($sock)]} {
169             disconnect $sock
170         }
171     } elseif {[string equal $line "services"]} {
172         set len 0
173         foreach serv [array names services] {
174             if {$len < [string length $serv]} {
175                 set len [string length $serv]
176             }
177         }
178         foreach {serv handler} [array get services] {
179             set port [lindex [fconfigure $serv -sockname] 2]
180             catch {puts $client [format "%-*s (port %d) = handler %s" $len $serv $port $handler]}
181         }
182     } elseif {[string equal [lindex $cmd 0] "addService"]} {
183         set service [eval telnetServer [lrange $cmd 1 end]]
184         catch {puts $client "Created service as $service"}
185     } elseif {[string equal [lindex $cmd 0] "removeService"]} {
186         set service [lindex $cmd 1]
187         if {[info exist services($service)]} {
188             closedownServer $service
189         }
190     } else {
191         # CHAIN TO DEFAULT
192         execCommand $client $line 0
193     }
194 }
195 
196 ## Executes a given command
197 proc remoteCommand {client line prompt} {
198     global tcl_platform
199     if {$prompt} {
200         catch {puts -nonewline $client "\$ "}
201         return
202     }
203     catch {eval $line} data
204     puts $client $data
205 }
206
207 telnetServer 2560 {orxonox rocks} remoteCommand
208 telnetServer 2561 {orxadmin *****} admin
209
210 puts stdout "Ready for service"
211
212 vwait termination
213 execute exit
Note: See TracBrowser for help on using the repository browser.