#! /usr/bin/perl -w

#
# A utility for converting squidGuard lists to a URL/link list
# suitable for the squidGuardRobot.
#
# By Pl Baltzersen 2000 (pal.baltzersen@ost.eltele.no)
#
# The current version may be found anytime at:
# http://ftp.ost.eltele.no/pub/www/proxy/squidGuard/contrib/squidGuardRobot/
#
# Typical usage:
# list2url -v < tmp >> robot/etc/blacklists/porn/link 2>/tmp/list2url.log &
#

# By accepting this notice, you agree to be bound by the following
# agreements:
# 
# This software product, squidGuardRobot, is copyrighted (C) 2000 by
# ElTele st AS, Oslo, Norway, with all rights reserved.
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License (version 2) as
# published by the Free Software Foundation.  It is distributed in the
# hope that it will be useful, but WITHOUT ANY WARRANTY; without even
# the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
# PURPOSE.  See the GNU General Public License (GPL) for more details.
# 
# You should have received a copy of the GNU General Public License
# (GPL) along with this program.

my $VERSION = "1.1.1";

my ($debug,$verbose,$quiet,$proxy,$timeout,$fake);

#
# USER CONFIGURABLE DEFAULTS:
#

$quiet		= 0;				# 0 == false; 1 == true;
$debug		= 0;				# 0 == false; 1 == true;
$verbose	= 1;				# 0 == false; 1 == true;

$proxy		= "http://proxy:80/";		# undef||"http://proxy:1234/"
$timeout	= 15;				# SECONDS BEFORE TIMEOUT DURING HEAD
$fake		= "Mozilla/5.0 (Windows; U; WinNT4.0; en-US; rv:0.9.4) Gecko/20011128 Netscape6/6.2.1";# undef||"Mozilla/4.78 [en] (WinNT; U)"

#
# END USER CONFIGURABLE DEFAULTS
#

use strict;
use Getopt::Std;
use HTTP::Request;
use HTTP::Response;
use HTTP::Status;
use LWP::UserAgent;

my $progname = $0; $progname =~ s/.*\057//;
my (%links,%urls);

sub configure();
sub ua($$);
sub normalize($$$);
sub success($);
sub redirect($);
sub servererror($);
sub check($@);
sub doit();

sub configure() {
  my (%opts);
  getopts("hc:dqvV", \%opts) || usage(1);
  if (defined($opts{h})) {
    usage(0);
  }
  if (defined($opts{c})) {
    open(CONFIG, $opts{c}) || error("$opts{c}: $!");
    while(<CONFIG>) {
      eval;
    }
    close(CONFIG);
  }
  if (defined($opts{"d"})) {
    $debug = 1;
    $verbose = 1;
    $quiet = 0;
  }
  if (defined($opts{"q"})) {
    $debug = 0;
    $verbose = 0;
    $quiet = 1;
  }
  if (defined($opts{"v"})) {
    $verbose = 1;
    $quiet = 0;
  }
  if (defined($opts{"V"})) {
    print "$VERSION\n";
    exit(0);
  }
  select(STDERR);$|=1;
  select(STDOUT);$|=1;
}

sub ua($$) {
  my ($timeout, $proxy) = @_;
  my $ua = LWP::UserAgent->new;
  $ua->proxy(['http', 'ftp'], $proxy) if(defined($proxy));
  $ua->agent($fake) if(defined($fake));
  $ua->timeout($timeout) if(defined($timeout));
  return($ua);
}

sub normalize($$$) {
  my ($scheme, $prefix, $url) = @_;
  
  if($url =~ /((http|ftp):\/\/)(.+)/i) {
    $scheme = lc($1);
    $url = $3;
  } elsif ($scheme) {
    $scheme .= "://";
  } else {
    $scheme = "http://";
  }
  if ($prefix) {
    $prefix .= ".";
  } else {
    $prefix = "";
  }
  return(URI->new($scheme . $prefix . $url)->canonical);
}

sub success($) {
  my $code = shift;
  return(1) if ($code >= 200 && $code < 300);
  return(1) if ($code == RC_UNAUTHORIZED);
  return(1) if ($code == RC_PAYMENT_REQUIRED);
  return(1) if ($code == RC_FORBIDDEN);
  return(0);
}

sub redirect($) {
  my $code = shift;
  return(1) if ($code == RC_MOVED_PERMANENTLY);
  return(1) if ($code == RC_FOUND);
  return(0);
}

sub servererror($) {
  my $code = shift;
  return(1) if ($code >= 500 && $code < 600);
  return(0);
}

sub check($@) {
  my ($key, $level) = @_;
  return(0) if ($level && $level > 1);
  my $ua = ua($timeout, $proxy);
  my ($ok, $redir, $code);
  my @prefixes = (undef, "www", "web", "ftp");
  @prefixes = (undef) if($key =~ m@^((http|ftp)://)?\d+\.\d+\.\d+\.\d+(\/|$)@);
  @prefixes = (undef) if($key =~ m@^((http|ftp)://)?(www|web|ftp)\d*\.@);
  foreach my $scheme ("http", "ftp") {
    foreach my $prefix (@prefixes) {
      my $url = normalize($scheme, $prefix, $key);
      next unless($url);
      $url .= "/" if($scheme eq "ftp" && $url !~ m@(/|://.*/.*\.(s?html?|\w{2,3}))$@);
      print STDERR " Checking: $url" if($verbose);
      my $request = HTTP::Request->new(HEAD => $url);
      my $response = $ua->simple_request($request);
      $code = $response->code;
      if (success($code)) {
	$ok++;
	print STDERR " OK ($code)\n" if($verbose);
	print STDOUT "$url\n";
      } elsif (redirect($code)) {
	$redir++;
	my $location = $response->header("Location");
	my $k = $key;
	$k =~ s@^(http|ftp)://@@;
	$k =~ s@/$@@;
	if ($location && $location =~ m@$k@) {
	  print STDERR " REDIRECT ($code $location)\n" if($verbose);
	  if(check($location,++$level)) {
	    $ok++;
	  } else {
	    print STDERR " FAILED ($code)\n" if($verbose);
	  }
	} else {
	  $location = " $location" if($location);
	  $location = "" unless($location);
	  print STDERR " FAILED ($code$location)\n" if($verbose);
	}
      } elsif (servererror($code)) {
	print STDERR " FAILED ($code)\n" if($verbose);
	next if($scheme eq "ftp");
	next if($url =~ m@(/|://.*/.*\.(s?html?|\w{2,3}))$@);
	if ($url =~ m@/$@) {
	  $url =~ s@/$@@;
	} else {
	  $url .= "/";
	}
	print STDERR " Checking: $url" if($verbose);
	$request = HTTP::Request->new(HEAD => $url);
	$response = $ua->simple_request($request);
	$code = $response->code;
	if(success($code)) {
	  $ok++;
	  print STDERR " OK ($code)\n" if($verbose);
	  print STDOUT "$url\n";
	} else {
	  print STDERR " FAILED ($code)\n" if($verbose);
	}
      } else {
	print STDERR " FAILED ($code)\n" if($verbose);
      }
      last if($ok);
    }
    last if($ok);
    last if($redir);
  }
  unless($ok) {
    print STDERR "$key FAILED\n" unless($quiet);
  }
  $ok
}

sub doit() {
  configure();
  while(<>) {
    chomp;
    s/\s+.*//g;
    s/\043.*//g;
    s/^\.//;
    s@\./?$@@;
    next if($_ eq "");
    print STDERR "$_\n" if($verbose);
    check($_);
    print STDERR "\n" if($verbose);
  }
}

doit();
