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