packages/vfs/VFSrsync.tcl

# This is the rsync file transfer interface.
#
# Rsync does not support a command line mode, i.e. each
# invocation completes a given operation and then
# terminates. There are only three commands possible:
# 1) File(s) transfer. This can be either read or write.
# 2) Directory transfer, i.e. get a file list
# 3) Delete
#
# The above directly inform the "get" and "put" comands
# to move files and the "list" command to get dirs and the
# "delete" command.

# Indirectly, we manage the working directory (cd and pwd).
# Internally we carry the "pwd" with out the VFS header
# (i.e. we keep the pwd "path" component in variable pwd)
#
# Also with rsync, there is no real notion of alive, so the
# alive functions are disabled.

# package require -exact Expect 0.0.0
package require Expect
package require fileutil
package provide VFSrsync 1.0

namespace eval VFSrsync {
  variable commands
  variable debug 0
  variable os $::tcl_platform(platform)
  variable abortflag
  variable tmpdir

  array set commands [list\
			  open ::VFSrsync::RSYNCopen\
			  live ::VFSrsync::RSYNClive\
			  cd ::VFSrsync::RSYNCcd\
			  mkdir ::VFSrsync::RSYNCmkdir\
			  delete ::VFSrsync::RSYNCdelete\
			  rmdir ::VFSrsync::RSYNCdelete\
			  rmdirEmpty 1\
			  isdir ::VFSrsync::RSYNCisDir\
			  pwd ::VFSrsync::RSYNCpwd\
			  list ::VFSrsync::RSYNClist\
			  get ::VFSrsync::RSYNCget\
			  put ::VFSrsync::RSYNCput\
			  RcopyOk 3\
			  close ::VFSrsync::RSYNCclose\
			  debug ::VFSrsync::RSYNC_debug]

  # Support routines *********************************
  proc eId {n} {return "(rsync $n): "}
  # ******************* all with names "RSYNC_..."
  proc RSYNClog_user {} {
    variable debug
    variable tmpdir
    upvar VFStok VFStok
    VFSglobal logging
    if {$logging || $debug} {
      exp_log_user $debug
      if {$debug} {
	catch {exp_log_file}
	exp_log_file -a $tmpdir/rsync.log
      }
    }
  }
  proc dproc {args} {}

  # On logging. We set logging true at open time and if there is
  # an error. We turn it off on sucess of any given command.

  proc RSYNClog {mess} {
    upvar VFStok VFStok
    VFSglobal errorExpected logging log
    set mess [regsub {\r} $mess {}]
    if {$logging && !$errorExpected } {
      eval [list {*}$log $mess]
    }
  }

  proc RSYNCfixParms {wh} {
    upvar VFStok VFStok
    upvar $wh fx
    VFSglobal mode module
    frputs mode module fx
    if {$mode == "daemon" && [string match /${module}* $fx]} {
      set fx [string range $fx [string length $module]+1  end]
      frputs fx
      if {$fx == {}} {set fx /}
    }
    frputs fx
    return
  }
  # The open request.  We have host, user, password & port
  # host and VFStok are usually the same and MUST not be ""
  # possible connection modes are:

  proc RSYNCopen {URL args} {
    global   config
    variable debug
    variable tmpdir
    IsVFS $URL
    frputs args


    # We are likely to change the URL so lets sort that out so we
    # can keep stuff where we can find it...

    frputs args "[llength $args] "
    array set parms {*}$args
    set Xuser $parms(user)
    # over ride user if found in address
    # The VFSadd (set by IsVFS) may contain a user name
    regexp {(.*)@(.*)} $VFSadd ma Xuser VFSadd

    set Xhost [regsub {:[0-9]*} $VFSadd {}]
    # host is address sans user and port (so far)
    # set timeout $rq_timeout
    set searchOps [list -index 0 -all -inline]
    set Xmodule [regsub {^/$|^/([^/]+).*} $VFSpath {\1}]
    set daemonKey $Xhost/$Xmodule
    # Lean on the rsync table for extra options...
    # mostly we want the mode info.
    # host is VFSadd cleared of user & port
    set info [lsearch {*}$searchOps $config(rsync,table) "*$Xhost*"]
    if {$info == {}} {
      set info [list [lindex $config(rsync,table) 0]]
    }
    frputs info
    if {[llength $info] > 1} {
      # try to pick the most useful one...
      # if we are dealing with modules (i.e. mode == deamon) we
      # need to match the host + the first element of the path.
      # defaults to last looked at...

     foreach inf $info {
	lassign $inf key rPath Mode tops
	if {($Mode == "daemon" && [string match *$daemonKey $key]) ||\
		[string match *sftp* $key] ||\
		[string match *scp* $Mode]} {
	  incr found
	  break
	}
      }
      if {![info exist found]} {
	lassign {} key rPath Mode
      }
    } else {
      lassign [lindex $info 0] key rPath Mode tops
    }
    frputs  key rPath Mode ops tops
    # An alternate program can be indicated by Mode "use=alt"
    # we don't use this module (it should be part of the host...)
    lassign [split $Mode =] Xmode modulex
    set Xprog [expr {$Xmode == {use} ? "$Xmodule" : "rsync -s"}]
    # Default port depends on mode...
    set Xport [expr {$Xmode == "daemon" ? 873 : 22}]
    regexp {(.*):(.*)} $VFSadd ma VFSadd Xport
    # allow override of that if port in URL
    #
    # Here is the URL as we will use it:
    set URL [URL norm rsync://$Xuser@${VFSadd}:$Xport/$VFSpath]
    IsVFS $URL
    VFSglobal echo errorExpected user host log logging mode module password port prog\
	passwordx spawn_id timeout ops filePrefix pwd

    foreach p {port user host mode module prog} {
      set $p [set X$p]
    }
    set logging 1
    set debug 0
    set errorExpected 0
    set passwordx {}
    set timeout {}
    set abortflag ::[namespace current]::abtflag
    set timefmt "%d%m%y "
    set tmpdir "/tmp"
    set log ::[namespace current]::dproc
    # ops is a global option to use on all requests..
    if {$::MSW} {
      # check the table opts (tops) to see if we have plink
      # if so, pass it the creds.
    }
    set ops {--no-motd}

    set poss {timeout abortflag timefmt log debug tmpdir}
    foreach opt $poss {
      if {[info exists parms($opt)]} {
	set $opt $parms($opt)
      }
    }
    set echo [expr {1 && $debug ? "" : "-noecho"}]
    # pelim done, lets see if we can talk...
    # we inclued the module address as the first path comp
    set filePrefix rsync://$VFSadd
    frputs  VFStok host user password port rq_timeout
    if {$mode == "daemon"} {
      set filePrefix $filePrefix/$module
      set pwd [regsub {(^/[^/]+)} $VFSpath {}]
      if {$pwd == {}} {
	set pwd /
      }
    } else {
      set pwd $VFSpath
    }
    frputs filePrefix
    # Here we try a list request to prove we can logon...
    ::VFSvars::VFS_WriteCache $filePrefix [RSYNClist $URL all]
    return $URL
  }


  proc RSYNCsingle {VFStok what args} {
    variable debug
    VFSglobal echo logging mode module user password passwordx prog\
	spawn_id timeout ops filePrefix pwd

    RSYNClog_user
    frputs #4 #3 #2 #1 ::glob(right,pwd)
    #lassign $password Pword none passphrase
    #  set send [string trim [slList {*}$what {*}$args]]
    # exp_send -- $send\r
    # We have two protocols to deal with, shell & daemon
    if {$mode != "daemon"} {
      foreach fil $args {
	if {[regsub -all {rsync://|:[0-9]+} $fil {} nfil] == 0} {
	  # simple file, pass it
	  lappend nargs $fil
	} else {
	  # rsync remote file, need a : in front of the first /
	  lappend nargs [regsub {/} $nfil {:/}]
	}
      }
    } else {
      # For daemon transfers, we have modules
      # The module is part of the filePrefix and should already be
      # in the args as such...
      # lappend nargs [regsub {(.*://.*)(/)} $args \\1/$module/]
      set nargs $args
    }
    frputs what args nargs
    set cmd [frECF [list spawn {*}$echo {*}$prog  {*}$ops {*}$what]\
		 $nargs\
		 [list -f 1]]
    while {1} {
      lassign $passwordx password none passphrase
      set acmd $cmd
      if {$::MSW} {
	# we need the password here...
	set acmd [subst -nocommands -nobackslashes $cmd]
      }
      frputs "spawn  " acmd
      set r [catch {{*}$acmd} out]
      if {$r != 0} {
	return -code error "[eId 2]Really bad error: $out"
      }
      set stuff {}
      # The first pattern takes care of the input line limit where back
      # spaces are inserted in the echo...
      expect_after timeout \
	  {set expect_out(buffer) "Connection timed out $VFStok";\
	       set re 1}\
	  eof {set expect_out(buffer) "Connection closed $VFStok" ;\
		   frputs "1.1 "
	    set re 0}

      expect -re "(.*assword:.*)" \
	  {RSYNClog  $expect_out(buffer)
	    # Log "sending password"
	    if {$password == {}} {
	      set passwordx [::pwLocker::getPw $filePrefix \
				full 1 \
				abort 1\
				prompt "(2)[regsub {\r} $expect_out(1,string) {}]"]
	      lassign $passwordx password none passphrase
	    }
	    frputs "open password  " Pword
	    RSYNClog  "sending pasword\n"
	    frputs "2 "
	    if {$::MSW} {
	      set re 5
	    } else {
	      exp_send $Pword\r
	      exp_continue
	    }
	  } \
	  -re "(.*.?assphrase for key .*: )" {
	    RSYNClog  $expect_out(buffer)
	    if {$passphrase == {}} {
	      set passwordx [::pwLocker::getPw $filePrefix \
				full 1 \
				abort 1\
				prompt "(3)[regsub {\r} $expect_out(1,string) {}]"]
	      lassign $passwordx password none passphrase
	    }
	    RSYNClog  "sending passphrase\n"
	    frputs "3 "
	    exp_send "$passphrase\r"
	    exp_continue} \
	  -re "(.* host key is not .*y/n. |.* authenticity of host .*\(yes/no\)\? )"\
	  {
	    # clean the out string for the smart_dialog call
	    set st [regsub -all {\r} $expect_out(1,string) {}]
	    RSYNClog  1$expect_out(buffer)
	    frputs "4 "
	    incr ignorto
	    if { [smart_dialog .apop . [_ "Accept new host?"] \
		      [list {} "$st" [_ "\nClick your answer."]] \
		      1 2 [list [_ "No"] [_ "Yes"]]] == 1} {
	      set an [expr {[string match "*(yes/*" $expect_out(1,string)] ? \
				"yes" : "y" } ]
	      unset ignorto
	      frputs "back from y/n " an
	      RSYNClog  "sending $an\n"
	      frputs "5 "
	      exp_send "$an\r"
	      exp_continue
	    } else {
	      RSYNClog  "sending 'no'\n"
	      frputs "6 "
	      exp_send "no\r"
	      Log "Aborting Login"
	      set re 10
	    }
	  } \
	  -re {(^[^\n]{0,10}yes\r\n)} {
	    RSYNClog  6$expect_out(buffer)
	    frputs "6 "
	    exp_continue} \
	  -re "(.*Warning: .*)\r?\n" {
	    RSYNClog  $expect_out(buffer)
	    frputs "7 "
	    exp_continue}\
	  -re "(.*Connecting .*)" {
	    RSYNClog  $expect_out(buffer)
	    RSYNClog  "sending password2\n"
	    frputs "8"
	    exp_send $password\r
	    exp_continue} \
	  -re "(.*Permanently added .*)\r*\n" {
	    RSYNClog  $expect_out(buffer)
	    frputs "9 "
	    exp_continue}\
	  -re "(.*assword.*|.*unable.*|.*assphrase.*|.*onnection closed.*)" {
	    if {[string match {*    *} $expect_out(1,string)]} {
	      append stuff $expect_out(buffer)
	      exp_continue
	    }
	    set ms "(10)$expect_out(buffer)\
            \n\nPlease try again."
	    set passwordx [::pwLocker::getPw $filePrefix \
			      full 1 \
			      startwith $password\
			      abort 1\
			      prompt [regsub {\r} $ms {}]]
	    lassign $passwordx password none passphrase

	    RSYNClog  "exit open: Failed with: $expect_out(1,string)\n"
	    frputs "10 "
	    set re 5}\
	  -re "(.*)\r*\n" {
	    #frputs expect_out(1,string) expect_out(0,string)
	    append stuff $expect_out(buffer)
	    #exp_log_user $debug
	    exp_continue}\
	  -re "(.*)\r" {
	    #frputs expect_out(1,string) expect_out(0,string)
	    append stuff $expect_out(buffer)
	    #exp_log_user $debug
	    exp_continue}

      if {$re != 5} {break}
    }
    # We get here on:
    # close            (re = 0)
    # timeout          (re = 1)
    # password failure (re = 5)
    # reject new host  (re = 10)
    #
    # After a close/timeout we need to do a wait to get the
    # status of the completion...m
    frputs "10.1 "
    catch "exp_close -i $spawn_id"
    frputs "10.2 "
    #ForceUpdate $inst
    set rtn [exp_wait -i $spawn_id]
    lassign $rtn r1 r2 r3 r4
    if {$r3 == 0 && $r4 == 0} {
      frputs "11 "
      set logging 0
      frputs "12 "
      return [regsub -all \r $stuff {}]
    }
    set logging 1
    switch $re {
      5 -
      10 {set err $expect_out(buffer)}
      default {
	# some sort of error...
	set err "rsync [expr {$r3 == 0 ? {threw system error} :\
               	                     {returned completion code}}]: $r4\n"
      }
    }
    frputs re err
    RSYNClog $err
    return -code error [eId 3]$err
  }

  # To verify if a directory exists, we try to cd to it. This is
  # rather painful (mostly due to the reconnedtion overhead) Sooo
  # we try to verify only when it makes sense.
  proc RSYNCcd {VFStok new_wd} {
    VFSglobal filePrefix pwd

    RSYNCfixParms new_wd
    # We depend on this to throw an error if "new_wd" is not a dir
    frputs #6 #5 #4 #3 #2 #1 new_wd
    # Don't verify if we are going to subset of where we are (including
    # not moving at all).
    if {![string match $new_wd* $pwd]} {
    set tmp [RSYNCsingle $VFStok {--list-only --include=. --exclude=* }\
		 [URL norm $filePrefix/$new_wd]/]
    }
    frputs tmp new_wd
    set pwd $new_wd
    return 1
   }

  proc RSYNCisDir {VFStok dir} {
    # what to do here???
    VFSglobal errorExpected logging
    set errorExpected 1
    set r [catch {RSYNCcd $VFStok $dir} really]
    set logging 0
    set errorExpected 0
    if {$r == 0 || [string match -nocase *permission* $really]} {
      return [RSYNCpwd $VFStok]
    }
    return 0
  }

  # proc RSYNCrename {VFStok  old new} {
  #   # current name old change to new
  #   return -code error "VFS rsync does not support rename"
  # }

  # There is no way to do a delete with out excluding all the
  # files that are not to be deleted. For now, at least, this
  # is just too much.
  # Ok, lets try overlaying the file with a zero length file
  # and then bring it back with a delete-source option
  # The --force option to rsync allows us to delete dirs
  # by forcing a file where a directory was so this works
  # for files and dirs.

  proc RSYNCdelete {VFStok filename} {
    VFSglobal ops filePrefix

    RSYNCfixParms fileName

    set tmp [makeTmp]/[file tail $filename]
    file delete -force $tmp
    ::fileutil::touch $tmp
    RSYNCsingle $VFStok [list {*}$ops --force] $tmp\
	[URL norm $filePrefix/[file dir $filename]]
    file delete -force $tmp

    set op [list -rvv  --remove-source-files]
    RSYNCsingle $VFStok $op [URL norm $filePrefix/$filename] $tmp
    file delete -force $tmp
    return
  }


  proc RSYNCmkdir {VFStok dir} {
    VFSglobal filePrefix
    # No create command, so we make one and copy it over
    set tmp [makeTmp]/[file tail $dir]
    set r [Try {file mkdir $tmp} "" 1]
    if {!$r} {
      RSYNCput  $VFStok $tmp $dir
      file delete $tmp
    }
    return
   }

  proc RSYNClive { VFStok } {
    # we just require a simple transation to prove life..
    # Not really feasable for rsync
    return 1
  }

  proc RSYNCpwd {VFStok} {
    VFSglobal filePrefix pwd
    # just when you thought this was simple...
    frputs pwd filePrefix
    if {$pwd != "/"} {
      set ppwd [RSYNCsingle $VFStok {--list-only -d -l --no-h} \
		    [URL norm $filePrefix/$pwd]]
      if {[set st [string first { -> } $ppwd]] != -1} {
	# It is a link... Clean it up
	regsub -all {\n} [string range $ppwd $st+3 end] {} ppwd
	set pwd [URL norm [file dir $pwd]/[string trim $ppwd]]
      }
    }
    return [URL norm $filePrefix/$pwd]
  }

  proc RSYNClist {URL all args} {
    VFSglobal filePrefix pwd
    # use -l (long list) -f (no sort) -a depends on all
    # about 12.5k entries at 80 chars each (hay, just poke around on sourceforge)
    #  set op [expr {$all ? "-l -a" : "-l"}]
    #set dir "${pwd}[expr {$pwd == {/} ? {} : {/}}]"
    set rtn [split [RSYNCsingle $VFStok {--list-only -d -l --no-h} \
			[URL norm $filePrefix/$pwd/]] \n]
	     if {[llength $rtn] < 3 && [string match -nocase *permission* $rtn]} {
	       set errorInfo {}
	       return -code error "[eId 4]Permission denied"
	     }
    frputs rtn'
    return  $rtn
  }


  proc RSYNCget { VFStok remoteFileName localFileName args} {
    RSYNCfixParms remoteFileName
    VFSglobal ops filePrefix pwd
    frputs localFileName remoteFileName
    # if {[file tail $remoteFileName] != [file tail $localFileName]} {
    #   return -code error "CopyAs not supported by VFS rsync."
    # }
    return [RSYNCsingle $VFStok "$ops -LkK"\
		[URL norm $filePrefix/$remoteFileName] $localFileName]
  }


  proc RSYNCput { VFStok localFileName remoteFileName args} {
    RSYNCfixParms remoteFileName
    VFSglobal timeout ops filePrefix pwd
    frputs localFileName remoteFileName
    # if {[file tail $remoteFileName] != [file tail $localFileName]} {
    #   return -code error "CopyAs not supported by VFS rsync."
    # }
    set localname [regsub -all " " $localFileName {\\ }]
    #
    return [RSYNCsingle $VFStok "$ops -LkKa " $localFileName\
		[URL norm $filePrefix/$remoteFileName]]
  }

  proc RSYNC_debug {onoff} {
    variable debug
    set debug $onoff
  }
}