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