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