package P2P::Transmission;

=head1 NAME

P2P::Transmission - Interface to the Transmission BitTorrent client

=head1 SYNOPSIS

  use P2P::Transmission;
  ...

=head1 DESCRIPTION

C<P2P::Transmission> can be used to control the popular cross-platform
B<Transmission> BitTorrent client. The module supports both the common
GUI-based client as well as the lesser-known B<transmission-daemon>.

Control of the client is achieved using an RPC interface provided by the
client itself. The module implements the documented 1.41 RPC spec.

=cut

use Carp;
use JSON;
use LWP::UserAgent;
use MIME::Base64;
use P2P::Transmission::Torrent;
use strict;

our $VERSION = '0.05';
our $REQUIRE = '1.41';

###
### AUTOGENERATED METHODS
###

use constant SESSION => qw{
    encryption
    download_dir
    peer_limit
    pex_allowed
    port
    port_forwarding_enabled
    speed_limit_down
    speed_limit_down_enabled
    speed_limit_up
    speed_limit_up_enabled
};

use constant STATS => qw{
    active_torrent_count
    download_speed
    paused_torrent_count
    torrent_count
    upload_speed
};

###
### PUBLIC METHODS
###

sub new {
    my ($class, %args) = @_;
    my $self = bless(\%args, $class);

    # initialize HTTP client for RPC comms
    $self->{ua} = LWP::UserAgent->new(agent => "P2P::Transmission $VERSION");
    croak("failed to initialize RPC agent") unless $self->{ua};

    # default settings: local instance
    $self->{host} ||= '127.0.0.1';
    $self->{port} ||= '9091';
    $self->{rpc}    = sprintf("http://%s:%s/transmission/rpc",
                               $self->{host},  $self->{port} );    
    # set other LWP defaults
    $self->{timeout} ||= 30;
    $self->{ua}->timeout($self->{timeout});
    
    if ($self->{username} && $self->{password}) {
        $self->{ua}->credentials($self->{host} . ':' . $self->{port},
                                 "Transmission RPC Server",
                                 $self->{username}, $self->{password} );
    }
    
    # verify version interoperability
    $self->{version} = $self->_rpc('session-get')->{version};
    if ($self->{version} =~ m/^(\d+\.\d+)\+? \((\d+)\)$/) {
        croak("This module requires Transmission $REQUIRE or later\n")
            unless ($1 >= $REQUIRE);
        $self->{revision} = $2;
    }
    
    return $self;
}

sub add {
    my ($self, %args) = @_;
    my %params = ();
    
    # enforce required parameters
    croak("either 'filename' or 'metainfo' must be passed to add()")
        unless ($args{filename} || $args{metainfo})
        and not($args{filename} && $args{metainfo});
    
    # sanitize remaining parameters
    foreach ('download_dir', 'paused', 'peer_limit', 'filename') {
        ($params{$_} = $args{$_}) if (exists $args{$_});
    }
    
    if (exists($args{metainfo})) {
        $params{metainfo} = encode_base64($args{metainfo});
    }
    
    my $r = $self->_rpc('torrent-add', %params);
    return P2P::Transmission::Torrent->new($self, $r->{'torrent-added'}->{id});
}

sub remove {
    my ($self, $req) = @_;
    
    # affect a specified torrent
    if (ref($req) eq 'P2P::Transmission::Torrent') {
        $self->_rpc('torrent-remove', ids => [ $req->{id} ]);
    }
    # affect all torrents
    elsif ($req eq 'all') {
        $self->_rpc('torrent-remove');
    } 
    else {
        croak("remove requires an argument");
    }
}

sub delete {
    my ($self, $req) = @_;
 
    ### PREVIEW! ###
    # this feature is live on the trunk but hasn't been put into 
    # a formally versioned release yet
    # http://trac.transmissionbt.com/changeset/7331
    croak("delete requires Transmission\@7331 or later")
        unless($self->{revision} > 7331);
    ################
    
    # affect a specified torrent
    if (ref($req) eq 'P2P::Transmission::Torrent') {
        $self->_rpc('torrent-remove', ids => [ $req->{id} ], 'delete-local-data' => 1);
    }
    # affect all torrents
    elsif ($req eq 'all') {
        croak("delete does not support 'all'");
    } 
    else {
        croak("delete requires an argument");
    }
}

sub start {
    my ($self, $req) = @_;
    
    # affect a specified torrent
    if (ref($req) eq 'P2P::Transmission::Torrent') {
        $self->_rpc('torrent-start', ids => [ $req->{id} ]);
    }
    # affect all torrents
    elsif ($req eq 'all') {
        $self->_rpc('torrent-start');
    } 
    else {
        croak("start requires an argument");
    }
}

sub stop {
    my ($self, $req) = @_;
    
    # affect a specified torrent
    if (ref($req) eq 'P2P::Transmission::Torrent') {
        $self->_rpc('torrent-stop', ids => [ $req->{id} ]);
    }
    # affect all torrents
    elsif ($req eq 'all') {
        $self->_rpc('torrent-stop');
    } 
    else {
        croak("stop requires an argument");
    }
}

sub torrents {
    my ($self) = @_;
    my @torrents;

    foreach (@{$self->_rpc("torrent-get", fields => ['id'])->{torrents}}) {
        push(@torrents, P2P::Transmission::Torrent->new($self, $_->{id}));
    }
    
    return @torrents;
}

sub verify {
    my ($self, $req) = @_;
    
    # affect a specified torrent
    if (ref($req) eq 'P2P::Transmission::Torrent') {
        $self->_rpc('torrent-verify', ids => [ $req->{id} ]);
    }
    # affect all torrents
    elsif ($req eq 'all') {
        $self->_rpc('torrent-verify');
    } 
    else {
        croak("verify requires an argument");
    }
}

sub version {
    my $self = shift;
    return $self->{version};
}

###
### PRIVATE METHODS
###

sub _rpc {
    my ($self, $method, %args) = @_;
    
    # translate keys-to-args
    foreach (keys %args) {
        my $key = $_;
        if ($key =~ tr/_/-/) {
            $args{$key} = delete($args{$_});
        }
    }

    # repack command into RPC structure
    my %command = (
        method    => $method,
        tag       => int(rand(65535)),
        arguments => \%args
    );
    
    # send RPC request
    my $r = $self->{ua}->post($self->{rpc}, Content => to_json(\%command));
    croak("RPC request failed [HTTP " . $r->code . ": " . $r->message . "]")
        unless ($r->is_success);
    
    # decode RPC response
    my $result = from_json($r->content);
    croak("RPC request failed [Tag Mismatch]")
        unless ($command{tag} == $result->{tag});
    
    # final sanity check
    croak('RPC error: "' . $result->{result} . '"')
        unless ($result->{result} eq 'success');

    # translate args-to-keys
    foreach (keys %args) {
        my $key = $_;
        if ($key =~ tr/_/-/) {
            $args{$key} = delete($args{$_});
        }
    }

    return $result->{arguments};
}

sub DESTROY {
    my $self = shift;
}

###
### METHOD GENERATOR
###

INIT {
    no strict 'refs';
    
    # generate SESSION accessors
    foreach my $method (SESSION) {
        *{$method} = sub {
            my ($self, $value) = @_;
            # inconsistent API fix:
            $method =~ tr/_/-/;

            if ($value) {
                $self->_rpc('session-set', $method => $value );
            }

            return $self->_rpc('session-get')->{$method};
        }
    }
    
    # generate STATS accessors
    foreach my $method (STATS) {
        *{$method} = sub {
            my ($self) = @_;
            # inconsistent API fix:
            $method =~ s/_(\w)/\u$1/g;

            return $self->_rpc('session-stats')->{'session-stats'}->{$method};
        }
    }
};

1;

__END__

=head1 BETA RELEASE WARNING

As of Transmission 1.21, the IPC/Socket protocol previously used to control
the client was replaced with a new RPC/HTTP protocol. This effectively
obsoleted P2P::Transmission 0.04.

This release (P2P::Transmission 0.05) is a nearly complete rewrite of the
old codebase to support the new communication protocol. Unfortunately, due to
B<significant> upstream API changes, this release could not be backwards
compatible with 0.04, so any pre-existing scripts will need to be updated.

Additionally, I'm publishing this release without a full set of documentation
and tests as I'm already a few months behind the Transmission guys in pace
and I want to get this code in the hands of the (few) people who will use it.

P2P::Transmission 0.06 should follow closely on the heels of this release
with all of the things currently missing: comprehensive documentation, a full
test suite, and some sample scripts ported from 0.04.

=head1 METHODS

=over 4

=item C<new( ... )>

=back

=head1 SEE ALSO

=over 4

=item * L<P2P::Transmission::Torrent>

=item * Transmission (http://www.transmissionbt.com/)

=back

=head1 AUTHOR

Brandon Gilmore, E<lt>brandon@mg2.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008 Brandon Gilmore

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut