#!/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;
use CGI::Carp qw(fatalsToBrowser);
use RTPG;


# items for send in torrent-lists
my @TLIST_ITEMS=qw(
    human_size human_done percent human_up_total ratio peers_connected
    human_up_rate human_down_rate hash message name priority
    is_hash_checking is_active
);

# items for send in file-lists
my @FLIST_ITEMS=qw(path human_size priority percent);

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

use CGI;
use RPC::XML;
use RPC::XML::Client;
use Template;
use JSON::XS;

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

my $cgi=new CGI;
my %CONFIG;
my $rtorrent;

# error messages
sub add_error_message(@)
{
	push @{$CONFIG{errors}}, join ' ', @_;
}

# loading skin list
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;

    my $form_input=$cgi->cookie('form')||'file';
    $form_input='file' unless $form_input=~/^(file|url)$/;
    $config{form_input}=$form_input;
    return %config;
}

# return script address and base name
sub get_script_address()
{
    my $proto='http';
    $proto='https' if $ENV{SERVER_PORT}==443;
    my $port = $ENV{SERVER_PORT};
    $port = '' if $port == 80 or $port == 443;
    $port = ":$port" if $port;

    my $url = sprintf "%s://%s%s%s",
        $proto, $ENV{SERVER_NAME}, $port, $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;
}

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

# remove all items exclude @FLIST_ITEMS
sub clean_file_list($)
{
	my $list=shift;
    for my $item (@$list)
    {
    	my $clean_item={};
    	$clean_item->{$_}=$item->{$_} for @FLIST_ITEMS;
    	if ($cgi->param('off_names'))
    	{
    	    delete $clean_item->{path};
    	    delete $clean_item->{human_size};
    	}
    	delete $clean_item->{percent}
    	    if defined($clean_item->{percent}) &&
    	    	    $clean_item->{percent} eq '0%';

    	delete $clean_item->{priority}
    	    if defined($clean_item->{priority}) &&
    	    	$clean_item->{priority} eq 1;

    	$item=$clean_item;
    }
    return $list;
}

# return torrents list in JSON format
# additional: return system info
sub get_list($$;$)
{
    my ($rtorrent, $view, $id)=@_;
	my ($list, $error)=$rtorrent->torrents_list($view);
	if (defined $list)
	{
		my ($l_upload_rate, $l_download_rate,
			$upload_rate, $download_rate)=(undef, undef,0,0);

		($l_upload_rate, $error)=$rtorrent->rpc_command('get_upload_rate');
		($l_download_rate, $error)
			=$rtorrent->rpc_command('get_download_rate')
			    if defined $l_upload_rate;
		if (defined $l_download_rate)
		{
            for my $item (@$list)
            {
                $upload_rate += $item->{up_rate};
                $download_rate += $item->{down_rate};
    
                # cleaning torrent list
                my $clean_item={};
                $clean_item->{$_}=$item->{$_} for @TLIST_ITEMS;
                unless(defined $clean_item->{message})
                {
                    delete $clean_item->{message};
                }
                else
                {
                    delete $clean_item->{message} 
                        unless length $clean_item->{message};
                }
                $item=$clean_item;
            }

            $list =
            {
            	system  =>
            	{
                    l_upload_rate   => $l_upload_rate,
                    l_download_rate => $l_download_rate,
                    upload_rate     => $upload_rate,
                    download_rate   => $download_rate,
            	},
            	list    => $list
            };
            if ($id)
            {
            	my $expanded;
            	($expanded, $error)=$rtorrent->file_list($id);
            	if (defined $expanded)
            	{
            		$list->{expanded_torrent}=clean_file_list $expanded;
            	}
            	else
            	{
            		$list->{expanded_torrent}={ error => $error };
            	}
            }
            ($list->{versions}, $error)=$rtorrent->system_information;
		}
		else
		{
            $list = { error => $error };
		}
	}
	else
	{
		$list = { error => $error };
	}

	return toJSON($list);
}

# return list of files for current torrent
sub get_file_list($$)
{
    my ($rtorrent, $id)=@_;
    my ($list, $error)=$rtorrent->file_list($id);
    return toJSON({ error => $error }) unless defined $list;
    return toJSON(clean_file_list $list);
}

# convert perl-object to JSON
sub toJSON($)
{
	return JSON::XS->new->encode(shift) unless $cgi->param('debug');
	return JSON::XS->new->indent(1)->encode(shift);
}

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

die "Can not load config file: not found or not defined\n"
    unless %CONFIG;
$CONFIG{rpc}=$rtorrent=new RTPG(url  => $CONFIG{rpc_uri});
my $view=$cgi->cookie('view')||'default';

if (my $what=$cgi->param('what'))
{
    # show all functions (test mode)
	if ($what eq 'test')
	{
		print_header('text/plain');
		my $list=$rtorrent->rpc_command('system.listMethods');
		print join "\n", @$list;
		exit;
	}

    # show list of torrents
	if ($what eq 'list')
	{
		my $id=$cgi->param('id');
		print_header('text/plain');
		print get_list($rtorrent, $view, $id);
		exit;
	}

    # set priority for one file
    if ($what eq 'file_priority')
    {
    	print_header('text/plain');
    	my $id=$cgi->param('id');
    	my $fid=$cgi->param('file_id');
    	my $pri=$cgi->param('priority');

    	my ($res, $error)=
    	    $rtorrent->rpc_command('f.set_priority', $id, $fid, $pri);
    	unless (defined $res)
    	{
    	    print toJSON({ error => $error });
    		exit;
    	}
    	print get_file_list($rtorrent, $id);
    	exit;
    }

    # update all files priorities
    if ($what eq 'files_priority')
    {
    	my $priority=$cgi->param('priority');
    	my $id=$cgi->param('id');
    	$priority=-1 unless defined $priority;
    	unless ($priority == -1)
    	{
    	    if (my $error=$rtorrent->set_files_priorities($id, $priority))
    	    {
    	        print_header('text/plain');
    	        print toJSON({ error => $error, id=>$id, pri=>$priority });
                exit;
    	    }
    	}
    	$what='files';
    }

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

    # start/stop/delete torrent
    if ($what =~ /^(start|stop|erase)$/)
    {
    	my $id=$cgi->param('id');
    	print_header('text/plain');
    	my ($res, $error)=$rtorrent->rpc_command("d.$what", $id);
    	if (defined $res)
    	{
    		print get_list($rtorrent, $view);
    		exit;
    	}
    	print toJSON({ error => $error });
    	exit;
    }

    # change priority
    if ($what eq 'priority')
    {
    	print_header('text/plain');
    	my $id=$cgi->param('id');
    	my $pri=$cgi->param('priority');
    	my ($res, $error)=$rtorrent->rpc_command("d.set_priority", $id, $pri);
    	if (defined $res)
    	{
    		print get_list($rtorrent, $view);
    		exit;
    	}
    	print toJSON({ error => $error });
    	exit;
    }
    
    # change upload/download rates
    if ($what eq 'set_rate')
    {
    	my $rate=int($cgi->param('rate')||0);
    	my $direction=$cgi->param('direction')||'';
    	my $cmd='set_upload_rate' if $direction eq 'up';
    	$cmd='set_download_rate' if $direction eq 'down';
    	
    	print_header('text/plain');
    	unless ($cmd)
    	{
    		print get_list($rtorrent, $view);
    		exit;
    	}
    	my ($res, $error)=$rtorrent->rpc_command($cmd, $rate);
    	if (defined $res)
    	{
    		print get_list($rtorrent, $view);
    		exit;
    	}
    	print toJSON({ error => $error });
    	exit;
    }

    # read one torrent information
    if ($what eq 'one_torrent')
    {
    	my $id=$cgi->param('id');
    	my ($tinfo, $error)=$rtorrent->torrent_info($id);
    	print_header('text/plain');
    	unless (defined $tinfo)
    	{
    	    print toJSON({ error => $error });
    		exit;
    	}
    	print toJSON($tinfo);
    	exit;
    }
    
    # add torrent from file
    if ($what eq 'add_torrent_file')
    {{
	    if (my $file=$cgi->param('file_torrent'))
	    {
		    my $fh=$cgi->upload('file_torrent');
		    unless ($fh)
		    {
			    add_error_message 'Error upload torrent';
			    last;
		    }
		    local $/;
		    my $torrent=RPC::XML::base64->new(<$fh>);
		    my ($res, $error)=$rtorrent->rpc_command(load_raw => $torrent);
		    add_error_message($error) unless defined $res;
		    refresh_browser();
		    last;
	    }
    }}

    # add torrent from url
    if ($what eq 'add_torrent_url')
    {{
	    if (my $url=$cgi->param('url_torrent'))
	    {
            $url=RPC::XML::base64->new($url);
		    my ($res, $error)=$rtorrent->rpc_command(load_verbose => $url);
		    add_error_message($error) unless defined $res;
		    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_list($rtorrent, $view),
    	    script_addr     => get_script_address,
    	    skin            => "$CONFIG{skin_dir}/$CONFIG{current_skin}",
    	    view            => $view,
    	    languages       => \@langs_available,
        }
    );