| 1 |
dpavlin |
1.1 |
#!/usr/local/bin/perl |
| 2 |
|
|
# File: lwp-http.mon |
| 3 |
|
|
# Author: Daniel Hagerty, hag@linnaean.org |
| 4 |
|
|
# Date: Sun Mar 19 22:06:02 2000 |
| 5 |
|
|
# Description: Perform a simple top level HTTP get using LWP. |
| 6 |
|
|
# Lots of options. |
| 7 |
|
|
# |
| 8 |
|
|
# $Id: lwp-http.mon,v 1.3 2000/03/20 05:55:48 hag Exp $ |
| 9 |
|
|
|
| 10 |
|
|
use strict; |
| 11 |
|
|
|
| 12 |
|
|
use LWP::UserAgent; |
| 13 |
|
|
use HTTP::Cookies; |
| 14 |
|
|
use HTTP::Request; |
| 15 |
|
|
use Getopt::Std; |
| 16 |
|
|
use File::Basename; |
| 17 |
|
|
use URI; |
| 18 |
|
|
|
| 19 |
|
|
### |
| 20 |
|
|
|
| 21 |
|
|
use vars qw($opt_h $opt_p $opt_t $opt_z $opt_d $opt_r $opt_s $opt_P |
| 22 |
|
|
$opt_v $opt_c); |
| 23 |
|
|
|
| 24 |
|
|
## |
| 25 |
|
|
|
| 26 |
|
|
# Configure this. |
| 27 |
|
|
my $maintainer = 'youremailhere@localhost'; |
| 28 |
|
|
|
| 29 |
|
|
## |
| 30 |
|
|
|
| 31 |
|
|
my $port; |
| 32 |
|
|
my $directory; |
| 33 |
|
|
my $regex; |
| 34 |
|
|
my $proto = "http"; |
| 35 |
|
|
my $timeout = 60; |
| 36 |
|
|
|
| 37 |
|
|
my $version = "0.1"; |
| 38 |
|
|
my $agent = "Yet Another Monitor Bot/$version"; |
| 39 |
|
|
|
| 40 |
|
|
my $u_proto; |
| 41 |
|
|
|
| 42 |
|
|
### |
| 43 |
|
|
|
| 44 |
|
|
sub main { |
| 45 |
|
|
do_usage() if(@_ == 0); |
| 46 |
|
|
|
| 47 |
|
|
$directory = $opt_d if($opt_d); |
| 48 |
|
|
$port = $opt_p if($opt_p); |
| 49 |
|
|
$timeout = $opt_t if($opt_t); |
| 50 |
|
|
$regex = $opt_r if($opt_r); |
| 51 |
|
|
$proto = "https" if ($opt_s); |
| 52 |
|
|
$proto = $opt_P if($opt_P); |
| 53 |
|
|
|
| 54 |
|
|
$directory =~ s/^\///; # Nuke leading slash |
| 55 |
|
|
$u_proto = $proto; $u_proto =~ tr/[a-z]/[A-Z]/; |
| 56 |
|
|
|
| 57 |
|
|
my $user_agent = LWP::UserAgent->new() || lose("LWP create failure"); |
| 58 |
|
|
$user_agent->agent($agent); |
| 59 |
|
|
$user_agent->from($maintainer); |
| 60 |
|
|
$user_agent->timeout($timeout); |
| 61 |
|
|
|
| 62 |
|
|
my @failed; |
| 63 |
|
|
my %failure; |
| 64 |
|
|
host: |
| 65 |
|
|
foreach my $host (@_) { |
| 66 |
|
|
my $ht_lose = sub { |
| 67 |
|
|
push(@failed, $host); |
| 68 |
|
|
$failure{$host} = join(" ", @_); |
| 69 |
|
|
|
| 70 |
|
|
# This generates a warning. |
| 71 |
|
|
next host; |
| 72 |
|
|
}; |
| 73 |
|
|
|
| 74 |
|
|
if($opt_c) { |
| 75 |
|
|
# Generate new cookies for each host. |
| 76 |
|
|
my $cookies = HTTP::Cookies->new() || |
| 77 |
|
|
&{$ht_lose}("HTTP::Cookies create failure"); |
| 78 |
|
|
|
| 79 |
|
|
$user_agent->cookie_jar($cookies); |
| 80 |
|
|
} |
| 81 |
|
|
|
| 82 |
|
|
# XXX Kludge around some wierness with generating our own |
| 83 |
|
|
# URI interacting with cookies. |
| 84 |
|
|
my $uri_str = "$proto://$host/$directory"; |
| 85 |
|
|
my $request = HTTP::Request->new("GET" => $uri_str) || |
| 86 |
|
|
&{$ht_lose}("HTTP::Request create failure"); |
| 87 |
|
|
my $uri = $request->uri(); |
| 88 |
|
|
$uri->port($port) if(defined($port)); |
| 89 |
|
|
|
| 90 |
|
|
my $response = $user_agent->request($request) || |
| 91 |
|
|
&{$ht_lose}("UserAgent request failure"); |
| 92 |
|
|
|
| 93 |
|
|
unless($response->is_success) { |
| 94 |
|
|
&{$ht_lose}("Request failed:", $response->message); |
| 95 |
|
|
} |
| 96 |
|
|
|
| 97 |
|
|
my $strref = $response->content_ref; |
| 98 |
|
|
if(!$opt_z && length($$strref) == 0) { |
| 99 |
|
|
&{$ht_lose}("Empty document"); |
| 100 |
|
|
} |
| 101 |
|
|
|
| 102 |
|
|
if(defined($regex)) { |
| 103 |
|
|
my $winning; |
| 104 |
|
|
map {$winning++ if(/$regex/);} split("\n", $$strref); |
| 105 |
|
|
if($opt_v) { |
| 106 |
|
|
&{$ht_lose}("Failure regex matches:", $winning) if($winning); |
| 107 |
|
|
} elsif(!$winning) { |
| 108 |
|
|
&{$ht_lose}("Regex not found"); |
| 109 |
|
|
} |
| 110 |
|
|
} |
| 111 |
|
|
} |
| 112 |
|
|
if(@failed) { |
| 113 |
|
|
print "$u_proto Failures: " . join(" ", @failed) . "\n"; |
| 114 |
|
|
foreach my $fail (@failed) { |
| 115 |
|
|
print "$fail: $failure{$fail}\n"; |
| 116 |
|
|
} |
| 117 |
|
|
exit(1); |
| 118 |
|
|
} |
| 119 |
|
|
exit; |
| 120 |
|
|
} |
| 121 |
|
|
|
| 122 |
|
|
sub lose { |
| 123 |
|
|
die join(" ", @_); |
| 124 |
|
|
} |
| 125 |
|
|
|
| 126 |
|
|
sub do_usage { |
| 127 |
|
|
my $extended = shift; |
| 128 |
|
|
|
| 129 |
|
|
my $base = basename $0; |
| 130 |
|
|
print STDERR "Usage: $base [options...] hosts ...\n"; |
| 131 |
|
|
if($extended) { |
| 132 |
|
|
print <<'EOF'; |
| 133 |
|
|
-h Help. You're reading it. |
| 134 |
|
|
-d URL URL to test on the remote host. Default is /. |
| 135 |
|
|
-p PORT Port to connect to. Default is proto specific. |
| 136 |
|
|
-P PROTO Protocol to fetch. Default is http. |
| 137 |
|
|
-s Fetch via https. Equivalent to -P https. |
| 138 |
|
|
-t TIMEOUT Timeout for the fetch. Default is 60 seconds. |
| 139 |
|
|
-r REGEX A regular expression that the retrieved content must match. |
| 140 |
|
|
-v Invert the regular expression. Content must NOT match. |
| 141 |
|
|
-z Supress zero-length check. |
| 142 |
|
|
-c Enable Cookies. |
| 143 |
|
|
EOF |
| 144 |
|
|
} |
| 145 |
|
|
exit 1; |
| 146 |
|
|
} |
| 147 |
|
|
|
| 148 |
|
|
### |
| 149 |
|
|
|
| 150 |
|
|
getopts("hszvcp:t:d:r:P:") || do_usage(); |
| 151 |
|
|
do_usage($opt_h) if($opt_h); |
| 152 |
|
|
|
| 153 |
|
|
&main(@ARGV); |
| 154 |
|
|
|
| 155 |
|
|
# EOF |
Parent Directory
| 
Revision Log