diff -r 22104f5d42ca -r 99e8455f50dc hlog.pl --- 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 = ) { + + 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] =~ /^ + +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 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 + +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