1 #! /usr/bin/perl

     2 

     3 #    HTTP access to some (log) file

     4 #    Copyright (C) 2009  Heiko Schlittermann

     5 #

     6 #    This program is free software: you can redistribute it and/or modify

     7 #    it under the terms of the GNU General Public License as published by

     8 #    the Free Software Foundation, either version 3 of the License, or

     9 #    (at your option) any later version.

    10 #

    11 #    This program is distributed in the hope that it will be useful,

    12 #    but WITHOUT ANY WARRANTY; without even the implied warranty of

    13 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    14 #    GNU General Public License for more details.

    15 #

    16 #    You should have received a copy of the GNU General Public License

    17 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.

    18 #

    19 #    Heiko Schlittermann <hs@schlittermann.de>

    20 

    21 use strict;

    22 use warnings;

    23 use Getopt::Long;

    24 use IO::Socket::INET;

    25 use Pod::Usage;

    26 use File::Basename;

    27 use POSIX qw(:sys_wait_h setsid);

    28 use Cwd;

    29 

    30 my $opt_addr   = "0.0.0.0";

    31 my $opt_port   = 8080;

    32 my $opt_lines  = 10;

    33 my $opt_daemon = 1;

    34 my $opt_kill   = 0;

    35 

    36 my $ME = basename $0;

    37 

    38 # these vars will be filled with the real dirs later

    39 my $rundir = [ "/var/run/$ME", "$ENV{HOME}/.$ME" ];

    40 my $logdir = [ "/var/log/$ME", "$ENV{HOME}/.$ME" ];

    41 

    42 my $maxlogsize  = 1000_000_000;    # ca 1 MByte

    43 my $killtimeout = 3;

    44 

    45 # these are refs to detect if they're converted already

    46 my $access  = \"%s/access.log";

    47 my $errors  = \"%s/error.log";

    48 my $pidfile = \"%s/%s.%s.pid";     # %dir/%ip.%port

    49 

    50 END {

    51     unlink $pidfile

    52       if defined $pidfile and not ref $pidfile;

    53 }

    54 

    55 sub find_writable_dir(@);

    56 

    57 sub log_open($);

    58 sub log_write($);

    59 

    60 sub handle_request($);

    61 sub http($@);

    62 

    63 sub bad_request();

    64 sub date1123(;$);

    65 

    66 my %FILE;

    67 

    68 MAIN: {

    69 

    70     GetOptions(

    71         "addr=s"  => \$opt_addr,

    72         "port=i"  => \$opt_port,

    73         "lines=i" => \$opt_lines,

    74         "daemon!" => \$opt_daemon,

    75         "kill"    => \$opt_kill,

    76         "help"    => sub { pod2usage(-verbose => 1, -exitval => 0) },

    77         "man"     => sub { pod2usage(-verbose => 2, -exitval => 0) },

    78     ) or pod2usage();

    79 

    80     if (defined($logdir = find_writable_dir(@$logdir))) {

    81         $access = sprintf $$access, $logdir;

    82         $errors = sprintf $$errors, $logdir;

    83         log_open($access);

    84     }

    85 

    86     if (defined($rundir = find_writable_dir(@$rundir))) {

    87 

    88         # santize hostname

    89         (my $host = $opt_addr) =~ s/([^\w.-])/sprintf "%%%02X", ord($1)/gie;

    90         $pidfile = sprintf $$pidfile, $rundir, $host, $opt_port,;

    91     }

    92     else { $pidfile = undef }

    93 

    94     if ($opt_kill) {

    95         warn "Killing process on $opt_addr:$opt_port\n";

    96         open(my $p, $pidfile) or die "Can't open $pidfile: $!\n";

    97         defined($_ = <$p>) or die "no pid found in $pidfile\n";

    98         chomp;

    99         kill -15 => $_ or die "Can't kill pid $_: $!\n";

   100 

   101         # we can't wait, it's not our process group, so we've to poll

   102         eval {

   103             $SIG{ALRM} = sub { die "TIMEOUT\n" };

   104             alarm($killtimeout);

   105             for (my $sleep = 1 ; kill -0 => $_ ; $sleep++) {

   106                 sleep($sleep > 10 ? 10 : $sleep);

   107             }

   108             alarm(0);

   109         };

   110         if ($@ eq "TIMEOUT\n") {

   111             warn "Child $_ didn't respond. Using violence.\n";

   112             kill -9 => $_;

   113         }

   114         exit 0;

   115     }

   116 

   117     pod2usage() if not @ARGV;

   118 

   119     # resolve tags and filenames

   120     foreach (@ARGV) {

   121         $_ = "default=$_" if not /=/ or /^\//;

   122         my ($tag, $file) = split /=/, $_, 2;

   123         die "tag $tag already exists with file $FILE{$tag}\n"

   124           if exists $FILE{$tag};

   125         $file = getcwd() . "/$file" if $file !~ /^\//;

   126         $FILE{$tag} = $file;

   127     }

   128 

   129     # start the listener

   130     my $listener = new IO::Socket::INET(

   131         LocalAddr => $opt_addr,

   132         LocalPort => $opt_port,

   133         Proto     => "tcp",

   134         Listen    => 1,

   135         ReuseAddr => 1,

   136     ) or die "Can't create listener socket: $!\n";

   137 

   138     # go daemon

   139     chdir("/") or die "Can't chdir to /: $!\n";

   140 

   141     if ($opt_daemon) {

   142 

   143         defined(my $pid = fork()) or die "Can't fork: $!\n";

   144 

   145         # parent

   146         if ($pid) {

   147             print "listener $pid "

   148               . $listener->sockhost . ":"

   149               . $listener->sockport . "\n";

   150             undef $pidfile;

   151             exit 0;

   152         }

   153 

   154         # child

   155         setsid() or die "Can't start a new session: $!\n";

   156         open(STDIN,  "/dev/null")  or die "Can't read /dev/null: $!\n";

   157         open(STDOUT, ">/dev/null") or die "Can't write to /dev/null: $!\n";

   158 

   159         if (defined $logdir) {

   160             open(STDERR, $_ = ">>$errors") or warn "Can't open $_: $!\n";

   161         }

   162         else {

   163             open(STDERR, ">&STDOUT") or die "Can't dup stdout: $!\n";

   164         }

   165 

   166     }

   167 

   168     $SIG{INT} = $SIG{TERM} = sub { warn "Got signal $_[0]\n"; exit 0 };

   169     $SIG{__WARN__} = sub { print STDERR localtime() . " ", @_ };

   170     $SIG{__DIE__} = sub { print STDERR @_; exit $? };

   171 

   172     if (defined $pidfile) {

   173         open(PID, ">$pidfile")

   174           or die "Can't open $pidfile: $!\n";

   175 

   176         print PID "$$\n";

   177         close PID;

   178     }

   179 

   180     $SIG{CHLD} = sub {

   181         while (waitpid(-1, WNOHANG) > 0) {

   182         }

   183     };

   184 

   185     while (1) {

   186         my $client = $listener->accept;

   187         next if not defined $client;    # may be because of signal

   188 

   189         my $pid = fork();

   190         die "Can't fork: $!\n" if not defined $pid;

   191         if ($pid == 0) {

   192             $SIG{CHLD} = "DEFAULT";

   193             $listener->close;

   194             handle_request($client);

   195             exit 0;

   196         }

   197         $client->close;

   198 

   199         # maintenance of logfiles

   200         if (-s $access > $maxlogsize) {

   201             rename $access, "$access.1";

   202             log_open($access);

   203         }

   204 

   205         if (-s $errors > $maxlogsize) {

   206             rename $errors, "$errors.1";

   207             open(STDERR, ">>$errors");

   208         }

   209     }

   210 

   211 }

   212 

   213 sub find_writable_dir(@) {

   214     foreach (@_) {

   215         return $_ if -d and -w _;

   216         return $_ if mkdir $_, 0755;

   217     }

   218     return undef;

   219 }

   220 

   221 {

   222     my $fh;

   223 

   224     sub log_open($) {

   225         open($fh, $_ = ">>$_[0]") or die "Can't open $_: $!\n";

   226     }

   227 

   228     sub log_write($) {

   229         $fh->print(localtime() . " $_[0]\n")

   230           if defined $fh;

   231     }

   232 

   233 }

   234 

   235 sub handle_request($) {

   236     my $client = shift;

   237     local $_ = <$client>;

   238 

   239     # should be HTTP/x.x

   240     if (not s/\s+HTTP\/\S+\s*$//) {

   241         $client->print(bad_request);

   242         return;

   243     }

   244 

   245     # should be a GET request

   246     if (not s/GET\s+//) {

   247         $client->print(http "400 Bad Request" => bad_request);

   248     }

   249 

   250     # number of lines and tag to show

   251     my $lines = (s/(\d+)$//    ? $1 : $opt_lines);

   252     my $tag   = (s/^\/*(\w+)// ? $1 : "default");

   253 

   254     # read the header(s) and discard

   255     while (<$client>) { last if /^\s*$/ }

   256 

   257     if (not exists $FILE{$tag}) {

   258         $client->print(http "500 unknown file tag",

   259             "Sorry, unknown file tag \"$tag\"");

   260         log_write("unknown tag $tag");

   261         return;

   262     }

   263 

   264     my %file = analyze($FILE{$tag});

   265     if (!%file) {

   266         $client->print(http "500 internal error", "internal error");

   267         return;

   268     }

   269 

   270     log_write($client->peerhost . ":" . $client->peerport . " $tag ($lines)");

   271 

   272     seek($file{fh}, -($lines + 1) * $file{avglen}, 2);

   273     $file{fh}->getline;

   274 

   275     $client->print(http "200 OK" => join "", <<__EOF, $file{fh}->getlines);

   276 # Proof of concept ;-)

   277 # see https://keller.schlittermann.de/hg/hlog

   278 #

   279 # FILE:    @{[sprintf "%s", $file{name}]}

   280 # LENGTH:  @{[sprintf "%5d", $file{size}]}

   281 # LINES:   @{[sprintf "%5d approx", $file{lines}]}

   282 # LENGTH:  @{[sprintf "%5d approx", $file{avglen}]}

   283 # DISPLAY: @{[sprintf "%5d approx", $lines]}

   284 # 

   285 # append ?<number> to your request to select the number of displayed

   286 # lines

   287 #

   288 __EOF

   289 

   290 }

   291 

   292 sub analyze($) {

   293     my %r;

   294     $r{name} = shift;

   295     $r{size} = -s $r{name};

   296     open($r{fh}, $r{name}) or do {

   297         $@ = "Can't open $r{name}: $!\n";

   298         return ();

   299     };

   300 

   301     if ($r{size} == 0) {

   302         $r{lines} = 0;

   303     }

   304     else {

   305         my $s;

   306         while (defined($_ = $r{fh}->getline)) {

   307             $s += length;

   308             last if $. == 100;

   309         }

   310         $r{avglen} = $s / $.;

   311         $r{lines}  = int($r{size} / $r{avglen});

   312     }

   313 

   314     seek($r{fh}, 0, 0);

   315     return %r;

   316 }

   317 

   318 sub http($@) {

   319     my $code = shift;

   320     my $date = date1123();

   321 

   322     my $type = $_[0] =~ /^<!DOCTYPE HTML/ ? "text/html" : "text/plain";

   323 

   324     return <<__EOF, @_;

   325 HTTP/1.1 $code

   326 Date: $date

   327 Connection: close

   328 Content-Type: $type

   329 

   330 __EOF

   331 }

   332 

   333 sub date1123(;$) {

   334     my @now = gmtime(@_ ? shift : time);

   335     sprintf "%s, %2d %s %4d %02d:%02d:%02d GMT",

   336       qw(Sun Mon Tue Wed Thu Fri Sat Sun) [ $now[6] ],

   337       $now[3],

   338       qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) [ $now[4] ],

   339       $now[5] + 1900, @now[ 2, 1, 0 ];

   340 }

   341 

   342 sub bad_request() {

   343     return <<'__EOF';

   344 <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">

   345 <html><head>

   346 <title>400 Bad Request</title>

   347 </head><body>

   348 <h1>Bad Request</h1>

   349 <p>Your browser sent a request that this server could not understand.<br

   350 />

   351 </p>

   352 </body></html>

   353 __EOF

   354 }

   355 

   356 __END__

   357 

   358 =head1 NAME

   359 

   360 hlog - simple http server providing access to some logfile

   361 

   362 =head1 SYNOPSIS

   363     

   364     hlog [--[no]daemon] 

   365 	 [-k|--kill]

   366          [-a|--address address] [-p|--port port]

   367 	 [--lines n] 

   368 	 {file|tag=file ...}

   369 

   370     hlog [-h|--help] [-m|--man]

   371 

   372 =head1 DESCRIPTION

   373 

   374 This script should run as a server providing access to 

   375 the last lines of a logfile. It should understand basic HTTP/1.x.

   376 

   377 See the L<FILES> section for more information on files.

   378 

   379 =head1 OPTIONS

   380 

   381 =over

   382 

   383 =item B<-a>|B<--address> I<address>

   384 

   385 The address to listen on. (default: 0.0.0.0)

   386 

   387 =item B<--[no]daemon>

   388 

   389 Do (or do not) daemonize. (default: do)

   390 

   391 =item B<--lines> I<lines>

   392 

   393 The number of lines to show. (default: 10)

   394 

   395 =item B<-k>|B<--kill>

   396 

   397 With this option the corresponding (address/port) process gets killed.

   398 (default: off)

   399 

   400 =item B<-p>|B<--port> I<port>

   401 

   402 The port to listen on. (default: 8080)

   403 

   404 =back

   405 

   406 =head1 EXAMPLES

   407 

   408 Using tags makes it possible to access more then one log file

   409 via the same running instance by specifying the tag in the URL.

   410 

   411 Once started as:

   412 

   413     hlog error=/var/log/apache/error.log access=/var/log/apache/access.log

   414 

   415 The following URLs are valid:

   416 

   417     http://<server>:8080/error

   418     http://<server>:8080/access?10

   419 

   420 =head1 FILES

   421 

   422 The B<hlog> tool tries to create several files

   423 

   424 =head2 F<access.log> and F<error.log>

   425 

   426 These files will be written to F</var/log/hlog/> or F<$HOME/.hlog/> if

   427 possible. The mentioned directories (the leave part) will be created, if

   428 possible. It is no fatal error if B<hlog> fails on this.

   429 

   430 =head2 PID file

   431 

   432 B<hlog> tries to create a pid file in F</var/run/hlog/> or

   433 F<$HOME/.hlog>. It even tries to create the leave part the directory.

   434 Failing on this it not fatal, but then the B<--kill> option will not

   435 work!

   436 

   437 The pid file will be named according to the hostname (see B<--address>)

   438 beeing used. For safety the hostname will be sanitized to avoid

   439 dangerous filenames.

   440 

   441 =cut