--- a/hlog.pl Tue Dec 01 10:33:26 2009 +0100
+++ b/hlog.pl Tue Dec 29 11:23:22 2009 +0100
@@ -42,8 +42,8 @@
my $opt_ssl_key = "key.pem";
# 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" ];
+my $rundir = ["/var/run/$ME", "$ENV{HOME}/.$ME"];
+my $logdir = ["/var/log/$ME", "$ENV{HOME}/.$ME"];
my $maxlogsize = 1_000_000; # ca 1 MByte
my $killtimeout = 3;
@@ -51,7 +51,7 @@
# these are refs to detect if they're converted already
my $access = \"%s/access.log";
my $errors = \"%s/error.log";
-my $pidfile = \"%s/%s.%s.pid"; # %dir/%ip.%port
+my $pidfile = \"%s/%s.%s.pid"; # %dir/%ip.%port
# 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
@@ -81,69 +81,70 @@
sub new {
- my $class = shift;
-
- my %args = @_;
- my $ssl = delete $args{SSL};
+ my $class = shift;
+
+ my %args = @_;
+ my $ssl = delete $args{SSL};
- if ($ssl) {
+ if ($ssl) {
- @ISA = qw(IO::Socket::SSL);
- $IO::Socket::SSL::DEBUG = $DEBUG ? 3 : 0;
+ @ISA = qw(IO::Socket::SSL);
+ $IO::Socket::SSL::DEBUG = $DEBUG ? 3 : 0;
- } else {
+ }
+ else {
- %args = _delete_ssl_args(%args);
- @ISA = qw(IO::Socket::INET);
+ %args = _delete_ssl_args(%args);
+ @ISA = qw(IO::Socket::INET);
- }
+ }
- my $self;
- unless ($self = $class->SUPER::new(%args)) {
+ my $self;
+ unless ($self = $class->SUPER::new(%args)) {
- return;
+ return;
- }
+ }
- print "$class: $self created\n" if $DEBUG;
+ print "$class: $self created\n" if $DEBUG;
- return $self;
+ return $self;
}
sub close {
- my $self = shift;
- print "$self: closing\n" if $DEBUG;
+ my $self = shift;
+ print "$self: closing\n" if $DEBUG;
- my %args = @_;
+ my %args = @_;
- %args = _delete_ssl_args(%args) unless $self->_is_ssl;
+ %args = _delete_ssl_args(%args) unless $self->_is_ssl;
- return $self->SUPER::close(%args);
+ return $self->SUPER::close(%args);
}
sub errstr {
- return IO::Socket::SSL::errstr if _is_ssl();
+ return IO::Socket::SSL::errstr if _is_ssl();
- return $@;
+ return $@;
}
sub _delete_ssl_args {
- my %args = @_;
- map { delete $args{$_} if /^SSL/; } keys %args;
- return %args;
+ my %args = @_;
+ map { delete $args{$_} if /^SSL/; } keys %args;
+ return %args;
}
sub _is_ssl {
- my $self = shift;
- return $ISA[0] eq "IO::Socket::SSL";
+ my $self = shift;
+ return $ISA[0] eq "IO::Socket::SSL";
}
@@ -156,84 +157,92 @@
sub new {
- my $class = shift;
-
- my $self = { @_ };
+ my $class = shift;
+
+ my $self = {@_};
- die "At least one of 'filename' or 'authdata' parameters is required" unless $self->{filename} || $self->{authdata};
+ die "At least one of 'filename' or 'authdata' parameters is required"
+ unless $self->{filename} || $self->{authdata};
- bless $self, $class;
- $self->authdata if $self->{filename};
+ bless $self, $class;
+ $self->authdata if $self->{filename};
- return $self;
+ return $self;
}
sub verify_base64 {
- my $self = shift;
- return $self->verify(split /:/, decode_base64($_[0]));
+ my $self = shift;
+ return $self->verify(split /:/, decode_base64($_[0]));
}
-
sub verify {
- my $self = shift;
+ my $self = shift;
+
+ my ($u, $p) = @_;
- my ($u, $p) = @_;
+ my $hp = $self->{authdata}->{$u};
- my $hp = $self->{authdata}->{$u};
+ # crypt?
+ if (length $hp == 13) {
+ return crypt($p, $hp) eq $hp;
- # 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<<<";
- }
+ # apache md5?
+ }
+ elsif (length $hp == 37 && $hp =~ /^\$apr/) {
+ return apache_md5_crypt($p, $hp) eq $hp;
+ }
+ elsif ($hp =~ s/^\{SHA\}//) {
- return;
+ # 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 $self = shift;
+
+ my ($htpasswd) = @_ || $self->{filename} || die "Missing filename";
- my ($htpasswd) = @_ || $self->{filename} || die "Missing filename";
+ $self->{authdata} = {};
- $self->{authdata} = {};
+ open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!";
+ while (my $line = <H>) {
+
+ chomp $line;
- open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!";
- while (my $line = <H>) {
+ # htpasswd lines may have more than 2 fields
+ my ($u, $p) = split /:/, $line, 3;
- 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;
+ }
- 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;
+
}
- 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': $!";
- close H or warn "Cant close '<$htpasswd': $!";
+ warn "no authentication data found" unless %{ $self->{authdata} };
- warn "no authentication data found" unless %{$self->{authdata}};
+ return $self->{authdata};
- return $self->{authdata};
-
}
# back to main package
@@ -241,7 +250,10 @@
END {
unlink $pidfile
- if defined $pidfile and not ref $pidfile and defined $masterpid and $masterpid == $$;
+ if defined $pidfile
+ and not ref $pidfile
+ and defined $masterpid
+ and $masterpid == $$;
}
sub find_writable_dir(@);
@@ -278,7 +290,8 @@
$IO::Socket::hlog::DEBUG = $opt_debug;
- $authdata = new Authen::hlog(filename => $opt_htpasswd, realm => $opt_realm) if $opt_auth;
+ $authdata = new Authen::hlog(filename => $opt_htpasswd, realm => $opt_realm)
+ if $opt_auth;
if (defined($logdir = find_writable_dir(@$logdir))) {
$access = sprintf $$access, $logdir;
@@ -337,12 +350,11 @@
Listen => 1,
ReuseAddr => 1,
SSL => $opt_ssl,
- SSL_key_file => $opt_ssl_key,
+ SSL_key_file => $opt_ssl_key,
SSL_cert_file => $opt_ssl_cert,
debug => $opt_debug
) or die "Can't create listener socket: ", IO::Socket::hlog::errstr, "\n";
-
# go daemon
chdir("/") or die "Can't chdir to /: $!\n";
@@ -463,24 +475,33 @@
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*$/;
-
+
+ # 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;
+ $client->print(
+ http {
+ code => "401 Unauthorized",
+ headers => {
+ "WWW-Authenticate" => "Basic realm=\"$authdata->{realm}\""
+ }
+ },
+ "not authorized"
+ );
+ return;
}
@@ -551,17 +572,19 @@
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;
+ 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";
@@ -578,10 +601,10 @@
sub date1123(;$) {
my @now = gmtime(@_ ? shift : time);
sprintf "%s, %2d %s %4d %02d:%02d:%02d GMT",
- qw(Sun Mon Tue Wed Thu Fri Sat Sun) [ $now[6] ],
+ qw(Sun Mon Tue Wed Thu Fri Sat Sun) [$now[6]],
$now[3],
- qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) [ $now[4] ],
- $now[5] + 1900, @now[ 2, 1, 0 ];
+ qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) [$now[4]],
+ $now[5] + 1900, @now[2, 1, 0];
}
sub bad_request() {