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