FS/FS/cust_svc.pm

   1 package FS::cust_svc;
   2
   3 use strict;
   4 use vars qw( @ISA $ignore_quantity );
   5 use Carp qw( cluck );
   6 use FS::Record qw( qsearch qsearchs dbh );
   7 use FS::cust_pkg;
   8 use FS::part_pkg;
   9 use FS::part_svc;
  10 use FS::pkg_svc;
  11 use FS::svc_acct;
  12 use FS::svc_domain;
  13 use FS::svc_forward;
  14 use FS::svc_broadband
  15 use FS::svc_external;
  16 use FS::domain_record;
  17 use FS::part_export;
  18
  19 @ISA = qw( FS::Record );
  20
  21 $ignore_quantity = 0;
  22
  23 sub _cache {
  24   my $self = shift;
  25   my ( $hashref, $cache ) = @_;
  26   if ( $hashref->{'username'} ) {
  27     $self->{'_svc_acct'} = FS::svc_acct->new($hashref, '');
  28   }
  29   if ( $hashref->{'svc'} ) {
  30     $self->{'_svcpart'} = FS::part_svc->new($hashref);
  31   }
  32 }
  33
  34 =head1 NAME
  35
  36 FS::cust_svc - Object method for cust_svc objects
  37
  38 =head1 SYNOPSIS
  39
  40   use FS::cust_svc;
  41
  42   $record = new FS::cust_svc \%hash
  43   $record = new FS::cust_svc { 'column' => 'value' };
  44
  45   $error = $record->insert;
  46
  47   $error = $new_record->replace($old_record);
  48
  49   $error = $record->delete;
  50
  51   $error = $record->check;
  52
  53   ($label, $value) = $record->label;
  54
  55 =head1 DESCRIPTION
  56
  57 An FS::cust_svc represents a service.  FS::cust_svc inherits from FS::Record.
  58 The following fields are currently supported:
  59
  60 =over 4
  61
  62 =item svcnum - primary key (assigned automatically for new services)
  63
  64 =item pkgnum - Package (see L<FS::cust_pkg>)
  65
  66 =item svcpart - Service definition (see L<FS::part_svc>)
  67
  68 =back
  69
  70 =head1 METHODS
  71
  72 =over 4
  73
  74 =item new HASHREF
  75
  76 Creates a new service.  To add the refund to the database, see L<"insert">.
  77 Services are normally created by creating FS::svc_ objects (see
  78 L<FS::svc_acct>, L<FS::svc_domain>, and L<FS::svc_forward>, among others).
  79
  80 =cut
  81
  82 sub table { 'cust_svc'; }
  83
  84 =item insert
  85
  86 Adds this service to the database.  If there is an error, returns the error,
  87 otherwise returns false.
  88
  89 =item delete
  90
  91 Deletes this service from the database.  If there is an error, returns the
  92 error, otherwise returns false.  Note that this only removes the cust_svc
  93 record - you should probably use the B<cancel> method instead.
  94
  95 =item cancel
  96
  97 Cancels the relevant service by calling the B<cancel> method of the associated
  98 FS::svc_XXX object (i.e. an FS::svc_acct object or FS::svc_domain object),
  99 deleting the FS::svc_XXX record and then deleting this record.
 100
 101 If there is an error, returns the error, otherwise returns false.
 102
 103 =cut
 104
 105 sub cancel {
 106   my $self = shift;
 107
 108   local $SIG{HUP} = 'IGNORE';
 109   local $SIG{INT} = 'IGNORE';
 110   local $SIG{QUIT} = 'IGNORE';
 111   local $SIG{TERM} = 'IGNORE';
 112   local $SIG{TSTP} = 'IGNORE';
 113   local $SIG{PIPE} = 'IGNORE';
 114
 115   my $oldAutoCommit = $FS::UID::AutoCommit;
 116   local $FS::UID::AutoCommit = 0;
 117   my $dbh = dbh;
 118
 119   my $part_svc = $self->part_svc;
 120
 121   $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 122     $dbh->rollback if $oldAutoCommit;
 123     return "Illegal svcdb value in part_svc!";
 124   };
 125   my $svcdb = $1;
 126   require "FS/$svcdb.pm";
 127
 128   my $svc = $self->svc_x;
 129   if ($svc) {
 130     my $error = $svc->cancel;
 131     if ( $error ) {
 132       $dbh->rollback if $oldAutoCommit;
 133       return "Error canceling service: $error";
 134     }
 135     $error = $svc->delete;
 136     if ( $error ) {
 137       $dbh->rollback if $oldAutoCommit;
 138       return "Error deleting service: $error";
 139     }
 140   }
 141
 142   my $error = $self->delete;
 143   if ( $error ) {
 144     $dbh->rollback if $oldAutoCommit;
 145     return "Error deleting cust_svc: $error";
 146   }
 147
 148   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 149
 150   ''; #no errors
 151
 152 }
 153
 154 =item replace OLD_RECORD
 155
 156 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 157 returns the error, otherwise returns false.
 158
 159 =cut
 160
 161 sub replace {
 162   my ( $new, $old ) = ( shift, shift );
 163
 164   local $SIG{HUP} = 'IGNORE';
 165   local $SIG{INT} = 'IGNORE';
 166   local $SIG{QUIT} = 'IGNORE';
 167   local $SIG{TERM} = 'IGNORE';
 168   local $SIG{TSTP} = 'IGNORE';
 169   local $SIG{PIPE} = 'IGNORE';
 170
 171   my $oldAutoCommit = $FS::UID::AutoCommit;
 172   local $FS::UID::AutoCommit = 0;
 173   my $dbh = dbh;
 174
 175   my $error = $new->SUPER::replace($old);
 176   if ( $error ) {
 177     $dbh->rollback if $oldAutoCommit;
 178     return $error if $error;
 179   }
 180
 181   if ( $new->svcpart != $old->svcpart ) {
 182     my $svc_x = $new->svc_x;
 183     my $new_svc_x = ref($svc_x)->new({$svc_x->hash});
 184     my $error = $new_svc_x->replace($svc_x);
 185     if ( $error ) {
 186       $dbh->rollback if $oldAutoCommit;
 187       return $error if $error;
 188     }
 189   }
 190
 191   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 192   ''; #no error
 193
 194 }
 195
 196 =item check
 197
 198 Checks all fields to make sure this is a valid service.  If there is an error,
 199 returns the error, otehrwise returns false.  Called by the insert and
 200 replace methods.
 201
 202 =cut
 203
 204 sub check {
 205   my $self = shift;
 206
 207   my $error =
 208     $self->ut_numbern('svcnum')
 209     || $self->ut_numbern('pkgnum')
 210     || $self->ut_number('svcpart')
 211   ;
 212   return $error if $error;
 213
 214   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 215   return "Unknown svcpart" unless $part_svc;
 216
 217   if ( $self->pkgnum ) {
 218     my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 219     return "Unknown pkgnum" unless $cust_pkg;
 220     my $pkg_svc = qsearchs( 'pkg_svc', {
 221       'pkgpart' => $cust_pkg->pkgpart,
 222       'svcpart' => $self->svcpart,
 223     });
 224     # or new FS::pkg_svc ( { 'pkgpart'  => $cust_pkg->pkgpart,
 225     #                        'svcpart'  => $self->svcpart,
 226     #                        'quantity' => 0                   } );
 227     my $quantity = $pkg_svc ? $pkg_svc->quantity : 0;
 228
 229     my @cust_svc = qsearch('cust_svc', {
 230       'pkgnum'  => $self->pkgnum,
 231       'svcpart' => $self->svcpart,
 232     });
 233     return "Already ". scalar(@cust_svc). " ". $part_svc->svc.
 234            " services for pkgnum ". $self->pkgnum
 235       if scalar(@cust_svc) >= $quantity && !$ignore_quantity;
 236   }
 237
 238   $self->SUPER::check;
 239 }
 240
 241 =item part_svc
 242
 243 Returns the definition for this service, as a FS::part_svc object (see
 244 L<FS::part_svc>).
 245
 246 =cut
 247
 248 sub part_svc {
 249   my $self = shift;
 250   $self->{'_svcpart'}
 251     ? $self->{'_svcpart'}
 252     : qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 253 }
 254
 255 =item cust_pkg
 256
 257 Returns the definition for this service, as a FS::part_svc object (see
 258 L<FS::part_svc>).
 259
 260 =cut
 261
 262 sub cust_pkg {
 263   my $self = shift;
 264   qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 265 }
 266
 267 =item label
 268
 269 Returns a list consisting of:
 270 - The name of this service (from part_svc)
 271 - A meaningful identifier (username, domain, or mail alias)
 272 - The table name (i.e. svc_domain) for this service
 273
 274 =cut
 275
 276 sub label {
 277   my $self = shift;
 278   my $svcdb = $self->part_svc->svcdb;
 279   my $svc_x = $self->svc_x
 280     or die "can't find $svcdb.svcnum ". $self->svcnum;
 281   my $tag;
 282   if ( $svcdb eq 'svc_acct' ) {
 283     $tag = $svc_x->email;
 284   } elsif ( $svcdb eq 'svc_forward' ) {
 285     if ( $svc_x->srcsvc ) {
 286       my $svc_acct = $svc_x->srcsvc_acct;
 287       $tag = $svc_acct->email;
 288     } else {
 289       $tag = $svc_x->src;
 290     }
 291     $tag .= '->';
 292     if ( $svc_x->dstsvc ) {
 293       my $svc_acct = $svc_x->dstsvc_acct;
 294       $tag .= $svc_acct->email;
 295     } else {
 296       $tag .= $svc_x->dst;
 297     }
 298   } elsif ( $svcdb eq 'svc_domain' ) {
 299     $tag = $svc_x->getfield('domain');
 300   } elsif ( $svcdb eq 'svc_www' ) {
 301     my $domain = qsearchs( 'domain_record', { 'recnum' => $svc_x->recnum } );
 302     $tag = $domain->zone;
 303   } elsif ( $svcdb eq 'svc_broadband' ) {
 304     $tag = $svc_x->ip_addr;
 305   } elsif ( $svcdb eq 'svc_external' ) {
 306     $tag = $svc_x->id. ': '. $svc_x->title;
 307   } else {
 308     cluck "warning: asked for label of unsupported svcdb; using svcnum";
 309     $tag = $svc_x->getfield('svcnum');
 310   }
 311   $self->part_svc->svc, $tag, $svcdb;
 312 }
 313
 314 =item svc_x
 315
 316 Returns the FS::svc_XXX object for this service (i.e. an FS::svc_acct object or
 317 FS::svc_domain object, etc.)
 318
 319 =cut
 320
 321 sub svc_x {
 322   my $self = shift;
 323   my $svcdb = $self->part_svc->svcdb;
 324   if ( $svcdb eq 'svc_acct' && $self->{'_svc_acct'} ) {
 325     $self->{'_svc_acct'};
 326   } else {
 327     #require "FS/$svcdb.pm";
 328     qsearchs( $svcdb, { 'svcnum' => $self->svcnum } );
 329   }
 330 }
 331
 332 =item seconds_since TIMESTAMP
 333
 334 See L<FS::svc_acct/seconds_since>.  Equivalent to
 335 $cust_svc->svc_x->seconds_since, but more efficient.  Meaningless for records
 336 where B<svcdb> is not "svc_acct".
 337
 338 =cut
 339
 340 #note: implementation here, POD in FS::svc_acct
 341 sub seconds_since {
 342   my($self, $since) = @_;
 343   my $dbh = dbh;
 344   my $sth = $dbh->prepare(' SELECT SUM(logout-login) FROM session
 345                               WHERE svcnum = ?
 346                                 AND login >= ?
 347                                 AND logout IS NOT NULL'
 348   ) or die $dbh->errstr;
 349   $sth->execute($self->svcnum, $since) or die $sth->errstr;
 350   $sth->fetchrow_arrayref->[0];
 351 }
 352
 353 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 354
 355 See L<FS::svc_acct/seconds_since_sqlradacct>.  Equivalent to
 356 $cust_svc->svc_x->seconds_since_sqlradacct, but more efficient.  Meaningless
 357 for records where B<svcdb> is not "svc_acct".
 358
 359 =cut
 360
 361 #note: implementation here, POD in FS::svc_acct
 362 sub seconds_since_sqlradacct {
 363   my($self, $start, $end) = @_;
 364
 365   my $svc_x = $self->svc_x;
 366
 367   my @part_export = $self->part_svc->part_export('sqlradius');
 368   push @part_export, $self->part_svc->part_export('sqlradius_withdomain');
 369   die "no sqlradius or sqlradius_withdomain export configured for this".
 370       "service type"
 371     unless @part_export;
 372     #or return undef;
 373
 374   my $seconds = 0;
 375   foreach my $part_export ( @part_export ) {
 376
 377     next if $part_export->option('ignore_accounting');
 378
 379     my $dbh = DBI->connect( map { $part_export->option($_) }
 380                             qw(datasrc username password)    )
 381       or die "can't connect to sqlradius database: ". $DBI::errstr;
 382
 383     #select a unix time conversion function based on database type
 384     my $str2time;
 385     if ( $dbh->{Driver}->{Name} =~ /^mysql(PP)?$/ ) {
 386       $str2time = 'UNIX_TIMESTAMP(';
 387     } elsif ( $dbh->{Driver}->{Name} eq 'Pg' ) {
 388       $str2time = 'EXTRACT( EPOCH FROM ';
 389     } else {
 390       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
 391            "; guessing how to convert to UNIX timestamps";
 392       $str2time = 'extract(epoch from ';
 393     }
 394
 395     my $username;
 396     if ( $part_export->exporttype eq 'sqlradius' ) {
 397       $username = $svc_x->username;
 398     } elsif ( $part_export->exporttype eq 'sqlradius_withdomain' ) {
 399       $username = $svc_x->email;
 400     } else {
 401       die 'unknown exporttype '. $part_export->exporttype;
 402     }
 403
 404     my $query;
 405
 406     #find closed sessions completely within the given range
 407     my $sth = $dbh->prepare("SELECT SUM(acctsessiontime)
 408                                FROM radacct
 409                                WHERE UserName = ?
 410                                  AND $str2time AcctStartTime) >= ?
 411                                  AND $str2time AcctStopTime ) <  ?
 412                                  AND $str2time AcctStopTime ) > 0
 413                                  AND AcctStopTime IS NOT NULL"
 414     ) or die $dbh->errstr;
 415     $sth->execute($username, $start, $end) or die $sth->errstr;
 416     my $regular = $sth->fetchrow_arrayref->[0];
 417
 418     #find open sessions which start in the range, count session start->range end
 419     $query = "SELECT SUM( ? - $str2time AcctStartTime ) )
 420                 FROM radacct
 421                 WHERE UserName = ?
 422                   AND $str2time AcctStartTime ) >= ?
 423                   AND $str2time AcctStartTime ) <  ?
 424                   AND ( ? - $str2time AcctStartTime ) ) < 86400
 425                   AND (    $str2time AcctStopTime ) = 0
 426                                     OR AcctStopTime IS NULL )";
 427     $sth = $dbh->prepare($query) or die $dbh->errstr;
 428     $sth->execute($end, $username, $start, $end, $end)
 429       or die $sth->errstr. " executing query $query";
 430     my $start_during = $sth->fetchrow_arrayref->[0];
 431
 432     #find closed sessions which start before the range but stop during,
 433     #count range start->session end
 434     $sth = $dbh->prepare("SELECT SUM( $str2time AcctStopTime ) - ? )
 435                             FROM radacct
 436                             WHERE UserName = ?
 437                               AND $str2time AcctStartTime ) < ?
 438                               AND $str2time AcctStopTime  ) >= ?
 439                               AND $str2time AcctStopTime  ) <  ?
 440                               AND $str2time AcctStopTime ) > 0
 441                               AND AcctStopTime IS NOT NULL"
 442     ) or die $dbh->errstr;
 443     $sth->execute($start, $username, $start, $start, $end ) or die $sth->errstr;
 444     my $end_during = $sth->fetchrow_arrayref->[0];
 445
 446     #find closed (not anymore - or open) sessions which start before the range
 447     # but stop after, or are still open, count range start->range end
 448     # don't count open sessions (probably missing stop record)
 449     $sth = $dbh->prepare("SELECT COUNT(*)
 450                             FROM radacct
 451                             WHERE UserName = ?
 452                               AND $str2time AcctStartTime ) < ?
 453                               AND ( $str2time AcctStopTime ) >= ?
 454                                                                   )"
 455                               #      OR AcctStopTime =  0
 456                               #      OR AcctStopTime IS NULL       )"
 457     ) or die $dbh->errstr;
 458     $sth->execute($username, $start, $end ) or die $sth->errstr;
 459     my $entire_range = ($end-$start) * $sth->fetchrow_arrayref->[0];
 460
 461     $seconds += $regular + $end_during + $start_during + $entire_range;
 462
 463   }
 464
 465   $seconds;
 466
 467 }
 468
 469 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 470
 471 See L<FS::svc_acct/attribute_since_sqlradacct>.  Equivalent to
 472 $cust_svc->svc_x->attribute_since_sqlradacct, but more efficient.  Meaningless
 473 for records where B<svcdb> is not "svc_acct".
 474
 475 =cut
 476
 477 #note: implementation here, POD in FS::svc_acct
 478 #(false laziness w/seconds_since_sqlradacct above)
 479 sub attribute_since_sqlradacct {
 480   my($self, $start, $end, $attrib) = @_;
 481
 482   my $svc_x = $self->svc_x;
 483
 484   my @part_export = $self->part_svc->part_export('sqlradius');
 485   push @part_export, $self->part_svc->part_export('sqlradius_withdomain');
 486   die "no sqlradius or sqlradius_withdomain export configured for this".
 487       "service type"
 488     unless @part_export;
 489     #or return undef;
 490
 491   my $sum = 0;
 492
 493   foreach my $part_export ( @part_export ) {
 494
 495     next if $part_export->option('ignore_accounting');
 496
 497     my $dbh = DBI->connect( map { $part_export->option($_) }
 498                             qw(datasrc username password)    )
 499       or die "can't connect to sqlradius database: ". $DBI::errstr;
 500
 501     #select a unix time conversion function based on database type
 502     my $str2time;
 503     if ( $dbh->{Driver}->{Name} =~ /^mysql(PP)?$/ ) {
 504       $str2time = 'UNIX_TIMESTAMP(';
 505     } elsif ( $dbh->{Driver}->{Name} eq 'Pg' ) {
 506       $str2time = 'EXTRACT( EPOCH FROM ';
 507     } else {
 508       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
 509            "; guessing how to convert to UNIX timestamps";
 510       $str2time = 'extract(epoch from ';
 511     }
 512
 513     my $username;
 514     if ( $part_export->exporttype eq 'sqlradius' ) {
 515       $username = $svc_x->username;
 516     } elsif ( $part_export->exporttype eq 'sqlradius_withdomain' ) {
 517       $username = $svc_x->email;
 518     } else {
 519       die 'unknown exporttype '. $part_export->exporttype;
 520     }
 521
 522     my $sth = $dbh->prepare("SELECT SUM($attrib)
 523                                FROM radacct
 524                                WHERE UserName = ?
 525                                  AND $str2time AcctStopTime ) >= ?
 526                                  AND $str2time AcctStopTime ) <  ?
 527                                  AND AcctStopTime IS NOT NULL"
 528     ) or die $dbh->errstr;
 529     $sth->execute($username, $start, $end) or die $sth->errstr;
 530
 531     $sum += $sth->fetchrow_arrayref->[0];
 532
 533   }
 534
 535   $sum;
 536
 537 }
 538
 539 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
 540
 541 See L<FS::svc_acct/get_session_history_sqlradacct>.  Equivalent to
 542 $cust_svc->svc_x->get_session_history_sqlradacct, but more efficient.
 543 Meaningless for records where B<svcdb> is not "svc_acct".
 544
 545 =cut
 546
 547 sub get_session_history {
 548   my($self, $start, $end, $attrib) = @_;
 549
 550   my $username = $self->svc_x->username;
 551
 552   my @part_export = $self->part_svc->part_export('sqlradius')
 553     or die "no sqlradius export configured for this service type";
 554     #or return undef;
 555
 556   my @sessions = ();
 557
 558   foreach my $part_export ( @part_export ) {
 559
 560     my $dbh = DBI->connect( map { $part_export->option($_) }
 561                             qw(datasrc username password)    )
 562       or die "can't connect to sqlradius database: ". $DBI::errstr;
 563
 564     #select a unix time conversion function based on database type
 565     my $str2time;
 566     if ( $dbh->{Driver}->{Name} =~ /^mysql(PP)?$/ ) {
 567       $str2time = 'UNIX_TIMESTAMP(';
 568     } elsif ( $dbh->{Driver}->{Name} eq 'Pg' ) {
 569       $str2time = 'EXTRACT( EPOCH FROM ';
 570     } else {
 571       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
 572            "; guessing how to convert to UNIX timestamps";
 573       $str2time = 'extract(epoch from ';
 574     }
 575
 576     my @fields = qw( acctstarttime acctstoptime acctsessiontime
 577                      acctinputoctets acctoutputoctets framedipaddress );
 578
 579     my $sth = $dbh->prepare('SELECT '. join(', ', @fields).
 580                             "  FROM radacct
 581                                WHERE UserName = ?
 582                                  AND $str2time AcctStopTime ) >= ?
 583                                  AND $str2time AcctStopTime ) <=  ?
 584                                  ORDER BY AcctStartTime DESC
 585     ") or die $dbh->errstr;
 586     $sth->execute($username, $start, $end) or die $sth->errstr;
 587
 588     push @sessions, map { { %$_ } } @{ $sth->fetchall_arrayref({}) };
 589
 590   }
 591   \@sessions
 592
 593 }
 594
 595 =item pkg_svc
 596
 597 Returns the pkg_svc record for for this service, if applicable.
 598
 599 =cut
 600
 601 sub pkg_svc {
 602   my $self = shift;
 603   my $cust_pkg = $self->cust_pkg;
 604   return undef unless $cust_pkg;
 605
 606   qsearchs( 'pkg_svc', { 'svcpart' => $self->svcpart,
 607                          'pkgpart' => $cust_pkg->pkgpart,
 608                        }
 609           );
 610 }
 611
 612 =back
 613
 614 =head1 BUGS
 615
 616 Behaviour of changing the svcpart of cust_svc records is undefined and should
 617 possibly be prohibited, and pkg_svc records are not checked.
 618
 619 pkg_svc records are not checked in general (here).
 620
 621 Deleting this record doesn't check or delete the svc_* record associated
 622 with this record.
 623
 624 In seconds_since_sqlradacct, specifying a DATASRC/USERNAME/PASSWORD instead of
 625 a DBI database handle is not yet implemented.
 626
 627 =head1 SEE ALSO
 628
 629 L<FS::Record>, L<FS::cust_pkg>, L<FS::part_svc>, L<FS::pkg_svc>,
 630 schema.html from the base documentation
 631
 632 =cut
 633
 634 1;
 635