24 use Pod::Usage; |
24 use Pod::Usage; |
25 use File::Basename; |
25 use File::Basename; |
26 use if $ENV{DEBUG} => "Smart::Comments"; |
26 use if $ENV{DEBUG} => "Smart::Comments"; |
27 use POSIX qw(:sys_wait_h setsid); |
27 use POSIX qw(:sys_wait_h setsid); |
28 use Cwd qw(abs_path getcwd); |
28 use Cwd qw(abs_path getcwd); |
|
29 use Authen::Simple::Passwd; |
|
30 use MIME::Base64 qw(decode_base64); |
|
31 use IO::Socket::INET; |
|
32 use IO::Socket::SSL; |
29 |
33 |
30 my $ME = basename $0; |
34 my $ME = basename $0; |
31 |
35 |
32 my $opt_addr = "0.0.0.0"; |
36 my $opt_addr = "0.0.0.0"; |
33 my $opt_auth = 1; |
37 my $opt_auth = $ME; |
34 my $opt_port = 8080; |
38 my $opt_port = 8080; |
35 my $opt_lines = 10; |
39 my $opt_lines = 10; |
36 my $opt_daemon = 1; |
40 my $opt_daemon = 1; |
37 my $opt_kill = 0; |
41 my $opt_kill = 0; |
38 my $opt_debug = 0; |
42 my $opt_debug = 0; |
39 my $opt_htpasswd = "htpasswd"; |
43 my $opt_htpasswd = "htpasswd"; |
40 my $opt_realm = $ME; |
|
41 my $opt_ssl = 1; |
44 my $opt_ssl = 1; |
42 my $opt_ssl_cert = "crt.pem"; |
45 my $opt_ssl_cert = "crt.pem"; |
43 my $opt_ssl_key = "key.pem"; |
46 my $opt_ssl_key = "key.pem"; |
44 |
47 |
45 # these vars will be filled with the real dirs later |
48 # these vars will be filled with the real dirs later |
57 # remember the pid that is actually written to the pid file so we can ensure |
60 # remember the pid that is actually written to the pid file so we can ensure |
58 # that only the process with that pid is attempting to remove the pidfile at |
61 # that only the process with that pid is attempting to remove the pidfile at |
59 # exit |
62 # exit |
60 my $masterpid; |
63 my $masterpid; |
61 |
64 |
62 # usernames & password hashes |
|
63 my $authdata; |
|
64 |
|
65 # attempt to generalize some interface differences between |
|
66 # IO::Socket::{INET,SSL}; currently we need to pass an SSL specific argument |
|
67 # when closing an SSL Socket to avoid affecting the socket in |
|
68 # parent(s)/children; passing unknown arguments to the 'close' method of non |
|
69 # SSL Sockets would result in an runtime error; error reporting is also done |
|
70 # differently; currently we achieve that by setting @ISA in the constructor to |
|
71 # either qw(IO::Socket::INET) or qw(IO::Socket::SSL); that means you cant mix |
|
72 # SSL and non SSL Sockets in the program (@ISA is a class variable); using just |
|
73 # IO::Socket::SSL would (probably) require more coding and certainly more |
|
74 # background knowledge and might not even address the problems we work around |
|
75 # here |
|
76 END { |
65 END { |
77 unlink $pidfile |
66 unlink $pidfile |
78 if defined $pidfile |
67 if defined $pidfile |
79 and not ref $pidfile |
68 and not ref $pidfile |
80 and defined $masterpid |
69 and defined $masterpid |
90 sub http($@); |
79 sub http($@); |
91 |
80 |
92 sub bad_request(); |
81 sub bad_request(); |
93 sub date1123(;$); |
82 sub date1123(;$); |
94 |
83 |
|
84 sub authenticated($$); |
|
85 |
95 my %FILE; |
86 my %FILE; |
96 |
87 |
97 MAIN: { |
88 MAIN: { |
98 |
89 |
99 GetOptions( |
90 GetOptions( |
100 "addr=s" => \$opt_addr, |
91 "addr=s" => \$opt_addr, |
101 "auth!" => \$opt_auth, |
92 "auth:s" => sub { $opt_auth = $_[1] eq '' ? $ME : $_[1] }, |
102 "port=i" => \$opt_port, |
93 "noauth" => sub { undef $opt_auth }, |
103 "lines=i" => \$opt_lines, |
94 "port=i" => \$opt_port, |
104 "daemon!" => \$opt_daemon, |
95 "lines=i" => \$opt_lines, |
105 "debug!" => \$opt_debug, |
96 "daemon!" => \$opt_daemon, |
106 "kill" => \$opt_kill, |
97 "debug!" => \$opt_debug, |
107 "help" => sub { pod2usage(-verbose => 1, -exitval => 0) }, |
98 "kill" => \$opt_kill, |
108 "man" => sub { pod2usage(-verbose => 2, -exitval => 0) }, |
99 "help" => sub { pod2usage(-verbose => 1, -exitval => 0) }, |
|
100 "man" => sub { pod2usage(-verbose => 2, -exitval => 0) }, |
109 "htpasswd=s" => \$opt_htpasswd, |
101 "htpasswd=s" => \$opt_htpasswd, |
110 "realm=s" => \$opt_realm, |
|
111 "ssl!" => \$opt_ssl, |
102 "ssl!" => \$opt_ssl, |
112 "ssl-cert=s" => \$opt_ssl_cert, |
103 "ssl-cert=s" => \$opt_ssl_cert, |
113 "ssl-key=s" => \$opt_ssl_key |
104 "ssl-key=s" => \$opt_ssl_key |
114 ) or pod2usage(); |
105 ) or pod2usage(); |
115 |
106 |
116 $IO::Socket::hlog::DEBUG = $opt_debug; |
|
117 |
|
118 if ($opt_kill) { |
107 if ($opt_kill) { |
119 $opt_auth = 0; |
108 $opt_auth = 0; |
120 $opt_ssl = 0; |
109 $opt_ssl = 0; |
121 } |
110 } |
122 |
111 |
123 foreach ($opt_ssl_key, $opt_ssl_cert) { |
112 foreach ($opt_htpasswd, $opt_ssl_key, $opt_ssl_cert) { |
124 $_ = abs_path($_) if defined; |
113 $_ = abs_path($_) if defined; |
125 } |
114 } |
126 |
115 |
127 ### $opt_ssl_key |
116 ### $opt_ssl_key |
128 ### $opt_ssl_cert |
117 ### $opt_ssl_cert |
129 |
118 ### $opt_auth |
130 $authdata = new Authen::hlog(filename => $opt_htpasswd, realm => $opt_realm) |
|
131 if $opt_auth; |
|
132 |
119 |
133 if (defined($logdir = find_writable_dir(@$logdir))) { |
120 if (defined($logdir = find_writable_dir(@$logdir))) { |
134 $access = sprintf $$access, $logdir; |
121 $access = sprintf $$access, $logdir; |
135 $errors = sprintf $$errors, $logdir; |
122 $errors = sprintf $$errors, $logdir; |
136 log_open($access); |
123 log_open($access); |
317 |
304 |
318 # number of lines and tag to show |
305 # number of lines and tag to show |
319 my $lines = (s/(\d+)$// ? $1 : $opt_lines); |
306 my $lines = (s/(\d+)$// ? $1 : $opt_lines); |
320 my $tag = (s/^\/*(\w+)// ? $1 : "default"); |
307 my $tag = (s/^\/*(\w+)// ? $1 : "default"); |
321 |
308 |
322 my $authorized; |
309 my $authenticated = defined $opt_auth ? 0 : 1; |
323 $authorized = 1 unless $opt_auth; |
310 ### $authenticated |
324 |
311 |
325 # read and verify (first) authentication header and discard any other headers |
312 # read and verify (first) authentication header and discard any other headers |
326 while (<$client>) { |
313 while (<$client>) { |
327 |
|
328 if (!defined $authorized |
|
329 && /^Authorization: Basic ([[:alnum:]+\/=]+)\r?$/) |
|
330 { |
|
331 $authorized = $authdata->verify_base64($1); |
|
332 log_write("authentication failure from " . $client->peerhost) |
|
333 unless $authorized; |
|
334 } |
|
335 last if /^\s*$/; |
314 last if /^\s*$/; |
336 |
315 next if $authenticated; |
337 } |
316 |
338 |
317 if (/^Authorization:\s+Basic\s+([[:alnum:]+\/=]+)\r?$/) { |
339 unless ($authorized) { |
318 $authenticated = authenticate($opt_htpasswd => $1) |
|
319 or log_write("authentication failure from " . $client->peerhost); |
|
320 } |
|
321 |
|
322 } |
|
323 ### $authenticated |
|
324 |
|
325 unless ($authenticated) { |
340 |
326 |
341 $client->print( |
327 $client->print( |
342 http { |
328 http { |
343 code => "401 Unauthorized", |
329 code => "401 Unauthorized", |
344 headers => { |
330 headers => |
345 "WWW-Authenticate" => "Basic realm=\"$authdata->{realm}\"" |
331 { "WWW-Authenticate" => "Basic realm=\"$opt_auth\"", } |
346 } |
|
347 }, |
332 }, |
348 "not authorized" |
333 "not authorized" |
349 ); |
334 ); |
350 return; |
335 return; |
351 |
336 |
466 </p> |
451 </p> |
467 </body></html> |
452 </body></html> |
468 __EOF |
453 __EOF |
469 } |
454 } |
470 |
455 |
471 # PACKAGES |
456 sub authenticate($$) { |
472 { |
457 my ($htpasswd, $userinfo) = @_; |
473 |
458 my $auth = new Authen::Simple::Passwd(path => $htpasswd) |
474 # authentication |
459 or die "Can't open \"$htpasswd\": $!\n"; |
475 package Authen::hlog; |
460 $auth->authenticate(split /:/, decode_base64($userinfo)); |
476 |
|
477 use Crypt::PasswdMD5; |
|
478 use Digest::SHA1 qw(sha1_base64); |
|
479 use MIME::Base64 qw(decode_base64); |
|
480 |
|
481 sub new { |
|
482 |
|
483 my $class = shift; |
|
484 |
|
485 my $self = {@_}; |
|
486 |
|
487 die "At least one of 'filename' or 'authdata' parameters is required" |
|
488 unless $self->{filename} || $self->{authdata}; |
|
489 |
|
490 bless $self, $class; |
|
491 $self->authdata if $self->{filename}; |
|
492 |
|
493 return $self; |
|
494 |
|
495 } |
|
496 |
|
497 sub verify_base64 { |
|
498 |
|
499 my $self = shift; |
|
500 return $self->verify(split /:/, decode_base64($_[0])); |
|
501 |
|
502 } |
|
503 |
|
504 sub verify { |
|
505 |
|
506 my $self = shift; |
|
507 |
|
508 my ($u, $p) = @_; |
|
509 |
|
510 my $hp = $self->{authdata}->{$u}; |
|
511 |
|
512 # crypt? |
|
513 if (length $hp == 13) { |
|
514 return crypt($p, $hp) eq $hp; |
|
515 |
|
516 # apache md5? |
|
517 } |
|
518 elsif (length $hp == 37 && $hp =~ /^\$apr/) { |
|
519 return apache_md5_crypt($p, $hp) eq $hp; |
|
520 } |
|
521 elsif ($hp =~ s/^\{SHA\}//) { |
|
522 |
|
523 # remove trailing equality signs because sha1_base64 refuses to add any |
|
524 $hp =~ s/=*$//; |
|
525 return sha1_base64($p) eq $hp; |
|
526 } |
|
527 else { |
|
528 warn "unknown hash format: >>>$hp<<<"; |
|
529 } |
|
530 |
|
531 return; |
|
532 |
|
533 } |
|
534 |
|
535 sub authdata { |
|
536 |
|
537 my $self = shift; |
|
538 |
|
539 my ($htpasswd) = @_ || $self->{filename} || die "Missing filename"; |
|
540 |
|
541 $self->{authdata} = {}; |
|
542 |
|
543 open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!"; |
|
544 while (my $line = <H>) { |
|
545 |
|
546 chomp $line; |
|
547 |
|
548 # htpasswd lines may have more than 2 fields |
|
549 my ($u, $p) = split /:/, $line, 3; |
|
550 |
|
551 unless ($u && $p) { |
|
552 warn "invalid htpasswd line in '$htpasswd' at line $."; |
|
553 next; |
|
554 } |
|
555 |
|
556 warn |
|
557 "duplicate user '$u' in '$htpasswd' at line $. - overriding previous record" |
|
558 if exists $self->{authdata}->{$u}; |
|
559 $self->{authdata}->{$u} = $p; |
|
560 |
|
561 } |
|
562 |
|
563 close H or warn "Cant close '<$htpasswd': $!"; |
|
564 |
|
565 warn "no authentication data found" unless %{ $self->{authdata} }; |
|
566 |
|
567 return $self->{authdata}; |
|
568 |
|
569 } |
|
570 } |
461 } |
571 |
462 |
572 __END__ |
463 __END__ |
573 |
464 |
574 =head1 NAME |
465 =head1 NAME |
581 [--[no]debug] |
472 [--[no]debug] |
582 [-k|--kill] |
473 [-k|--kill] |
583 [-a|--address address] [-p|--port port] |
474 [-a|--address address] [-p|--port port] |
584 [--lines n] |
475 [--lines n] |
585 [--htpasswd path] |
476 [--htpasswd path] |
586 [--realm realm] |
|
587 [--[no]ssl] |
477 [--[no]ssl] |
|
478 [--auth=[realm] | --noauth] |
588 [--ssl-cert path] |
479 [--ssl-cert path] |
589 [--ssl-key path] |
480 [--ssl-key path] |
590 {file|tag=file ...} |
481 {file|tag=file ...} |
591 |
482 |
592 hlog [-h|--help] [-m|--man] |
483 hlog [-h|--help] [-m|--man] |
593 |
484 |
594 =head1 DESCRIPTION |
485 =head1 DESCRIPTION |
595 |
486 |
596 This script should run as a server providing access to |
487 This script should run as a server providing access to |
597 the last lines of a logfile. It should understand basic HTTP(S)/1.x. |
488 the last lines of a logfile. It understands basic HTTP(S)/1.x. |
598 |
489 |
599 See the L<FILES> section for more information on files. |
490 See the L<FILES> section for more information on files. |
600 |
491 |
601 =head1 OPTIONS |
492 =head1 OPTIONS |
602 |
493 |
604 |
495 |
605 =item B<-a>|B<--address> I<address> |
496 =item B<-a>|B<--address> I<address> |
606 |
497 |
607 The address to listen on. (default: 0.0.0.0) |
498 The address to listen on. (default: 0.0.0.0) |
608 |
499 |
609 =item B<--[no]auth> |
500 =item B<--auth>[ I<realm>] | B<--noauth> |
610 |
501 |
611 Do (or do not) authorize all access. (default: do) |
502 Do (or do not) authorize all access. Optional you may pass the |
|
503 name of a authentication realm. (default: do, realm is hlog) |
612 |
504 |
613 =item B<--[no]daemon> |
505 =item B<--[no]daemon> |
614 |
506 |
615 Do (or do not) daemonize. (default: do) |
507 Do (or do not) daemonize. (default: do) |
616 |
508 |