#!/usr/bin/perl
# Copyright Carlos Francisco Ferry Sauterel - carlos@gnu.cl
# Baalux0.1: March 29, 2007
# Baalux0.2: May 27, 2007
BEGIN {
use strict;
use warnings;
use Cwd;
use DBI;
use Net::DNS;
use Data::Dumper;
use LWP::UserAgent;
use Lingua::Identify qw/langof/;
use CGI qw(:standard);
use HTML::TokeParser;
use HTML::SimpleLinkExtor;
use HTML::LinkExtor;
use Term::ANSIColor qw(:constants);
use open ':utf8';
use Acme::Comment type => 'C++', one_line => 1, own_line => 0;
my $curdir = getcwd;
my $ifor = 10;
my $nprintmode = 'term';
my $timeout=65;
my $identifier = "NS";
my $dfolder=$curdir . '/getemp/';
my $lfolder=$curdir . '/logs/';
my $datafolder=$curdir . '/data/';
my $server = `uname -n`;;
my $range = 5000;
my $dsn = 'DBI:mysql:wildserv:localhost';
my $dusn = 'wildserv';
my $dpass = 'XXXXXXXXX';
/*
my $dsn = 'DBI:mysql:carlosf_wildserv:www.elite-team.cl';
my $dusn = 'carlosf_wildserv';
my $dpass = 'XXXXXXXX';
*/
my $dbh = DBI->connect($dsn, $dusn, $dpass);
no warnings "recursion";
$Term::ANSIColor::AUTORESET = 1;
$SIG{'INT'} = 'CLEANUP';
$SIG{'HUP'} = 'CLEANUP';
if (defined($ARGV[0]) && $ARGV[0] eq "stop")
{
CLEANUP();
}
/* I make a general check */
start_check();
/* I check if mySQL works || not */
if (!$dbh)
{
die "Error:" . $dbh->errstr . "\n";
}
else
{
nprint("S","Connection to mySQL established.");
}
sub start_check {
my $lfolder_status;
nprint("N","Starting.");
/* We check directories, incorrenctly named as folder in vars */
if (!chdir($lfolder)) {
$lfolder_status = "N";
mkdir($lfolder);
} else {
nprint("N","'$lfolder' exists");
chdir($curdir);
}
nprint("N","Checking software ...");
nprint("N","Checking directories ...");
if (defined($lfolder_status)) {
if ($lfolder_status eq "N"){
nprint("E","'$lfolder' didn't exist!");
nprint("N","'$lfolder' created");
}
}
if (!chdir($dfolder)) {
nprint("E","'$dfolder' doesn't exist!");
nprint("N","Creating '$dfolder'..");
mkdir($dfolder);
} else {
nprint("N","'$dfolder' exists");
chdir($curdir);
}
if (!chdir($datafolder)) {
nprint("E","'$datafolder' doesn't exist!");
nprint("N","Creating '$datafolder'..");
mkdir($datafolder);
} else {
nprint("N","'$datafolder' exists");
chdir($curdir);
}
}
/* Colors in nprint: E = ERROR - S = SUCCESSFUL OPERATION - N = NORMAL OPERATION */
sub nprint {
my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);
my $time = sprintf("%0.2d:%0.2d:%0.2d",$hour,$min,$sec);
my $date = sprintf("%0.4d/%0.2d/%0.2d",$year+1900,++$mon,$mday);
my $ldate = sprintf("%0.4d-%0.2d-%0.2d",$year+1900,++$mon,$mday);
my $timestamp = "$time - $date";
my ($flag, $lfile, $npm);
$lfile = $lfolder . $ldate . "-logs.txt";
open PFILE, ">>$lfile" or die nprint("E","Unable to open $lfile $!");
if ($_[0] eq "E") {
$flag = RED;
}
elsif ($_[0] eq "S") {
$flag = GREEN;
}
elsif ($_[0] eq "N") {
$flag = YELLOW;
}
elsif ($_[0] eq "F") {
$flag = CYAN;
}
print PFILE $flag . '[' . $identifier . '][' . $timestamp . ']-> ' . $_[1] . "\n", RESET;
close PFILE;
}
sub get_words {
my @words;
my $downl_file = $_[0];
my @text = $_[2];
my $url = $_[1];
my $c;
my $line_n;
my $word;
my $sth;
my $V;
my $outfile;
#open( FILEX, "< $filename" ) or die "Can't open $filename : $!";
my $i;
#my @webtitle = get_title($downl_file);
my @webdesc = get_description($downl_file);
my @furl = map {split '\.|\/'} $url;
#my @wholetext = dump_html($_[0]);
for ($i=0;$i < 50;$i++){
push @text, get_description($downl_file);
}
for ($i=0;$i < 5;$i++){
push @text, @webdesc;
}
for ($i=0;$i < 50;$i++){
push @text, @furl;
}
push @text, $url;
push @text, dump_html($_[0]);
#print "@text\n";
#chomp(@texty);
foreach my $l (@text)
{
if (defined($l))
{
/* Aca irian todos los saltadores */
next if $l =~ /^(\s)*$/;
if ($l =~ /[A-Z]/)
{
$l = lc($l);
}
# my $llength = length($l);
# next if $llength eq 2;
push @words, $l;
}
#undef @wholetext;
my @sfinal_words = map {split ' '} @words;
#undef @words;
my @final_words = map {split '-|_|,'} @sfinal_words;
#undef @sfinal_words;
$outfile = $downl_file . '.words.html';
open OUT, "> $outfile" or die nprint("E","Couldn't open $outfile :$!");
foreach $V (@final_words) {
$c++;
print OUT $V . "\n";
}
foreach $V (@final_words) {
$line_n++;
foreach my $tain (@final_words) {
if ($V eq $tain) {
$word++;
}
}
my $tf = ($word*100)/$c;
my $f = ($tf * $tf);
$sth = $dbh->prepare(qq{ select id FROM `words` where word = ? and url = ? });
$sth->execute("$V","$url");
my $idu_number = $sth->fetchrow_array();
if (!defined($idu_number)) {
$sth = $dbh->prepare(qq{ insert into `words` (url, word, density, repeated, last_date) values (?, ?, ?, ?, CURDATE()) });
$sth->execute("$url","$V","$f","$word");
} else {
/* ya taba! */
}
undef $f;
undef $word;
undef $tf;
undef $idu_number;
}
close OUT;
unlink($outfile);
}
nprint("N","$line_n words were found.");
}
#close FILEX;
sub get_ahref {
my $sth;
my $url_from = $_[1];
my ($c, $nc, $t);
my $extor = HTML::SimpleLinkExtor->new($url_from);
$extor->parse_file(shift);
my @a_hrefs = $extor->a;
$sth = $dbh->prepare(qq{ delete from `linkers` where url_from = ? });
$sth->execute("$url_from");
foreach $a (@a_hrefs) {
if ($a =~ /[A-Z]/) {
$a = lc($a);
}
/* solucion temporal (mostly javascript) */
next if $a =~ /^mailto:/;
next if $a =~ /^javascript:/;
next if $a =~ /#/;
next if $a =~ s/^(.*)\.mp3$//;
/* eliminamos soporte a los pdf */
next if $a =~ s/^(.*)\.pdf$//;
$sth = $dbh->prepare(qq{ select id from `linkers` where url_to = ? and url_from = ? });
$sth->execute("$a","$url_from");
my $link_id = $sth->fetchrow_array();
if (!defined($link_id) && "$a" ne "$url_from")
{
$sth = $dbh->prepare(qq{ insert into `linkers` (url_to, url_from) values (?, ?) });
$sth->execute("$a","$url_from");
}
$sth = $dbh->prepare(qq{ select id from `update` where url = ? });
$sth->execute("$a");
my $update_id = $sth->fetchrow_array();
if (!defined($update_id)) {
$sth = $dbh->prepare(qq{ insert into `update` (url, next_date) values (?, 0000-00-00) });
$sth->execute("$a");
}
undef $link_id;
undef $update_id;
}
}
sub clean_protocol {
my $url = $_[0];
$url =~ s/^(.*):\/\///m;
$url =~ s/\/(.*)$//m;
return $url;
}
sub get_description {
my $content;
my $p = HTML::TokeParser->new($_[0]);
while ( my $tag = $p->get_tag("meta") ) {
if ( defined( $tag->[1]{'name'} )) {
if($tag->[1]{'name'} eq "description") {
$content = $tag->[1]{'content'}
}
};
}
/* I'm going to try to get description by h1 ;-) */
if (!defined($content)) {
$p = HTML::TokeParser->new($_[0]);
if ($p->get_tag("h1")) {
$content = $p->get_trimmed_text;
}
}
return $content;
}
sub get_dns {
my $basedomain = $_[0];
if ($basedomain =~ /\/$/) {
$basedomain =~ s/\/$//g;
}
#print "$basedomain !\n";
my $res = Net::DNS::Resolver->new;
my $query = $res->search($basedomain);
my $dns;
my $status;
if ($query) {
foreach my $rr ($query->answer) {
next unless $rr->type eq "A";
$dns = $rr->address;
$status = "Y";
nprint("S","DNS: $basedomain -> " . $rr->address);
}
} else {
nprint ("E","DNS query failed: $res->errorstring");
$status = "N";
}
return ($status,$dns);
}
sub get_erank {
my $co;
my $erank;
my $sth;
$sth = $dbh->prepare(qq{ select url_from from `linkers` where url_to = ? });
$sth->execute("$_[0]");
while (defined(my $url_from = $sth->fetchrow_array())) {
$co++;
}
if (!defined($co)) {
$erank = 0.0000000003;
} else {
$erank = $co * 0.000000004;
}
if ($erank > 10) {
$erank=10;
}
return $erank;
}
sub get_title {
my $title;
my $p = HTML::TokeParser->new($_[0]);
if ($p->get_tag("title")) {
$title = $p->get_trimmed_text;
if (defined($title)) {
return $title;
}
}
}
sub wget {
my ($status, $rnumber, $wget_outfile, $response);
my $read_size = ":read_size_hint";
$rnumber = rand($range);
$wget_outfile = $dfolder . $rnumber . '.html';
my $ua = LWP::UserAgent->new;
$ua->agent('Mozilla/5.0');
$ua->protocols_allowed( [ 'http', 'ftp', 'https'] );
$ua->from('carlos@gnu.cl');
$ua->timeout($timeout);
$ua->env_proxy;
nprint("N","Ready to download $_[0] ");
$response = $ua->get($_[0]);
if ($response->is_success) {
open OUT, "> $wget_outfile" or exit nprint("E","Can't open $wget_outfile : $!");
nprint("S",$response->status_line);
print OUT $response->content;
close OUT;
$status = "S";
my $filesize = -s $wget_outfile;
return ($status,$wget_outfile,$filesize);
}
else {
nprint("E","Something wrong happened while processing $_[0]");
nprint("E",$response->status_line);
$status = "N";
return $status;
}
}
sub get_lang {
my @lang;
my $langfilename = $_[0];
open( FILEL, "< $langfilename" ) or nprint ("E","Can't open $langfilename : $!");
foreach my $line (<FILEL>) {
push @lang, $line;
}
close FILEL;
my $text = join "\n", @lang;
my $language = langof($text);
return $language;
}
sub dump_html {
my @dumped = ` lynx -dump -nolist -nonumbers -dont_wrap_pre $_[0]`;
return @dumped;
}
sub fetch {
my $cleaned_url = clean_protocol($_[0]);
my $sth;
/* A function which recognizes how often does a webpage changes should be here, read carlos castillo tesis. */
$sth = $dbh->prepare(qq{ update `update` SET `ip` = 'Y', `sv` = '$server' where url = ? });
$sth->execute($_[0]);
my ($dns_status, $dns) = get_dns($cleaned_url);
if ($dns_status eq "N") {
nprint("E","Couldn't reverse $_[0], trying next page");
/* It didn't resolve, I'll try again in 2 days. */
$sth = $dbh->prepare(qq{ update `update` SET next_date = DATE_ADD(CURDATE(), INTERVAL +2 DAY) where url = ? });
$sth->execute($_[0]);
}
else
{
my ($line, @fline, @url_links, $p);
my ($downl_status, $downl_file, $filesize) = wget($_[0]);
#VALUE RETURNED SHOULD INDICATE: N = NOT SUCCESSFUL OPERATION, S = SUCCESSFUL OPERATION.
if ($downl_status eq "N")
{
&nprint("E","Error!, trying to fetch it in 72 days");
$sth = $dbh->prepare(qq{ update `update` SET next_date = DATE_ADD(CURDATE(), INTERVAL +72 DAY) where url = ? });
$sth->execute($_[0]);
}
else
{
nprint("S","$_[0] downloaded successfully: " . $filesize * 0.000976562499 . " KB");
my $webtitle = get_title($downl_file);
my $webdesc = get_description($downl_file);
/* aca deberia ir una opcion porq si es .pdf lo mande a dump_pdf, quizas sera necesario q todas las funciones (dump_html, get_lang, get_erank)
sean una variable dependiendo si es .pdf o .html ($dump, $lang), etc*/
my @dumped = dump_html($downl_file);
my $lang = get_lang($downl_file);
my $erank = get_erank($_[0]);
get_ahref($downl_file,$_[0]);
get_words($downl_file,$_[0],@dumped);
$sth = $dbh->prepare(qq{ select id from `indexed` where url = ? });
$sth->execute("$_[0]");
my $url_id = $sth->fetchrow_array();
if (!defined($url_id)) {
$sth = $dbh->prepare(qq{ insert into `indexed` (url, webtext, webdesc, language, title, rank) values (?, ?, ?, ?, ?, ?) });
$sth->execute("$_[0]", "@dumped", "$webdesc", "$lang", "$webtitle","$erank");
nprint("S","New url $_[0] Added to the DB.");
} else {
$sth = $dbh->prepare(qq{ update `indexed` set webtext = ?, webdesc = ?, language = ?, title = ?, rank = ? where url = ? });
$sth->execute("@dumped","$webdesc","$lang","$webtitle","$erank","$_[0]");
nprint("S","url $_[0] Updated in the DB.");
}
unlink($downl_file);
#ACA DEBERIA IR EL UPLOADER
# Here should be a nice math function whichr recognizes where to make the next update. (consultar tesis de castillo)
$sth = $dbh->prepare(qq{ update `update` SET next_date = DATE_ADD(CURDATE(), INTERVAL +17 DAY) where url = ? });
$sth->execute($_[0]);
# We set the update to inprogress N.
#delete($downl_file);
nprint("F","$_[0] -> All done");
}
}
$sth = $dbh->prepare(qq{ update `update` SET `ip` = 'N', `sv` = 'N' where url = ? and `sv` = '$server' });
$sth->execute($_[0]);
}
sub CLEANUP {
my $sth;
nprint ("N","Caught Interrupt, Aborting.");
$sth = $dbh->prepare(qq{ update `update` SET `ip` = 'N', `sv` = 'N' where `sv` = '$server' });
$sth->execute();
$sth->finish();
print "Successfully stoped.\n";
exit(1);
}
sub autonomous_fetch {
#fork and exit;
my $sth;
my $readytofetch;
my $instances=10;
my @urls_to_fetch;
my $wbfc;
my $seconds=10;
/* ip = inprogress */
$sth = $dbh->prepare(qq{ select distinct url from `update` where url like '%.cl%' and next_date <= CURDATE() and `ip` = 'N' order by rand() limit $instances });
$sth->execute();
while (defined(my $willbefetched = $sth->fetchrow_array())) {
fetch($willbefetched);
}
$sth->finish();
}
sub run_nucleous {
autonomous_fetch();
/* Recursive */
#autonomous_fetch();
run_nucleous();
}
my $i;
#fork and die;
for ($i=0;$i < 4;$i++) {
#fork;
run_nucleous();
}
/* BEGIN {'s end */
}