#! /usr/bin/perl

use strict ;
use warnings ;

our $prog = substr $0, rindex ( $0, '/' ) + 1 ;
our $RSYNC = '/usr/bin/rsync' ;
our @OPT_R = qw(-avzHSx --delete --stats -h) ;
our $OPT_N = '-n' ;
our $OPT_L = '--link-dest' ;
our $RE_DATE = qr(\d{4}-\d{2}-\d{2}) ;
our $IS_DATE = qr{^$RE_DATE$} ;
our $DEF_IVALS = 
###       noun opt def siz
  [ [ qw( day   D   7    1 ) ]
  , [ qw( week  W   4   7D ) ]
  , [ qw( moon  M   3   4W ) ]
  , [ qw( quad  Q   3  13W ) ]
  , [ qw( yere  Y   1   4Q ) ]
  ] ;

our $DEBUG = 0 ;

sub DATE
  { my $time = shift || $^T ;
    my ($sec,$min,$hour,$mday,$mon,$yea,$wday,$yday,$isdst) = localtime $time ;
    $yea += 1900 ; $mon += 1 ;
    sprintf '%04d-%02d-%02d', $yea, $mon, $mday ;
  }

package OBB ;

# use base 'OBB' ; __PACKAGE__ -> mk_getset ( qw(attr ...) ) ;

sub mk_getset
  { my $self = shift ;
    my @bads = grep ! /^[A-Za-z_]\w*$/, @_ ; die "bad attr [@bads]\n" if @bads ;
    my $sub  = <<'SUB' ;
sub %s::%s { my $self = shift ; $self -> {%s} = shift if @_ ; $self -> {%s} ; }
SUB
    eval sprintf $sub, $self, $_, $_, $_ for @_ ;
  }
sub New  { my $self = shift ; bless {}, $self ; }
sub Defs { () ; }
sub Init
  { my $self = shift ;
    my %opts = ( $self -> Defs, @_ ) ;
    my @opts = keys %opts ;
    @$self { @opts } = @opts { @opts } ; # splice
    $self ;
  }
sub Make { my $self = shift ; $self -> New -> Init ( @_ ) ; }

package Ival ;

use base 'OBB' ; __PACKAGE__ -> mk_getset ( qw(noun opt def siz len num nam) ) ;

sub Init
  { my $self = shift ;
    @$self { qw(noun opt def siz) } = @{ shift @_ } ;
    $self ;
  }

sub units
  { my $self = shift ;
    sprintf "1 %s is %d %ss (%s days)", $self -> noun, $self -> num, $self -> nam, $self -> len ;
  }

sub adjv { my $res = shift -> noun ; $res =~ s/day/dai/ ; $res . 'ly' ; }

package Ivals ;

use base 'OBB' ; __PACKAGE__ -> mk_getset ( qw() ) ;

sub New { my $self = shift ; bless [], $self ; }
sub Init
  { my $self = shift ;
    my $rows = shift ;
    push @$self, map Ival -> Make ( $_ ), @$rows ;
    my %hash = () ;
    for my $ival ( $self -> list )
      { my $opt = $ival -> opt ;
        my $siz = $ival -> siz ;
        $ival -> num ( 1 ) ;
        $ival -> nam ( $ival -> noun ) ;
        $ival -> len ( $siz ) ;
        if ( $siz =~ /^(\d+)([A-Z])$/ )
          { my $up = $hash { $2 } ;
            $ival -> num ( $1 ) ;
            $ival -> nam ( $up -> noun ) ;
            $ival -> len ( $1 * $up -> len ) ;
          }
        $hash { $ival -> opt } = $ival ;
      }
    $self ;
  }
sub list { my $self = shift ; @$self ; }
sub opts { my $self = shift ; map $_ -> opt, $self -> list ; }
sub dlst { my $self = shift ; map $_ -> def, $self -> list ; }
sub _hsh
  { my $self = shift ;
    my $res = {} ;
    @$res { $self -> opts } = ( @_ ) ;
    $res ;
  }

sub hash { my $self = shift ; $self -> _hsh ( $self -> list ) ; }
sub defs { my $self = shift ; $self -> _hsh ( $self -> dlst ) ; }

sub summ
  { my $self = shift ;
    my $opts = shift ;
    join ', ' , map
      { sprintf "%d %s", $opts -> { $_ -> opt }, $_ -> adjv ;
      } $self -> list ;
  }

sub units
  { my $self = shift ;
    my @keys = @_ ;
    my $hash = $self -> hash ;
    join ' ; ', map { $hash -> { $_ } -> units ; } @keys ;
  }

sub utxt
  { my $self = shift ;
    my $fmt  = 'option %s : keep <%s> %-6s backups (default %d)%s' ;
    my @res  = () ;
    for my $ival ( $self -> list )
      { my $opt = $ival -> opt ;
        push @res, sprintf $fmt, $opt, $opt, $ival -> adjv, $ival -> def,
          ( $opt eq 'D'
          ? ''
          : sprintf " ; 1 %s = %2d %ss%s"
              , $ival -> noun, $ival -> num, $ival -> nam
              , ( $opt ne 'W'
                ? sprintf ( ' = %3d days', $ival -> len )
                : ''
                )
          ) ;
      }
    join "\n", @res ;
  }

package Remote ;

use base 'OBB' ; __PACKAGE__ -> mk_getset ( qw(name type) ) ;
sub Defs { name => 'no_name', type => 'no_type' ; }

sub get
  { my $self = shift ;
    my $from = shift ;
    my @CMD  = ( $RSYNC, '--no-motd', '--list-only', $from ) ;
    my $pid  = open FROM, '-|' ; die "can't popen @CMD\n" unless defined $pid ;
    unless ( $pid )
      { unless ( $DEBUG ) { close STDERR ; open STDERR, '>', '/dev/null' ; }
        exec @CMD ;
      }
    my @FROM = <FROM> ;
    close FROM or die sprintf "can't find [%s] (%s)\n", $from, $? >> 8 ;
    map
      { my @line = split ' ', $_ ; 
        my $name = $line[$#line] ;
        my $type = substr $line[0], 0, 1 ;
        $self -> Make ( name => $name, type => $type ) ;
      } @FROM ;
  }

sub get_bups
  { my $self = shift ;
    my $from = shift ;
    my $res  = {} ;
    for my $rem ( grep $_ -> name =~ /$RE_DATE$/, $self -> get ( "$from/" ) )
      { $res -> { $rem -> name } = $rem ; }
    $res ;
  }

sub get1
  { my $self = shift ; my $from = shift ; ( $self -> get ( $from ) ) [0]  ; }

sub dmp
  { my $self = shift ; sprintf "%s %s\n", $self -> type, $self -> name ; }

package Logger ;

use base 'OBB' ; __PACKAGE__ -> mk_getset ( qw(logd name drun opts fh) ) ;
use File::Path qw(mkpath) ;
use IO::File ;

sub file { sprintf "%s/%s.log", $_[0] -> logd, $_[0] -> name ; }

sub setup
  { my $self = shift ;
    my $opts = $self -> opts ;
    my $drun = $self -> drun ;
    my $logd = $self -> logd ;
    my $file = $self -> file ;
    unless ( $drun )
      { -d $logd || eval { mkpath $logd ; } ;
        die "[error] $prog: can't mkpath [$logd] ($@)" if $@ ;
        my $fh = $self -> fh ( new IO::File ) ;
        unless ( $fh and $fh -> open ( $file, '>>', 0644 ) )
          { die "[error] $prog: can't append $file ($!)" ; }
      }
    if ( $opts->{q} ) { close STDOUT ; open STDOUT, '>/dev/null' ; }
    $self -> print ( \*STDOUT, "$prog start %s\n", scalar localtime ) ;
    $self ;
  }

sub print
  { my $self = shift ;
    my $out  = shift ;
    my $fmt  = shift ;
    my $msg  = sprintf $fmt, @_ ;
    print $out $msg ;
    $self -> fh -> print ( $msg ) if $self -> fh ;
  }

sub keep_only
  { my $self = shift ;
    my $rep  = shift ;
    my $TAG  = shift ;
    my $optv = shift ;
    my $optf = shift ;
    my %keep = () ; $keep { $_ } ++ for map "$_.log", @_ ;
    my $logd = $self -> logd ;
    unless ( opendir LOGD, $logd )
      { return "can't open $logd ; skip cleanup\n" ; }
    for my $log ( grep /^$RE_DATE\.log$/, readdir LOGD )
      { my $fil = "$logd/$log" ;
        unless ( $keep { $log } )
          { $rep -> { $log } = "$TAG remove $fil" ;
            unlink $fil if $optf ;
          }
        elsif ( $optv )
          { $rep -> { $log } = "$TAG keep   $fil" ; }
      }
    closedir LOGD ;
    '' ;
  }

our $DEF_LOGD = "/var/log/$prog" ;

package main ;

use File::Path qw(mkpath rmtree) ;

our $IVALS = Ivals -> Make ( $DEF_IVALS ) ;
our @OPTS  = $IVALS -> opts ;
our $DEFS  = $IVALS -> defs ;
our $UTXT  = $IVALS -> utxt ;

my $Usage = <<USAGE ;
Usage : $prog [OPTIONS] src ... dst
   or : $prog [OPTIONS] 'STDIN' dst
option q : be quiet ; show errors only ; closes STDOUT
option v : be verbose
option d : show debug info
option n : only show commands ; implies -v
option f : action ; otherwise dry-run
option r : -r 'opt ...' ; use extra rsync options
option R : don't use the default rsync options
option l : -l 'log-dir' ; default $Logger::DEF_LOGD/ ;
           logs are named yyyy-mm-dd.log
option c : cleanup backups ; remove corresponding logs
on cleanup :
$UTXT
-----------------------------------------------------
default rsync options : @OPT_R
-----------------------------------------------------
$prog rsyncs each src/ to dst/YYYY-MM-DD/src/
   where /YYYY-MM-DD is the current date ;
-- Suppose PREV == dst/yyyy-mm-dd/src/ is the previous dump of src ;
   if src/xxx and PREV/xxx are equal, then dst/YYYY-MM-DD/src/xxx
   is hardlinked to PREV/xxx in the previous dump.
-- Argument src, ..., :
   -- must be an absolute path to a directory or a valid (existing)
      rsync src like [[user@]host:]/path/to/directory
   -- must not point to a symlink ;
   -- must not contain .. as a path-component ;
-- Argument dst :
   -- must be a directory
-- If 'src ...' == 'STDIN' then the src's (one per line) are read from STDIN ;
   leading and trailing white space is stripped from each line ;
   blank lines are silently ignored, as are #-comment lines.
-- By default, $prog uses "rsync -v" ; unset with "$prog -r --no-v".
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die "[error] $prog: $_[0]\n" ; }
sub Warn  { warn "[warn] $prog: $_[0]\n" ; }

# usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
# usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
# ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
# ID  = perl identifier
# SPC = i|f|s for integer, fixedpoint real or string argument

use Getopt::Long ;
Getopt::Long::config ( 'no_ignore_case' ) ;
my %opt = () ; Usage '' unless GetOptions
  ( \%opt, qw( v q d f n c R r=s ), map "$_=i", @OPTS ) ;
Usage("Arg count\n") unless @ARGV >= 2 ;
sub is_dry_run { ! $opt{f} or $opt{n} ; }

$opt{v} ||= $opt{d} ;
$opt{v} ||= $opt{n} ;
@OPT_R = () if $opt{R} ;
for my $x ( @OPTS ) { $opt{$x} = $DEFS -> {$x} unless defined $opt{$x} ; }

Error "not sane : -c -D $opt{D}" if $opt{c} and ! $opt{D} ;
Error "not sane : -R without -r" if $opt{R} and ! $opt{r} ;

my $DST = pop ;
my @SRC =
  ( ( @ARGV == 1 && $ARGV[0] eq 'STDIN' )
  ? grep /\S/, grep ! /^#/, map { s/^\s+// ; s/\s+$// ; $_ ; } <stdin>
  : @ARGV
  ) ;

my $TAG  = $opt{f} ? 'DID' : 'WOULD' ;
my $LOGR = Logger -> Make
  ( logd => ( $opt{l} || $Logger::DEF_LOGD )
  , name => DATE
  , drun => is_dry_run
  , opts => \%opt
  ) -> setup ;

for ( @SRC, $DST )
  { chomp ;
    chop while m!./$! ;
    Error "not absolute [$_]" unless m!^([^:]+:)?/! ;
    Error "'..' in path [$_]" if grep $_ eq '..', split m!/!, $_ ;
    my $itm = Remote -> get1 ( $_ ) ;
    Error "is a symlink [$_]" if $itm -> type eq 'l' ;
    Error "no directory [$_]" if $itm -> type ne 'd' ;
  }

Error "dst [$DST] is not a (local) directory" unless -d $DST ;

unshift @OPT_R, $OPT_N unless $opt{f} ;
push @OPT_R, split ' ', $opt{r} if $opt{r} ;

sub pr_out { $LOGR -> print ( \*STDOUT, @_ ) ; }
sub pr_err { $LOGR -> print ( \*STDERR, @_ ) ; }

sub days_ago { my $x = shift || 0 ; DATE time - $x * 24 * 60 * 60 ; }

sub Backups
  { opendir DST, $DST or Error "can't opendir $DST ($!)" ;
    my @res = sort grep $_ =~ $IS_DATE, readdir DST ;
    closedir DST ;
    @res ;
  }

sub last_date
  { my @res = Backups ;
    pop @res if @res and $res[$#res] eq DATE ;
    pop @res ;
  }

sub Mkpath
  { my $dir = shift ;
    return $dir if -d $dir ;
    pr_out "$TAG mkpath $dir\n" if $opt{v} ;
    if ( $opt{f} )
      { eval { mkpath $dir ; } ; Error "can't mkpath [$dir] ($@)" if $@ ; }
    $dir ;
  }

sub sync
  { my $src = shift ;
    my $dst = shift ;
    my $err = "/tmp/buperr.$$" ;
    my @CMD =
      ( $RSYNC
      , @OPT_R
      , @_
      , "$src/"
      , "$dst/"
      ) ;
    my $cmd = join ' ', @CMD ;
    my $res ;
    pr_out "$TAG %s\n", $cmd if $opt{v} ;
    return if $opt{n} ;
    my $pid = open CMD, '-|' ; die "can't popen @CMD\n" unless defined $pid ;
    unless ( $pid )
      { close STDERR ; open STDERR, '>', $err ; exec @CMD ; }
    pr_out $_ while <CMD> ;
    my $diag ;
    close CMD or $diag = sprintf "bad rsync exit [%s] (%s)\n", $? >> 8, $cmd ;
    if ( -s $err )
      { if ( open ERR, '<', $err ) { pr_err $_ while <ERR> ; } }
    unlink $err or Warn "can't unlink $err\n" ;
    if ( defined $diag ) { pr_err $diag ; die "exit" ; }
  }

sub lose1
  { Error "lose1 #args" unless @_ == 3 ;
    my $rep = shift ;
    my $tag = shift || 'unknown' ;
    my $bup = shift ;
    my $dst = sprintf "$DST/%s", $bup ;
    $rep -> { $bup } = "$TAG remove ; $tag" ;
    pr_out "# $TAG [$tag] remove %s\n", $bup if $opt{d} ;
    return if $opt{n} ;
    rmtree $dst if $opt{f} ;
  }

sub lose
  { Error "lose #args" unless @_ >= 2 ;
    my $rep = shift ;
    my $tag = shift ;
    lose1 $rep, $tag, $_ for @_ ;
  }

sub keep
  { Error "keep #args" unless @_ == 3 ;
    my $rep = shift ;
    my $tag = shift || 'unknown' ;
    my $bup = shift ;
    $rep -> { $bup } = "$TAG keep   ; $tag" ;
    pr_out "# $TAG [$tag]   keep %s\n", $bup if $opt{d} ;
    $bup ;
  }

# backups are ordered from 'old' to 'new' ; of course
sub cleanup
  { my @bups  = Backups ;
    my @keeps = () ;
    pr_out "--- cleanup backups -----------------------------\n" ;
    pr_out "Keeping %s backups ;\n", $IVALS -> summ ( \%opt ) ;
    pr_out "%s.\n", $IVALS -> units ( qw(M Q Y) ) ;
    my $res = {} ; $res -> { $_ } = 'init' for @bups ;
    
    for my $ival ( $IVALS -> list )
      { my $noun = $ival -> noun ;
        my $len  = $ival -> len ;
        my $opt  = $opt { $ival -> opt } ;
        for ( my $x = 0 ; $x < $opt ; $x ++ )
          { my $date1 = days_ago $len * ( $x + 1 ) - 1 ;
            my $date2 = days_ago $len * $x ;
            my $range = sprintf "for %-4s %s ; $date1"
              . ( $date1 eq $date2 ? '' : " .. $date2" )
              , $noun, $x + 1 ;
            my @ival = () ;
            while ( @bups and $bups [ $#bups ] ge $date1 )
              { unshift @ival, pop @bups ; }
            pr_out "# %-4s $x ; $date1 .. $date2 ; [%s]\n"
              , $noun, join ',', @ival if $opt{d} ;
            push @keeps, keep $res, $range, shift @ival if @ival ;
            lose $res, $range, @ival ;
          }
      }
    lose $res, 'too old', @bups ;
    for my $bup ( reverse sort keys %$res )
      { pr_out "%s : %s\n", $bup, $res -> { $bup } ; }
    pr_out "--- cleanup logs --------------------------------\n" ;
    my $err = $LOGR -> keep_only
      ( $res = {}, $TAG, $opt{v}, $opt{f}, sort @keeps ) ;
    pr_out $err if $err ;
    for my $log ( reverse sort keys %$res )
      { pr_out "%s\n", $res -> { $log } ; }
    pr_out "-------------------------------------------------\n" ;
  }

my $last = last_date || '' ;

for my $SRC ( @SRC )
  { my $src = substr $SRC, 1 + index $SRC, ':' ; $src = substr $src, 1 ;
    my $new = sprintf "%s/%s", DATE , ( $SRC eq '/' ? 'ROOT' : $src ) ;
    my $NEW = Mkpath sprintf "$DST/%s", $new ;
    my $dot = $new ; $dot =~ s![^/]+!..!g ;
    my $LNK = "$DST/$last/$src" ;
    my @OPT = ( $last && -d $LNK ) ? ( $OPT_L, $LNK ) : () ;
    sync $SRC, $NEW, @OPT ;
  }

cleanup if $opt{c} ;

pr_out "THIS IS A DRY-RUN\n" if is_dry_run ;