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