FS/FS/log.pm

   1 package FS::log;
   2
   3 use strict;
   4 use base qw( FS::Record );
   5 use FS::Record qw( qsearch qsearchs dbdef );
   6 use FS::UID qw( dbh driver_name );
   7 use FS::Log;
   8 use FS::log_context;
   9 use FS::log_email;
  10 use FS::upgrade_journal;
  11 use Tie::IxHash;
  12
  13 =head1 NAME
  14
  15 FS::log - Object methods for log records
  16
  17 =head1 SYNOPSIS
  18
  19   use FS::log;
  20
  21   $record = new FS::log \%hash;
  22   $record = new FS::log { 'column' => 'value' };
  23
  24   $error = $record->insert;
  25
  26   $error = $new_record->replace($old_record);
  27
  28   $error = $record->delete;
  29
  30   $error = $record->check;
  31
  32 =head1 DESCRIPTION
  33
  34 An FS::log object represents a log entry.  FS::log inherits from
  35 FS::Record.  The following fields are currently supported:
  36
  37 =over 4
  38
  39 =item lognum - primary key
  40
  41 =item _date - Unix timestamp
  42
  43 =item agentnum - L<FS::agent> to which the log pertains.  If it involves a
  44 specific customer, package, service, invoice, or other agent-specific object,
  45 this will be set to that agentnum.
  46
  47 =item tablename - table name to which the log pertains, if any.
  48
  49 =item tablenum - foreign key to that table.
  50
  51 =item level - log level: 'debug', 'info', 'notice', 'warning', 'error',
  52 'critical', 'alert', 'emergency'.
  53
  54 =item message - contents of the log entry
  55
  56 =back
  57
  58 =head1 METHODS
  59
  60 =over 4
  61
  62 =item new HASHREF
  63
  64 Creates a new log entry.  Use FS::Log instead of calling this directly,
  65 please.
  66
  67 =cut
  68
  69 sub table { 'log'; }
  70
  71 =item insert [ CONTEXT... ]
  72
  73 Adds this record to the database.  If there is an error, returns the error,
  74 otherwise returns false.
  75
  76 CONTEXT may be a list of context tags to attach to this record.
  77
  78 Will send emails according to the conditions in L<FS::log_email>.
  79
  80 =cut
  81
  82 sub insert {
  83   # not using process_o2m for this, because we don't have a web interface
  84   my $self = shift;
  85
  86   my $error = $self->SUPER::insert;
  87   return $error if $error;
  88
  89   my $contexts = {};
  90   my $context_height = @_;
  91   foreach ( @_ ) { # ordered from least to most specific
  92     my $context = FS::log_context->new({
  93         'lognum'  => $self->lognum,
  94         'context' => $_
  95     });
  96     $error = $context->insert;
  97     return $error if $error;
  98     $contexts->{$_} = $context_height--;
  99   }
 100
 101   foreach my $log_email (
 102     qsearch('log_email',
 103       {
 104         'disabled' => '',
 105         'min_level' => {
 106           'op' => '<=',
 107           'value' => $self->level,
 108         },
 109       }
 110     )
 111   ) {
 112     # shouldn't be a lot of log_email records, so not packing these checks into the qsearch
 113     next if $log_email->context && !$contexts->{$log_email->context};
 114     next if $log_email->context_height && ($contexts->{$log_email->context} > $log_email->context_height);
 115     my $msg_template = qsearchs('msg_template',{ 'msgnum' => $log_email->msgnum });
 116     unless ($msg_template) {
 117       warn "Could not send email when logging, could not load message template for logemailnum " . $log_email->logemailnum;
 118       next;
 119     }
 120     my $emailerror = $msg_template->send(
 121       'msgtype' => 'admin',
 122       'to'      => $log_email->to_addr,
 123       'substitutions' => {
 124         'loglevel'   => $FS::Log::LEVELS{$self->level} || 'unknown',
 125         'logcontext' => join(', ', keys( %$contexts )) || 'unknown',
 126         'logmessage' => $self->message,
 127       },
 128     );
 129     warn "Could not send email when logging: $emailerror" if $emailerror;
 130   }
 131   '';
 132 }
 133
 134 # these methods can be inherited from FS::Record
 135
 136 sub delete  { die "Log entries can't be modified." };
 137
 138 sub replace { die "Log entries can't be modified." };
 139
 140 =item check
 141
 142 Checks all fields to make sure this is a valid example.  If there is
 143 an error, returns the error, otherwise returns false.  Called by the insert
 144 and replace methods.
 145
 146 =cut
 147
 148 sub check {
 149   my $self = shift;
 150
 151   my $error =
 152     $self->ut_numbern('lognum')
 153     || $self->ut_number('_date')
 154     || $self->ut_numbern('agentnum')
 155     || $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum')
 156     || $self->ut_textn('tablename')
 157     || $self->ut_numbern('tablenum')
 158     || $self->ut_number('level')
 159     || $self->ut_anything('message')
 160   ;
 161   return $error if $error;
 162
 163   if ( my $tablename = $self->tablename ) {
 164     my $dbdef_table = dbdef->table($tablename)
 165       or return "tablename '$tablename' does not exist";
 166     $error = $self->ut_foreign_key('tablenum',
 167                                    $tablename,
 168                                    $dbdef_table->primary_key);
 169     return $error if $error;
 170   }
 171
 172   $self->SUPER::check;
 173 }
 174
 175 =item context
 176
 177 Returns the context for this log entry, as an array, from least to most
 178 specific.
 179
 180 =cut
 181
 182 sub context {
 183   my $self = shift;
 184   map { $_->context } qsearch({
 185       table     => 'log_context',
 186       hashref   => { lognum => $self->lognum },
 187       order_by  => 'ORDER BY logcontextnum ASC',
 188   });
 189 }
 190
 191 =back
 192
 193 =head1 CLASS METHODS
 194
 195 =over 4
 196
 197 =item search HASHREF
 198
 199 Returns a qsearch hash expression to search for parameters specified in
 200 HASHREF.  Valid parameters are:
 201
 202 =over 4
 203
 204 =item agentnum
 205
 206 =item date - arrayref of start and end date
 207
 208 =item level - either a specific level, or an arrayref of min and max level
 209
 210 =item context - a context string that the log entry must have.  This may
 211 change in the future to allow searching for combinations of context strings.
 212
 213 =item object - any database object, to find log entries related to it.
 214
 215 =item tablename, tablenum - alternate way of specifying 'object'.
 216
 217 =item custnum - a customer number, to find log entries related to the customer
 218 or any of their subordinate objects (invoices, packages, etc.).
 219
 220 =item message - a text string to search in messages.  The search will be
 221 a case-insensitive LIKE with % appended at both ends.
 222
 223 =back
 224
 225 =cut
 226
 227 # used for custnum search: all tables with custnums
 228 my @table_stubs;
 229
 230 sub _setup_table_stubs {
 231   foreach my $table (
 232     qw(
 233     contact
 234     cust_attachment
 235     cust_bill
 236     cust_credit
 237     cust_location
 238     cust_main
 239     cust_main_exemption
 240     cust_main_note
 241     cust_msg
 242     cust_pay
 243     cust_pay_batch
 244     cust_pay_pending
 245     cust_pay_void
 246     cust_pkg
 247     cust_refund
 248     cust_statement
 249     cust_tag
 250     cust_tax_adjustment
 251     cust_tax_exempt
 252     did_order_item
 253     qual
 254     queue ) )
 255   {
 256     my $pkey = dbdef->table($table)->primary_key;
 257     push @table_stubs,
 258       "log.tablename = '$table' AND ".
 259       "EXISTS(SELECT 1 FROM $table WHERE log.tablenum = $table.$pkey AND ".
 260       "$table.custnum = "; # needs a closing )
 261   }
 262   # plus this case
 263   push @table_stubs,
 264       "(log.tablename LIKE 'svc_%' OR log.tablename = 'cust_svc') AND ".
 265       "EXISTS(SELECT 1 FROM cust_svc JOIN cust_pkg USING (svcnum) WHERE ".
 266       "cust_pkg.custnum = "; # needs a closing )
 267 }
 268
 269 sub search {
 270   my ($class, $params) = @_;
 271   my @where;
 272
 273   ##
 274   # parse agent
 275   ##
 276
 277   if ( $params->{'agentnum'} =~ /^(\d+)$/ ) {
 278     push @where,
 279       "log.agentnum = $1";
 280   }
 281
 282   ##
 283   # parse custnum
 284   ##
 285
 286   if ( $params->{'custnum'} =~ /^(\d+)$/ ) {
 287     _setup_table_stubs() unless @table_stubs;
 288     my $custnum = $1;
 289     my @orwhere = map { "( $_ $custnum) )" } @table_stubs;
 290     push @where, join(' OR ', @orwhere);
 291   }
 292
 293   ##
 294   # parse level
 295   ##
 296
 297   if ( ref $params->{'level'} eq 'ARRAY' ) {
 298     my ($min, $max) = @{ $params->{'level'} };
 299     if ( $min =~ /^\d+$/ ) {
 300       push @where, "log.level >= $min";
 301     }
 302     if ( $max =~ /^\d+$/ ) {
 303       push @where, "log.level <= $max";
 304     }
 305   } elsif ( $params->{'level'} =~ /^(\d+)$/ ) {
 306     push @where, "log.level = $1";
 307   }
 308
 309   ##
 310   # parse date
 311   ##
 312
 313   if ( ref $params->{'date'} eq 'ARRAY' ) {
 314     my ($beg, $end) = @{ $params->{'date'} };
 315     if ( $beg =~ /^\d+$/ ) {
 316       push @where, "log._date >= $beg";
 317     }
 318     if ( $end =~ /^\d+$/ ) {
 319       push @where, "log._date <= $end";
 320     }
 321   }
 322
 323   ##
 324   # parse object
 325   ##
 326
 327   if ( $params->{'object'} and $params->{'object'}->isa('FS::Record') ) {
 328     my $table = $params->{'object'}->table;
 329     my $pkey = dbdef->table($table)->primary_key;
 330     my $tablenum = $params->{'object'}->get($pkey);
 331     if ( $table and $tablenum ) {
 332       push @where, "log.tablename = '$table'", "log.tablenum = $tablenum";
 333     }
 334   } elsif ( $params->{'tablename'} =~ /^(\w+)$/ ) {
 335     my $table = $1;
 336     if ( $params->{'tablenum'} =~ /^(\d+)$/ ) {
 337       push @where, "log.tablename = '$table'", "log.tablenum = $1";
 338     }
 339   }
 340
 341   ##
 342   # parse message
 343   ##
 344
 345   if ( $params->{'message'} ) { # can be anything, really, so escape it
 346     my $quoted_message = dbh->quote('%' . $params->{'message'} . '%');
 347     my $op = (driver_name eq 'Pg' ? 'ILIKE' : 'LIKE');
 348     push @where, "log.message $op $quoted_message";
 349   }
 350
 351   ##
 352   # parse context
 353   ##
 354
 355   if ( $params->{'context'} ) {
 356     my $quoted = dbh->quote($params->{'context'});
 357     if ( $params->{'context_height'} =~ /^\d+$/ ) {
 358       my $subq = 'SELECT context FROM log_context WHERE log.lognum = log_context.lognum'.
 359                  ' ORDER BY logcontextnum DESC LIMIT '.$params->{'context_height'};
 360       push @where,
 361         "EXISTS(SELECT 1 FROM ($subq) AS log_context_x WHERE log_context_x.context = $quoted)";
 362     } else {
 363       push @where,
 364         "EXISTS(SELECT 1 FROM log_context WHERE log.lognum = log_context.lognum ".
 365         "AND log_context.context = $quoted)";
 366     }
 367   }
 368
 369   # agent virtualization
 370   my $access_user = $FS::CurrentUser::CurrentUser;
 371   push @where, $access_user->agentnums_sql(
 372     table => 'log',
 373     viewall_right => 'Configuration',
 374     null => 1,
 375   );
 376
 377   # put it together
 378   my $extra_sql = '';
 379   $extra_sql .= 'WHERE ' . join(' AND ', @where) if @where;
 380   my $count_query = 'SELECT COUNT(*) FROM log '.$extra_sql;
 381   my $sql_query = {
 382     'table'         => 'log',
 383     'hashref'       => {},
 384     'select'        => 'log.*',
 385     'extra_sql'     => $extra_sql,
 386     'count_query'   => $count_query,
 387     'order_by'      => 'ORDER BY _date ASC',
 388     #addl_from, not needed
 389   };
 390 }
 391
 392 sub _upgrade_data {
 393   my ($class, %opts) = @_;
 394
 395   return if FS::upgrade_journal->is_done('log__remap_levels');
 396
 397   tie my %levelmap, 'Tie::IxHash',
 398     2 => 1, #notice -> info
 399     6 => 5, #alert -> critical
 400     7 => 5, #emergency -> critical
 401   ;
 402
 403   # this method should never autocommit
 404   # should have been set in upgrade, but just in case...
 405   local $FS::UID::AutoCommit = 0;
 406
 407   # in practice, only debug/info/warning/error appear to have been used,
 408   #   so this probably won't do anything, but just in case
 409   foreach my $old (keys %levelmap) {
 410     # FS::log has no replace method
 411     my $sql = 'UPDATE log SET level=' . dbh->quote($levelmap{$old}) . ' WHERE level=' . dbh->quote($old);
 412     warn $sql unless $opts{'quiet'};
 413     my $sth = dbh->prepare($sql) or die dbh->errstr;
 414     $sth->execute() or die $sth->errstr;
 415     $sth->finish();
 416   }
 417
 418   foreach my $log_email (
 419     qsearch('log_email',{ 'min_level' => 2 }),
 420     qsearch('log_email',{ 'min_level' => 6 }),
 421     qsearch('log_email',{ 'min_level' => 7 }),
 422   ) {
 423     $log_email->min_level($levelmap{$log_email->min_level});
 424     my $error = $log_email->replace;
 425     if ($error) {
 426       dbh->rollback;
 427       die $error;
 428     }
 429   }
 430
 431   FS::upgrade_journal->set_done('log__remap_levels');
 432
 433 }
 434
 435 =back
 436
 437 =head1 BUGS
 438
 439 =head1 SEE ALSO
 440
 441 L<FS::Record>, schema.html from the base documentation.
 442
 443 =cut
 444
 445 1;
 446