hlog: comparison hlog.pl

equal deleted inserted replaced

-:22104f5d42ca
+:99e8455f50dc
 use Pod::Usage;
 use File::Basename;
 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" ];
 # remember the pid that is actually written to the pid file so we can ensure
 # that only the process with that pid is attempting to remove the pidfile at
 # 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
 # when closing an SSL Socket to avoid affecting the socket in
 # parent(s)/children; passing unknown arguments to the 'close' method of non
 my $self = shift;
 return $ISA[0] eq "IO::Socket::SSL";
 }
+# 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 {
 unlink $pidfile
 if defined $pidfile and not ref $pidfile and defined $masterpid and $masterpid == $$;
 MAIN: {
 GetOptions(
 "addr=s"     => \$opt_addr,
+"auth!"      => \$opt_auth,
 "port=i"     => \$opt_port,
 "lines=i"    => \$opt_lines,
 "daemon!"    => \$opt_daemon,
 "debug!"     => \$opt_debug,
 "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
 ) or pod2usage();
 $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;
 log_open($access);
 # number of lines and tag to show
 my $lines = (s/(\d+)$//    ? $1 : $opt_lines);
 my $tag   = (s/^\/*(\w+)// ? $1 : "default");
-# read the header(s) and discard
+my $authorized;
-while (<$client>) { last if /^\s*$/ }
+$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",
 "Sorry, unknown file tag \"$tag\"");
 log_write("unknown tag $tag");
 seek($r{fh}, 0, 0);
 return %r;
 }
 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";
 return <<__EOF, @_;
 HTTP/1.1 $code
 Date: $date
 Connection: close
 Content-Type: $type
+$headers
 __EOF
 }
 sub date1123(;$) {
 my @now = gmtime(@_ ? shift : time);
 [--[no]debug]
 	 [-k|--kill]
 [-a|--address address] [-p|--port port]
 	 [--lines n]
 [--htpasswd path]
+[--realm realm]
 [--[no]ssl]
 [--ssl-cert path]
 [--ssl-key path]
 	 {file|tag=file ...}
 =item B<-a>|B<--address> I<address>
 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)
 =item B<--[no]debug>
 Do (or do not) print debug information to STDOUT/ERR and logfile. (default: dont)
 =item B<--htpasswd> I<path>
-Path to alternate htpasswd file (default: htpasswd)
+Path to alternate htpasswd file (default: htpasswd).
 =item B<-k>|B<--kill>
 With this option the corresponding (address/port) process gets killed.
 (default: off)
 The number of lines to show. (default: 10)
 =item B<-p>|B<--port> I<port>
 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)
 beeing used. For safety the hostname will be sanitized to avoid
 dangerous filenames.
 =head1 BUGS / TODO
-This tool should understand basic HTTP authentication.
+No known bugs.
 =cut

branch	foerste
changeset 40	99e8455f50dc
parent 39	22104f5d42ca
child 42	97c0f39be179