This script generates a report containing various statistics about the Technicolor AG plus VDNT-S Router VDSL2 (also known as the "Telecom Italia VDSL/Fibra modem"). This is achieved by logging in to the router, requesting the various statistics page and summarising everything in a JSON file. The file is saved inside the REPORT_DIR, with the for…

router-report.pl

#!/usr/bin/env perl
use autodie;
use strict;
use warnings;
use Digest::MD5 "md5_hex";
use File::Path ();
use File::Spec;
use Fcntl qw(:DEFAULT :flock);
use HTTP::Cookies;
use JSON::MaybeXS;
use LWP::UserAgent;
use POSIX ();

use subs qw[get_vars url];
use constant ETHERNET_FIELDS => qw[interface status sent_ok recv_ok sent_err recv_err];
use constant {
    REPORT_DIR      => $ENV{REPORT_FOLDER} || "reports",
    ROUTER_ADDR     => $ENV{ROUTER_ADDR} || "10.0.0.1",
    ETHERNET_NUM    => 4, # Number of Ethernet interfaces
    WANSTAT_DUMP    => { # Fields of the WAN statistics to dump
        "Versione Software" => "firmware",
        "Indirizzo IP Pubblico connessione da modem" => "ip"
    }
};

my $pwd = $ARGV[0] || $ENV{ROUTER_PASSWD} || die "The password is required.\n";

my $jar = HTTP::Cookies->new (hide_cookie2 => 1);
my $lwp = LWP::UserAgent->new (cookie_jar => $jar);

#$lwp->add_handler("request_send",  sub { shift->dump; return });
#$lwp->add_handler("response_done", sub { shift->dump; return });

# Get the root of the webserver, follow the redirect.
my $req = $lwp->get (url "/");
die "Can't request the root of the router: $req->status_line\n" unless $req->is_success;

# Retrieve the 'xAuth_SESSION_ID' cookie, used to satisfy the CSRF check later
my $sid;
$jar->scan (sub {
    my (undef, $name, $val) = @_;
    $sid = $val if $name eq "xAuth_SESSION_ID";
});
die "session cookie not found\n" unless defined $sid;

# Look for interesting stuff
my ($realm, $nonce, $qop) = get_vars qw[realm nonce qop];

# Generate the fake HTTP digest string
$pwd = md5_hex (sprintf
    "%s:%s:%s:%s:%s:%s",
    md5_hex ("admin:$realm:$pwd"),
    $nonce,
    "00000001",
    "xyz",
    $qop,
    md5_hex ("GET:/index_auth.lp")
);

# Make the authentication request.
$req = $lwp->post (url ("/index_auth.lp"), {
    rn => $sid,
    hidepw => $pwd
});
# Small explanation: when the password is incorrect the HTML of the returned page has the login
# form (loginMask) hidden and the password incorrect box (passwordko) box shown. This is easily
# detectable with a regular expression.
die "Authentication failed (incorrect password)\n"
    if $req->content =~ /passwordko" style="display:"/;

# When the authentication is successful, a 302 is returned leading to /.
die "Authentication failed for unknown reasons: $req->code ", $req->header ("Location"), "\n"
    if $req->code != 302 || $req->header ("Location") ne url "/";

# Yay, we did it! Retrieve the statistics, with some advanced regex wizardry.
$req = $lwp->get (url "/statisticsAG.lp");
die "Can't retrieve the router statistics: $req->status_line" unless $req->is_success;
my $raw_stats = $req->content;

# The layout of the main statistics is like this:
# <td class="sectionArea-1 ...">Stat name:</td><td class="sectionArea-2 ...">Stat value</td>
# The following regexp just parses that, and performs a pretty cool hack. The /g modifier, in
# list context, returns a list containing every matched group. To make it clear:
# Input:  abcXXXabcXXXabc
# Regexp: /(ab)(c)/g
# Result: ( 'ab', 'c', 'ab', 'c', 'ab', 'c' )
# Now, in Perl an hash may be considered as an unordered array with an even number of elements.
# %hash = ( animal => 'cow', fish => 'carp' )
# -> @array = ( 'animal', 'cow', 'fish', 'carp' )
# So, what happens if we assign the returned array from the regexp to an hash?
# We obtain the hash we were looking for: %ret = ( 'stat name' => 'stat val', ... )
my %stats = $raw_stats =~ /sectionArea\-1.+?>(.+?):?<.+?sectionArea\-2.+?>(.+?)</g;
my $ethernet_data = [];
my ($index, $counter) = (0, 0);

# Populate $ethernet_data. This uses a pretty simple algorithm.
# The data for each ethernet port is specified like this in the source:
# <td ... class="...alignMid...">Ethernet 1</td>
# <td...>bla bla bla</td>
# ...
# Processing all this data is as simple as using a single global-matching regexp.
while ($raw_stats =~ /alignMid rowvertical">([^<]+)</g)
{
    # Be sure that the main hash is defined first.
    $ethernet_data->[$index] ||= {};
    my $ref = $ethernet_data->[$index];
    # Set the key ETHERNET_FIELDS[$counter] of the hash to the matched value.
    $ref->{(ETHERNET_FIELDS)[$counter]} = $1;
    # Reset the counter and increase the main index if $counter exceeds the number of elements
    # in ETHERNET_FIELDS.
    if (++$counter >= scalar (ETHERNET_FIELDS))
    {
        $counter = 0;
        ++$index;
    }
    # Stop once we processed all the Ethernet ports.
    last if $index >= ETHERNET_NUM;
}

# Parse the WAN status, to retrieve the IP address and firmware version.
$req = $lwp->get (url "/wanStatus.lp");
die "Can't retrieve the WAN status: $req->status_line" unless $req->is_success;

# Use a system similar to the one used before to scrape the statistics.
# This uses a smaller but less accurate regexp. Also, this regexp supports colored rows.
my @ws_tmp = $req->content =~ /"(?:sectionArea\-[12]|td.).+?>(.+?):?</g;

# Make sure that the list is even. (there could be an empty "Other DNS servers" which annoys us)
pop @ws_tmp if @ws_tmp % 2 != 0;
my %wan_status = @ws_tmp;

# Retrieve the fields we are interested in.
my %subset = map { WANSTAT_DUMP->{$_} => $wan_status{$_} } keys %{+WANSTAT_DUMP};

# Prepare the report stuff.
# The resulting file will be YYYY-MM/DD.json.
my $encoder = JSON::MaybeXS->new;
# Cache the localtime before doing blocking operations.
# NOTE: I'm using strftime for two reasons: it's handy, and it automatically adds zeroes when
# necessary. I like it.
my @time = localtime;
my $path = File::Spec->catfile (REPORT_DIR, POSIX::strftime ("%Y-%m", @time));
File::Path::make_path ($path);
$path = File::Spec->catfile ($path, POSIX::strftime ("%d.json", @time));
my $flag = -e $path;

sysopen my $report_fh, $path, O_RDWR | O_CREAT;
flock $report_fh, LOCK_EX;
my $json = {};
$json = $encoder->decode (do { local $/ = undef; <$report_fh> }) if $flag; # ... slurp
die "incorrect JSON file structure\n" if ref $json ne "HASH";

$json->{POSIX::strftime ("%H:%M", @time)} = {
    statistics => \%stats,
    interfaces => $ethernet_data,
    %subset
};

seek $report_fh, 0, 0; # Rewind
print $report_fh $encoder->encode ($json), $/;
truncate $report_fh, tell ($report_fh);
close $report_fh;

print "Report saved @ $path\n";

sub get_vars (@)
{
    my @ret;
    foreach (@_)
    {
        $req->content =~ qr/$_ = "([^"]+)"/ or die "match for $_ failed\n";
        push @ret, $1;
    }
    @ret
}

sub url ($)
{
    sprintf "http://%s%s", ROUTER_ADDR, shift
}

I'm keen to get this working on my Technicolor TG789. Are you able to help get it working with me?