[SDW] This is an example implementation of a client/server arrangment to execute commands in a remote safe interpreter.

This script may be out of date. Check Sean's website for changes: http://www.etoyoc.com/programs


  namespace eval ::rpc {
    variable mysock
    variable sport 
    variable connections

    proc trace string {
	puts $string
    }


    ###
    #  Change me, should be an odd number 
    #  smaller than the random number range
    ###
    variable secret_key  666
    variable secret_range 10000

    proc hash {arglist {key {}}} {
	set accum 0
	if { $key == {} } { 
	    variable secret_key
	    set key $secret_key
	}
	foreach s $arglist {
	    set accum [expr ($accum + $s) % $key]
	}
	return $accum
    }

    proc init {interp port} {
	variable mysock 
	variable sport 
	variable error_log_file

	set sport $port
	set mysock [socket -server [list ::rpc::newcon $interp] $port]
    }

    proc newcon {interp sock addr port} {

	fconfigure $sock -buffering line -translation crlf

	trace [list OPEN $sock from $addr]
	upvar #0 [namespace current]::${sock} state
	array set state [list interp $interp ipaddr $addr ipport $port state ready]
	fileevent $sock readable [list ::rpc::getline $sock]
	
    }

    proc closechan {sock} {
	catch { close $sock }
	trace "$sock closed"
	###
	#  Wake up any pending command
	###
	set [namespace current]::${sock}_block -1
	update
	catch {unset [namespace current]::${sock}_block}
	array unset [namespace current]::${sock}
    }

    proc getline {sock} { 
	upvar #0 [namespace current]::${sock} state
	if { [gets $sock line] < 0 } { 
	    closechan $sock
	    return
	}
	state_$state(state) $sock $line

    }

    proc state_ready {sock line} { 
	upvar #0 [namespace current]::${sock} state

	variable secret_range
	switch [lindex $line 0] {
	    NOOP {
		puts $sock [list NOOP]
	    }
	    AUTH {
		set n [expr rand() * 10]
		set state(challenge) {}
		for {set x 0} { $x < $n } { incr x } { 
		    lappend state(challenge) [expr int(rand() * $secret_range)]
		}
		puts $sock [list CHAL $state(challenge)]
	    }
	    RESP {
		set response [lindex $line 1]
		set correct [hash $state(challenge)]
		
		if { $response != $correct } { 
		    closechan $sock	    
		}
		set state(state) auth
		
		puts $sock "OK"
	    }
	    QUIT {
		closechan $sock
	    }
	}
    }

    proc state_auth {sock line} { 
	upvar #0 [namespace current]::${sock} state
	switch [lindex $line 0] { 
	    EVAL {
		puts $sock "BEGIN SCRIPT, TERMIATE WITH '.'"
		set state(state) data
		set state(script) {}
	    }
	    NOOP { 
		puts $sock NOOP
	    }
	}
	
    }

    proc state_data {sock line} { 
	upvar #0 [namespace current]::${sock} state
	if { $line == "." } { 
	    set buffer [decode $state(script)]
	    ###
	    #  Eval script
	    ###
	    set ::errorInfo {}

	    set err [catch { interp eval $state(interp) $buffer } reply]
	    if $err {
		puts $sock ERROR
		puts $sock [encode [list $err $reply $::errorInfo]]
	    } else {
		if ![regexp \n $reply] {
		    if { [string length $reply] > 32768 } {
			set reply [join $reply \n]
		    }
		}
		if [regexp \n $reply] {
		    puts $sock MULTILINE
		    puts $sock [encode $reply]
		    puts $sock .		
		} else {
		    puts $sock [list RETURN $reply]
		}
	    }

	    # puts $sock [list RETURN]

	    set state(state) auth
	} else {
	    if { $state(script) == {} } { 
		set state(script) $line
	    } else {
		append state(script) \n $line
	    }
	}
    }

    proc encode buffer {
	regsub -all "\n." $buffer "\n.." buffer
	return $buffer
    }

    proc decode buffer {
	regsub -all "\n.." $buffer "\n." buffer
	return $buffer
    }



    ###
    #  Begin Client Code
    ###

    proc reval_init {handle server port {key {}}} { 
	upvar #0 [namespace current]::${handle} token
	if { $key == {} } { 
	    variable secret_key
	    set key $secret_key
	}
	array set token [list handle $handle server $server port $port secret_key $key sock {}]
    }

    proc reval_wake handle {
	upvar #0 [namespace current]::${handle} token	
	set sock $token(sock)

	###
	# Check for echo
	###
	if { $sock != {} } {
	    if [catch {
		sendline $sock NOOP $handle NOOP line
	    }] {
		set sock {}
	    }
	}
	
	if { $sock == {} } { 
	    trace [list OPENING connection to $token(server) at $token(port)]
	    set sock [socket $token(server) $token(port)]
	    fconfigure $sock -buffering line -translation crlf -blocking 1
	    set token(sock) $sock
	    sendline $sock AUTH $handle CHAL line

	    set hash [hash [lindex $line 1] $token(secret_key)]
	    sendline $sock [list RESP $hash] $handle OK line
	}
	set token(sock) $sock
	return $sock
    }

    proc reval_reset {handle sock} {
	upvar #0 [namespace current]::${handle} token	
	closechan $sock
	set token(sock) {}
    }

    proc sendline {sock sendline handle token resultvar} { 
	upvar 1 $resultvar reply
	puts $sock $sendline
	if { [gets $sock reply] < 0 } { 
	    reval_reset $sock $handle
	    error "Connection Closed"
	}
	if { [lindex $reply 0] != "$token" } { 
	    error "Server sent [lindex $line 0] instead of $token in response to $sendline"
	}
	return $reply
    }

    proc recvline {sock} { 
	if { [gets $sock line] < 0 } { 
	    closechan $sock
	    error "Connection Closed"
	}
	return $line
    }

    proc getblock {sock varname} {
	upvar 1 $varname result
	set result {}
	while 1 {
	    if {[gets $sock line] < 0 } { 
		error "Connection Reset"
	    }
	    if { $line == "." } break
	    append result \n $line
	}
	return [decode [string range $result 1 end]]
    }

    proc reval {handle args} {
	if { [llength $args] == 1 } { 
	    set args [lindex $args 0]
	}
	set sock [reval_wake $handle]
	sendline $sock EVAL $handle BEGIN line

	puts $sock [encode $args]
	puts $sock .

	set reply [recvline $sock]
	switch [lindex $reply 0] {
	    RETURN {
		return [lindex $reply 1]
	    }
	    ERROR {
		if [catch {getblock $sock reply} err] {
		    reval_reset $handle $sock
		    error $err
		}
		return -code [lindex $reply 0] -errorinfo [lindex $reply 2] [lindex $reply 1]		
	    }
	    MULTILINE {
		if [catch {getblock $sock reply} err] {
		    reval_reset $handle $sock
		    error $err
		}
		return $reply
	    }
	}
    }

 }


Starting a server process:

    interp create -safe example
    ::rpc::init example 8016 1337
    ###
    #  Important, or the server will never
    #  start listening
    ###
    vwait forever

Starting a client process:

    ::rpc::reval_init localhost localhost 8016 1337
    set stmt {expr 1 + 1}
    set reply [::rpc::reval localhost $stmt]
    puts [list $stmt = $reply]





----
Related topics include "[Tuplespace]",
"[remote execution using tcl and Pcom]", 
"[Remote execution]",
"[remote ssh tcl]", '[mkextensions]' mkRinterp,
"[Simple remote Tk execution - distanciel]",
"[Distributing a series of tasks]", and so on.
And so on includes ... "[comm]".



----

[Category Example]