#!/usr/bin/env perl
#
# Created: 29 July 2018
# Author: Bert Bos <bert@w3.org>


=head1 NAME

mksitemap - crawl a site to make a sitemap.xml file

=head1 SYNOPSIS

B<mksitemap> B<-c> I<contact> [B<-n> I<max-urls>] [B<-d>
I<max-duration>] [B<-t> I<timeout>] [B<-s> I<max-html-size>] [B<-p>
I<pause>] [B<-l> I<logfile>] [B<-u> I<user-agent>] [B<-q>] I<URL>
[I<URL>...]

=head1 DESCRIPTION

B<mksitemap> is a simple Web spider that collects all URLs of a Web
site. The output is in the form of a Google sitemap (an XML-based
format). The sitemap is written on standard output.

(Although it is usually called a "map" and stored in a file called
"sitemap.xml", it is not so much a map as a list. The relations
between the URLs are not recorded.)

B<mksitemap> can also make a log of errors it encounters, typically
broken links.

If the standard output is redirected to a file (and the standard error
output is not), B<mksitemap> will show its progress and an estimate
of the remaining time on the standard error output.

=head2 URL arguments

The typical invocation is with the root URL of a site:

 mksitemap -c me@example.org http://example.org/ >sitemap.xml

If the URL has a path component, B<mksitemap> will only visit URLs
with that path as a prefix. E.g.,

 mksitemap -c me@example.org http://example.org/people/

will only visit URLs that start with "http://example.org/people/".

You can give multiple URLs, e.g., if parts of a site are not reachable
by just following links. E.g.,

 mksitemap -c me@example.org \
  http://example.org/people/ http://example.org/animals

will write to standard output a sitemap with all URLs that can be
reached from one or both of the two URLs and that start with one of
those URLs as prefix.

=head2 robots.txt

B<mksitemap> respects the robots.txt file. It will silently skip URLs
that it is not supposed to fetch, according to the rules in a site's
robots.txt file. As the sitemap that B<mksitemap> creates is meant
primarily for search engines, i.e., other robots, it makes sense to
omit those URLs.

If you want a sitemap with all URLs that can be reached, the best way
to do that is to change the robots.txt file of that site and add
something like this to it:

 User-agent: mksitemap
 Allow: /

(There must be an empty line before the "User-agent" line.) Or better
still, invent a name for your crawler:

 User-agent: my-special-mksitemap
 Allow: /

and then call mksitemap with that name:

 mksitemap -a my-special-mksitemap/0.1 ...

=head2 Running time and infinite sites

On a small site, with a few tens of thousands of pages and a finite
URL space, B<mksitemap> can make a site map in one or two minutes,
assuming it is running on the same machine as the Web server and
without pausing (option B<-p 0>). On a site with a few million links
running on a different machine, it can take several days.

More complex sites also often have an infinite URL space, either
deliberately or because of configuration errors or errors in dynamic
pages. E.g., it is quite common that there is a URL /foo/ that returns
a document with a link to /foo/foo/, which returns a document
(possibly the same one) with a link to /foo/foo/foo/, etc.
B<mksitemap> will eventually stop (see the options B<-n> and B<-d>),
but at that point it will likely have found a number of these
"infinite" URLs, while it didn't yet find all normal ones.

=head1 OPTIONS

=over

=item B<-c> I<contact>

The B<-c> option is required. It specifies an address (e-mail address,
home page...) of the person running B<mksitemap>, so that site owners
can see who to contact in case the crawler is causing problems on
their site. The value is passed as a "From" header in each request to
the site.

=item B<-d> I<max-duration>

B<mksitemap> will not crawl longer than this many hours, Default is 24.

=item B<-l> I<logfile>

If this option is given, B<mksitemap> will write all errors (failed
attempts to fetch a URL) to this file. The file is emptied if it
already existed. Default is to not log any errors.

=item B<-n> I<max-numer-of-urls>

B<mksitemap> will not write more than this many URLs to the output. Default is
2000000 (2 million).

=item B<-p> I<pause>

B<mksitemap> will wait for this many seconds between requests to the
same site, so as not to overload the site. Default is 5.

=item B<-q>

Be quiet. Don't show an estimate of the progress on standard error
output.

=item B<-s> I<max-html-size>

B<mksitemap> will download HTML documents and scan them for links
only if they are not bigger than this many bytes. Default is 3145728
(3 MB).

=item B<-t> I<timeout>

If a site is slow to respond, B<timeout> will wait for at most this
many seconds for a response. If logging is turned on (option B<-l>), a
failed request is reported in the log.

=item B<-u> I<user-agent>

This option specifies the name by which the crawler identifies itself
to a site. By convention, this name has the form "name/version", but
it can be any string. Default is "mksitemap/0.1".

=back

=head1 OUTPUT

The sitemap that is written to standard output looks like this

 <?xml version="1.0" encoding="UTF-8"?>
 <urlset xmlns="http://www.sitemaps.org/schemas/sitemap/0.9"
  xmlns:dc="http://purl.org/dc/elements/1.1/">
 <dc:date >2018-07-31T14:11:18Z</dc:date>
 <dc:creator>me@example.org</dc:creator>
 <url>
 <loc>http://example.org/</loc>
 <lastmod>2016-10-21T15:42:09Z</lastmod>
 <changefreq>daily</changefreq>
 </url>
    ... more <url> records...
 </urlset>

=head1 BUGS

On a site with an "infinite" URL space (see L</"Running time and
infinite sites">), B<mksitemap> will obviously not be able to make a
complete site map. When it stops due to a maximum run time (B<-d>) or
a maximum number of URLs (B<-n>), it is up to the user to inspect the
resulting URLs and decide if raising the limits would make it succeed.

=head1 AUTHOR

L<Bert Bos|https://www.w3.org/People/Bos/>
L<E<lt>bert@w3.orgE<gt>|mailto:bert@w3.org>

=head1 SEE ALSO

L<Google sitemap format|https://www.sitemaps.org/index.html>,
L<robots.txt|http://www.robotstxt.org/>

Some ideas in the code were inspired by examples from the book "Perl &
LWP" by Sean M. Burke.

=cut


# TODO: If a response indicates language variants, try different
# languages. (A well-designed site should have explicit links to each
# translation, but...)
#
# TODO: Also look for HTTP Link headers.
#
# TODO: A test suite.
#
# TODO: Statistics (number of errors, number of links from each type
# of attribute...)
#
# TODO: A way to continu an interrupted crawl (by reading the
# generated sitemap and the remaining queue that was saved somewhere?)


use strict;
use warnings;
use LWP::RobotUA;
use HTML::TokeParser;
use Getopt::Std;
use utf8;
use feature 'unicode_strings';

my $maxhits = 2000000;		# Max. # of URLs to output (default 2 million)
my $maxduration = 24;		# Maximum runtime (default 24 hours)
my $timeout = 15;		# Timeout waiting for server (default 15 seconds)
my $maxsize = 3145728;		# Only consider HTML documents smaller than this
my $pause = 5;			# Delay between requests (default 5 seconds)
my $log;			# File handle of error log
my $user_agent = "mksitemap/0.1"; # Our name & version (default mksitemap/0.1)
my $show_progress = 1;		# Whether to show progress on STDERR
my $maxtime;			# Stop before this time
my @starting_urls;		# URLs given on command line
my @queue = ();			# URLs still to check
my $robot;			# The user agent object
my $numhits = 0;		# URLs fetched so far
my $contact;			# Address of person running the crawler
my %referrers = ();		# Where each URL was referenced from
my $stopping = 0;		# True if we got an interrupt (Ctrl-C)
my $start_time;			# Start time of main loop

local $URI::ABS_REMOTE_LEADING_DOTS;


# change_frequency -- estimate a change frequency for the resource of a URL
sub change_frequency($)
{
  my ($response) = @_;
  my $freshness_lifetime = $response->freshness_lifetime(h_max => 155520000);

  return 'never' if $freshness_lifetime >= 155520000; # 5 years
  return 'yearly' if $freshness_lifetime >= 31557600; # 1 year
  return 'monthly' if $freshness_lifetime >= 2592000; # 30 days
  return 'weekly' if $freshness_lifetime >= 604800;   # 1 week
  return 'daily' if $freshness_lifetime >= 86400;     # 1 day
  return 'hourly' if $freshness_lifetime >= 3600;     # 1 hour
  return 'always';
}


# output_url -- print a URL's info to stdout
sub output_url($)
{
  my ($response) = @_;
  my $uri = $response->request->uri;
  my $lastmod = $response->last_modified;
  my @t = gmtime($lastmod) if defined $lastmod;

  print "<url>\n";
  print "<loc>", $uri, "</loc>\n";
  printf "<lastmod>%04d-%02d-%02dT%02d:%02d:%02dZ</lastmod>\n",
      $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0] if defined $lastmod;
  print "<changefreq>", change_frequency($response), "</changefreq>\n";
  print "</url>\n";
  $numhits++;
}


# log_error -- log an error about a URL that could not be fetched
sub log_error($$)
{
  my ($response, $referrer) = @_;

  printf $log "%d on %s referrer %s\n", $response->code,
      $response->request->uri, $referrer if defined $log;
}


# is_html -- true if the response is some form of HTML
sub is_html($)
{
  my ($response) = @_;

  return $response->content_type eq 'text/html'
      || $response->content_type eq 'application/xhtml+xml';
}


# check_and_add_to_queue -- if the URL is in our domain, add it to the queue
sub check_and_add_to_queue($$)
{
  my ($url, $referrer) = @_;

  $url =~ s/#.*//;		# Remove any fragment ID
  $url = URI->new_abs($url, $referrer)->canonical;
  return if defined $referrers{$url}; # Already queued this URL before

  # Check if the URL is in the subtree of any of the starting URLs. If
  # so, add it to the queue. (We assume hierarchical URL schemes, such
  # as http or ftp.)
  #  
  foreach (@starting_urls) {
    if (substr($url, 0, length($_)) eq $_) {
      push(@queue, $url);
      $referrers{$url} = $referrer;
      return;
    }
  }
}


# extract_and_queue_links -- find and queue links from the body of a response
sub extract_and_queue_links($)
{
  my ($response) = @_;
  my ($parser, $tagref, $tag, $attr, $s, $url);

  $s = $response->decoded_content;
  $parser = HTML::TokeParser->new(\$s);
  $parser->empty_element_tags(1);

  # Loop over all tags in the document, looking for attributes that
  # contain a URL.
  #
  while (($tagref = $parser->get_tag())) {
    next if $tagref->[0] =~ /^\//;	# It's an end tag

    # Loop over all known attributes that may contain URLs.
    #
    foreach $attr ('src', 'href', 'data', 'longdesc', 'usemap', 'srcset',
		   'classid', 'codebase', 'cite', 'action', 'profile') {
      if (defined ($url = $tagref->[1]{$attr})) {
	check_and_add_to_queue($url, $response->request->uri);
      }
    }
  }
}


# process_url -- check a URL and queue any URLs its target contains
sub process_url($$)
{
  my ($url, $referrer) = @_;
  my ($response, $new_url, $content_loc);

  $response = $robot->head($url, 'Referer' => $referrer); # Do HEAD request first

  if ($response->is_success) {

    # Success. Check if the response has a Content-Location that is
    # different from the current URL. If so, queue it. Otherwise
    # output the current URL, and, if it points to HTML that is not
    # too big, continue to get its body.
    #
    if (defined ($content_loc = $response->header('Content-Location'))) {
      $content_loc = URI->new_abs($content_loc, $url)->canonical;
      if ($content_loc ne $url) {
	check_and_add_to_queue($content_loc, $url);
	return;
      }
    }
    output_url($response);
    return if !is_html($response) || ($response->content_length//0) > $maxsize;

  } elsif ($response->is_error) {

    # Skip this URL if it was filtered by robots.txt rules. Otherwise
    # log the error and scan the body (i.e., the error message).
    #
    return if $response->code == 403 &&
	$response->message eq 'Forbidden by robots.txt';
    log_error($response, $referrer);

  } elsif (defined ($new_url = $response->header('Location'))) {

    # It's a redirect with a Location header with a URL. Queue that
    # URL and don't try to get the body (the error message).
    #
    check_and_add_to_queue($new_url, $url);
    return;

  }

  # Get the body (which may be an error message), scan it for links.
  #
  return if $stopping;		# Don't start a new request if we got a signal
  $response = $robot->get($url, 'Referer' => $referrer);
  extract_and_queue_links($response) if is_html($response);
}


# show_progress -- show info about the crawl
sub show_progress()
{
  my ($now, $runtime, $s, $time_per_hit, $todo);

  $now = time;
  $runtime = $now - $start_time;
  $time_per_hit = $numhits > 0 ? $runtime / $numhits : $pause;
  $todo = scalar @queue;
  $todo = $maxhits - $numhits if $todo > $maxhits - $numhits; # Option -n
  $s = $todo * $time_per_hit;
  $s = $maxtime - $now if $s > $maxtime - $now; # Time limit (option -d)

  printf STDERR "%7d found  %7d queued", $numhits, scalar @queue;
  printf STDERR "  %d:%02d:%02d ETA", ($s / 3600), ($s / 60) % 60, $s % 60;
  print STDERR "  \r";
}


# show_total -- show final results
sub show_total()
{
  my $s = time - $start_time;
  my $m = $s / 60;
  my $h = $m / 60;
  my $f;

  foreach $f (*STDERR, $log) {
    next if ! defined $f;
    if ($stopping) {print $f "\nInterrupted by signal\n";}
    elsif ($numhits==$maxhits) {print $f "\nStopping after $maxhits URLs\n";}
    elsif (time() >= $maxtime) {print $f "\nStopping after time limit\n";}
    else {print $f "\nNo more URLs to process\n";}
    printf $f "%d found  %d queued  %d:%02d:%02d runtime\n",
	$numhits, scalar @queue, $h, $m % 60, $s % 60;
  }
}


# VERSION_MESSAGE -- print version info
sub VERSION_MESSAGE($$$$)
{
  my ($fh, $package, $version, $switches) = @_;

  printf $fh "Version: %s\n", $user_agent;
}


# HELP_MESSAGE -- print usage information
sub HELP_MESSAGE($$$$)
{
  my ($fh, $package, $version, $switches) = @_;

  print $fh
      "Usage: $0 [options] [--] URL [URL...]\n",
      "\n",
      "  $0 outputs an XML sitemap to standard output.\n",
      "\n",
      "  -c <contact-address>\n",
      "      How to contact the person responsible for the crawl. Required.\n",
      "  -n <number-of-urls>\n",
      "      Maximum number of URLs to output (default: 2000000).\n",
      "  -d <duration>\n",
      "      Maximum time in hours to run the crawl (default: 24).\n",
      "  -t <timeout>\n",
      "      Timeout for individual requests to a server (default: 15).\n",
      "  -s <max-size>\n",
      "      HTML documents bigger than this (in bytes) are not\n",
      "      downloaded (default: 3145728, i.e., 3 MB).\n",
      "  -p <pause>\n",
      "      Pause in seconds between requests to a server (default: 5).\n",
      "  -l <logfile>\n",
      "      File in which to to log failed requests (default: none)\n",
      "  -u <user-agent>\n",
      "      User agent name to tell servers (default: mksitemap/0.1)\n",
      "  -q\n",
      "      Quiet. Don't show estimated progress on standard error output\n";
}


# parse_command_line -- interpret command line options and arguments
sub parse_command_line()
{
  my %opts;

  # TODO: Better checking of syntax and better error messages.

  $Getopt::Std::STANDARD_HELP_VERSION = 1;
  getopts('c:n:d:t:s:p:l:u:q', \%opts) or die "Try --help\n";
  $contact = $opts{'c'} or die "A contact e-mail (option -c) is required.\n";
  $maxhits = $opts{'n'} if defined $opts{'n'};
  $maxduration = $opts{'d'} if defined $opts{'d'};
  $maxtime = time() + 3600 * $maxduration; # 1 hour = 3600 s
  $timeout = $opts{'t'} if defined $opts{'t'};
  $maxsize = $opts{'s'} if defined $opts{'s'};
  $pause = $opts{'p'} if defined $opts{'p'};
  open($log, ">:encoding(UTF-8)", $opts{'l'})
      or die "Cannot write to ".$opts{'l'}."\n" if defined $opts{'l'};
  $user_agent = $opts{'u'} if defined $opts{'u'};
  $show_progress = 0 if defined $opts{'q'};

  die "Need at least one URL argument\n" if ! scalar @ARGV;
  foreach (@ARGV) {
    push(@starting_urls, URI->new($_)->canonical);
    $referrers{$_} = $_;
  }
}


# init_queue -- initialize the queue of URLs with the starting URLs.
sub init_queue()
{
  foreach (@starting_urls) {
    push(@queue, $_);
    $referrers{$_} = $_;
  }
}


# init_robot -- initialize our user agent
sub init_robot()
{
  $robot = LWP::RobotUA->new($user_agent, $contact);
  $robot->delay($pause/60);	# Delay between requests in minutes
  $robot->timeout($timeout);
  $robot->max_redirect(0);	# We handle redirects ourselves
  $URI::ABS_REMOTE_LEADING_DOTS = 1; # "/../foo/bar" --> "/foo/bar"
}


# init_signals -- set a handler for Ctrl-C
sub init_signals
{
  $SIG{'INT'} = sub { $stopping = 1;};
}


# init_output -- write preamble to stdout
sub init_output
{
  my (@now, $date, $c);

  # Only show progress if STDOUT is redirected and STDERR is not.
  #
  $show_progress = $show_progress && -t STDERR && ! -t STDOUT;

  @now = gmtime;
  $date = sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ",
		  $now[5] + 1900, $now[4] + 1, $now[3],
		  $now[2], $now[1], $now[0]);

  $c = $contact =~ s/&/&amp;/gr =~ s/</&lt;/gr =~ s/>/&gt;/gr;

  binmode(STDOUT, ":utf8");
  print "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n",
      "<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\"\n",
      " xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\n",
      "<dc:date >$date</dc:date>\n",
      "<dc:creator>$c</dc:creator>\n";
}


# main_loop -- loop until queue empty, time's up, or interrupted
sub main_loop()
{
  my ($url, $referrer);

  $start_time = time;
  while (@queue && $numhits < $maxhits && time() < $maxtime && !$stopping) {
    show_progress() if $show_progress;
    $url = splice(@queue, rand(@queue), 1); # Pick a random URL
    $referrer = $referrers{$url};
    process_url($url, $referrer);
  }
  show_total();
}


# finalize_output -- write postamble to stdout
sub finalize_output
{
  print "</urlset>\n";
}


# Main body
#
parse_command_line();
init_robot();
init_signals();
init_output();
init_queue();
main_loop();
finalize_output();
exit(0);