70 # either qw(IO::Socket::INET) or qw(IO::Socket::SSL); that means you cant mix |
70 # either qw(IO::Socket::INET) or qw(IO::Socket::SSL); that means you cant mix |
71 # SSL and non SSL Sockets in the program (@ISA is a class variable); using just |
71 # SSL and non SSL Sockets in the program (@ISA is a class variable); using just |
72 # IO::Socket::SSL would (probably) require more coding and certainly more |
72 # IO::Socket::SSL would (probably) require more coding and certainly more |
73 # background knowledge and might not even address the problems we work around |
73 # background knowledge and might not even address the problems we work around |
74 # here |
74 # here |
75 { |
|
76 |
|
77 package IO::Socket::hlog; |
|
78 |
|
79 use IO::Socket::INET; |
|
80 use IO::Socket::SSL; |
|
81 |
|
82 our (@ISA, $DEBUG); |
|
83 |
|
84 sub new { |
|
85 |
|
86 my $class = shift; |
|
87 |
|
88 my %args = @_; |
|
89 my $ssl = delete $args{SSL}; |
|
90 |
|
91 if ($ssl) { |
|
92 |
|
93 @ISA = qw(IO::Socket::SSL); |
|
94 $IO::Socket::SSL::DEBUG = $DEBUG ? 3 : 0; |
|
95 |
|
96 } |
|
97 else { |
|
98 |
|
99 %args = _delete_ssl_args(%args); |
|
100 @ISA = qw(IO::Socket::INET); |
|
101 |
|
102 } |
|
103 |
|
104 my $self; |
|
105 unless ($self = $class->SUPER::new(%args)) { |
|
106 |
|
107 return; |
|
108 |
|
109 } |
|
110 |
|
111 print "$class: $self created\n" if $DEBUG; |
|
112 |
|
113 return $self; |
|
114 |
|
115 } |
|
116 |
|
117 sub close { |
|
118 |
|
119 my $self = shift; |
|
120 print "$self: closing\n" if $DEBUG; |
|
121 |
|
122 my %args = @_; |
|
123 |
|
124 %args = _delete_ssl_args(%args) unless $self->_is_ssl; |
|
125 |
|
126 return $self->SUPER::close(%args); |
|
127 |
|
128 } |
|
129 |
|
130 sub errstr { |
|
131 |
|
132 return IO::Socket::SSL::errstr if _is_ssl(); |
|
133 |
|
134 return $@; |
|
135 |
|
136 } |
|
137 |
|
138 sub _delete_ssl_args { |
|
139 |
|
140 my %args = @_; |
|
141 map { delete $args{$_} if /^SSL/; } keys %args; |
|
142 return %args; |
|
143 |
|
144 } |
|
145 |
|
146 sub _is_ssl { |
|
147 |
|
148 my $self = shift; |
|
149 return $ISA[0] eq "IO::Socket::SSL"; |
|
150 |
|
151 } |
|
152 } |
|
153 |
|
154 { |
|
155 |
|
156 # authentication |
|
157 package Authen::hlog; |
|
158 |
|
159 use Crypt::PasswdMD5; |
|
160 use Digest::SHA1 qw(sha1_base64); |
|
161 use MIME::Base64 qw(decode_base64); |
|
162 |
|
163 sub new { |
|
164 |
|
165 my $class = shift; |
|
166 |
|
167 my $self = {@_}; |
|
168 |
|
169 die "At least one of 'filename' or 'authdata' parameters is required" |
|
170 unless $self->{filename} || $self->{authdata}; |
|
171 |
|
172 bless $self, $class; |
|
173 $self->authdata if $self->{filename}; |
|
174 |
|
175 return $self; |
|
176 |
|
177 } |
|
178 |
|
179 sub verify_base64 { |
|
180 |
|
181 my $self = shift; |
|
182 return $self->verify(split /:/, decode_base64($_[0])); |
|
183 |
|
184 } |
|
185 |
|
186 sub verify { |
|
187 |
|
188 my $self = shift; |
|
189 |
|
190 my ($u, $p) = @_; |
|
191 |
|
192 my $hp = $self->{authdata}->{$u}; |
|
193 |
|
194 # crypt? |
|
195 if (length $hp == 13) { |
|
196 return crypt($p, $hp) eq $hp; |
|
197 |
|
198 # apache md5? |
|
199 } |
|
200 elsif (length $hp == 37 && $hp =~ /^\$apr/) { |
|
201 return apache_md5_crypt($p, $hp) eq $hp; |
|
202 } |
|
203 elsif ($hp =~ s/^\{SHA\}//) { |
|
204 |
|
205 # remove trailing equality signs because sha1_base64 refuses to add any |
|
206 $hp =~ s/=*$//; |
|
207 return sha1_base64($p) eq $hp; |
|
208 } |
|
209 else { |
|
210 warn "unknown hash format: >>>$hp<<<"; |
|
211 } |
|
212 |
|
213 return; |
|
214 |
|
215 } |
|
216 |
|
217 sub authdata { |
|
218 |
|
219 my $self = shift; |
|
220 |
|
221 my ($htpasswd) = @_ || $self->{filename} || die "Missing filename"; |
|
222 |
|
223 $self->{authdata} = {}; |
|
224 |
|
225 open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!"; |
|
226 while (my $line = <H>) { |
|
227 |
|
228 chomp $line; |
|
229 |
|
230 # htpasswd lines may have more than 2 fields |
|
231 my ($u, $p) = split /:/, $line, 3; |
|
232 |
|
233 unless ($u && $p) { |
|
234 warn "invalid htpasswd line in '$htpasswd' at line $."; |
|
235 next; |
|
236 } |
|
237 |
|
238 warn |
|
239 "duplicate user '$u' in '$htpasswd' at line $. - overriding previous record" |
|
240 if exists $self->{authdata}->{$u}; |
|
241 $self->{authdata}->{$u} = $p; |
|
242 |
|
243 } |
|
244 |
|
245 close H or warn "Cant close '<$htpasswd': $!"; |
|
246 |
|
247 warn "no authentication data found" unless %{ $self->{authdata} }; |
|
248 |
|
249 return $self->{authdata}; |
|
250 |
|
251 } |
|
252 } |
|
253 |
|
254 END { |
75 END { |
255 unlink $pidfile |
76 unlink $pidfile |
256 if defined $pidfile |
77 if defined $pidfile |
257 and not ref $pidfile |
78 and not ref $pidfile |
258 and defined $masterpid |
79 and defined $masterpid |
349 $file = getcwd() . "/$file" if $file !~ /^\//; |
170 $file = getcwd() . "/$file" if $file !~ /^\//; |
350 $FILE{$tag} = $file; |
171 $FILE{$tag} = $file; |
351 } |
172 } |
352 |
173 |
353 # start the listener |
174 # start the listener |
354 my $listener = new IO::Socket::hlog( |
175 my $listener = |
|
176 $opt_ssl |
|
177 ? new IO::Socket::SSL( |
355 LocalAddr => $opt_addr, |
178 LocalAddr => $opt_addr, |
356 LocalPort => $opt_port, |
179 LocalPort => $opt_port, |
357 Proto => "tcp", |
180 Proto => "tcp", |
358 Listen => 1, |
181 Listen => 1, |
359 ReuseAddr => 1, |
182 ReuseAddr => 1, |
360 SSL => $opt_ssl, |
183 SSL => $opt_ssl, |
361 SSL_key_file => $opt_ssl_key, |
184 SSL_key_file => $opt_ssl_key, |
362 SSL_cert_file => $opt_ssl_cert, |
185 SSL_cert_file => $opt_ssl_cert, |
363 debug => $opt_debug |
186 #debug => $opt_debug |
364 ) or die "Can't create listener socket: ", IO::Socket::hlog::errstr, "\n"; |
187 ) |
|
188 : new IO::Socket::INET( |
|
189 LocalAddr => $opt_addr, |
|
190 LocalPort => $opt_port, |
|
191 Proto => "tcp", |
|
192 Listen => 1, |
|
193 ReuseAddr => 1, |
|
194 #debug => $opt_debug, |
|
195 ); |
365 |
196 |
366 # go daemon |
197 # go daemon |
367 chdir("/") or die "Can't chdir to /: $!\n"; |
198 chdir("/") or die "Can't chdir to /: $!\n"; |
368 |
199 |
369 if ($opt_daemon) { |
200 if ($opt_daemon) { |
628 </p> |
459 </p> |
629 </body></html> |
460 </body></html> |
630 __EOF |
461 __EOF |
631 } |
462 } |
632 |
463 |
|
464 # PACKAGES |
|
465 { |
|
466 |
|
467 package IO::Socket::hlog; |
|
468 |
|
469 use IO::Socket::INET; |
|
470 use IO::Socket::SSL; |
|
471 |
|
472 our (@ISA, $DEBUG); |
|
473 |
|
474 sub new { |
|
475 |
|
476 my $class = shift; |
|
477 |
|
478 my %args = @_; |
|
479 my $ssl = delete $args{SSL}; |
|
480 |
|
481 if ($ssl) { |
|
482 |
|
483 @ISA = qw(IO::Socket::SSL); |
|
484 $IO::Socket::SSL::DEBUG = $DEBUG ? 3 : 0; |
|
485 |
|
486 } |
|
487 else { |
|
488 |
|
489 %args = _delete_ssl_args(%args); |
|
490 @ISA = qw(IO::Socket::INET); |
|
491 |
|
492 } |
|
493 |
|
494 my $self; |
|
495 unless ($self = $class->SUPER::new(%args)) { |
|
496 |
|
497 return; |
|
498 |
|
499 } |
|
500 |
|
501 print "$class: $self created\n" if $DEBUG; |
|
502 |
|
503 return $self; |
|
504 |
|
505 } |
|
506 |
|
507 sub close { |
|
508 |
|
509 my $self = shift; |
|
510 print "$self: closing\n" if $DEBUG; |
|
511 |
|
512 my %args = @_; |
|
513 |
|
514 %args = _delete_ssl_args(%args) unless $self->_is_ssl; |
|
515 |
|
516 return $self->SUPER::close(%args); |
|
517 |
|
518 } |
|
519 |
|
520 sub errstr { |
|
521 |
|
522 return IO::Socket::SSL::errstr if _is_ssl(); |
|
523 |
|
524 return $@; |
|
525 |
|
526 } |
|
527 |
|
528 sub _delete_ssl_args { |
|
529 |
|
530 my %args = @_; |
|
531 map { delete $args{$_} if /^SSL/; } keys %args; |
|
532 return %args; |
|
533 |
|
534 } |
|
535 |
|
536 sub _is_ssl { |
|
537 |
|
538 my $self = shift; |
|
539 return $ISA[0] eq "IO::Socket::SSL"; |
|
540 |
|
541 } |
|
542 } |
|
543 |
|
544 { |
|
545 |
|
546 # authentication |
|
547 package Authen::hlog; |
|
548 |
|
549 use Crypt::PasswdMD5; |
|
550 use Digest::SHA1 qw(sha1_base64); |
|
551 use MIME::Base64 qw(decode_base64); |
|
552 |
|
553 sub new { |
|
554 |
|
555 my $class = shift; |
|
556 |
|
557 my $self = {@_}; |
|
558 |
|
559 die "At least one of 'filename' or 'authdata' parameters is required" |
|
560 unless $self->{filename} || $self->{authdata}; |
|
561 |
|
562 bless $self, $class; |
|
563 $self->authdata if $self->{filename}; |
|
564 |
|
565 return $self; |
|
566 |
|
567 } |
|
568 |
|
569 sub verify_base64 { |
|
570 |
|
571 my $self = shift; |
|
572 return $self->verify(split /:/, decode_base64($_[0])); |
|
573 |
|
574 } |
|
575 |
|
576 sub verify { |
|
577 |
|
578 my $self = shift; |
|
579 |
|
580 my ($u, $p) = @_; |
|
581 |
|
582 my $hp = $self->{authdata}->{$u}; |
|
583 |
|
584 # crypt? |
|
585 if (length $hp == 13) { |
|
586 return crypt($p, $hp) eq $hp; |
|
587 |
|
588 # apache md5? |
|
589 } |
|
590 elsif (length $hp == 37 && $hp =~ /^\$apr/) { |
|
591 return apache_md5_crypt($p, $hp) eq $hp; |
|
592 } |
|
593 elsif ($hp =~ s/^\{SHA\}//) { |
|
594 |
|
595 # remove trailing equality signs because sha1_base64 refuses to add any |
|
596 $hp =~ s/=*$//; |
|
597 return sha1_base64($p) eq $hp; |
|
598 } |
|
599 else { |
|
600 warn "unknown hash format: >>>$hp<<<"; |
|
601 } |
|
602 |
|
603 return; |
|
604 |
|
605 } |
|
606 |
|
607 sub authdata { |
|
608 |
|
609 my $self = shift; |
|
610 |
|
611 my ($htpasswd) = @_ || $self->{filename} || die "Missing filename"; |
|
612 |
|
613 $self->{authdata} = {}; |
|
614 |
|
615 open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!"; |
|
616 while (my $line = <H>) { |
|
617 |
|
618 chomp $line; |
|
619 |
|
620 # htpasswd lines may have more than 2 fields |
|
621 my ($u, $p) = split /:/, $line, 3; |
|
622 |
|
623 unless ($u && $p) { |
|
624 warn "invalid htpasswd line in '$htpasswd' at line $."; |
|
625 next; |
|
626 } |
|
627 |
|
628 warn |
|
629 "duplicate user '$u' in '$htpasswd' at line $. - overriding previous record" |
|
630 if exists $self->{authdata}->{$u}; |
|
631 $self->{authdata}->{$u} = $p; |
|
632 |
|
633 } |
|
634 |
|
635 close H or warn "Cant close '<$htpasswd': $!"; |
|
636 |
|
637 warn "no authentication data found" unless %{ $self->{authdata} }; |
|
638 |
|
639 return $self->{authdata}; |
|
640 |
|
641 } |
|
642 } |
|
643 |
|
644 |
633 __END__ |
645 __END__ |
634 |
646 |
635 =head1 NAME |
647 =head1 NAME |
636 |
648 |
637 hlog - simple http server providing access to some logfile |
649 hlog - simple http server providing access to some logfile |