File Coverage

blib/lib/WebService/FritzBox.pm

Criterion	Covered	Total	%
statement	25	75	33.3
branch	0	18	0.0
condition			n/a
subroutine	9	18	50.0
pod	3	3	100.0
total	37	114	32.4

package WebService::FritzBox;
# ABSTRACT: Interface to FritzBox devices
use Digest::MD5 qw/md5_hex/;
use JSON::MaybeXS;
use LWP::UserAgent;
use Log::Log4perl;
use Moose;
use MooseX::Params::Validate;
use Try::Tiny;
use YAML;
BEGIN { Log::Log4perl->easy_init() };
our $VERSION = 0.008;

with "MooseX::Log::Log4perl";

=head1 NAME

WebService::FritzBox

=head1 DESCRIPTION

Interact with FritzBox devices

=head1 ATTRIBUTES

=cut

with "MooseX::Log::Log4perl";

=over 4

=item password

Required.

=cut
has 'password' => (
    is          => 'ro',
    isa         => 'Str',
    required    => 1,
    );

=item host

Optional.  Default: fritz.box

=cut
has 'host' => (
    is		=> 'ro',
    isa		=> 'Str',
    required	=> 1,
    default     => 'fritz.box',
    );

=item use_https

Optional.  Default: 0

=cut

has 'use_https' => (
    is		=> 'ro',
    isa		=> 'Bool',
    );

=item user_agent

Optional.  A new LWP::UserAgent will be created for you if you don't already have one you'd like to reuse.

=cut

has 'user_agent' => (
    is		=> 'ro',
    isa		=> 'LWP::UserAgent',
    required	=> 1,
    lazy	=> 1,
    builder	=> '_build_user_agent',

    );

=item loglevel

Optional.

=cut

has 'loglevel' => (
    is		=> 'rw',
    isa		=> 'Str',
    trigger     => \&_set_loglevel,
    );

has 'base_url' => (
    is		=> 'ro',
    isa		=> 'Str',
    required	=> 1,
    lazy	=> 1,
    builder	=> '_build_base_url',
    );

has 'sid' => (
    is		=> 'ro',
    isa		=> 'Str',
    required	=> 1,
    lazy	=> 1,
    builder	=> '_build_sid',
    );

sub _build_user_agent {
    my $self = shift;
    $self->log->debug( "Building useragent" );
    my $ua = LWP::UserAgent->new(
	keep_alive	=> 1
    );
   # $ua->default_headers( $self->default_headers );
    return $ua;
}

sub _build_base_url {
    my $self = shift;
    my $base_url = 'http' . ( $self->use_https ? 's' : '' ) . '://' . $self->host;
    $self->log->debug( "Base url: $base_url" );
    return $base_url;
}

sub _build_sid {
    my $self = shift;

    my $response = $self->user_agent->get( $self->base_url . '/login_sid.lua' );
    $self->log->trace( "Login (get challenge) http response:\n" . Dump( $response ) ) if $self->log->is_trace;
    my( $challenge_str ) = ( $response->decoded_content =~ /<Challenge>(\w+)/i );
    # generate a response to the challenge
    my $ch_pw = $challenge_str . '-' . $self->password;
    $ch_pw =~ s/(.)/$1 . chr(0)/eg;
    my $md5 = lc(md5_hex($ch_pw));
    my $challenge_response = $challenge_str . '-' . $md5;
    # Get session id
    $response = $self->user_agent->get( $self->base_url . '/login_sid.lua?user=&response=' . $challenge_response );
    $self->log->trace( "Login (challenge sent) http response :\n" . Dump( $response ) ) if $self->log->is_trace;

    # Read session id from XMl
    my( $sid ) = ( $response->content =~ /<SID>(\w+)/i );
    $self->log->debug( "SID: $sid" );
    return $sid;
}

sub _set_loglevel {
    my( $self, $new, $old ) = @_;
    $self->log->level( $new );
}


=back

=head1 METHODS

=over 4

=item init

Create the user agent log in (get a sid).

=cut

sub init {
    my $self = shift;
    my $ua = $self->user_agent;
    my $sid = $self->sid;
}

=item get

Get some path from the FritzBox.  e.g.

  my $response = $fb->get( path => '/internet/inetstat_monitor.lua?useajax=1&xhr=1&action=get_graphic' );

Returns the HTTP::Response object

=cut

sub get {
    my ( $self, %params ) = validated_hash(
        \@_,
        path        => { isa    => 'Str' },
    );

    my $response = $self->user_agent->get(
        $self->base_url .
        $params{path} .
        ( $params{path} =~ m/\?/ ? '&' : '?' ) .
        'sid=' . $self->sid );
    $self->log->trace( Dump( $response ) ) if $self->log->is_trace;
    return $response;
}

=item bandwidth

A wrapper around the /inetstat_monitor endpoint which responds with a normalised hash.  The monitor web page
on the fritz.box refreshes every 5 seconds, and it seems there is a new value every 5 seconds... 5 seconds is
probably a reasonable lowest request interval for this method.

Example response:

    ---
    available:
      downstream: 11404000
      upstream: 2593000
    current:
      downstream:
        internet: 303752
        media: 0
        total: 303752
      upstream:
        default: 33832
        high: 22640
        low: 0
        realtime: 1600
        total: 58072
    max:
      downstream: 342241935
      upstream: 655811

The section C<current> represents the current (last 5 seconds) bandwith consumption.
The value C<current.downstream.total> is the sum of the C<media> and C<internet> fields
The value C<current.upstream.total> is the sum of the respective C<default>, C<high>, C<low> and C<realtime> fields
The section C<available> is the available bandwidth as reported by the DSL modem.
The section C<max> represents

=cut
sub bandwidth {
    my $self = shift;

    my $response = $self->get( path => '/internet/inetstat_monitor.lua?useajax=1&xhr=1&action=get_graphic' );
    $self->log->trace( Dump( $response ) ) if $self->log->is_trace();
    if( not $response->is_success ){
        $self->log->logdie( "Request failed: ($response->code): $response->decoded_content" );
    }
    my $data;
    try{
        $data = decode_json( $response->decoded_content );
        # It's just an array with one element...
        $data = $data->[0];
    }catch{
        $self->log->logdie( "Could not decode json: $_" );
    };

    # There is an array of values for every key, but we just want to capture the latest one
    my %latest;
    foreach( qw/prio_default_bps prio_high_bps prio_low_bps prio_realtime_bps mc_current_bps ds_current_bps/ ){
        # all the '_bps' entries are bytes per second... multiply by 8 to normalise to bits per second
        $latest{$_} = ( split( ',', $data->{$_} ) )[0] * 8;
    }
    my $document = {
        "available" => {
            "upstream"      => int( $data->{upstream} ),
            "downstream"    => int( $data->{downstream} ),
        },
        "max" => {
            "upstream"   => int( $data->{max_us} ),
            "downstream" => int( $data->{max_ds} ),
        },
        "current" => {
            "upstream" => {
                "low"       => int( $latest{prio_low_bps} ),
                "default"   => int( $latest{prio_default_bps} ),
                "high"      => int( $latest{prio_high_bps} ),
                "realtime"  => int( $latest{prio_realtime_bps} ),
                "total"     => $latest{prio_low_bps} + $latest{prio_default_bps} + $latest{prio_high_bps} + $latest{prio_realtime_bps},
            },
            "downstream" => {
                "internet"  => int( $latest{ds_current_bps} ),
                "media"     => int( $latest{mc_current_bps} ),
                "total"     => $latest{ds_current_bps} + $latest{mc_current_bps},
            },
        }
    };

    # Info if the current bandwidth is higher than what we expect to have available (this is not a problem, but
    # it is odd...)
    # Occasionally (when DSL reconnects) there can be massive spikes... maybe these should be cut out?
    if( $document->{current}{upstream}{total} > $document->{available}{upstream} ){
        $self->log->info( sprintf( "Upstream total (%u) is greater than the available bandwidth (%u)",
            $document->{current}{upstream}{total}, $document->{available}{upstream} ) );
    }
    if( $document->{current}{downstream}{total} > $document->{available}{downstream} ){
        $self->log->info( sprintf( "Downstream total (%u) is greater than the available bandwidth (%u)",
            $document->{current}{downstream}{total}, $document->{available}{downstream} ) );
    }

    return $document;
}

1;

=back

=head1 COPYRIGHT

Copyright 2015, Robin Clarke

=head1 AUTHOR

Robin Clarke <[e-mail]>