#!/usr/bin/perl
# ==================================================================
# Links SQL - enhanced directory management system
#
#   Website  : http://gossamer-threads.com/
#   Support  : http://gossamer-threads.com/scripts/support/
#   Revision : $Id: verify-child.pl,v 1.17 2001/12/30 23:17:07 alex Exp $
# 
# Copyright (c) 2001 Gossamer Threads Inc.  All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================

    $| = 1;

    use lib '.';
    use Links qw/$IN $CFG $DB/;
    use Links::Tools;
    use GT::SQL::Condition;
    use Socket;
    use strict;
    use vars    qw/$METHOD $CRLF $TIMEOUT/;

    $| = 1;
    local $SIG{__DIE__} = \&Links::fatal;
    Links::init('.');

    $METHOD     = "GET";
    $CRLF       = "\015\012";
    $TIMEOUT    = 10;

    main();

sub main {
# -------------------------------------------------------------------
    my (%url_ids, $db, $sth, $id, $SQLquery, @row , $status, $err);

# We get a list of ID numbers passed to us on command line.
    for (@ARGV) { $url_ids{$_} = 1; }

    my $cond = new GT::SQL::Condition;
    my $val  = "(" . join (",", @ARGV) . ")";
    $cond->add ("ID", "IN", \$val);

    $db  = $DB->table ('Links');
    $sth = $db->select ( $cond, ['ID', 'URL'] );

    while ( @row = $sth->fetchrow_array() ) {
        $status = ($row[1] =~ m,^ftp://,) ? check_ftp_link ($row[1]) : check_link ( $row[1] );
        delete @url_ids{$row[0]};
        print "$row[0]\t$status\t$row[1]\t\t\n";
    }

# flag id could not be resolved error, this should not happen
    for (keys %url_ids) {
        print "$_\t-7\t\tUnknown ID\t\n"; 
    }
}

sub check_link {
# -----------------------------------------------------
# Check links without LWP.
#
    my ($url) = shift;
    my ($host, $port, $path, $sock, $line, $iaddr, $sin, $proto);

    ($url =~ m,^http://([^:/]+):?(\d*)(.*),i) and (($host, $port, $path) = ($1, $2, $3));
    $path ||= '/';
    $port ||= 80;
    $path =~ s/#.*//;

    $host or return -5;

    $proto = getprotobyname('tcp');
    $iaddr = gethostbyname($host) || return -6;
    socket(SOCK, PF_INET, SOCK_STREAM, $proto) || return -2;
    $sin = sockaddr_in($port,$iaddr);
    connect(SOCK,$sin) || return -4;

    select SOCK; $|++; select STDOUT;

    print SOCK "$METHOD $path HTTP/1.0$CRLF";
    ($port == 80) ? (print SOCK "Host: $host$CRLF") : (print SOCK "Host: $host:$port$CRLF");
    print SOCK "User-Agent: Links SQL (http://gossamer-threads.com/scripts/links-sql/)$CRLF$CRLF";
    my ($protocol, $status, $rin);
    $rin = '';
    vec ( $rin, fileno (SOCK), 1 ) = 1;

    if ( select ( $rin, undef, undef, $TIMEOUT ) ) {
        my $response = <SOCK>;
        ($protocol, $status) = split ( / /, $response ); # /
        # kills the connection after the first line. This is not polite. However,
        # there have been more than a few cases where certain servers hang the
        # child in mid check
        #while (defined ($line = <SOCK>)) { };      
    } else {
        $status = 204;
    };

    close (SOCK);
    $status = int ( $status );

# no a good response, reply with NON_PARSEABLE error -8
    if (!$status) { $status = -8; };
    return $status;

}

sub  check_ftp_link {
# -----------------------------------------------------
# Checks an ftp link.
#
    my $url = shift;
    my ($host, $port, $path, $sock, $line, $iaddr, $sin, $proto, $user, $pass);

    ($url =~ m,^ftp://(?:([^:]+):([^@]+)@)?([^/:]+):?(\d*)(.*)$,i) and (($user, $pass, $host, $port, $path) = ($1, $2, $3, $4, $5));
    $path ||= '/';
    $port ||= 21;
    $user ||= 'annonymous';
    $pass ||= 'links-sql@gossamer-threads.com';

    $host or return -5;

    $proto = getprotobyname('tcp');
    $iaddr = gethostbyname($host) || return -6;
    socket(SOCK, PF_INET, SOCK_STREAM, $proto) || return -2;
    $sin = sockaddr_in($port,$iaddr);
    connect(SOCK,$sin) || return -4;

    select SOCK; $|++; select STDOUT;

# Get the welcome message.
    unless (get_status()) {
        return -4;
    }

# Login to the server
    print SOCK "USER $user$CRLF";
    unless (get_status()) {
        return 401;
    }
    print SOCK "PASS $pass$CRLF";
    unless (get_status()) {
        return 401;
    }

# We can have either a directory or a file so check both
# if both fail then the ftp is bad.
    my $ok = 0;

# Check for file
    print SOCK "CWD $path$CRLF";
    if (get_status()) {
        $ok = 1;
    }
    else {
        print SOCK "SIZE $path$CRLF";
        if (get_status()) {
            $ok = 1;
        }
    }
    close SOCK;

    return $ok ? 200 : 404;
}

sub get_status {
# -----------------------------------------------------
# Get's a response from the server.
#   
    my $rin     = '';
    my $tics    = time();
    my $check   = 5;
    while ( 1 ) {

# ... check for time out in 10 seconds
        if ( ( time() - $tics ) > 10 ) {
            last;
        }

# .. get some data
        my $input;
        vec ( $rin, fileno (SOCK), 1 ) = 1;
        if ( select ( $rin, undef, undef, 0 ) ) {       
            my $tmp;
            sysread SOCK, $tmp, 100000;

            my @atmp = grep $_ !~ /^\s*$/, split /(\n|\r)+/, $tmp;
            if ( $atmp[$#atmp] =~ /^(\d)\d+\s+/ ) {
                $check = $1;
                last;
            }
            $tics = time();
        }

    }
    if ($check > 3) { return; }
    return 1
}