Posted to tcl by black_13 at Fri May 30 20:46:42 GMT 2014view raw

  1. #!/usr/bin/tclsh
  2. #
  3. # Authors:
  4. # 2003, Reinhard Max
  5. # SSL support added by Pat Thoyts <patthoyts@users.sourceforge.net>
  6. #
  7. # This file may be used and distributed under the same conditions as Tcl/Tk
  8. #
  9.  
  10. # Which port do we listen on. The second element can be an alternative socket
  11. # command.
  12. set ports {{4242 {}} {443 {}}}
  13.  
  14. # If you want to use SSL on port 443 then you need to provide a pair of OpenSSL
  15. # files for the keys. We setup the tls package here and below we can specify
  16. # what command to use to create the socket for each port.
  17. if {![catch {package require tls 1.4}] } {
  18. if {[file exists server-public.pem]} {
  19. ::tls::init \
  20. -certfile server-public.pem \
  21. -keyfile server-private.pem \
  22. -ssl2 1 \
  23. -ssl3 1 \
  24. -tls1 0 \
  25. -require 0 \
  26. -request 0
  27. # fix this if you change the ports variable above.
  28. lset ports 1 1 ::tls::socket
  29. }
  30. }
  31.  
  32. # Which commands shall be understood by our protocol
  33. set commands {
  34. echo
  35. I
  36. help
  37. listme
  38. bye
  39. reload
  40. showstate
  41. auth
  42. }
  43.  
  44. array unset help
  45. array set help {
  46. help {Lists the available commands.}
  47. {help <command>} {Prints a short help on the given command.}
  48. {echo <arg>} {Return the given arguments.}
  49. {I am <name>} {Tell the server your name and it will greet you.}
  50. listme {Returns the Tcl script that implements this server.}
  51. bye {Close the connection.}
  52. showstate {Show the state array of the current connection.}
  53. {auth <user> <password>} {Authenticate yourself.}
  54. }
  55.  
  56. proc auth {user pass} {
  57. upvar 1 state state
  58. # Put your code for username/password lookup here.
  59. set state(user) $user
  60. set state(pass) $pass
  61. set state(auth) 1
  62. return OK
  63. }
  64.  
  65. proc showstate {} {
  66. upvar 1 state state
  67. farray state
  68. }
  69.  
  70. proc reload {args} {
  71. after idle [list source [info script]]
  72. return "Matrix reloaded! ;)"
  73. }
  74.  
  75. proc echo {args} {
  76. upvar 1 state state
  77. return $args
  78. }
  79.  
  80. proc I {args} {
  81. set args [lrange $args 1 end]
  82. return "Hello $args!"
  83. }
  84.  
  85. proc listme {} {
  86. set fd [open [info script]]
  87. set script [read $fd]
  88. close $fd
  89. return $script
  90. }
  91.  
  92. proc bye {} {
  93. upvar 1 state state
  94. after idle [list slaveServer::closeSocket $state(socket)]
  95. return "Good bye!"
  96. }
  97.  
  98. proc strip {string} {
  99. regsub -all -line {^\s+} $string {}
  100. }
  101.  
  102. proc max {a b} {expr {$a > $b ? $a : $b}}
  103.  
  104. proc farray {array {separator =} {pattern *}} {
  105. upvar $array a
  106. set names [lsort [array names a $pattern]]
  107. set max 0
  108. foreach name $names {
  109. set max [max $max [string length $name]]
  110. }
  111. set result [list]
  112. foreach name $names {
  113. lappend result [format " %-*s %s %s" $max $name $separator $a($name)]
  114. }
  115. return [join $result "\n"]
  116. }
  117.  
  118. proc help {{{<command>} {}}} {
  119. global help
  120. set helps [farray help - ${<command>}*]
  121. if {$helps == ""} {
  122. set helps "No help available for ${<command>}!"
  123. }
  124. return "\n$helps\n"
  125. }
  126.  
  127. namespace eval slaveServer {
  128. # procs that start with a lowercase letter are public
  129. namespace export {[a-z]*}
  130. variable serversocket
  131. }
  132.  
  133. proc slaveServer::closeSocket {socket} {
  134. variable $socket
  135. upvar 0 $socket state
  136. puts stderr "Closing $socket [clock format [clock seconds]]"
  137. catch {close $socket}
  138. unset state
  139. }
  140.  
  141. # This gets called whenever a client connects
  142. proc slaveServer::Server {socket host port} {
  143. variable $socket
  144. upvar 0 $socket state
  145. # just to be sure ...
  146. array unset state
  147. set state(socket) $socket
  148. set state(host) $host
  149. set state(port) $port
  150. puts stderr "New Connection: $socket $host $port [clock format [clock seconds]]"
  151. fconfigure $socket -buffering line -blocking 0
  152. fileevent $socket readable [namespace code [list Handler $socket]]
  153. puts $socket "Welcome to this little demo server!"
  154. puts $socket "Type \"help\" to see what you can do here."
  155. }
  156.  
  157. # This gets called whenever a client sends a new line
  158. # of data or disconnects
  159. proc slaveServer::Handler {socket} {
  160. variable $socket
  161. upvar 0 $socket state
  162.  
  163. # Do we have a disconnect?
  164. if {[eof $socket]} {
  165. closeSocket $socket
  166. return
  167. }
  168.  
  169. # Does reading the socket give us an error?
  170. if {[catch {gets $socket line} ret] == -1} {
  171. puts stderr "Closing $socket"
  172. closeSocket $socket
  173. return
  174. }
  175. # Did we really get a whole line?
  176. if {$ret == -1} return
  177.  
  178. # ... and is it not empty? ...
  179. set line [string trim $line]
  180. if {$line == ""} return
  181.  
  182. ## ... and not an SSL request? ...
  183. #if {[string index $line 0] == "\200"} {
  184. # puts stderr "SSL request - closing connection"
  185. # closeSocket $socket
  186. # return
  187. #}
  188.  
  189. # OK, so log it ...
  190. puts stderr "$socket > $line"
  191.  
  192. # ... evaluate it, ...
  193. if {[catch {slave eval $line} ret]} {
  194. set ret "ERROR: $ret"
  195. }
  196. # ... log the result ...
  197. puts stderr [regsub -all -line ^ $ret "$socket < "]
  198.  
  199. # ... and send it back to the client.
  200. if {[catch {puts $socket $ret}]} {
  201. closeSocket $socket
  202. }
  203. }
  204.  
  205. proc slaveServer::init {ports commands} {
  206. variable serversockets
  207. # (re-)create a safe slave interpreter
  208. catch {interp delete slave}
  209. interp create -safe slave
  210. # remove all predefined commands from the slave
  211. foreach command [slave eval info commands] {
  212. slave hide $command
  213. }
  214. # link the commands for the protocol into the slave
  215. puts -nonewline stderr "Initializing commands:"
  216. foreach command $commands {
  217. puts -nonewline stderr " $command"
  218. interp alias slave $command {} $command
  219. }
  220. puts stderr ""
  221. #(re-)create the server socket
  222. if {[info exists serversockets]} {
  223. foreach sock $serversockets {
  224. catch {close $sock}
  225. }
  226. unset serversockets
  227. }
  228. puts -nonewline stderr "Opening sockets:"
  229. foreach {port} $ports {
  230. foreach {port socketCmd} $port {}
  231. if {$socketCmd == {}} { set socketCmd ::socket }
  232. puts -nonewline stderr " $port ($socketCmd)"
  233. lappend serversockets \
  234. [$socketCmd -server [namespace code Server] $port]
  235. }
  236. puts stderr ""
  237. }
  238.  
  239. slaveServer::init $ports $commands
  240. if {![info exists forever]} {
  241. set forever 1
  242. vwait forever
  243. }