#! perl package Stonehenge::DBILog; use strict; ## usage: PerlPostConfigHandler Stonehenge::DBILog ## config my $PNOTE_IDENTIFIER = 'DBILog_Times'; my $LOGGER = "[* env.PREFIX *]/sbin/logger"; ## end config use Apache2::Const qw(DECLINED OK); use Apache2::Util qw(ht_time); my $logger_handle; sub handler { my ($conf_pool, $log_pool, $temp_pool, $s) = @_; ## warn "executed in $$\n"; for (my $vs = $s; $vs; $vs = $vs->next) { ## set this up in the "real" server: next if $vs->is_virtual; ## warn "setting up ", $vs->server_hostname, ":", $vs->port, "\n"; $vs->push_handlers(PerlPostReadRequestHandler => __PACKAGE__ . '::PerlPostReadRequestHandler'); $vs->push_handlers(PerlLogHandler => __PACKAGE__ . '::PerlLogHandler'); } open $logger_handle, "|$LOGGER" or die "Cannot create |$LOGGER: $!"; { my $old = select($logger_handle); $| = 1; select($old); } return OK; } sub PerlPostReadRequestHandler { my $r = shift; return DECLINED unless $r->is_initial_req; my @times = (time, times); $r->pnotes($PNOTE_IDENTIFIER, \@times); ## warn "saved @times in pnote\n"; return DECLINED; } sub PerlLogHandler { my $r = shift; ## warn "running the handler for ", $r->uri, "\n"; ## first, reap any zombies so child CPU is proper: { my $kid = waitpid(-1, 1); if ($kid > 0) { # $r->warn("found kid $kid"); # DEBUG redo; } } my @times = @{$r->pnotes($PNOTE_IDENTIFIER) || []}; unless (@times) { $r->warn($r->uri, ": DBILog: where is \@times?"); return DECLINED; } ## delta these times: @times = map { $_ - shift @times } time, times; my $orig = $r->main || $r; my $last = $orig; $last = $last->next while $last->next; my $s = $orig->server; my $c = $orig->connection; my $server = $orig->dir_config->get("DBILogServer"); =for SQL create table requests ( uid text, cookie text, stamp timestamp with timezone default now(), host text not null, server text, vhost text not null, method text not null, url text not null, basicauth text, referer text, useragent text, status int default 0, bytes int, wall int, cpuuser real, cpusys real, cpucuser real, cpucsys real, ); =cut my %data; $data{uid} = $orig->headers_in->{"x-stonehenge-unique-id"} || $r->headers_in->{"x-stonehenge-unique-id"} || $last->headers_in->{"x-stonehenge-unique-id"} || $orig->subprocess_env->{UNIQUE_ID} || $r->subprocess_env->{UNIQUE_ID} || $last->subprocess_env->{UNIQUE_ID}; $data{cookie} = $orig->notes->{"cookie"} || $r->notes->{"cookie"} || $last->notes->{"cookie"}; $data{stamp} =Apache2::Util::ht_time($r->pool, $orig->request_time); $data{host} = $c->get_remote_host; $data{server} = $server; $data{vhost} = join(":", $s->server_hostname, $s->port); $data{method} = $orig->method; $data{url} =($orig->the_request =~ /^\S+\s+(\S+)/)[0]; $data{basicauth} =$orig->user; $data{referer} =$orig->headers_in->{'Referer'}; $data{useragent} =$orig->headers_in->{'User-agent'}; $data{status} =$orig->status; $data{bytes} =$r->bytes_sent; @data{qw(wall cpuuser cpusys cpucuser cpucsys)} = @times; my $data = join(" ", map { defined $data{$_} ? "$_=" . unpack("H*", $data{$_}) : () } sort keys %data ); ## we hope we get an atomic write here... print $logger_handle "<$data>\n" or die "Write error on $logger_handle: $!"; ## hopefully, angle bracket markers will tell us if we got scrambled return OK; } 1;