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