--- a/hlog.pl Wed Nov 25 16:51:14 2009 +0100
+++ b/hlog.pl Tue Dec 01 10:32:16 2009 +0100
@@ -26,19 +26,21 @@
use POSIX qw(:sys_wait_h setsid);
use Cwd;
+my $ME = basename $0;
+
my $opt_addr = "0.0.0.0";
+my $opt_auth = 1;
my $opt_port = 8080;
my $opt_lines = 10;
my $opt_daemon = 1;
my $opt_kill = 0;
my $opt_debug = 0;
my $opt_htpasswd = "htpasswd";
+my $opt_realm = $ME;
my $opt_ssl = 1;
my $opt_ssl_cert = "crt.pem";
my $opt_ssl_key = "key.pem";
-my $ME = basename $0;
-
# these vars will be filled with the real dirs later
my $rundir = [ "/var/run/$ME", "$ENV{HOME}/.$ME" ];
my $logdir = [ "/var/log/$ME", "$ENV{HOME}/.$ME" ];
@@ -56,6 +58,8 @@
# exit
my $masterpid;
+# usernames & password hashes
+my $authdata;
# attempt to generalize some interface differences between
# IO::Socket::{INET,SSL}; currently we need to pass an SSL specific argument
@@ -143,6 +147,96 @@
}
+# authentication
+package Authen::hlog;
+
+use Crypt::PasswdMD5;
+use Digest::SHA1 qw(sha1_base64);
+use MIME::Base64 qw(decode_base64);
+
+sub new {
+
+ my $class = shift;
+
+ my $self = { @_ };
+
+ die "At least one of 'filename' or 'authdata' parameters is required" unless $self->{filename} || $self->{authdata};
+
+ bless $self, $class;
+ $self->authdata if $self->{filename};
+
+ return $self;
+
+}
+
+sub verify_base64 {
+
+ my $self = shift;
+ return $self->verify(split /:/, decode_base64($_[0]));
+
+}
+
+
+sub verify {
+
+ my $self = shift;
+
+ my ($u, $p) = @_;
+
+ my $hp = $self->{authdata}->{$u};
+
+ # crypt?
+ if (length $hp == 13) {
+ return crypt ($p, $hp) eq $hp;
+ # apache md5?
+ } elsif (length $hp == 37 && $hp =~ /^\$apr/) {
+ return apache_md5_crypt ($p, $hp) eq $hp;
+ } elsif ($hp =~ s/^\{SHA\}//) {
+ # remove trailing equality signs because sha1_base64 refuses to add any
+ $hp =~ s/=*$//;
+ return sha1_base64($p) eq $hp;
+ } else {
+ warn "unknown hash format: >>>$hp<<<";
+ }
+
+ return;
+
+}
+
+sub authdata {
+
+ my $self = shift;
+
+ my ($htpasswd) = @_ || $self->{filename} || die "Missing filename";
+
+ $self->{authdata} = {};
+
+ open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!";
+ while (my $line = <H>) {
+
+ chomp $line;
+ # htpasswd lines may have more than 2 fields
+ my ($u, $p) = split /:/, $line, 3;
+
+ unless ($u && $p) {
+ warn "invalid htpasswd line in '$htpasswd' at line $.";
+ next;
+ }
+
+ warn "duplicate user '$u' in '$htpasswd' at line $. - overriding previous record" if exists $self->{authdata}->{$u};
+ $self->{authdata}->{$u} = $p;
+
+ }
+
+ close H or warn "Cant close '<$htpasswd': $!";
+
+ warn "no authentication data found" unless %{$self->{authdata}};
+
+ return $self->{authdata};
+
+}
+
+# back to main package
package main;
END {
@@ -167,6 +261,7 @@
GetOptions(
"addr=s" => \$opt_addr,
+ "auth!" => \$opt_auth,
"port=i" => \$opt_port,
"lines=i" => \$opt_lines,
"daemon!" => \$opt_daemon,
@@ -174,7 +269,8 @@
"kill" => \$opt_kill,
"help" => sub { pod2usage(-verbose => 1, -exitval => 0) },
"man" => sub { pod2usage(-verbose => 2, -exitval => 0) },
- "htpasswd=s" => \$opt_htpasswd,
+ "htpasswd=s" => \$opt_htpasswd,
+ "realm=s" => \$opt_realm,
"ssl!" => \$opt_ssl,
"ssl-cert=s" => \$opt_ssl_cert,
"ssl-key=s" => \$opt_ssl_key
@@ -182,6 +278,8 @@
$IO::Socket::hlog::DEBUG = $opt_debug;
+ $authdata = new Authen::hlog(filename => $opt_htpasswd, realm => $opt_realm) if $opt_auth;
+
if (defined($logdir = find_writable_dir(@$logdir))) {
$access = sprintf $$access, $logdir;
$errors = sprintf $$errors, $logdir;
@@ -363,8 +461,28 @@
my $lines = (s/(\d+)$// ? $1 : $opt_lines);
my $tag = (s/^\/*(\w+)// ? $1 : "default");
- # read the header(s) and discard
- while (<$client>) { last if /^\s*$/ }
+ my $authorized;
+ $authorized = 1 unless $opt_auth;
+ # read and verify (first) authentication header and discard any other headers
+ while (<$client>) {
+
+ if (!defined $authorized && /^Authorization: Basic ([[:alnum:]+\/=]+)\r?$/) {
+ $authorized = $authdata->verify_base64($1);
+ log_write("authentication failure from " . $client->peerhost) unless $authorized;
+ }
+ last if /^\s*$/;
+
+ }
+
+ unless ($authorized) {
+
+ $client->print(http {
+ code => "401 Unauthorized",
+ headers => { "WWW-Authenticate" => "Basic realm=\"$authdata->{realm}\"" }
+ }, "not authorized");
+ return;
+
+ }
if (not exists $FILE{$tag}) {
$client->print(http "500 unknown file tag",
@@ -428,8 +546,23 @@
}
sub http($@) {
- my $code = shift;
- my $date = date1123();
+
+ my ($headers, $code, $date) = ('');
+
+ if (ref $_[0] eq "HASH") {
+
+ my $h;
+ ($code, $date, $h) = @{$_[0]}{'code', 'date', 'headers'};
+ $headers = ( join "\n", map { "$_: $h->{$_}" } keys %{$h} ) . "\n" if defined $h;
+ shift;
+
+ } else {
+
+ $code = shift;
+
+ }
+
+ $date ||= date1123();
my $type = $_[0] =~ /^<!DOCTYPE HTML/ ? "text/html" : "text/plain";
@@ -438,7 +571,7 @@
Date: $date
Connection: close
Content-Type: $type
-
+$headers
__EOF
}
@@ -479,6 +612,7 @@
[-a|--address address] [-p|--port port]
[--lines n]
[--htpasswd path]
+ [--realm realm]
[--[no]ssl]
[--ssl-cert path]
[--ssl-key path]
@@ -501,6 +635,10 @@
The address to listen on. (default: 0.0.0.0)
+=item B<--[no]auth>
+
+Do (or do not) authorize all access. (default: do)
+
=item B<--[no]daemon>
Do (or do not) daemonize. (default: do)
@@ -511,7 +649,7 @@
=item B<--htpasswd> I<path>
-Path to alternate htpasswd file (default: htpasswd)
+Path to alternate htpasswd file (default: htpasswd).
=item B<-k>|B<--kill>
@@ -526,6 +664,10 @@
The port to listen on. (default: 8080)
+=item B<--realm> I<realm>
+
+Alternate Name for the HTTP Authentication realm parameter (default: basename($0))
+
=item B<--[no]ssl>
Enable (or disable) https connections (default: enabled)
@@ -577,6 +719,6 @@
=head1 BUGS / TODO
-This tool should understand basic HTTP authentication.
+No known bugs.
=cut