1#
2# Sensus Consulting Ltd (c) 1997-1999
3# Matt Newman <matt@sensus.org>
4#
5# $Header$
6#
7# Simple REXEC Server
8#
9namespace eval rexec {
10    variable debug 0
11    variable state
12
13    proc now {} {
14	return [clock format [clock seconds] -format {%Y%m%d %T}]
15    }
16    proc log {msg {level 0}} {
17	variable debug
18	if {$level > $debug} return
19	puts stderr "[now] REXEC: $msg"
20	flush stderr
21	catch {update idletasks}
22    }
23    proc getns {chan} {
24	set data ""
25	while 1 {
26	    set c [read $chan 1]
27	    if [string compare $c "\0"]==0 {
28		return $data
29	    }
30	    append data $c
31	}
32    }
33    proc putns {chan str} {
34	puts -nonewline $chan "${str}\0"
35	flush $chan
36    }
37    proc nack {chan msg} {
38	puts $chan "\001${msg}"
39	flush $chan
40    }
41    proc ack {chan} {
42	puts -nonewline $chan "\0"
43	flush $chan
44    }
45    proc accept {callback chan host port} {
46	log "Accept: $chan $host $port"
47
48	fconfigure $chan -buffering none -translation binary
49
50	set rport [getns $chan]
51	if {$rport != "" && $rport != 0} {
52	    log "Calling back to $host.$rport"
53	    set rchan [socket $host $rport]
54	} else {
55	    set rchan ""
56	}
57	set user [getns $chan]
58	set pass [getns $chan]
59	set args [getns $chan]
60	log "user=$user pass=$pass args=>$args<"
61
62	if {[string compare $user abort]==0} {
63	    nack $chan "Bog off!"
64	    close $chan
65	    catch {close $rchan}
66	    return
67	}
68	if {[catch {eval $callback [list $user $pass] $args} ret]} {
69	    nack $chan $ret
70	} else {
71	    ack $chan
72	    puts $chan $ret
73	}
74	close $chan
75	catch {close $rchan}
76    }
77    proc clnt_accept {chan rchan host port} {
78	variable state
79	log "clnt_accept: $rchan $host $port"
80	set state($chan) $port
81    }
82    proc connect {host user pass cmd {port 512}} {
83	variable state
84	set chan [socket $host $port]
85	fconfigure $chan -translation binary -buffering none
86	#
87	# Setup control socket - sever will contact me.
88	#
89	#set rchan [socket -server "rexec::clnt_accept $chan" 0]
90	#set rport [lindex [fconfigure $rchan -sockname] 2]
91	#
92	# Tell server which port I am listening on.
93	#
94	#putns $chan ${rport}
95	# Disable callback channel
96	putns $chan ""
97
98	#
99	# Wait for server to connect back.
100	#
101	#log "waiting on $chan (rchan=$rchan)"
102	#vwait [namespace which -variable state]($chan)
103	#log "got reply, logging in..."
104	#
105	# Logon
106	#
107	putns $chan ${user}
108	putns $chan ${pass}
109	putns $chan ${cmd}
110	#
111	# If all is well the server will send "\0", otherwise it
112	# will send an error.
113	#
114	log "checking status..."
115	set c [read $chan 1]
116	if {[string compare $c "\0"]!=0} {
117	    set err [gets $chan]
118	    close $chan
119	    catch {close $rchan}
120	    error $err
121	}
122	set msg [gets $chan]
123	# Auto-close
124	close $chan
125	return $msg
126	#
127	#fconfigure $chan -translation auto -buffering line
128	#return $chan
129    }
130}
131proc bgerror {args} {
132    tclLog ${::errorInfo}
133}
134proc rexec::callback {user pass args} {
135    # Default callback - no security!
136    eval $args
137}
138array set opts {
139    -port 	512
140    -ipaddr	0.0.0.0
141}
142
143while {[llength $argv] > 0} {
144    set option [lindex $argv 0]
145    if {![info exists opts($option)] || [llength $argv] == 1} {
146	puts stderr "usage: rexecd ?options?"
147	puts stderr "\nwhere options are any of the following:\n"
148	foreach opt [lsort [array names opts -*]] {
149	    puts stderr [format "\t%-15s default: %s" $opt $opts($opt)]
150	}
151	exit 1
152    }
153    set opts($option) [lindex $argv 1]
154    set argv [lrange $argv 2 end]
155}
156
157set svcfd [socket -server [list rexec::accept rexec::callback] \
158	-myaddr $opts(-ipaddr) $opts(-port)]
159
160tclLog "Accepting connections on rexec://$opts(-ipaddr):$opts(-port)/"
161
162if {![info exists tcl_service]} {
163    vwait forever		;# start the Tcl event loop
164}
165