#! /usr/bin/perl -T
# FIXME: UPDATE {{
# Example .htaccess
# | Options -Indexes
# | <Files once.pl>
# | AuthType Basic
# | AuthName upload
# | Require valid-user
# | AuthUserFile /home/heiko/public_html/.passwd
# | </Files>
#
# Je nach Permission-Lage kann es gut sein, daß das upload.d-Verzeichnis
# mit der Hand angelegt werden muß und dem Webserver-Nutzer „geschenkt“
# werden muß.
#
# Das Upload-Verzeichnis sollte natuerlich vor der Indizierung geschuetzt
# werden - siehe Beispiel .htaccess.
#
# Eventuell in der Apache-Config sowas wie
#   ScriptAlias /ud	    /home/ud/XXX/once.pl
#   Alias	/d	    /home/ud/XXX/d/
# gesetzt werden.
#
# }}
#
#
# Directory Structure
# $VAR/ (from ONCE_VAR environment)
#     $userdir/
#              $uuid1-$timestamp-$removal_hint/$uploaded-file1
#              $uuid2-$timestamp-$removal_hint/$uploaded-file1


# TODO: Security review!

use 5.018;
use strict;
use warnings;
use IO::File;
use CGI qw(param upload header request_method url redirect);
use CGI::Carp qw(fatalsToBrowser);
use FindBin qw($RealBin $Bin);
use File::Basename;
use File::Path qw(remove_tree make_path);
use File::Spec::Functions;
use File::ShareDir qw(dist_dir);
use File::MimeInfo qw(mimetype);
use Cwd qw(getcwd realpath);
use Digest::MD5 qw(md5_hex md5);
use Template;
use experimental qw(smartmatch lexical_topic);

my $DIST = basename $0, '.pl';

sub humanize;     # convert numbers to human readable format
sub deletedir;    # safely delete directories
sub confirm;      # ask for user confirmation (HTML)
sub deslash;      # cleanup a path name
sub gen_uuid;     # create a uniq identifier
sub base62;
sub md5_base62 { ... }
sub untaint;

# These to RX are used in several places. Do not change them. It's
# important that they do not include the ../ sequence (not even URL
# encoded!)
my $rxVIEW = qr/[a-z\d]{6}-[a-z\d]+/i;          # date-userhash
my $rxFILE = qr/[a-z\d]{6}-[a-z\d]+-[dme]/i;    # date-filehash-removalmode

my %TT_CONFIG = (
  INCLUDE_PATH =>
      [ (map { catfile($Bin, $_) } qw(templates templates.default) ),
	#(map { catfile(dist_dir($DIST), $_) } qw(var templates.override templates)),
	(map { catfile($RealBin, $_) } qw(templates)),
      ]
);

umask 077;

# The working (var) directory gets passed to us via ONCE_VAR environment
# FIXME: Should we allow the current directory as an alternative?

die "Environment ONCE_VAR needs to be defined\n"
  if not defined $ENV{ONCE_VAR};
my $VAR = untaint($ENV{ONCE_VAR}, qr((^/.*)));

exit main() if not caller;

sub main {

    # Handle the UPLOAD / VIEW request
    # per view (user) we have an own directory

    # Preconditions: $VAR needs to exist (it's the base directory
    # for all R/W operations
    -d $VAR
      or mkdir $VAR => 0777
      or die "Can't mkdir $VAR: $! (Your admin should have created it. (uid:$> gids:$)))\n";

    -x -w $VAR
      or die "Can't write to $VAR: $!\n";

    # Check if the PATH_INFO looks like a download request.
    # If so, we're done.
    handle_download($ENV{PATH_INFO})
      and exit 0;

    handle_removal(param('delete'))
        and exit 0;

    # Setup the essentials: view and user_dir
    my ($view, $user_dir) = do {

        # view: display name
        #       anonymous | hans | …
        # user_dir: the directory name, per view/user
        #
        # NOTE: if you change the generated user_dir string here, you may need
        # to adapt the patterns $rxVIEW and $rxFILE at the beginning of
        # the script.
        #
        my ($v, $d);
        my $remote_user = defined $ENV{REMOTE_USER}
            ? untaint $ENV{REMOTE_USER}, qr/(\w+)/
            : 'anonymous';
        $d = join '-' => base62(time), $remote_user;
        $v = $remote_user;
        $v, deslash catfile($VAR, $d);
    };

    # save the uploaded file

    if (length(my $file = param('upload'))) {
        my $upload_fh = upload('upload');
        my $uuid      = gen_uuid();
        my ($delete, $expires, $days) = do {
            my ($d, $e);
            my $days = param('expires') // 0;

            # sanitize expires
            $days =~ /.*?([+-]?\d+).*/;
            $days = $1 // 10;
            $e = base62 time + $days * 86400;

            if    ($days == 0) { $d = 'd' }    # at first [d]ownload
            elsif ($days < 0)  { $d = 'm' }    # only [m]anually
            else               { $d = 'e' }    # if expired
            ($d, $e, $days);
        };

        # sanitize the filename
        my $filename = do {
            $file =~ tr /\\/\//;
            $file =~ /(.*)/;
            $1;
        };

        my $dir = catfile($user_dir, "$expires-$uuid-$delete");
        make_path($dir);
        {
            my $outfh = new IO::File "$dir/$filename", 'w'
              or die "Can't create $dir/$filename: $!\n";
            print {$outfh} <$upload_fh>;
        }

        if (not $delete ~~ [qw(d m)]
            and my $atfh = new IO::File("|at now + $days days"))
        {
            print {$atfh}
              "rm -f \"$dir/$filename\"\n",
              "rmdir \"$dir\"\n";
            close $atfh;
        }

    }

    # create the view
    my %tt = (view => $view);
    my $tt = Template->new(\%TT_CONFIG)
      or die $Template::ERROR;

    # List the current content
    if (my @files = map { deslash $_ } glob "$user_dir/*-*/*") {

        foreach (map { /(.*)/ } sort { -M $a <=> -M $b } @files) {

            my %file;

            my ($file, $dir) = fileparse($_);
            $dir = substr $dir, length $VAR;    # make it relative to $VAR

            # FIXME: use the rx* patterns from above
            $dir =~ m{/(?<expires>[a-z\d]{6})-(?<hash>[a-z\d]+)-(?<delete>.)}i
              or next;
            my ($hash, $expires, $delete) = @{+}{qw/hash expires delete/};
            if (${expires} <= time and $delete eq 'e') {
                /(.*)/;
                unlink $_  or die "Can't unlik $_: $!\n";
                rmdir $dir or die "Can't rmdir $dir: $!\n";
                next;
            }

            my $d;
            if ($delete eq 'e') {
                $d = localtime ${expires};
            }
            elsif ($delete eq 'd') {
                $d = 'unmittelbar nach Download';
            }
            else {
                $d = 'nur manuell';
            }

            $file{name}          = $file;
            $file{link}          = "$ENV{PATH_INFO}/$dir$file";
            $file{size}          = humanize -s $_;
            $file{uploaded}      = (stat _)[9];
            $file{removal}{type} = $d;
            $file{removal}{link} = "?delete=$dir";

            push @{ $tt{files} }, \%file;
        }

    }
    $tt->process('inventory.html', \%tt) or die sprintf "template: %s\nINCLUDE_PATH:\n%s\n",
	$tt->error(),
	join "\n", @{$TT_CONFIG{INCLUDE_PATH}};
    return 0;
}

sub deletedir {
    remove_tree
      map  { /^(\/.*)/ }
      grep { /^\Q$VAR\E/ } @_;
}

sub humanize {
    my $_     = shift;
    my @units = qw(B K M G T);
    while (length int > 3 and @units) {
        $_ = sprintf "%.1f" => $_ / 1024;
        shift @units;
    }
    croak "filesize is too big (can't convert to human readable number)"
      if !@units;
    return "$_$units[0]";
}

sub deslash { $_[0] =~ s{/+}{/}gr }

sub confirm {
    my ($base, $mimetype) = @_;
    my %tt = (
        file => {
            name     => $base,
            mimetype => $mimetype
        }
    );
    my $tt = Template->new(\%TT_CONFIG)
      or die $Template::ERROR;
    $tt->process('confirm.html' => \%tt);
    exit 0;
}

sub unbase62 {
    my @digits = reverse split '', shift;
    state $value = do {
        my %value;
        for (
            my ($symbol, $value) = (base62(0), 0) ;
            length($symbol) == 1 ;
            $symbol = base62 ++$value
          )
        {
            $value{$symbol} = $value;
        }
        \%value;
    };
    state $base = scalar keys %$value;

    my $unbase62 = 0;
    while (my ($p, $symbol) = each @digits) {
        $unbase62 += $value->{$symbol} * $base**$p;
    }
    return $unbase62;
}

sub base62 {
    my $n = shift // $_;
    die 'input is >MAXINT' if $n == $n - 1 or $n == $n + 1;
    state $digits = [0 .. 9, 'a' .. 'z', 'A' .. 'Z'];
    state $base = @$digits;
    my @result;

    for (; $n >= $base ; $n = int($n / $base)) {
        my $mod = $n % $base;
        unshift @result, $digits->[$mod];
    }
    unshift @result, $digits->[$n];
    join '', @result;
}

sub untaint {
    my ($_, $rx) = (@_, qr((\w+)));
    /$rx/;
    die sprintf("%s:%s:%d: untaint('%s', %s): not defined\n", caller, $_, $rx)
      if not defined $1;
    return $1;
}

sub gen_uuid {

    #open my $f, '/dev/urandom' or croak;
    #read $f, my($_), 128/8;
    #/^(.*)$/;
    #die join '-', map { base62 $_ } unpack 'Q*', $1;
    return base62 int rand(2**64);
}

# Download?
# PATH_INFO is something like
# /once/hDOPzMJMY0p/3fLjYmbYlGk-1450284310-d/boot.dot
#       |-VIEW-----|                         |-BASE-|
#       |-STORE----------------------------|
# …     |-PATH--------------------------------------|
sub handle_download {
    my $path_info = shift;

    $path_info =~ m{/(?<path>(?<store>(?<view>$rxVIEW)/$rxFILE)/(?<base>.*))}
      or return 0;

    #        use Data::Dumper;
    #        die Dumper \%+;
    my $view  = deslash realpath catfile $VAR, $+{view};
    my $store = deslash realpath catfile $VAR, $+{store};
    my $file  = deslash realpath catfile $VAR, $+{path};
    my $base  = $+{base};

    unless (-f $file) {
        print header('text/plain', '404 Not found'), 'Not found';
        exit 0;
    }

    my $mimetype = mimetype($file);
    confirm $base, $mimetype
      if $store =~ /-d$/ and not defined param('confirmed');

    open my $f, '<', $file or die "Can't open <`$file`: $!\n";
    remove_tree $1 if $store =~ m(^(/.*-d)$);
    rmdir $1 if $view =~ m(^(/.*));

    print header(-type => $mimetype, -charset => 'UTF-8');
    if (request_method() ~~ [qw(GET POST)]) {
        local $/ = \do { 1 * 2**20 };    # 1 MB Buffer
        print while <$f>;
    }

    return 1;
}

sub handle_removal {
    my $delete = shift;


    return 0
        if not $delete =~ m{(?<store>(?<view>$rxVIEW)/$rxFILE/?)};

    # FIXME: sanitization
    my $store = untaint(deslash(catfile $VAR, $+{store}), qr{(\Q$VAR\E.+)});
    my $view  = untaint(deslash(catfile $VAR, $+{view}), qr{(\Q$VAR\E.+)});

    die "<< $store | $view ($+{store} $+{view}) >>";

    remove_tree $store;
    rmdir $view;
    print redirect(-uri => url(-path_info => 1));

    return 1;
}

