FS/FS/cust_svc.pm

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