#!/usr/bin/perl

=head1 AUTHORS

 Copyright (C) 2008 Dmitry E. Oboukhov <unera@debian.org>
 Copyright (C) 2008 Nikolaev Roman <rshadow@rambler.ru>

=head1 LICENSE

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.

You should have received a copy of the GNU  General  Public  License  along
with this program.  If not, see <http://www.gnu.org/licenses/>.

=cut

use strict;
use warnings;
use utf8;
use open qw(:std :utf8);

package MyUTFTemplate::Provider;
use base qw(Template::Provider);
sub _decode_unicode
{
	my ($self, $string)=@_;
	$string="\x{ef}\x{bb}\x{bf}$string";
	$self->SUPER::_decode_unicode($string);
}

package main;


our @langs_available=
(
    { lang  => 'en',    title => 'English' },
    { lang  => 'ru',    title => 'Русский' },
);

use CGI::Carp qw(fatalsToBrowser);
use CGI;
use RPC::XML;
use RPC::XML::Client;
use Template;
use JSON::XS;

our $VERSION="0.0.2";
our $PROJECT_NAME="rtpg";

my $SIZE_BY_CHUNKS_LIMIT=1024**3; # 1Gb

my $cgi=new CGI;
my %CONFIG;

# error messages
sub add_error_message($;@)
{
	my ($msg_id, @add_text)=@_;
	@add_text=('') unless @add_text;
	push @{$CONFIG{errors}},
	{
		err_id      => $msg_id,
		err_text    => join ', ', @add_text
	};
}

# execute rpc command
sub rpc_command($;@)
{
	return undef unless  $CONFIG{rpc};
	my ($cmd, @args)=@_;
	my $resp = $CONFIG{rpc}->send_request($cmd, @args);
	if (ref $resp)
	{
		if ('RPC::XML::fault' eq ref $resp)
		{
			add_error_message('ERR_RPC_RESPONSE',
			    $resp->value->{faultString}, ' fault code: ',
			    $resp->value->{faultCode}, ' function: ',
			    $cmd, @args
			);
            return undef;
		}
		$resp = $resp->value;
		return $resp;
	}

	add_error_message('ERR_RPC_REQUEST', $cmd, @args, $resp);
	return undef;
}

sub load_skin_list($)
{
	my $skins_dir=shift;
    opendir my $sd, $skins_dir or die "Can not open directory $skins_dir: $!\n";
    my @list_skins=map { s/\s+$//; $_ } grep { $_ !~ /^\./ } readdir $sd;

    for (@list_skins)
    {
        $_={ name => $_, title => $_ };
        my $sp="$skins_dir/$_->{name}";
        next unless -f "$sp/title.txt";
        open my $title, '<', "$sp/title.txt"
            or die "Can not open file '$sp/title.txt': $!\n";
        $title=<$title>;
        s/\s+$//, s/\s+/ /g, s/^\s+// for $title;
        $_->{title}=$title if length $title;
    }
    return \@list_skins;
}

# loading configuration
sub load_config()
{
	my $cfile=$ENV{RTPG_CONFIG}||'rtpg.conf';
	return () unless -f $cfile;
	open my $c, '<', $cfile or die "Can not open '$cfile': $!\n";

    my %config;

    while(<$c>)
    {
    	s/#.*//; s/\s+$//; s/^\s+//;
        my ($key, $value) = split /\s*=\s*/, $_, 2;
        next unless defined $value;
        next unless defined $key;
        $config{$key}=$value;
    }
    $config{errors}=[];
    my $to=$cgi->cookie('refresh_timeout');
    if (defined $to)
    {
    	$to=int $to;
        $config{refresh_timeout}=$to if ($to/1000>=1 or $to==0);
    }

    unless (defined $config{skin_dir})
    {
        $config{skin_dir}='skins';
        $config{current_skin}='default';
    }
    $config{current_skin}='default' unless defined $config{current_skin};
    s/\/$// for ($config{current_skin}, $config{skin_dir});

    $config{skins}=load_skin_list($config{skin_dir});

    unless (grep { $config{current_skin} eq $_->{name}  } @{$config{skins}})
    {
        $config{current_skin}='default';
        $config{skin_dir}='skins' if ($config{skin_dir} ne 'skins');
        $config{skins}=load_skin_list($config{skin_dir});
    }


    if (defined $cgi->cookie('skin'))
    {
    	my $user_skin=$cgi->cookie('skin');
    	if (grep { $user_skin eq $_->{name}  } @{$config{skins}})
    	{
    		$config{current_skin}=$user_skin;
    	}
    }

    my $lang;
    if ($cgi->cookie('lang'))
    {
        $lang=$cgi->cookie('lang');
        $lang=undef
            unless (-f "templates/langs/$lang.html"
                and -f "js/langs/$lang.main.js");
    }

    unless($lang)
    {{
        my $accept_langs=$ENV{HTTP_ACCEPT_LANGUAGE} or last;
        $accept_langs=~s/;.*$//;
        $accept_langs=~s/\s+//g;
        for (split /,/, $accept_langs)
        {
            if (-f "templates/langs/$_.html" and -f "js/langs/$_.main.js")
            {
            	$lang=$_;
            	last;
            }
            $lang=undef;
        }
    }}

    $lang='en' unless $lang;
    $config{lang}=$lang;
    return %config;
}

# first connect
sub connect_to_rtorrent()
{
    return if ($CONFIG{rpc});

    $CONFIG{rpc}=new RPC::XML::Client($CONFIG{rpc_uri});

    if (ref $CONFIG{rpc})
    {
        if ($CONFIG{rtorrent_version}=rpc_command('system.client_version'))
        {
        	$CONFIG{library_version}=rpc_command('system.library_version');
        	return 1;
        }
        return $CONFIG{rpc}=undef;
    }

    add_error_message('ERR_RPC_CONNECT', $CONFIG{rpc});
    return $CONFIG{rpc}=undef;
}

# convert big numbers to small 1024 = 1K, etc
sub human_size($)
{
	my ($size, $sign)=(shift, 1);
	if ($size<0) { return '>2G'; }
	return 0 unless $size;
	my @suffixes=('', 'K', 'M', 'G', 'T', 'P', 'E');
	my ($limit, $div)=(1024, 1);
    for (@suffixes)
    {
    	if ($size<$limit || $_ eq $suffixes[-1])
    	{
            $size = sprintf '%1.1f', $sign*$size/$div;
            $size =~ s/\.0//;
            return "$size$_";
    	}
        $div = $limit;
        $limit *= 1024;
    }
}

# return script address and base name
sub get_script_address()
{
    my $proto='http';
    $proto='https' if $ENV{SERVER_PORT}==443;
    my $url="$proto://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}";
    my $base_path=$url;
    s{[^/]+$}{} for $base_path;
    return { base => $base_path, url=>$url };
}

# reload page
sub refresh_browser()
{
	return if @{$CONFIG{errors}};
    print $cgi->header(-location=>get_script_address->{url});
    exit;
}

sub get_percent_string($$)
{
	my ($part, $full)=@_;
	return undef unless $full;
	return undef unless defined $part;
	return undef if $part<0;
	return undef if $full<0;
	return undef if $part>$full;
	my $percent=$part*100/$full;
	if ($percent<10)
	{
		$percent=sprintf '%1.2f', $percent;
	}
	else
	{
		$percent=sprintf '%1.1f', $percent;
	}
	s/0+$//, s/\.$// for $percent;
	return "$percent%";
}

# return torrent list and system information
sub get_torrents_list($)
{
	my $view=shift;
    my $list=rpc_command('download_list', $view);
    return undef unless $list;

    my ($ur, $dr)=(0,0);
    for (@$list)
    {
	    $_={ hash => $_ };
        my @info_list=qw(
            is_active is_hash_checked is_hash_checking is_multi_file
            is_open is_pex_active is_private get_name get_priority
            get_ratio get_size_bytes get_hash get_peers_connected
            get_bytes_done get_message get_directory get_up_total
            get_complete get_up_rate get_down_rate
            get_size_chunks
            get_completed_chunks
            get_chunk_size
        );

        for my $il(@info_list)
        {
    	    my $name=$il;
    	    $name=~s/^get_//;
    	    $_->{$name}=rpc_command("d.$il", $_->{hash});
        }

        $_->{percent}=get_percent_string($_->{completed_chunks},
            $_->{size_chunks})||0;

        my ($bytes_done, $size_bytes)=
        (
            1.0*$_->{completed_chunks}*$_->{chunk_size},
            1.0*$_->{size_chunks}*$_->{chunk_size}
        );
        $_->{size_bytes}=$size_bytes if $size_bytes>$SIZE_BY_CHUNKS_LIMIT;
        $_->{bytes_done}=$bytes_done if $bytes_done>$SIZE_BY_CHUNKS_LIMIT;
        $_->{up_total}=1.0*$_->{bytes_done}*($_->{ratio}/1000);


        $_->{ratio}=sprintf '%1.2f', $_->{ratio}/1000;
        $_->{ratio}=~s/((\.00)|0)$//;

        $_->{human_size}=human_size $_->{size_bytes};
        $_->{human_done}=human_size $_->{bytes_done};
        $_->{human_up_total}=human_size $_->{up_total};

        $_->{human_up_rate}=human_size $_->{up_rate};
        $_->{human_down_rate}=human_size $_->{down_rate};

        for ($_->{human_up_rate}, $_->{human_down_rate})
        {
        	next if $_ eq 0;
        	$_ .= 'b/s';
        }

        $ur += $_->{up_rate};
        $dr += $_->{down_rate};

        delete $_->{size_chunks};
        delete $_->{completed_chunks};
        delete $_->{chunk_size};
    }

    for ($ur, $dr)
    {
    	next if $_ == 0;
    	$_ = human_size $_;
        $_ .= 'b/s';
    }

    if ($list)
    {
    	$list =
    	{
    		list    => $list,
    		system  =>
    		{
    			l_upload_rate   => rpc_command('get_upload_rate'),
    			l_download_rate => rpc_command('get_download_rate'),
    			free_space      => rpc_command("get_safe_free_diskspace"),
    			upload_rate     => $ur,
    			download_rate   => $dr,
    		}
    	};
    	$list->{system}{free_space}=human_size($list->{system}{free_space});
    }
    return $list;
}


sub get_torrents_list_JSON($)
{
	my $view=shift;
	my $list=get_torrents_list($view);
	return JSON::XS->new->encode(
    	{
    	    error   => 1,
    	    errors  => $CONFIG{errors}
    	}
	) unless $list;
	return JSON::XS->new->encode($list);
}

# return list files in one torrent
sub get_list_files_JSON($)
{
    my $id=shift;
	my @cmds=(
	        "f.get_path",
            "f.get_priority",
            "f.get_size_bytes",
            "f.get_size_chunks",
            "f.get_completed_chunks",
	);

    my $chunk_size=rpc_command('d.get_chunk_size', $id);
	my $results=[];

	INDEX_CYCLE: for (my $i=0; ; $i++)
	{
		my %finfo;
		for my $cmd(@cmds)
		{
			my $hname=$cmd;
			my $resp=rpc_command($cmd, $id, $i);
            unless (defined $resp)
			{
                $results={ error=>1, errors=>$CONFIG{errors} } unless $i;
			    last INDEX_CYCLE;
			}
			s/^..//, s/^get_// for $hname;
			$finfo{$hname}=$resp;
		}

		my $size_bytes=1.0*$chunk_size*$finfo{size_chunks};
		$finfo{size_bytes}=$size_bytes if $size_bytes > $SIZE_BY_CHUNKS_LIMIT;
		$finfo{human_size}=human_size $finfo{size_bytes};
		$finfo{percent}=get_percent_string($finfo{completed_chunks},
		    $finfo{size_chunks})||0;

		delete $finfo{size_chunks};
		delete $finfo{completed_chunks};
		push @$results, \%finfo;
	}

	return JSON::XS->new->encode($results);
}

sub get_cookies()
{
	return
	[
	    $cgi->cookie(-name=>'skin',
	        -value=>$CONFIG{current_skin}, -expires=>'+2y'),

	    $cgi->cookie(-name=>'refresh_timeout',
	        -value=>$CONFIG{refresh_timeout}, -expires=>'+2y'),
	];
}

sub print_header($;$)
{
	my $type=shift;
	my $cookie=shift;
	print $cgi->header(
	    -type           => $type,
	    -charset        => 'utf-8',
	    -Cache_Control  => 'no-cache, no-store, max-age=0, must-revalidate',
	    -expires        => 'now',
	    $cookie?(-cookie    => $cookie):(),
	);
}

#====================================================================
# program
#====================================================================
%CONFIG=load_config();

if (%CONFIG)
{
    connect_to_rtorrent();

    my $view=$cgi->cookie('view')||'default';

    # show all functions (test mode)
    if ($cgi->param('test_mode'))
    {
    	require Data::Dumper;
    	print_header('text/plain');
	    my $resp=rpc_command('system.listMethods');
	    print Data::Dumper::Dumper($resp);
	    exit;
    }

    # set priority for one file
    if (my $id=$cgi->param('file_priority'))
    {{
	    my $pri=$cgi->param('pri');
        last unless defined $pri;
	    my $fid=$cgi->param('fid');
	    last unless defined $fid;
	    last unless $pri=~/^\d+$/;
	    last unless $fid=~/^\d+$/;
	    rpc_command('f.set_priority', $id, $fid, $pri);
    	print_header('text/plain');
	    print get_list_files_JSON($id);
	    exit;
    }}

    # show files in torrent
    if (my $id=$cgi->param('files'))
    {
    	print_header('text/plain');
	    print get_list_files_JSON($id);
	    exit;
    }

    # set upload rate
    if (defined $cgi->param('rate_up'))
    {
        my $rate=$cgi->param('rate_up');
    	rpc_command('set_upload_rate', $rate);
    	print_header('text/plain');
	    print get_torrents_list_JSON($view);
	    exit;
    }

    # set download rate
    if (defined $cgi->param('rate_down'))
    {
        my $rate=$cgi->param('rate_down');
    	rpc_command('set_download_rate', $rate);
    	print_header('text/plain');
	    print get_torrents_list_JSON($view);
	    exit;
    }

    # get download list in JSON format
    if ($cgi->param('get_list'))
    {
    	print_header('text/plain');
	    print get_torrents_list_JSON($view);
        exit;
    }

    # remove from torrents_list
    if (my $id=$cgi->param('delete'))
    {
        rpc_command('d.erase', $id);
    	print_header('text/plain');
	    print get_torrents_list_JSON($view);
        exit;
    }

    # stop torrent
    if (my $id=$cgi->param('stop'))
    {
	    rpc_command('d.stop', $id);
    	print_header('text/plain');
	    print get_torrents_list_JSON($view);
        exit;
    }

    # start torrent
    if (my $id=$cgi->param('start'))
    {
	    rpc_command('d.start', $id);
    	print_header('text/plain');
	    print get_torrents_list_JSON($view);
        exit;
    }

    # change priority
    if (my $id=$cgi->param('hash'))
    {
	    my $pri=$cgi->param('priority');
	    if (defined $pri)
	    {
		    rpc_command('d.set_priority', $id, $pri);
    	    print_header('text/plain');
		    print get_torrents_list_JSON($view);
		    exit;
	    }
    }

    # add torrent to list
    if ($cgi->param('add_torrent'))
    {{
	    if (my $file=$cgi->param('file_torrent'))
	    {
		    my $fh=$cgi->upload('file_torrent');
		    unless ($fh)
		    {
			    add_error_message 'ERR_UPLOAD_TORRENT';
			    last;
		    }
		    local $/;
		    my $torrent=RPC::XML::base64->new(<$fh>);
		    rpc_command(load_raw => $torrent);
		    refresh_browser();
		    last;
	    }

	    if (my $url=$cgi->param('url_torrent'))
	    {
            $url=RPC::XML::base64->new($url);
		    rpc_command(load_verbose => $url);
		    refresh_browser();
		    last;
	    }
    }}

    # template/output
    print_header('text/html');
    Template->new(
        LOAD_TEMPLATES  => [ MyUTFTemplate::Provider->new() ]
        )->process(
            "templates/langs/$CONFIG{lang}.html",
            {
    	        CONFIG          => (%CONFIG)?\%CONFIG:undef,
    	        version         => $VERSION,
    	        PROJECT_NAME    => $PROJECT_NAME,
    	        listJSON        => get_torrents_list_JSON($view),
    	        script_addr     => get_script_address,
    	        skin            => "$CONFIG{skin_dir}/$CONFIG{current_skin}",
    	        view            => $view,
    	        languages       => \@langs_available,
            }
        );
    exit;
}

die "Can not load config\n";