#!/usr/bin/perl -w
use warnings;
use strict;
use utf8;
use WWW::Mechanize;
use MIME::Base64;
use HTML::TreeBuilder;
use Time::Local;
use Encode qw(decode encode from_to);
use File::Path;
use Unicode::Semantics;

#Simple date-time formatting function
sub fmtime {#1st arg switches time output, 2nd defines date-time
    my $time_to_format;
    if ($_[1]){
	$time_to_format = $_[1];
    }
    else {
	$time_to_format = time;
    };
    my @datestamp = (localtime($time_to_format))[3..5];
    $datestamp[1] += 1;
    $datestamp[2] += 1900;
    my $date_str = join '.', reverse (@datestamp);
    my $time_str;
    if ($_[0]) {
	my @timestamp = (localtime($time_to_format))[0..2];
	$time_str = " $timestamp[2]h $timestamp[1]m $timestamp[0]s";
    }
    else {
	$time_str = "";
    };
    return $date_str.$time_str;
}


#Required data
print ":initializing data...\n";
my $protocol = 'http://';
my $site = 'techsupp.1c.ru';
my $username = '07502-92';
my $password = 'fynbrhbpbc';
#Base downloads directory
my $basedir = '/home/hijarian/list-updates/'; #WITH trailing slash, motherfuckers!
if (mkpath($basedir) > 0){
    print ":created path to base directory: $basedir\n";
};

my $tempfile = $basedir.fmtime(1, time).'.html';
my $is_verbose = 1;
my $msg_end_of_record = "::end of record\n\n";
#-----------------
#FUCKING SHIT
#my $excluded = "1[CС].[Сс]овмест?но"; #can't use this regexp: charclasses contains multibyte symbols, FUCK!
#-----------------
#Defaults and exclusions
my $default_typename = 'other';
my $default_name = 'unnamed';
my $default_name_counter = 1;
my $excluded = "1С-Совместно";
my $invalid_chars = "[:\\\/?*\"]"; #regexp for characters, not allowed in filenames
#Date of last check
my $last_check_date = timelocal(0, 0, 0, 31, 7, 2009); #Month = [0..11] (!!!)
print ":data init OK, will now check for records marked later than ".localtime($last_check_date)."\n";


print ":creating bot...\n";
#New bot
my $bot = WWW::Mechanize->new();

#Loading auth info
$bot->credentials($username, $password);

#Getting page
print ":requesting html content via $protocol from $site as $username...\n"; 
$bot->get($protocol.$site);
my $result = $bot->response();
#What was return code?
print ':reply from server: '.$result->code().' '.$result->message()."\n";

#Report about received HTTP headers if something's not right
if ($result->code() != 200){
    print ":received code differs from 200 OK, dumping headers then halt\n";
    print "--begin headers dump--\n";
    $bot->dump_headers();
    print "--end headers dump--\n";
    die;
}


#Stop if bot not reports success, for certainity :)
if (not $bot->success()){
    print ":strange, bot reports it's status as unsuccesful, aborting now\n";
    die $!
}

#Save page if all right
my $html = $bot->content();
#суки твари кормят utf-8 документами, а кодировку объявляют cp1251!!
print ":content received, saving to temp file ($tempfile)...\n";
$html =~ s/(charset=)windows-1251/$1utf-8/isg;
open FH, ">:encoding(UTF-8)", $tempfile or die $!;
print FH encode('UTF-8', $html);
close FH;
print ":succesfully saved to $tempfile\n";

my $doctree = HTML::TreeBuilder->new();
$doctree->parse_content($html);

=begin comment
#that's for local debugging
my $doctree = HTML::TreeBuilder->new();
open(my $tfh, '<:utf8', $tempfile) or die $!;
$doctree->parse_file($tfh);
=end comment
=cut

#Now we have a reply page
#Starting parse
print ":loading parse tree...\n";

print ":retrieving records list\n";
my $updtree = $doctree->look_down('_tag', 'table', 'class', 'content');
my @records = $updtree->look_down('_tag', 'tr');
my @parsed_records; #container for final data;
print ":record list retrieved, extracting useful data\n";
RECPARSE:
 foreach my $record (@records){
     print "::begin record\n" if $is_verbose;
#     print $record->as_HTML()."\n"; #debug
#Extracting row cells...
     my @cells = $record->look_down(
	 '_tag', 'td',
	 sub {
	     my @containers_count = $_[0]->look_up('_tag', 'td');
	     return (@containers_count > 1)?0:1; #don't bother with contained cells
	 }
	 );
#Skip if no cells in current row
     if (@cells == 0) {
	 print "!:no valid cells in record\n" if $is_verbose;
	 print $msg_end_of_record if $is_verbose;
	 next RECPARSE;
     };
#I know that there's exactly 4 columns
#Got date:
     print ":::parsing date\n" if $is_verbose;
     my $date_cell = $cells[0];
#Parsing date...
     my $date_str = $date_cell->as_text;
#Skip if incorrect data in "date" field
     my $is_correct = $date_str =~ /(\d\d)\.(\d\d)\.(\d\d\d\d)/;
     if (not $is_correct){
	 print "!:strange date found:".$date_str."... don't know what to do with record \n" if $is_verbose;
	 print $msg_end_of_record if $is_verbose;
	 next RECPARSE;
     }
     my $date = timelocal(0, 0, 0, $1, $2 - 1, $3);
#Skip if old date found
     if ($date < $last_check_date) {
	 print "!:old record: date ".localtime($date)." is older than date of last check: ".localtime($last_check_date)."\n" if $is_verbose;
	 print $msg_end_of_record if $is_verbose;
	 next RECPARSE;
     };
     print ":::extracted date: ".localtime($date)."\n" if $is_verbose;
#Parsing names...
     print ":::parsing name\n" if $is_verbose;
     my $type_name = $cells[1]->look_down('_tag', 'b');
     if ($type_name) {
	 $type_name = $type_name->as_text();
	 print ":::found type name: $type_name\n" if $is_verbose;
     }
     else {
	 $type_name = $default_typename;
	 print ":!:cannot find type name, defaulted to $type_name\n";
     };
     if ($type_name =~ /$excluded/){
	 print "!:update type $type_name - skipped by exclusion list\n" if $is_verbose;
	 print $msg_end_of_record if $is_verbose;
	 next RECPARSE;
     };
     my $name = $cells[1]->look_down('_tag', 'span', 'class', 'new');
     if ($name){
	 $name = $name->as_text();
	 print ":::found configuration name: $name\n" if $is_verbose;
     }
     else {
	 $name = $default_name.'-'.$default_name_counter;
	 $default_name_counter += 1;
	 print ":!:cannot find update name, defaulted to $name\nn";
     };
     print ":::extracted type name: $type_name\n" if $is_verbose;
     print ":::extracted name: $name\n" if $is_verbose;
#Parsing version (simplest from all)...
     print ":::parsing version\n" if $is_verbose;
     my $version = $cells[2]->as_text;
     print ":::extracted version: $version\n" if $is_verbose;
#Parsing linklists...
     print ":::parsing links\n" if $is_verbose;
     my @link_obj_list = $cells[3]->look_down(
	'_tag', 'a',
	sub {
	    return unless $_[0]->attr('href');
	    print "\t".$_[0]->attr('href'), ": " if $is_verbose;
	    my $is_valid_link = $_[0]->attr('href') =~ /\.(rar|txt|html?|exe|rtf)$/i;
	    print $is_valid_link?"valid":"invalid", " by filetype\n" if $is_verbose;
	    return $is_valid_link;
	}
	);
     if (@link_obj_list == 0) {
	 print "!:empty linklist - skipped...\n" if $is_verbose;
	 print $msg_end_of_record if $is_verbose;
	 next RECPARSE;
     };
#Formatting linklist to absolute-URI form
    my @linklist;
    foreach (@link_obj_list){
	my $temp = $_->attr("href");
	if ($temp !~ /$protocol$site/){ #if not yet absolute path
	    push @linklist, 'http://'.$site.$temp;
	}
	else{#if already absolute path
	    push @linklist, $temp;
	}
    };
     if ($is_verbose){
	 print ":::extracted linklist:\n";
	 foreach (@linklist){
	     print "\t".$_."\n";
	 };
     };
#Storing parsed record in working array
     push @parsed_records, [$date, $type_name, $name, $version, \@linklist];#array of references!
     print "::succesfully parsed\n\n" if $is_verbose;
};

#If working array is empty, abort
if (@parsed_records == 0){
    print ":no meaningful data today, will now halt. Goodbye.\n";
    die;
}

=begin comment
So, each item in @parsed_records is list of next entities: 
[0] : date of update;
[1] : update type;
[2] : configuration name;
[3] : update version;
[4] : list of links, each link - absolute URI in simple string;
=end comment
=cut

#Report job status
print ":so, current job is:\n";
foreach (@parsed_records){
    print localtime($_->[0])."/\n\t".$_->[1]."/\n\t".$_->[2]."/\n".$_->[3]."/\n";
    my $links = $_->[4];
    foreach (@{$links}){
	print "\t $_\n";
    }
    print "\n";
}
print ":executing job queue...\n";
foreach my $item (@parsed_records){
    print "::begin processing job item\n" if $is_verbose;
    my $type_str = $item->[1];
    $type_str =~ s/$invalid_chars/ /g; #clearing characters that are not allowed in filenames
    $type_str =~ s/  +/ /g; #collapsing spaces
    $type_str =~ s:^\s*(\S.*\S)\s*$:$1:;
    my $name_str = $item->[2];
    $name_str =~ s/$invalid_chars/ /g; #clearing characters that are not allowed in filenames
    $name_str =~ s/  +/ /g; #collapsing spaces
    $name_str =~ s:^\s*(\S.*\S)\s*$:$1:;
    my $date_str = fmtime(0, $item->[0]);
    my $dirname = encode('UTF-8', $basedir.$date_str.'/'.$type_str.'/'.$name_str.'/'.$item->[3].'/');
    print "::saving path: $dirname\n" if $is_verbose;
    my @created_dirs = mkpath($dirname);
    if ($is_verbose){
	if (@created_dirs == 0){#normally for new update at least 1 subdirectory should be created
	    print "::seems that exact subtree for current package exists, maybe some problem?\n";
	};
	foreach (@created_dirs){
	    print "::created dir: $_\n";
	};
    };
    foreach my $link (@{$item->[4]}){
	print ":::trying to get $link...\n";
        $bot->get($link);
	if ($bot->success()){
	    print ":::succesful: will now put in $dirname\n";
	    $link =~ s/.*\/(.*\..*)$/$1/;
	    my $savepath = decode('UTF-8', $dirname).$link;
#i hope that binary saving will be error-free...
	    $bot->save_content($savepath);
#TODO: show download status
	    print "::update downloaded: $link in $dirname\n";
	}
	else{
	    print ":::couldn't download from $link\n";
	}
    };
=begin comment
=end comment
=cut
};

=begin comment
    print $record->as_text, "\n";
	$
}
=end comment
=cut

exit(0);
