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 |
---|