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