1# This file contains Tcl code to implement a remote server that can be
2# used during testing of Tcl socket code. This server is used by some
3# of the tests in socket.test.
4#
5# Source this file in the remote server you are using to test Tcl against.
6#
7# Copyright (c) 1995-1996 Sun Microsystems, Inc.
8#
9# See the file "license.terms" for information on usage and redistribution
10# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11#
12# RCS: @(#) $Id: remote.tcl,v 1.6 2004/02/11 22:41:25 razzell Exp $
13
14# load tls package
15package require tls
16
17# Initialize message delimitor
18
19# Initialize command array
20catch {unset command}
21set command(0) ""
22set callerSocket ""
23
24# Detect whether we should print out connection messages etc.
25# set VERBOSE 1
26if {![info exists VERBOSE]} {
27    set VERBOSE 0
28}
29
30proc __doCommands__ {l s} {
31    global callerSocket VERBOSE
32
33    if {$VERBOSE} {
34	puts "--- Server executing the following for socket $s:"
35	puts $l
36	puts "---"
37    }
38    if {0} {
39	set fd [open remoteServer.log a]
40	catch {puts $fd "skey: $serverKey"}
41	puts $fd "--- Server executing the following for socket $s:"
42	puts $fd $l
43	puts $fd "---"
44	close $fd
45    }
46    set callerSocket $s
47    if {[catch {uplevel #0 $l} msg]} {
48    	if {0} {
49	    set fd [open remoteServer.log a]
50	    puts $fd "error: $msg"
51	    close $fd
52	}
53	list error $msg
54    } else {
55	list success $msg
56    }
57}
58
59proc __readAndExecute__ {s} {
60    global command VERBOSE
61
62    set l [gets $s]
63    if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
64	if {[info exists command($s)]} {
65	    puts $s [list error incomplete_command]
66	}
67	puts $s "--Marker--Marker--Marker--"
68	return
69    }
70    if {[string compare $l ""] == 0} {
71	if {[eof $s]} {
72	    if {$VERBOSE} {
73		puts "Server closing $s, eof from client"
74	    }
75	    close $s
76	}
77	return
78    }
79    append command($s) $l "\n"
80    if {[info complete $command($s)]} {
81	set cmds $command($s)
82	unset command($s)
83	puts $s [__doCommands__ $cmds $s]
84    }
85    if {[eof $s]} {
86	if {$VERBOSE} {
87	    puts "Server closing $s, eof from client"
88	}
89	close $s
90    }
91}
92
93proc __accept__ {s a p} {
94    global VERBOSE
95
96    if {$VERBOSE} {
97	puts "Server accepts new connection from $a:$p on $s"
98    }
99    tls::handshake $s
100    fileevent $s readable [list __readAndExecute__ $s]
101    fconfigure $s -buffering line -translation crlf
102}
103
104set serverIsSilent 0
105for {set i 0} {$i < $argc} {incr i} {
106    if {[string compare -serverIsSilent [lindex $argv $i]] == 0} {
107	set serverIsSilent 1
108	break
109    }
110}
111if {![info exists serverPort]} {
112    if {[info exists env(serverPort)]} {
113	set serverPort $env(serverPort)
114    }
115}
116if {![info exists serverPort]} {
117    for {set i 0} {$i < $argc} {incr i} {
118	if {[string compare -port [lindex $argv $i]] == 0} {
119	    if {$i < [expr $argc - 1]} {
120		set serverPort [lindex $argv [expr $i + 1]]
121	    }
122	    break
123	}
124    }
125}
126if {![info exists serverPort]} {
127    set serverPort 8048
128}
129
130if {![info exists serverAddress]} {
131    if {[info exists env(serverAddress)]} {
132	set serverAddress $env(serverAddress)
133    }
134}
135if {![info exists serverAddress]} {
136    for {set i 0} {$i < $argc} {incr i} {
137	if {[string compare -address [lindex $argv $i]] == 0} {
138	    if {$i < [expr $argc - 1]} {
139		set serverAddress [lindex $argv [expr $i + 1]]
140	    }
141	    break
142	}
143    }
144}
145if {![info exists serverAddress]} {
146    set serverAddress 0.0.0.0
147}
148
149if {$serverIsSilent == 0} {
150    set l "Remote server listening on port $serverPort, IP $serverAddress."
151    puts ""
152    puts $l
153    for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"}
154    puts ""
155    puts ""
156    puts "You have set the Tcl variables serverAddress to $serverAddress and"
157    puts "serverPort to $serverPort. You can set these with the -address and"
158    puts "-port command line options, or as environment variables in your"
159    puts "shell."
160    puts ""
161    puts "NOTE: The tests will not work properly if serverAddress is set to"
162    puts "\"localhost\" or 127.0.0.1."
163    puts ""
164    puts "When you invoke tcltest to run the tests, set the variables"
165    puts "remoteServerPort to $serverPort and remoteServerIP to"
166    puts "[info hostname]. You can set these as environment variables"
167    puts "from the shell. The tests will not work properly if you set"
168    puts "remoteServerIP to \"localhost\" or 127.0.0.1."
169    puts ""
170    puts -nonewline "Type Ctrl-C to terminate--> "
171    flush stdout
172}
173
174set certsDir	[file join [file dirname [info script]] certs]
175set serverCert	[file join $certsDir server.pem]
176set caCert	[file join $certsDir cacert.pem]
177set serverKey	[file join $certsDir server.key]
178if {[catch {set serverSocket \
179	[tls::socket -myaddr $serverAddress -server __accept__ \
180	-cafile $caCert -certfile $serverCert -keyfile $serverKey \
181	$serverPort]} msg]} {
182    puts "Server on $serverAddress:$serverPort cannot start: $msg"
183} else {
184    vwait __server_wait_variable__
185}
186