User:AnomieBOT/source/tasks/ReplaceExternalLinks5.pm

package tasks::ReplaceExternalLinks5;

=pod

=begin metadata

Bot:      AnomieBOT
Task:     ReplaceExternalLinks5
BRFA:     Wikipedia:Bots/Requests for approval/AnomieBOT 60
Status:   Approved 2011-12-04
Created:  2011-11-30
OnDemand: true

Add archiveurl for dead or dying links, when an archive can be found at
archive.org or webcitation.org, and optionally tag unarchived links with
{{tl|dead link}} or a similar template.

=end metadata

=cut

use utf8;
use strict;

use Data::Dumper;
use POSIX;
use Date::Parse;
use LWP::UserAgent;
use XML::LibXML;
use HTML::Entities ();
use URI;
use AnomieBOT::Task qw/:time/;
use vars qw/@ISA/;
@ISA=qw/AnomieBOT::Task/;

my $req='[[User:AnomieBOT/req/Gamepro links|request]]';

# Useful character sets
my $chars='[^][<>"\x00-\x20\x7F\p{Zs}]';
my $dchars='[^][<>"\x00-\x20\x7F\p{Zs}/.]';
my $portre=qr!(?::\d+)?!;

# Template for marking dead links. Set undef for no tagging.
my $deadlink=undef; #'dead link';

# euquery values to search for
my @euquery=('*.gamepro.com');

# Regular expression matching links to replace. No protocol.
my $linkre=qr!(?:$dchars+\.)*(?i:gamepro\.com)$portre\/!;

# Description of links
my $desc='Gamepro';

###########################
# Marker to indicate where {{dead links}} should be removed
my $rmdl="\x02*\x03";

# Placeholder for when 
my $nodl="\x02x\x03";

# The text part of a bracketed link
my $btext=qr/ *[^\]\x00-\x08\x0a-\x1F]*?/;

# Protocol re
my $proto1=qr!(?:https?:)?//!;
my $proto2=qr!https?://!;

sub new {
    my $class=shift;
    my $self=$class->SUPER::new();
    $self->{'iter'}=undef;
    $self->{'ua'}=LWP::UserAgent->new(
        agent=>"AnomieBOT link checker for en.wikipedia.org (https://en.wikipedia.org/wiki/Wikipedia:Bots/Requests_for_approval/AnomieBOT_60)",
        keep_alive=>300,
    );
    # Unfortunately, webcite seems to like quoting back the url without
    # encoding ampersands in certain error messages.
    $self->{'xml'}=XML::LibXML->new(recover=>1);
    $self->{'protocols'}=[];
    bless $self, $class;
    return $self;
}

=pod

=for info
Approved 2011-12-04.<br />[[Wikipedia:Bots/Requests for approval/AnomieBOT 60]]

=cut

sub approved {
    return -1;
}

sub run {
    my ($self, $api)=@_;
    my $res;

    $api->task('ReplaceExternalLinks5', 0, 10, qw/d::Redirects d::Templates d::Nowiki/);

    my $screwup='Errors? [[User:'.$api->user.'/shutoff/ReplaceExternalLinks5]]';

    # Spend a max of 5 minutes on this task before restarting
    my $endtime=time()+300;

    # Get list of citation templates
    my %templates=$api->redirects_to_resolved(
        'Template:Citation',
        'Template:Citation metadata',
        'Template:Cite api',
        'Template:Cite book',
        'Template:Cite conference',
        'Template:Cite IETF',
        'Template:Cite interview',
        'Template:Cite journal',
        'Template:Cite mailing list',
        'Template:Cite news',
        'Template:Cite press release',
        'Template:Cite video',
        'Template:Cite web',
        'Template:Unicite',
        'Template:Vancite conference',
        'Template:Vancite journal',
        'Template:Vancite news',
        'Template:Vancite web',
        'Template:Vcite conference',
        'Template:Vcite journal',
        'Template:Vcite news',
        'Template:Vcite web',
    );
    if(exists($templates{''})){
        $api->warn("Failed to get citation template redirects: ".$templates{''}{'error'}."\n");
        return 60;
    }

    # Get regex for finding {{dead link}}
    my (%dl,$dlre);
    if(defined($deadlink)){
        %dl=$api->redirects_to_resolved($deadlink);
        if(exists($dl{''})){
            $api->warn("Failed to get dead link template redirects: ".$dl{''}{'error'}."\n");
            return 60;
        }
        $dlre='{{(?i:\s*Template\s*:)?\s*(?:'.join('|',map { $_="\Q$_\E"; s/^Template\\:(.)/(?i:$1)/; s/\\ /[ _]/g; $_; } keys %dl).')(?>\s*(?s:\|.*?)?}})';
        $dlre=qr/$dlre/;
    } else {
        %dl=();
        $dlre=qr/(*F)x/;
    }

    $self->{'protocols'}=[qw/http https/] unless @{$self->{'protocols'}};
    while(@{$self->{'protocols'}}){
        if(!defined($self->{'iter'})){
            $self->{'iter'}=$api->iterator(
                list        => 'exturlusage',
                euprop      => 'title',
                euquery     => [@euquery],
                euprotocol  => shift @{$self->{'protocols'}},
                eunamespace => '0',
                eulimit     => '1000', # exturlusage has issues with big lists
            );
        }
        while(my $pg=$self->{'iter'}->next){
            if(!$pg->{'_ok_'}){
                $api->warn("Failed to retrieve page list for ".$self->{'iter'}->iterval.": ".$pg->{'error'}."\n");
                return 60;
            }

            return 0 if $api->halting;
            my $page=$pg->{'title'};
            my $tok=$api->edittoken($page, EditRedir => 1);
            if($tok->{'code'} eq 'shutoff'){
                $api->warn("Task disabled: ".$tok->{'content'}."\n");
                return 300;
            }
            if($tok->{'code'} ne 'success'){
                $api->warn("Failed to get edit token for $page: ".$tok->{'error'}."\n");
                next;
            }
            if(exists($tok->{'missing'})){
                $api->warn("WTF? $page does not exist?\n");
                next;
            }

            # Setup flags
            $self->{'flags'}={cite=>0,link=>0,404=>0,fail=>0};

            my $intxt=$tok->{'revisions'}[0]{'slots'}{'main'}{'*'};
            my $outtxt=$intxt;

            # Replace the links. First, do citation templates.
            my $nowiki;
            $outtxt=$api->process_templates($outtxt, sub {
                return undef if $self->{'flags'}{'fail'};
                my $name=shift;
                my $params=shift;
                my $wikitext=shift;
                my $data=shift;
                my $oname=shift;

                return undef unless exists($templates{"Template:$name"});

                my $ret="{{$oname";
                my $archived=0;
                my $url='';
                my ($accessdate,$date,$year,$month);
                $year=$month='XXX';
                foreach ($api->process_paramlist(@$params)){
                    $_->{'name'}=~s/^\s+|\s+$//g;
                    $_->{'value'}=~s/^\s+|\s+$//g;
                    if($_->{'name'} eq 'url'){
                        $url=$_->{'value'};
                    } elsif($_->{'name'} eq 'accessdate'){
                        $accessdate=str2time($_->{'value'});
                    } elsif($_->{'name'} eq 'date'){
                        $date=str2time($_->{'value'});
                    } elsif($_->{'name'} eq 'year' && $_->{'value'}=~/^\d+$/){
                        $year=$_->{'value'};
                    } elsif($_->{'name'} eq 'month'){
                        $month=$_->{'value'};
                    } elsif($_->{'name'} eq 'archiveurl'){
                        $archived=1;
                    }
                    $ret.='|'.$_->{'text'};
                }
                my $r404='';
                if(!$archived && $url=~m!^$proto1$linkre!){
                    my ($u,$dt);
                    $dt=$accessdate // $date // str2time("1 $month $year") // str2time("1 June $year") // time();
                    ($u,$dt,$r404)=chkExtLink($self,$api,0,$url, $dt);
                    return undef if($self->{'flags'}{'fail'});
                    $ret.="|archiveurl=$u|archivedate=$dt" unless $r404;
                    if(!$r404){
                        $ret=~s/$rmdl//g;
                        $r404=$rmdl;
                    }
                }
                $ret.="}}".$r404;
                return $ret;
            });
            return 60 if($self->{'flags'}{'fail'});

            # Next, strip for raw link processing
            # Regular expressions are adapted from those MediaWiki uses to
            # recognize external links.
            ($outtxt,$nowiki)=$api->strip_nowiki($outtxt);
            ($outtxt,$nowiki)=$api->strip_templates($outtxt, sub {
                my $name=shift;
                return exists($templates{"Template:$name"});
            }, {}, $nowiki);

            # Strip out ref tags, then replace any links with a guess at access
            # date.
            ($outtxt,$nowiki)=$api->strip_regex(qr!<ref[ >].*?</ref>!, $outtxt, $nowiki);
            my @arc=qw/[aA]rchive webcitation\.org [wW]ayback/;
            my $arc='(?:'.join('|',@arc).')';
            while(my ($k,$v)=each %$nowiki){
                next unless $v=~/^<ref/;
                next if $v=~/$arc/;
                my ($dt,$nw);

                # We have to re-strip here, because the saved values here are
                # automatically unstripped.
                ($v,$nw)=$api->strip_nowiki($v);
                ($v,$nw)=$api->strip_templates($v, sub {
                    my $name=shift;
                    return exists($templates{"Template:$name"});
                }, {}, $nw);

                $dt=str2time($1) if $v=~/(?:accessed|retrieved)(?: +on)? +(\d{4}-\d{2}-\d{2}|\d+ \w+,? \d{4}|\w+ \d+,? \d{4})/i;

                $v=~s{\[($proto1$linkre$chars*)($btext)\]}{ chkExtLink($self,$api,1,$1,$dt // time(),$2) }ge;
                return 60 if($self->{'flags'}{'fail'});
                ($v,$nw)=$api->strip_regex(qr{\[$proto1$chars+$btext\]}, $v, $nw);
                $v=~s{\b($proto2$linkre$chars*)}{ chkExtLink($self,$api,2,$1,$dt // time()) }ge;
                return 60 if($self->{'flags'}{'fail'});
                $v=$api->replace_stripped($v,$nw);
                $nowiki->{$k}=$v;
            }

            # Fix any bracketed external link that doesn't have "Archive" or the
            # like in the line after it.
            $outtxt=~s{\[($proto1$linkre$chars*)($btext)\](?!.*$arc)}{ chkExtLink($self,$api,1,$1,time(),$2) }ge;
            return 60 if($self->{'flags'}{'fail'});

            # Hide all bracketed external links. We have to keep track of the
            # replacement token for the ones that have "Archive" etc in their
            # display text.
            ($outtxt,$nowiki)=$api->strip_regex(qr{\[$proto1$chars+$btext\]}, $outtxt, $nowiki);
            while(my ($k,$v)=each %$nowiki){
                push @arc, $k if $v=~m!^\[$proto1$chars+ *.*$arc!;
            }
            $arc='(?:'.join('|',@arc).')';

            # Fix any bare external link that doesn't have "Archive" or the like in
            # the line after it.
            $outtxt=~s{\b($proto2$linkre$chars+)(?!.*$arc)}{ chkExtLink($self,$api,2,$1,time()) }ge;
            return 60 if($self->{'flags'}{'fail'});

            # Unstrip
            $outtxt=$api->replace_stripped($outtxt,$nowiki);

            # Remove "no-dead-link" markers
            $outtxt=~s/\Q$nodl\E//g;

            # rm marked {{dead link}} templates (and $rmdl markers)
            $outtxt=~s/\Q$rmdl\E(?:\s*$dlre)*//g;

            # rm duplicate {{dead link}} templates too
            $outtxt=~s/$dlre+($dlre)/$1/g;

            if($outtxt ne $intxt){
                my @summary=();
                push @summary, "adding archiveurl for archived $desc cites" if $self->{'flags'}{'cite'};
                push @summary, "changing archived $desc links" if $self->{'flags'}{'link'};
                push @summary, "tagging dead $desc links" if($self->{'flags'}{'404'} && defined($deadlink));
                unless(@summary){
                    $api->warn("Changes made with no summary for $page, not editing");
                    next;
                }
                $summary[$#summary]='and '.$summary[$#summary] if @summary>1;
                my $summary=ucfirst(join((@summary>2)?', ':' ', @summary));
                $summary.=" per $req";
                $api->log("$summary in $page");
                my $r=$api->edit($tok, $outtxt, "$summary. $screwup", 1, 1);
                if($r->{'code'} ne 'success'){
                    $api->warn("Write failed on $page: ".$r->{'error'}."\n");
                    next;
                }
            }

            # If we've been at it long enough, let another task have a go.
            return 0 if time()>=$endtime;
        }
        $self->{'iter'}=undef;
    }

    $api->log("May be DONE!");
    return 600;
}

sub chkExtLink {
    my $self=shift;
    if($self->{'flags'}{'fail'}){
        return wantarray?('fail','fail','fail'):'fail';
    }

    my $api=shift;
    my $fmt=shift;
    my $url=shift;
    my $date=shift;
    my $txt='';

    if($fmt==2){
        # Duplicate Mediawiki post-processing of bare external links
        $txt=$1.$txt if $url=~s/((?:[<>]|&[lg]t;).*$)//;
        my $sep=',;\.:!?';
        $sep.=')' unless $url=~/\(/;
        $txt=$1.$txt if $url=~s/([$sep]+$)//;

        # There shouldn't be a template inside the url
        $txt=$1.$txt if $url=~s/(\{\{.*$)//;

        return $url.$txt unless $url=~m!^$proto2$linkre!;
    }

    # Get archive link and date
    my @archives;
    my ($u, $dt);
    if(exists($api->store->{$url})){
        @archives=@{$api->store->{$url}};
    } else {
        ($u="http://web.archive.org/web/*/$url")=~s!/$proto1!/!;
        $api->log("... Checking $u");

        # Screen-scrape archive.org
        my $r=$self->{'ua'}->get($u);
        if($r->is_success){
            foreach $_ ($r->decoded_content=~m!href="(http://web.archive.org/web/\d+/[^\x22]*)"!g) {
                $_ = HTML::Entities::decode($_);
                $api->log("... Got $_");

                if(m!^http://web.archive.org/web/(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})!){
                    $dt=timegm($6,$5,$4,$3,$2-1,$1-1900);
                } else {
                    $dt=time();
                }
                push @archives, [$dt, $_];
            }
        } elsif($r->code eq '404'){
            $api->log("... Failed with ".$r->code);
        } elsif($r->code eq '403' && $r->decoded_content=~m!<p class="mainTitle">Blocked Site Error.<br><br>\s*</p>\s*<p class="mainBigBody"><i>\Q$url\E</i> is not available in the Wayback Machine!){
            $api->log("... Failed with 403 'not available in the Wayback Machine'");
        } else {
            $api->log("... Failed with ".$r->code.", will retry later");
            $self->{'flags'}{'fail'}=1;
            return chkExtLink($self);
        }

        # check webcite too
        $u=URI->new('http://www.webcitation.org/query');
        $u->query_form(url=>$url,returnxml=>1);
        $u=$u->as_string;
        $api->log("... Checking $u");
        $r=$self->{'ua'}->get($u);
        if($r->is_success){
            my $xml=$self->{'xml'}->load_xml(string=>$r->decoded_content);
            if($xml){
                foreach $_ (@{$xml->find('//result[@status=\'success\']')}){
                    $dt=$_->find('./timestamp');
                    my $uu=URI->new('http://www.webcitation.org/query');
                    $uu->query_form(url=>$url,date=>$dt);
                    $uu=$uu->as_string;
                    # Not exactly RFC-compliant, but it works fine
                    $uu=~s/%3A/:/g; $uu=~s/%2F/\//g;
                    $api->log("... Got $uu");
                    push @archives, [str2time($dt) // time(), $uu];
                }
            } else {
                $api->log("... Invalid XML data");
                $self->{'flags'}{'fail'}=1;
                return chkExtLink($self);
            }
        } elsif($r->code eq '404'){
            $api->log("... Failed with ".$r->code);
        } else {
            $api->log("... Failed with ".$r->code.", will retry later");
            $self->{'flags'}{'fail'}=1;
            return chkExtLink($self);
        }

        $api->store->{$url}=\@archives;
    }

    # Then pull the closest archive to the accessdate or whatever.
    my ($diff,$r404)=(1e100,defined($deadlink)?"{{$deadlink|date=".strftime('%B %Y', gmtime)."|bot=".$api->user."}}":$nodl);
    $u=undef;
    foreach $_ (@archives){
        if(abs($_->[0] - $date) < $diff){
            $diff=abs($_->[0] - $date);
            ($dt,$u)=@$_;
            $r404='';
        }
    }

    if($r404){
        $self->{'flags'}{'404'}=1;
    } elsif($fmt==0){
        $self->{'flags'}{'cite'}=1;
    } else {
        $self->{'flags'}{'link'}=1;
    }

    if($fmt==0){ # cite template
        return ($u,strftime('%Y-%m-%d',gmtime($dt // 0)),$r404);
    } elsif($fmt==1){ # Bracketed external link
        my $txt=shift;
        return $r404?"[$url$txt]$r404":"[$u$txt]$rmdl";
    } elsif($fmt==2){ # Bare external link
        return ($r404?"[$url $url]$r404":"$u$rmdl").$txt.$rmdl;
    } else {
        return undef;
    }
}

1;