#! /usr/bin/perl -wT -I/home/raid/supp/invent/Building-info/backups/
#
#    This program is free software: you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation, either version 3 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
# Bug reports to bugs@damtp with .cam.ac.uk appended

my $revis='$Revision: 1.12 $';
use Sys::Syslog qw(:DEFAULT setlogsock);
use JSPUtil;
use Time::Local;
use Fcntl;
use Quota;
use POSIX;

# Get process name (well just the leaf)
my $comm=$0;
$comm =~ s/.*\///;

setlogsock('unix');
openlog($comm, 'pid,ndelay', 'daemon');
# How many old copies of the backups to keep
my $keepold = 34;

# Set verbosity level, verb has to start low because otherwise our messages
# confuse sftp clients.
$::verb=0;
$::sverb=7;
# A hack to tell dprin/sprin not to use stdout.
$::exiting=1;

my $rc23=".error-23-ok";
my $newlkg='.newlastknowngood';

my $testing=0;

# are we doing backups for real, or just making empty directories
my $norealbackups=0;
my $justtest=0;
my $sender=0;

# Avoid taint problems, and ensure we find a sane version of rsync!
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
$ENV{'PATH'}='/usr/local/bin:/usr/bin:/bin';
$ENV{'IFS'}=" \t";

# work out who is talking to us
my $logname=$login = getlogin || getpwuid($<) || $ENV{'LOGNAME'};
# untaint logname
if ($login =~ /^([\w_-]+)/) {
    $login=$1;
} else {
    sprin(0, "Don't know who you are!");
    exit 1;
}

#my $basepath="/local/scratch/public/$login";
# A better pathname to show to users (yes they can see it if they try).
my $basepath='/local/tardis/laptops';
my $pth="$basepath/$login";

if (! -d $basepath) {
    sprin(0, "Basepath $basepath doesn't exist!");
    exit 1;
}

my $tag='';
my $origcmd='';
my $cmd='';
my @OARGV=();
if (defined($ENV{'SSH_ORIGINAL_COMMAND'})) {
    # we are in a ForceCommand or command in an authorized-keys
    $cmd=$origcmd=$ENV{'SSH_ORIGINAL_COMMAND'};
    @OARGV=split(/\s/, $origcmd);
    $tag=$OARGV[$#OARGV];
} else {

    # When called with no arguments we can't easily tell if we *are*
    # being called as part of a ForceCommand but with no
    # orginal_command being passed.

    # The last argument is intended to be the desination, so we will use
    # it as part of the path so that a user with multiple laptops can
    # have a different tree for each...
    if ($#ARGV >= 0) {
	$tag=$ARGV[$#ARGV];
	$cmd=$0.' '.join(' ', @ARGV);
    }
}

# Is the orig command sftp?
my $sftpserver='/usr/tardis-openssh-5.1p1/libexec/sftp-server';
if ($origcmd =~ /^$sftpserver/) {
    if (! -d $pth) {
	mkdirp($pth, 0700);
    }
    chdir("$basepath/$login") || chdir('/');
    sprin(5, "Running sftpserver for $login origcmd: $origcmd");
    unless (exec($sftpserver)) {
	# Can't get beyond here unless the exec fails
	sprin(0, "Can't have got to here: exec failed for $login: $!");
	sleep 2;
	exit 1;
    }
}

$::verb=6;
if ($testing) {
    # Do something with arguments perhaps?
    sprin(4, "for $login args = ".join(', ', @ARGV));
    sprin(4, "env is");
    foreach $e (sort (keys %ENV)) {
	sprin(4, "env $e -> $ENV{$e}");
	syslog('crit|daemon', " env $e -> $ENV{$e}");
    }
    sprin(4, "for $login raw tag is $tag");
}

if (! -d $pth) {
    dprin(4, "Creating directory $pth");
    mkdirp($pth, 0700);
}

# Now log some stuff because we couldn't do it before checking for
# sftp-server stuff
sprin(4, "Tardis user: $login backupsdir: $basepath/$login tag: $tag cmd: $cmd");
sprin(7, "login=$login cmd=$cmd argv=$#ARGV");

if (!defined($tag) || ($tag eq '')) {
    sprin(0, "No command found!  Not a valid way to connect!");
    sleep 2;
    exit 1;
}

if ($cmd eq 'help') {
    # send them some help and quit
    # What should TARDIS stand for?
    # Temporal Archive Remote (Recovery) Data Important Stuff (Service/store)
    # trivial automatic rsync data implementing snapshots
    # 
    print <<EOF ;
This is DAMTP Tardis: $revis . Please be careful.

Valid commands are:

   list [tag]
   quota [tag]
   showpath tag
   newlkg tag
   rc23ok tag
   addkey
   and rsync (with permitted options)

For more information see the online help (point at web page?)

EOF
    exit(0);
}

# return user quota info
if ($cmd =~ /^quota\s*([^\s]*)/) {
    my $tag='';
    # Only set $tag iff we were actually passed one...
    $tag=fixtag($1) if ($1);
    my $qdev=Quota::getqcarg($basepath);

    if (!$qdev) {
	# Something went wrong, perhaps the directory doesn't exist or
	# quotas are not actually enabled...
	my $errnum=$!+0;
	my $errstr=Quota::strerr();
	sprin(0, "getqcarg failed ($login) for $basepath: $errstr ($errnum)");
	print "-1 -1\n";
	exit 0;
    }
    if (Quota::sync($qdev)) {
	sprin(0, "quota sync ($login) got %s %s", Quota::strerr(), $!);
    }

    my @qdata=Quota::query($qdev, $<, );
    if ($#qdata > 1) {
	print "$qdata[0] $qdata[1]\n";
	#print "Full info is: ".join(', ', @qdata)."\n";
    } else {
	# something went wrong - quotas are not enabled or this user
	# doesn't have any quota usage or something...
	my $errnum=$!+0;
	my $errstr=Quota::strerr();
	sprin(0, "Quota query ($login) failed: $errstr ($errnum)");
	print "0 0\n";
    }

    if ($tag) {
	$pth .= '/'.$tag;
	my $lkg="$pth/LastKnownGood";
	if (-d $pth) {
	    if (-l $lkg) {
		print "LastKnownGood -> ".readlink($lkg)."\n"
	    } else {
		print "No LastKnownGood\n"
	    }
	} else {
	    sprin(2, "for $login path $pth is missing - invalid tag $tag?");
	}
    }
    exit 0;
}

# show the path to this laptop's backups
if ($cmd =~ /^showpath\s*([^\s]*)/) {
    print "$basepath/$login/".fixtag($1)."\n";
    exit 0;
}

# list the tags or entries under a tag (showing the transformed names
# which would be needed to copy back from - if any fixups are done on
# the tag)...
if ($cmd =~ /^list\s*([^\s]*)/) {
    chdir($pth);
    my $glp='*';
    my $t='';
    if ($1) {
	$t=fixtag($1);
	$glp=$t.'/*';
	if (! -d $t) {
	    sprin(0, "No directory for $login tag: $t");
	    exit 0;
	}
    }
    foreach $i (glob($glp)) {
	next if ($i eq 'Zapping'); # don't show them the zapping directory!!
	if (-l $i) {
	    printf("%s  ->  %s\n", $i, readlink($i));
	} elsif (-d $i) {
	    print "$i\n";
	} else {
	    sprin(2, "Unexpected file type for $login file: $i");
	}
    }
    if (-e "$t/$rc23") {
	print " [ next backup will ignore error-23 from rsync ]\n";
    }
    if (-e "$t/$newlkg") {
	print " [ next backup will be marked LastKnownGood ]\n";
    }
    exit 0;
}

# mark that we want a new lastknowngood copy
if ($cmd =~ /^newlkg\s*([^\s]*)/) {
    my $tag=fixtag($1);
    $pth .= '/'.$tag;
    my $lkg="$pth/$newlkg";
    sprin(4, "Using $lkg to ask for new lastknowngood of $tag (for $login)");
    mkdirp($pth, 0700);
    symlink('.', $lkg);
    if (-e $lkg) {
	print "OK\n";
	exit 0;
    }
    sprin(0, "Symlink create failed for $login : $!");
    print "Failed: $!\n";
    exit 1;
}

# mark that the *next* backup should ignore 'error 23'
if ($cmd =~ /^rc23ok\s*([^\s]*)/) {
    my $tag=fixtag($1);
    $pth .= '/'.$tag;
    my $rc23f="$pth/$rc23";
    sprin(4, "Using $rc23f to ignore error-23 on next backup $tag (for $login)");
    mkdirp($pth, 0700);
    symlink('.', $rc23f);
    if (-e $rc23f) {
	print "OK\n";
	exit 0;
    }
    sprin(0, "Symlink create failed for $login : $!");
    print "Failed: $!\n";
    exit 1;
}

# Add an ssh public key to the tardis_authorized_keys file
if ($cmd =~ /^addkey\s*([^\s]*)/) {
    $tag=fixtag($1);
    my $sshdir="$ENV{HOME}/.ssh";
    my $akf="$sshdir/tardis_authorized_keys";
    # untaint $sshdir and $akf - we trust $HOME here...
    if ($sshdir =~ /^(.*)$/) {
	$sshdir=$1;
    } else {
	sprin(0, "Untaint of $sshdir for $login failed!");
	exit 1;
    }
    if ($akf =~ /^(.*)$/) {
	$akf=$1;
    } else {
	sprin(0, "Untaint of $akf for $login failed!");
	exit 1;
    }
    # Read an ssh public-key line from stdin.
    my $key=<STDIN>;
    chomp($key);
    # key must start with ssh-rsa or ssh-dss, complain and quit otherwise
    unless ($key =~ /^ssh-(rsa|dss) AAAA/) {
	sprin(0, "Key for $login doesn't look valid to me - quitting: $key");
	exit 1;
    };
    $key .= " for $tag added by $comm\n";
    if (! -d $sshdir) { # don't have a .ssh directory yet - so make one!
	mkdirp($sshdir, 0700);
    }
    unless (open (OUT, ">${akf}.new")) {
	sprin(0, "Can't write (as $login) to $akf.new: $!");
	exit 1;
    }
    if (-f $akf) {
	unless (open (IN, "<$akf")) {
	    sprin(0, "Can't read (as $login) $akf: $!");
	    exit 1;
	}
	while (<IN>) {
	    next if / for $tag added /; # skip matching key (we hope)
	    print OUT
	}
	close(IN);
    }
    print OUT $key;
    close(OUT);
    if (-f $akf) {
	unless (rename($akf, "$akf.oldtardis")) {
	    sprin(0, "rename (as $login) of $akf failed: $!");
	    exit 1;
	}
    }
    unless (rename("$akf.new", $akf)) {
	sprin(0, "rename (as $login) of $akf.new failed: $!");
	exit 1;
    }
    print "OK added key for $tag\n";
    exit 0;
}

# If the command doesn't contain rsync or laptopwrap we should quit
# rather than just confuse things
unless ($cmd =~ /rsync|laptopwrap/) {
    sprin(0, "Unknown command: $cmd - try help?");
    sleep 2;
    exit 1;
}

my $rsyncao='';
if ($cmd =~ /(--server\s+--sender\s+[\w\-\.]+)\s/) {
    sprin(0, "This seems to be an rsync fetch! login=$login cmdopts=$1 tag=$tag");
    $sender=1;
    $rsyncao=$1;
#    sleep 2;
#    exit 1;
} elsif ($cmd =~ /(--server\s+[\w\-\.]+)\s/) {
    sprin(0, "rsync being called with some options we expect login=$login cmdopts=$1 tag=$tag");
    $rsyncao=$1;
} else {
    sprin(0, "Not a supported rsync command (login=$login): $cmd - Quitting");
    sleep 2;
    exit 1;
}

$pth .= '/'.fixtag($tag) if (!$sender);
#$pth .= '/'.fixtag($tag);
sprin(5, "Using $pth for backups of $tag (for $login)");
mkdirp($pth, 0700);
chdir ($pth) || die "Can't chdir to $pth: $!\n";

my $link='';
my $now=time();
my @tl=localtime($now);
# Include seconds in bname too to reduce problems with clashes etc
my $bname = sprintf("%4d-%02d-%02d--%02d:%02d:%02d",
		    $tl[5]+1900, 1+$tl[4], $tl[3], $tl[2], $tl[1], $tl[0]);
# hack while we are running tests...
if (-d $bname) {
    sprin(2, "Avoiding using existing name $bname... creating unique name with pid (for $login)");
    $bname .= ".$$";
}

# The %age hash must be defined at top-level so we can re-use the data
# later for the zapping checks (only done iff we are not a sender)
my %age=();
my $bn;

if (!$sender) {
    my $latest=0;
    my $latestb='';
    my @sncons=glob('[0-9]*-[0-9]*-[0-9]*');

    foreach $bn (@sncons) {
	sprin(7, "l=$login tag=$tag: Checking age of $bn");
	my $thisage = my $statage=0;
	my @st=stat($bn);
	if (defined($st[9])) {
	    $thisage = $statage = $st[9];
	} else {
	    sprin(0, "l=$login: Can't stat $bn, got $?: $! - skipping entry");
	    next;
	}
	if ($bn =~ /^(\d+)-(\d+)-(\d+)--(\d+):(\d+):(\d+)$/) {
	    eval { $thisage=timelocal($6,$5,$4,$3,$2-1,$1) } || do {
		sprin(0, "Got bogus value for $bn in $pth (for $login)\n");
		$thisage=$statage;
	    };
	} elsif ($bn =~ /^(\d+)-(\d+)-(\d+)--(\d+):(\d+)$/) {
	    eval { $thisage=timelocal(0,$5,$4,$3,$2-1,$1) } || do {
		sprin(0, "Got bogus value for $bn in $pth (for $login)\n");
		$thisage=$statage;
	    };
	} else {
	    sprin(0, "Not in expected pattern: $bn (in $pth) for $login");
	    $thisage=$statage;
	}

	sprin(7, "Got age of $bn = $thisage ago= %s (%d)", timeprint($now - $thisage), $now - $thisage);
	$age{$bn}=$thisage;
	# keep track of latest
	if ($thisage > $latest) {
	    $latest = $thisage;
	    $latestb = $bn;
	}
    }

    # We can only use --link-dest if there was a 'previous' backup!
    if ($latestb =~ /^([\d\-\.:Tt]+)/) {
	$link="--link-dest=$pth/$1/"; # untainted if it exists
	sprin(4, "Using link-dest from $1 for $bname for $login");
    } else {
	sprin(4, "No link-dest - first backup for $login $tag");
    }
}

my $tmpsn='.TmpSnap';
#my $rsycmd="/usr/local/bin/rsync --server -vvlHogDtprS --delete $link . $tmpsn/";
#$rsycmd="strace -f -o /tmp/ook /usr/local/bin/rsync --server -vvlHogDtprS --delete $link . $tmpsn/";
#$rsycmd="/usr/local/bin/rsync --server -vvlHogDtprS --delete $link . $bname/";
#$rsycmd="/usr/local/bin/rsync --server -vvlHogDtprS --omit-dir-times --numeric-ids $link . $tmpsn/";
#$rsycmd="/usr/local/bin/rsync --server -lOHDtprRSze.is  $link . $tmpsn/";
#$rsycmd="/usr/local/bin/rsync --server -lOHDtprRSze.is --chmod u+rwX $link . $tmpsn/";
#$rsycmd="/usr/local/bin/rsync --server -lOHDtprRSze.is --chmod u+rwX $link . $tmpsn/";
#$rsycmd="/usr/local/bin/rsync --server -lOHogDtpXrRSze.is --chmod Du+rwX --fake-super $link . $tmpsn/";

# Now the server options get added later...
my $rsycmd='/usr/local/bin/rsync ';

if ($sender) {
    $qtag=quotemeta($tag);

    # we add the user-supplied options, then the fake-super and
    # location that they specified...
    $rsycmd .= "$rsyncao --fake-super . $qtag";
} else {

    # We add the user-supplied options and then our chmod, fake-super
    # and link options (if available), and then the place we are
    # copying to...
    $rsycmd .= "$rsyncao --chmod Du+rwX --fake-super $link . $tmpsn/";
}

sprin(5, "For $login rsync command will be: $rsycmd");
#sleep 2;
system ($rsycmd);
# Record the return code so we can use it...
my $err=$?;

if ($err != 0) { # failure
    my $ev=$err >> 8;
    my $status=$? & 255;
    if ($ev == 24) {
	sprin(5, "Failure from rsync but just: rsync-error 24 - files vanished from source during transfer login=$login (tag=$tag).  Ignoring");
    } else {
	if (($ev == 23) && (-e $rc23)) {
	    sprin(1, "Failure from rsync (error 23, partial success), but marked to ignore login=$login (tag=$tag)");
	} else {
	    sprin(0, "Failure from rsync: $? (exit-code=$ev status=$status login=$login tag=$tag)");
	    exit($ev);
	}
    }
} else {
    sprin(5, "Success from rsync for $login (tag=$tag)");
}

# If we got this far and there is an rc23 file then remove it
if (-e $rc23) {
    unlink($rc23);
}

if ($sender) {
    exit(0);
}

if (rename($tmpsn, $bname)) {
    sprin(5, "Renamed temporary tree to $bname for $login tag=$tag");
    $age{$bname}=$now;
    # create the latest symlink
    if (-l 'latest') {
	unlink('latest');
    }
    if (symlink($bname, 'latest')) {
	sprin(5, "Symlink latest at $bname for $login tag=$tag");
    } else {
	sprin(0, "Can't symlink to $bname: $! (login=$login tag=$tag)");
    }
    # remove any lastknowngood link...
    if (-e $newlkg) {
	unlink('LastKnownGood');
	unlink($newlkg);
    }
    # create lastknowngood link if there isn't one
    if (! -l 'LastKnownGood') {
	if (symlink($bname, 'LastKnownGood')) {
	    sprin(4, "Symlink LastKnownGood at $bname for $login tag=$tag");
	} else {
	    sprin(0, "Can't symlink LastKnownGood to $bname: $! (login=$login tag=$tag)");
	}
    }
} else {
    sprin(0, "Failed to rename $tmpsn to $bname: $! (login=$login tag=$tag)");
    exit(1);
}

# Now tidy up the older copies

# get list of backups in age order
my @backups = (sort {$age{$b} <=> $age{$a}} (keys %age));
my $count=$keepold;
my $countback=0;
my $zapped=0;
my $seen=0;
my $lkg='';
if (-l 'LastKnownGood') {
    $lkg=readlink('LastKnownGood');
}
if ($lkg eq $bname) { # just created lkg so allow one more for luck :-)
    $count++;
}
foreach $bn (@backups) {
    #dprin(6, "here with bn=$bn age=$age{$bn}");
    $seen++;
    if ($bn eq $bname) {
	sprin(4, "Skipping $bn it is latest - login=$login tag=$tag");
	next;
    }
    if ($bn eq $lkg) {
	sprin(4, "Skipping $bn it is LastKnownGood login=$login tag=$tag");
	next;
    }
    $count--;
    $countback++;
    if ($count > 0) {
	sprin(8, "Leaving $bn alone - old backup $countback login=$login tag=$tag");
    } else {
	sprin(6, "Zapping $bn - old backup $countback login=$login tag=$tag");
	if (! -d 'Zapping') {
	    mkdir('Zapping', 0700) || sprin(0, "Can't create Zapping: $! (login=$login tag=$tag)");
	}
	if (rename($bn, "Zapping/$bn")) {
	    $zapped++;
	} else {
	    sprin(0, "Can't rename $bn into Zapping/: $! (login=$login tag=$tag)");
	}
    }
}
sprin(6, "For $login tag=$tag keepold=$keepold count=$count countback=$countback seen=$seen zapped=$zapped");

if ($zapped > 0) {
    sprin(5, "about to delete $pth/Zapping");
    my $pid=fork();
    if ($pid < 0) {
	# fork failed for some reason
	sprin(0, "Can't fork got $pid, err=$!");
    } elsif ($pid > 0) {
	# this is the parent - we don't want to wait for the child
	sprin(5, "rm of $pth/Zapping launched with pid=$pid");
    } else {
	# child so do the work...

	# use setsid to disconnect from the parent session
	setsid || sprin(0, "Can't run setsid: $!");

	# close the fd's that might be connected to the sshd
	open(STDIN, "</dev/null");
	open(STDOUT, ">/dev/null");
	open(STDERR, ">/dev/null");

	sprin(0, "for $login child rm of $pth/Zapping starting");
	system("/bin/rm -rf ./Zapping");
	sprin(0, "for $login child rm of $pth/Zapping finished");
    }
}
exit 0;

# Mangle (and untaint) a tag
sub fixtag {
    my ($tag)=@_;
    my $allowchar='\w\-_\%\@\=\+\.';
    # Apparently '-' is too confusing for people (and some scripts!)
    # so map to = instead for the leading char
    $tag =~ s/^[^$allowchar]/=/;
    $tag =~ s/^-/=/;

    # Likewise we want to avoid tags starting with '.' since it makes
    # the files less obvious, and we certainly don't want them to just
    # be . or .. etc.
    if ($tag =~ /^\./) {
	if ($tag eq '.') {
	    $tag='Laptop';
	} else {
	    $tag =~ s/^\./=/;
	}
    }

    # Map the rest to -
    $tag =~ s/[^$allowchar]/-/g;
    if ($tag =~ /([$allowchar]+)/) {
	$tag=$1;
    } else {
	$tag='Laptop';
    }
    return $tag;
}