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 = <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