# $File$
#
# $Month$ $Year$, $User$
#
# Copyright (c) $Year$ by Cisco Systems, Inc.
# All rights reserved
#
# $Id: cvrpc.tcl,v 1.1.2.9 1996/03/29 01:01:06 iwallis Exp $
#
# $Endlog$
#
# WARNING!
#
# Emulation of tcl_dp RPC calls over native sockets in tk4.1.  See the 
# dp_RPC(n) man page.  The performance could be radically improved by
# recoding in C.  Since we don't have a requestid associated with each
# socket write, it is possible to not call the dp_RDO callbacks if an
# dp_RDO is followed by a dp_RPC.  The dp_RPC will return prematurely
# when the dp_RDO finally gets a response.
#
# Globals:
#
#	Dp_response	array indexed by socket descriptor which contains
#			response or state.  The states are:
#
#			dpblock:	synchronous request
#			dpnonblock:	asynchronous request
#			dpclosed:	connection has been closed
#			dptimeout:	call has timed out
#			dpcancel:	call has been cancelled
#			dpillegal:	call is illegal
#
#			(Let's hope no legitimate responses collide.)
#
#	Dp_loginProc	array indexed by socket number.  If set, call before
#			accepting connections.
#
#	Dp_cmdCheckProc	array indexed by socket descriptor.  If set, call 
#			before evaluating input.
#
#	Dp_RDOCB	array indexed by socket descriptor.  If set, call
#			on asynchronous response.
#
#	Dp_RDOErrorCB	array indexed by socket descriptor.  If set, call
#			on asynchronous error.
#
#	dp_rpcFile	current (or last) socket descriptor.
#
#	dp_ACL		access control list

# Blocking RPC call
# 	parameters are ?-events events? ?-timeout millisecs
#		 ??-timeoutReturn callback??? command ?args ...?
# XXX no -events support (needs to be done in C)
proc dp_RPC {sd args} {
        global Dp_response

	# Check for flags
	for {set i 0; set len [llength $args]} {$i < $len} {incr i} {
		if {[string index [lindex $args $i] 0] == "-"} {
			switch -exact -- [lindex $args $i] {
			-events		{incr i; # ignore}
			-timeout	{incr i; set timeout [lindex $args $i]}
			-timeoutReturn	{incr i; set timeoutReturn [lindex $args $i]}
			default		{error "[lindex $args $i]: unknown option"}
			}
		} else {
			break;	# Stop at end of flags
		}
	}
	if !$len {
		error "empty command"
	}
	if $i {
		# Remove flags from args
		incr i -1
		set args [lreplace $args 0 $i]

		if [info exists timeout] {
			# Wakeup after timeout and cancel RPC
			if ![info exists timeoutReturn] {
				set timeoutReturn ""
			}
			after $timeout dp_CheckTimeout $sd $timeoutReturn
		}
	}

	set Dp_response($sd) dpblock;	# inform dp_echoResp of response type
        puts $sd $args
        flush $sd
        vwait Dp_response($sd);		# wait for response
	if {$Dp_response($sd) == "dpcancel" || $Dp_response($sd) == "dptimeout"} {
		error $Dp_response($sd)
	}
        return $Dp_response($sd)
}

proc dp_CheckTimeout {sd {cb ""} } {
	global Dp_response

	if {$cb==""} {
		set Dp_response($sd) dptimeout
	} else {
		set Dp_response($sd) $cb
	}
}

# Non-blocking RPC call
#	parameters are peer ?-callback resultCallback? 
#		?-onerror errorCallback? command ?args ...?
proc dp_RDO {sd args} {
	global Dp_response Dp_RDOCB Dp_RDOErrorCB

	# Check for flags
	for {set i 0; set len [llength $args]} {$i < $len} {incr i} {
		if {[string index [lindex $args $i] 0] == "-"} {
			switch -exact -- [lindex $args $i] {
			-callback {incr i; set resultCallback [lindex $args $i]}
			-onerror  {incr i; set errorCallback [lindex $args $i]}
			default   {error "[lindex $args $i]: unknown option"}
			}
		} else {
			break;	# Stop at end of flags
		}
	}

	if !$len {
		error "empty command"
	}
	if $i {
		# Remove flags from args
		incr i -1
		set args [lreplace $args 0 $i]
	}
	set Dp_response($sd) dpnonblock

	if [info exists resultCallback] {
		set Dp_RDOCB($sd) $resultCallback
	} else {
		catch {unset Dp_RDOCB($sd)}
	}
	if [info exists errorCallback] {
		set Dp_RDOErrorCB($sd) errorCallback
	} else {
		catch {unset Dp_RDOErrorCB($sd)}
	}

        puts $sd $args
        flush $sd
}

# Accept RPC client connections
proc dp_MakeRPCServer {{tcpPort 0} {loginProc dp_CheckHost} {cmdCheckProc none} {retFile 0}} {
	global Dp_loginProc Dp_cmdCheckProc

	if {$tcpPort==0} {
		# Locate next available port.
		# socket doesn't give me next available socket :(
		for {set tcpPort 1024} {$tcpPort<=2048} {incr tcpPort} {
			if [catch {set sd [socket -server "dp_accept $tcpPort" $tcpPort]} err] {
				if {$err!="couldn't open socket: address already in use"} {
					error $err
				}
			} else {
				break
			}
		}
		if {$tcpPort>2048} {
			error "Can't open socket in range 1024..2048"
		}
	} elseif {$tcpPort<0} {
		error "Socket must be positive number"
	} else {
		set sd [socket -server "dp_accept $tcpPort" $tcpPort]
	}

	# Remember login & command check procs (if any)
	if {$loginProc!="dp_CheckHost"} {
		set Dp_loginProc($tcpPort) $loginProc
	} else {
		catch {unset Dp_loginProc($tcpPort)}
	}
	if {$cmdCheckProc!="none"} {
		set Dp_cmdCheckProc($sd) $cmdCheckProc
	} else {
		catch {unset Dp_cmdCheckProc($sd)}
	}

	if $retFile {
		return "$sd $tcpPort"
	}
	return $tcpPort
}

# Server: Accept Connections
proc dp_accept {myTcpPort s a remoteSocket} {
	global Dp_loginProc Dp_response

        #puts "dp_accept: $myTcpPort $s $remoteSocket $a"
	if [info exists Dp_loginProc($myTcpPort)] {
		if [catch {$Dp_loginProc($myTcpPort) $a}] return
	} else {
		catch {dp_CheckHost $a}
	}
	set Dp_response($s) "";		# Initialize
	dp_AniOpenConn $myTcpPort $s $a $remoteSocket
	fileevent $s readable [list dp_echoResp $s $myTcpPort]
	fconfigure $s -blocking 0
}

 #
 # Ani calls this func to determine who is making a connection
 #
 proc dp_AniOpenConn {myTcpPort s a remoteSocket} {
     #puts "dp_AniOpenConn: $myTcpPort $s $a $remoteSocket"
     return $s
 }
 
 #
 # Ani calls this func to determine who is breaking a connection
 #
 proc dp_AniCloseConn {s socket} {
     #puts "dp_AniCloseConn: $s $socket"
     return $s
 }
 

# Evaluate incoming requests
proc dp_echoReq {s myTcpPort req} {

	# In non-blocking mode, if a socket has been closed on other side, we are closed
	if [catch {set eof [eof $s]}] {
		set eof 1
	}
	if {!$eof && $req!=""} {
		global Dp_cmdCheckProc dp_rpcFile
		
	        #puts "dp_echoReq: $s $req"
		if {$req=="dpnull"} return

		if [info exists Dp_cmdCheckProc($s)] {
			if [catch {$Dp_cmdCheckProc($s) $req}] {
				puts $s dpillegal
				flush $s
			}
		}
		set dp_rpcFile $s
		set resp ""
		if {$req!="" && [catch {set resp [uplevel #0 $req]} err]} {
			#puts "$req->$err"
		}
		# We have to write something on the socket
		# Ignore error; other side might be closed
		if {$resp==""} {set resp dpnull}
		catch {puts $s $resp; flush $s}
	} else {
		# Windows has a bug where eof on a non-blocking socket always returns 0
		# Assume that an empty get is really an eof
		close $s
	}
}

# Socket reader
proc dp_echoResp {s socket} {
    global Dp_response Dp_RDOCB Dp_RDOErrorCB

        if {[catch "gets $s" buffer]} {
            if {![fblocked $s]} {
                puts stderr "I/O error - $buffer"
  	    }
	}
        # In non-blocking mode, if a socket has been closed on other side, we are closed
	if [catch {set eof [eof $s]}] {
		set eof 1
	}
        #puts "dp_echoResp: s=$s socket=$socket Dp_response(s)=$Dp_response($s) eof=$eof buffer=$buffer"
	if $eof {
		catch {dp_CloseRPC $s}
	        dp_AniCloseConn $s $socket
		if {$Dp_response($s)=="dpnonblock" && [info exists Dp_RDOErrorCB($s)]} {
			$Dp_RDOErrorCB($s) closed
		}
		set Dp_response($s) dpclosed
	} else {
		if {$Dp_response($s)!="dpblock" && $Dp_response($s)!="dpnonblock"} {
			# Unsolicited response; must be a request
			dp_echoReq $s $socket $buffer
			set Dp_response($s) ""
			return
		}
		if {$Dp_response($s)=="dpnonblock" && [info exists Dp_RDOCB($s)]} {
			$Dp_RDOCB($s) $buffer
		} else {
			set Dp_response($s) $buffer
		}
	}
}

# Make an RPC server connection
proc dp_MakeRPCClient {host socket {cmdCheckProc none}} {
	global Dp_cmdCheckProc Dp_response

	set s [socket $host $socket]
	fileevent $s readable [list dp_echoResp $s $socket]
	fconfigure $s -blocking 0
	if {$cmdCheckProc!="none"} {
		set Dp_cmdCheckProc($s) $cmdCheckProc
	}
	set Dp_response($s) "";		# initialize
	return $s
}

# Check requests
proc dp_SetCheckCmd {sd cmdCheckProc} {
	global Dp_cmdCheckProc

	set Dp_cmdCheckProc($sd) $cmdCheckProc
}

# Close an RPC connection
proc dp_CloseRPC {sd} {
	global Dp_cmdCheckProc

	catch {unset Dp_cmdCheckProc($sd)}
	close $sd
}

# Cancels current RPC invocations
proc dp_CancelRPC {args} {
	global Dp_response

	if {$args==""} {
		# Close all outstanding RPC invocations
		foreach sd [array names Dp_response] {
			if {$Dp_response($sd) == "dpblock"} {
				set Dp_response($sd) dpcancel
			}
		}
		return
	}
	foreach sd $args {
		if {[info exists Dp_response($sd)] && $Dp_response($sd) == "dpblock"} {
			set Dp_response($sd) dpcancel
		}
	}
}

# internet address record manipulation: tbd
proc dp_Address {args} {
	error "dp_Address unimplemented"
}

# ------ The following is taken from tcl_dp

proc Acl+ {acl str} {
    lappend acl [list 1 $str]
}

proc Acl- {acl str} {
    lappend acl [list 0 $str]
}

proc AclCheck {acl str} {
    set result 1
    foreach elt $acl {
        if {[string match [lindex $elt 1] $str] == 1} {
            set result [lindex $elt 0]
        }
    }
    return $result
}

set dp_Acl {}

proc dp_Host {str} {
    global dp_Acl
    set key [string range $str 0 0]
    set str [string range $str 1 end]
    case $key in {
    "+" {
	    if {[string length $str] == 0} {
		set dp_Acl {}
		set rv {Access control disabled. Any clients may connect}
	    } else {
		if {([string first * $str] != -1) ||
		    ([string first \[ $str] != -1) ||
		    ([string first ? $str] != -1) ||
		    ([string first \] $str] != -1)} {
		    set rv "Clients from $str may connect"
		    set dp_Acl [Acl+ $dp_Acl $str]
		} else {
		    set addr [dp_address create $str 0]
		    set ipaddr [lindex [dp_address info $addr] 0]
		    dp_address delete $addr
		    if {$ipaddr == "255.255.255.255"} {
			error "Unknown host $str"
		    }
		    set dp_Acl [Acl+ $dp_Acl $ipaddr]
		    set rv "Clients from $ipaddr may connect"
		}
	    }
	}

    "-" {
	    if {[string length $str] == 0} {
		set dp_Acl {{0 *} {0 *}}
		set rv {Access control enabled. No clients may connect}
	    } else {
		if {([string first * $str] != -1) ||
		    ([string first \[ $str] != -1) ||
		    ([string first ? $str] != -1) ||
		    ([string first \] $str] != -1)} {
		    set rv "Clients from $str may not connect"
		    set dp_Acl [Acl- $dp_Acl $str]
		} else {
		    set addr [dp_address create $str 0]
		    set ipaddr [lindex [dp_address info $addr] 0]
		    dp_address delete $addr
		    if {$ipaddr == "255.255.255.255"} {
			error "Unknown host $str"
		    }
		    set dp_Acl [Acl- $dp_Acl $ipaddr]
		    set rv "Clients from $ipaddr may not connect"
		}
	    }
	}

    default {return $dp_Acl}
    }
    return $rv
}

proc dp_CheckHost {inetAddr} {
    global dp_Acl
    if {[AclCheck $dp_Acl $inetAddr] == 0} {
	error "Host not authorized"
    }
}
