File Coverage

blib/lib/WWW/FBX.pm

Criterion	Covered	Total	%
statement	33	86	38.3
branch	0	28	0.0
condition	0	24	0.0
subroutine	11	21	52.3
pod			n/a
total	44	159	27.6

package WWW::FBX;
use Moose;
use Carp::Clan qw/^(?:WWW::FBX|Moose|Class::MOP)/;
use JSON::MaybeXS;
use Scalar::Util qw/reftype/;
use URI::Escape;
use HTTP::Request::Common;
use WWW::FBX::Error;
use Encode qw/encode_utf8/;
use Try::Tiny;
use LWP::UserAgent;

with 'WWW::FBX::Role::API::APIv3';
with 'WWW::FBX::Role::Auth';

use namespace::autoclean;

our $VERSION = "0.18";

has base_url    => ( isa => 'Str', is => 'ro', default => 'http://mafreebox.free.fr' );
has lwp_args    => ( isa => 'HashRef', is => 'ro', default => sub { {} } );
has [ qw/app_id app_name app_version device_name/ ] => (
    isa => 'Str', is => 'ro', required => 1 );
has ua          => ( isa => 'LWP::UserAgent', is => 'rw', lazy => 1, builder => '_build_ua' );
has uar         => ( isa => 'HashRef', is => 'rw' );
has uarh        => ( isa => 'HTTP::Response', is => 'rw' );
has debug       => ( isa => 'Bool', is => 'rw', default => 0, trigger => \&_set_debug );

has _json_handler   => (
    is      => 'rw',
    default => sub { JSON->new->allow_nonref },
    handles => { from_json => 'decode' },
);

sub _set_debug {
    my ( $self, $debug, $odebug) = @_ ;
    if ( defined $odebug and $odebug != $debug or $debug ) {
        if ($debug) {
            $self->ua->add_handler("request_send", sub { print ">" x 25, "\n"; shift->dump; return });
            $self->ua->add_handler("response_done", sub { print "<" x 25, "\n"; shift->dump; return });
        } else {
            $self->ua->remove_handler("request_send");
            $self->ua->remove_handler("response_done");
        }
    }
}

sub _build_ua {
    my $self = shift;

    my $ua = LWP::UserAgent->new(%{$self->lwp_args});

    return $ua;
}

sub _json_request {
    my ($self, $http_method, $uri, $args, $content_type ) = @_;

    my $msg = $self->_prepare_request($http_method, $uri, $args, $content_type);
    my $res = $self->_send_request($msg);

    #Store response content
    $self->uar( $self->_parse_result ($res, $args ) );

    #And HTTP response RAW
    $self->uarh( $res );

    return $self->uar->{result};
}

sub _prepare_request {
    my ($self, $http_method, $uri, $args, $content_type ) = @_;

    my $msg;

    if( $http_method eq 'PUT' ) {
        $msg = PUT( $uri, Content => encode_json  $args  );
    }
    elsif ( $http_method =~ /^(?:GET|DELETE)$/ ) {
        $uri->query($self->_query_string_for($args)) if keys %$args;
        $msg = HTTP::Request->new($http_method, $uri);
    }
    elsif ( $http_method eq 'POST' ) {
        if( !$content_type or $content_type eq 'application/json' ) {
            $msg = POST( $uri,  Content_Type => 'application/json', Content =>  encode_json $args );
        }
        elsif ( $content_type eq "form-data" ) {
            $msg = POST($uri, Content_Type => 'form-data', Content => [ map { ref $_ ? $_ : encode_utf8 $_ } %$args ]);
        }
        else {
            $msg = POST($uri, Content => $args);
        }
    }
    else {
        croak "unexpected HTTP method: $http_method";
    }

    return $msg;
}

sub _query_string_for {
    my ( $self, $args ) = @_;

    my @pairs;
    while ( my ($k, $v) = each %$args ) {
        push @pairs, join '=', $k, $v;
    }

    return join '&', @pairs;
}

sub _send_request { shift->ua->request(shift) }

sub _parse_result {
    my ($self, $res, $args) = @_;

    my $content = $res->content;

    my $j_obj = length $content ? try { $self->from_json($content) } : {};

    #Die if message contains an API error (even on HTTP 200)
    if ( ref $j_obj && reftype $j_obj eq 'HASH' && (exists $j_obj->{error_code} || exists $j_obj->{msg} ) ) {
        die WWW::FBX::Error->new(fbx_error => $j_obj, http_response => $res);
    }

    #If no API error and HTTP is 200 and answer is json
    return $j_obj if $res->is_success && defined $j_obj;

    #API Download file does not return JSON!!
    #If answer is 200 and not json, return unchanged (but still pack it in an HashRef for uar type check..)
    return { result => { filename => $res->filename, content => $content } } if $res->filename and $res->is_success;

    #Else die on HTTP failures, which might contain a json response or not
    my $error = WWW::FBX::Error->new(http_response => $res);
    $error->fbx_error($j_obj) if ref $j_obj;

    die $error;
}

__PACKAGE__->meta->make_immutable;

1;
__END__

=for html <a href="https://travis-ci.org/architek/WWW-FBX"><img src="https://travis-ci.org/architek/WWW-FBX.svg?branch=master"></a>

=encoding utf-8

=head1 NAME

WWW::FBX - Freebox v6 OS Perl Interface

=head1 FREEBOX SDK API 3.0

This version provides the API 3.0 support through the APIv3 role but other version can be provided by creating a new role.

=head1 AUTHENTICATION

Authentication is provided through the Auth role but other authentication mechanism can be provided by creating a new role.

=head1 SYNOPSIS

    use WWW::FBX;
    use Scalar::Util 'blessed';

    my $res;
    eval {
        my $fbx = WWW::FBX->new(
            app_id => "APP ID",
            app_name => "APP NAME",
            app_version => "1.0",
            device_name => "MY DEVICE",
            track_id => "48",
            app_token => "2/g43EZYD8AO7tbnwwhmMxMuELtTCyQrV1goMgaepHWGrqWlloWmMRszCuiN2ftp",
            base_url => "http://12.34.56.78:3333",
            debug => 1,
        );
        print "You are now authenticated with track_id ", $fbx->track_id, " and app_token ", $fbx->app_token, "\n";
        print "App permissions are:\n";
        while ( my( $key, $value ) = each %{ $fbx->uar->{result}{permissions} } ) {
            print "\t $key\n" if $value;
        }

        $res = $fbx->connection;
        print "Your ", $res->{media}, " internet connection state is ", $res->{state}, "\n";
        $fbx->set_ftp_config( {enabled => \1} );
        $fbx->reset_freeplug( "F4:CA:E5:DE:AD:BE/reset" );
    };

    if ( my $err = $@ ) {
        die $@ unless blessed $err && $err->isa('WWW::FBX::Error');

        warn "HTTP Response Code: ", $err->code, "\n",
             "HTTP Message......: ", $err->message, "\n",
             "API Error.........: ", $err->error, "\n",
             "Error Code........: ", $err->fbx_error_code, "\n",
    }

=head1 DESCRIPTION

This module provides a perl interface to the L<Freebox|https://en.wikipedia.org/wiki/Freebox#V6_generation.2C_Freebox_Revolution> v6 APIs.

See L<http://dev.freebox.fr/sdk/os/> for a full description of the APIs.

=head1 METHODS AND ARGUMENTS

 my $fbx = WWW::FBX->new( app_id => "APP ID", app_name => "APP NAME",
                          app_version => "1.0", device_name => "device" );

 my $fbx = WWW::FBX->new( app_id => "APP ID", app_name => "APP NAME",
                          app_version => "1.0", device_name => "device",
                          track_id => "48", app_token => "2/g43EZYD8AO7tbnwwhmMxMuELtTCyQrV1goMgaepHWGrqWlloWmMRszCuiN2ftp",
                          base_url => "http://12.34.56.78:3333" ,
                          debug => 1 );

Mandatory constructor parameters are app_id, app_name, app_version, device_name.
When track_id and app_token are also provided, they will be used to authenticate.
Otherwise, new track_id and app_token will be given by the freebox. These can be then used for later access.
base_url defaults to http://mafreebox.free.fr which is the base uri when accessing the freebox from the LAN side.

Note that adding the I<settings> or I<parental> permissions is only possible through the web interface (Paramètres de la Freebox -> Gestion des accès -> Applications)

The constructor takes care of detecting the API version and authentication.


The return value of all api methods is the L<result|http://dev.freebox.fr/sdk/os/#APIResponse.result> structure of APIResponse, or undef if no result is returned.

The full json response of the last request is available through the uar method (usefull when using the I<new> method) and the complete HTTP::Response is available through the uarh method.

Api methods will I<die> if the APIResponse is an error. It is up to the caller to handle this exception.

=head1 QUICK START

The list of currently available services implemented in this module is given in L<WWW::FBX::Role::API::APIv3>.

A script called fbx_test.pl is provided in script to show how to send commands and handle exceptions.

It can also be used standalone to get tokens and send a command.

On first call, you will be requested to physically authenticate on the freebox itself. Once done, the token is stored in the current directory in a file called app_token. You can then grant all permissions on the freebox web interface to allow all commands.

When suffix parameter is required, pass it as a normal parameter.

When more parameters are required, it is possible to send a json structure, see EXAMPLES. You need to escape the accolades though.

=head1 EXAMPLES

 fbx-test.pl --help
 fbx-test.pl connection
 fbx-test.pl system
 fbx-test.pl call_log
 fbx-test.pl call_log 2053
 fbx-test.pl reboot
 fbx-test.pl reset_freeplug F4:CA:42:22:53:EF/reset
 fbx-test.pl cp '{"files":["Disque dur/ds.txt"], "dst":"Disque dur/Temp", "mode":"both"}'

=head1 LICENSE

Copyright (C) Laurent Kislaire.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 AUTHOR

Laurent Kislaire E<lt>[e-mail]<gt>

=cut