FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $nossh_hack $conf $dir_prefix @shells $usernamemin
   5              $usernamemax $passwordmin $passwordmax
   6              $username_ampersand $username_letter $username_letterfirst
   7              $username_noperiod $username_uppercase
   8              $shellmachine $useradd $usermod $userdel $mydomain
   9              $cyrus_server $cyrus_admin_user $cyrus_admin_pass
  10              $cp_server $cp_user $cp_pass $cp_workgroup
  11              $dirhash
  12              $icradius_dbh
  13              @saltset @pw_set);
  14 use Carp;
  15 use FS::Conf;
  16 use FS::Record qw( qsearch qsearchs fields dbh );
  17 use FS::svc_Common;
  18 use Net::SSH;
  19 use FS::part_svc;
  20 use FS::svc_acct_pop;
  21 use FS::svc_acct_sm;
  22 use FS::cust_main_invoice;
  23 use FS::svc_domain;
  24 use FS::raddb;
  25 use FS::queue;
  26
  27 @ISA = qw( FS::svc_Common );
  28
  29 #ask FS::UID to run this stuff for us later
  30 $FS::UID::callback{'FS::svc_acct'} = sub {
  31   $conf = new FS::Conf;
  32   $dir_prefix = $conf->config('home');
  33   @shells = $conf->config('shells');
  34   $shellmachine = $conf->config('shellmachine');
  35   $usernamemin = $conf->config('usernamemin') || 2;
  36   $usernamemax = $conf->config('usernamemax');
  37   $passwordmin = $conf->config('passwordmin') || 6;
  38   $passwordmax = $conf->config('passwordmax') || 8;
  39   if ( $shellmachine ) {
  40     if ( $conf->exists('shellmachine-useradd') ) {
  41       $useradd = join("\n", $conf->config('shellmachine-useradd') )
  42                  || 'cp -pr /etc/skel $dir; chown -R $uid.$gid $dir';
  43     } else {
  44       $useradd = 'useradd -d $dir -m -s $shell -u $uid $username';
  45     }
  46     if ( $conf->exists('shellmachine-userdel') ) {
  47       $userdel = join("\n", $conf->config('shellmachine-userdel') )
  48                  || 'rm -rf $dir';
  49     } else {
  50       $userdel = 'userdel $username';
  51     }
  52     $usermod = join("\n", $conf->config('shellmachine-usermod') )
  53                || '[ -d $old_dir ] && mv $old_dir $new_dir || ( '.
  54                     'chmod u+t $old_dir; mkdir $new_dir; cd $old_dir; '.
  55                     'find . -depth -print | cpio -pdm $new_dir; '.
  56                     'chmod u-t $new_dir; chown -R $uid.$gid $new_dir; '.
  57                     'rm -rf $old_dir'.
  58                   ')';
  59   }
  60   $username_letter = $conf->exists('username-letter');
  61   $username_letterfirst = $conf->exists('username-letterfirst');
  62   $username_noperiod = $conf->exists('username-noperiod');
  63   $username_uppercase = $conf->exists('username-uppercase');
  64   $username_ampersand = $conf->exists('username-ampersand');
  65   $mydomain = $conf->config('domain');
  66   if ( $conf->exists('cyrus') ) {
  67     ($cyrus_server, $cyrus_admin_user, $cyrus_admin_pass) =
  68       $conf->config('cyrus');
  69     eval "use Cyrus::IMAP::Admin;"
  70   } else {
  71     $cyrus_server = '';
  72     $cyrus_admin_user = '';
  73     $cyrus_admin_pass = '';
  74   }
  75   if ( $conf->exists('cp_app') ) {
  76     ($cp_server, $cp_user, $cp_pass, $cp_workgroup) =
  77       $conf->config('cp_app');
  78     eval "use Net::APP;"
  79   } else {
  80     $cp_server = '';
  81     $cp_user = '';
  82     $cp_pass = '';
  83     $cp_workgroup = '';
  84   }
  85   if ( $conf->exists('icradiusmachines') ) {
  86     if ( $conf->exists('icradius_secrets') ) {
  87       #need some sort of late binding so it's only connected to when
  88       # actually used, hmm
  89       $icradius_dbh = DBI->connect($conf->config('icradius_secrets'))
  90         or die $DBI::errstr;
  91     } else {
  92       $icradius_dbh = dbh;
  93     }
  94   } else {
  95     $icradius_dbh = '';
  96   }
  97   $dirhash = $conf->config('dirhash') || 0;
  98 };
  99
 100 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
 101 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
 102
 103 #not needed in 5.004 #srand($$|time);
 104
 105 sub _cache {
 106   my $self = shift;
 107   my ( $hashref, $cache ) = @_;
 108   if ( $hashref->{'svc_acct_svcnum'} ) {
 109     $self->{'_domsvc'} = FS::svc_domain->new( {
 110       'svcnum'   => $hashref->{'domsvc'},
 111       'domain'   => $hashref->{'svc_acct_domain'},
 112       'catchall' => $hashref->{'svc_acct_catchall'},
 113     } );
 114   }
 115 }
 116
 117 =head1 NAME
 118
 119 FS::svc_acct - Object methods for svc_acct records
 120
 121 =head1 SYNOPSIS
 122
 123   use FS::svc_acct;
 124
 125   $record = new FS::svc_acct \%hash;
 126   $record = new FS::svc_acct { 'column' => 'value' };
 127
 128   $error = $record->insert;
 129
 130   $error = $new_record->replace($old_record);
 131
 132   $error = $record->delete;
 133
 134   $error = $record->check;
 135
 136   $error = $record->suspend;
 137
 138   $error = $record->unsuspend;
 139
 140   $error = $record->cancel;
 141
 142   %hash = $record->radius;
 143
 144   %hash = $record->radius_reply;
 145
 146   %hash = $record->radius_check;
 147
 148   $domain = $record->domain;
 149
 150   $svc_domain = $record->svc_domain;
 151
 152   $email = $record->email;
 153
 154   $seconds_since = $record->seconds_since($timestamp);
 155
 156 =head1 DESCRIPTION
 157
 158 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 159 FS::svc_Common.  The following fields are currently supported:
 160
 161 =over 4
 162
 163 =item svcnum - primary key (assigned automatcially for new accounts)
 164
 165 =item username
 166
 167 =item _password - generated if blank
 168
 169 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 170
 171 =item uid
 172
 173 =item gid
 174
 175 =item finger - GECOS
 176
 177 =item dir - set automatically if blank (and uid is not)
 178
 179 =item shell
 180
 181 =item quota - (unimplementd)
 182
 183 =item slipip - IP address
 184
 185 =item seconds -
 186
 187 =item domsvc - svcnum from svc_domain
 188
 189 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 190
 191 =item domsvc - service number of svc_domain with which to associate
 192
 193 =back
 194
 195 =head1 METHODS
 196
 197 =over 4
 198
 199 =item new HASHREF
 200
 201 Creates a new account.  To add the account to the database, see L<"insert">.
 202
 203 =cut
 204
 205 sub table { 'svc_acct'; }
 206
 207 =item insert
 208
 209 Adds this account to the database.  If there is an error, returns the error,
 210 otherwise returns false.
 211
 212 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 213 defined.  An FS::cust_svc record will be created and inserted.
 214
 215 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 216 username, uid, and dir fields are defined, the command(s) specified in
 217 the shellmachine-useradd configuration are added to the job queue (see
 218 L<FS::queue> and L<freeside-queued>) to be exectued on shellmachine via ssh.
 219 This behaviour can be surpressed by setting $FS::svc_acct::nossh_hack true.
 220 If the shellmachine-useradd configuration file does not exist,
 221
 222   useradd -d $dir -m -s $shell -u $uid $username
 223
 224 is the default.  If the shellmachine-useradd configuration file exists but
 225 it empty,
 226
 227   cp -pr /etc/skel $dir; chown -R $uid.$gid $dir
 228
 229 is the default instead.  Otherwise the contents of the file are treated as
 230 a double-quoted perl string, with the following variables available:
 231 $username, $uid, $gid, $dir, and $shell.
 232
 233 (TODOC: cyrus config file, L<FS::queue> and L<freeside-queued>)
 234
 235 =cut
 236
 237 sub insert {
 238   my $self = shift;
 239   my $error;
 240
 241   local $SIG{HUP} = 'IGNORE';
 242   local $SIG{INT} = 'IGNORE';
 243   local $SIG{QUIT} = 'IGNORE';
 244   local $SIG{TERM} = 'IGNORE';
 245   local $SIG{TSTP} = 'IGNORE';
 246   local $SIG{PIPE} = 'IGNORE';
 247
 248   my $oldAutoCommit = $FS::UID::AutoCommit;
 249   local $FS::UID::AutoCommit = 0;
 250   my $dbh = dbh;
 251
 252   my $amount = 0;
 253
 254   $error = $self->check;
 255   return $error if $error;
 256
 257   return "Username ". $self->username. " in use"
 258     if qsearchs( 'svc_acct', { 'username' => $self->username,
 259                                'domsvc'   => $self->domsvc,
 260                              } );
 261
 262   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 263   return "Unknown svcpart" unless $part_svc;
 264   return "uid in use"
 265     if $part_svc->part_svc_column('uid')->columnflag ne 'F'
 266       && qsearchs( 'svc_acct', { 'uid' => $self->uid } )
 267       && $self->username !~ /^(hyla)?fax$/
 268     ;
 269
 270   $error = $self->SUPER::insert;
 271   if ( $error ) {
 272     $dbh->rollback if $oldAutoCommit;
 273     return $error;
 274   }
 275
 276   my( $username, $uid, $gid, $dir, $shell ) = (
 277     $self->username,
 278     $self->uid,
 279     $self->gid,
 280     $self->dir,
 281     $self->shell,
 282   );
 283   if ( $username && $uid && $dir && $shellmachine && ! $nossh_hack ) {
 284     my $queue = new FS::queue {
 285       'svcnum' => $self->svcnum,
 286       'job' => 'Net::SSH::ssh_cmd',
 287     };
 288     $error = $queue->insert("root\@$shellmachine", eval qq("$useradd") );
 289     if ( $error ) {
 290       $dbh->rollback if $oldAutoCommit;
 291       return "queueing job (transaction rolled back): $error";
 292     }
 293   }
 294
 295   if ( $cyrus_server ) {
 296     my $queue = new FS::queue {
 297       'svcnum' => $self->svcnum,
 298       'job'    => 'FS::svc_acct::cyrus_insert',
 299     };
 300     $error = $queue->insert($self->username, $self->quota);
 301     if ( $error ) {
 302       $dbh->rollback if $oldAutoCommit;
 303       return "queueing job (transaction rolled back): $error";
 304     }
 305   }
 306
 307   if ( $cp_server ) {
 308     my $queue = new FS::queue {
 309       'svcnum' => $self->svcnum,
 310       'job'    => 'FS::svc_acct::cp_insert'
 311     };
 312     $error = $queue->insert($self->username, $self->_password);
 313     if ( $error ) {
 314       $dbh->rollback if $oldAutoCommit;
 315       return "queueing job (transaction rolled back): $error";
 316     }
 317   }
 318
 319   if ( $icradius_dbh ) {
 320
 321     my $radcheck_queue =
 322       new FS::queue {
 323       'svcnum' => $self->svcnum,
 324       'job' => 'FS::svc_acct::icradius_rc_insert'
 325     };
 326     $error = $radcheck_queue->insert( $self->username,
 327                                       $self->_password,
 328                                       $self->radius_check
 329                                     );
 330     if ( $error ) {
 331       $dbh->rollback if $oldAutoCommit;
 332       return "queueing job (transaction rolled back): $error";
 333     }
 334
 335     my $radreply_queue =
 336       new FS::queue {
 337       'svcnum' => $self->svcnum,
 338       'job' => 'FS::svc_acct::icradius_rr_insert'
 339     };
 340     $error = $radreply_queue->insert( $self->username,
 341                                       $self->_password,
 342                                       $self->radius_reply
 343                                     );
 344     if ( $error ) {
 345       $dbh->rollback if $oldAutoCommit;
 346       return "queueing job (transaction rolled back): $error";
 347     }
 348
 349   }
 350
 351   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 352   ''; #no error
 353 }
 354
 355 sub cyrus_insert {
 356   my( $username, $quota ) = @_;
 357
 358   warn "cyrus_insert: starting for user $username, quota $quota\n";
 359
 360   warn "cyrus_insert: connecting to $cyrus_server\n";
 361   my $client = Cyrus::IMAP::Admin->new($cyrus_server);
 362
 363   warn "cyrus_insert: authentication as $cyrus_admin_user\n";
 364   $client->authenticate(
 365     -user      => $cyrus_admin_user,
 366     -mechanism => "login",
 367     -password  => $cyrus_admin_pass
 368   );
 369
 370   warn "cyrus_insert: creating user.$username\n";
 371   my $rc = $client->create("user.$username");
 372   my $error = $client->error;
 373   die "cyrus_insert: error creating user.$username: $error" if $error;
 374
 375   warn "cyrus_insert: setacl user.$username, $username => all\n";
 376   $rc = $client->setacl("user.$username", $username => 'all' );
 377   $error = $client->error;
 378   die "cyrus_insert: error setacl user.$username: $error" if $error;
 379
 380   if ( $quota ) {
 381     warn "cyrus_insert: setquota user.$username, STORAGE => $quota\n";
 382     $rc = $client->setquota("user.$username", 'STORAGE' => $quota );
 383     $error = $client->error;
 384     die "cyrus_insert: error setquota user.$username: $error" if $error;
 385   }
 386
 387   1;
 388 }
 389
 390 sub cp_insert {
 391   my( $username, $password ) = @_;
 392
 393   my $app = new Net::APP ( $cp_server,
 394                         User     => $cp_user,
 395                         Password => $cp_pass,
 396                         Domain   => $mydomain,
 397                         Timeout  => 60,
 398                         #Debug    => 1,
 399                       ) or die "$@\n";
 400
 401   $app->create_mailbox(
 402                         Mailbox   => $username,
 403                         Password  => $password,
 404                         Workgroup => $cp_workgroup,
 405                         Domain    => $mydomain,
 406                       );
 407
 408   die $app->message."\n" unless $app->ok;
 409 }
 410
 411 sub icradius_rc_insert {
 412   my( $username, $password, %radcheck ) = @_;
 413
 414   my $sth = $icradius_dbh->prepare(
 415     "INSERT INTO radcheck ( id, UserName, Attribute, Value ) VALUES ( ".
 416     join(", ", map { $icradius_dbh->quote($_) } (
 417       '',
 418       $username,
 419       "Password",
 420       $password,
 421     ) ). " )"
 422   );
 423   $sth->execute or die "can't insert into radcheck table: ". $sth->errstr;
 424
 425   foreach my $attribute ( keys %radcheck ) {
 426     my $sth = $icradius_dbh->prepare(
 427       "INSERT INTO radcheck ( id, UserName, Attribute, Value ) VALUES ( ".
 428       join(", ", map { $icradius_dbh->quote($_) } (
 429         '',
 430         $username,
 431         $attribute,
 432         $radcheck{$attribute},
 433       ) ). " )"
 434     );
 435     $sth->execute or die "can't insert into radcheck table: ". $sth->errstr;
 436   }
 437
 438   1;
 439 }
 440
 441 sub icradius_rr_insert {
 442   my( $username, $password, %radreply ) = @_;
 443
 444   foreach my $attribute ( keys %radreply ) {
 445     my $sth = $icradius_dbh->prepare(
 446       "INSERT INTO radreply ( id, UserName, Attribute, Value ) VALUES ( ".
 447       join(", ", map { $icradius_dbh->quote($_) } (
 448         '',
 449         $username,
 450         $attribute,
 451         $radreply{$attribute},
 452       ) ). " )"
 453     );
 454     $sth->execute or die "can't insert into radreply table: ". $sth->errstr;
 455   }
 456
 457   1;
 458 }
 459
 460 =item delete
 461
 462 Deletes this account from the database.  If there is an error, returns the
 463 error, otherwise returns false.
 464
 465 The corresponding FS::cust_svc record will be deleted as well.
 466
 467 If the configuration value (see L<FS::Conf>) shellmachine exists, the
 468 command(s) specified in the shellmachine-userdel configuration file are
 469 added to the job queue (see L<FS::queue> and L<freeside-queued>) to be executed
 470 on shellmachine via ssh.  This behavior can be surpressed by setting
 471 $FS::svc_acct::nossh_hack true.  If the shellmachine-userdel configuration
 472 file does not exist,
 473
 474   userdel $username
 475
 476 is the default.  If the shellmachine-userdel configuration file exists but
 477 is empty,
 478
 479   rm -rf $dir
 480
 481 is the default instead.  Otherwise the contents of the file are treated as a
 482 double-quoted perl string, with the following variables available:
 483 $username and $dir.
 484
 485 (TODOC: cyrus config file)
 486
 487 =cut
 488
 489 sub delete {
 490   my $self = shift;
 491
 492   if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
 493     return "Can't delete an account which has (svc_acct_sm) mail aliases!"
 494       if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
 495   }
 496
 497   return "Can't delete an account which is a (svc_forward) source!"
 498     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 499
 500   return "Can't delete an account which is a (svc_forward) destination!"
 501     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 502
 503   return "Can't delete an account with (svc_www) web service!"
 504     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 505
 506   # what about records in session ?
 507
 508   local $SIG{HUP} = 'IGNORE';
 509   local $SIG{INT} = 'IGNORE';
 510   local $SIG{QUIT} = 'IGNORE';
 511   local $SIG{TERM} = 'IGNORE';
 512   local $SIG{TSTP} = 'IGNORE';
 513   local $SIG{PIPE} = 'IGNORE';
 514
 515   my $oldAutoCommit = $FS::UID::AutoCommit;
 516   local $FS::UID::AutoCommit = 0;
 517   my $dbh = dbh;
 518
 519   foreach my $cust_main_invoice (
 520     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 521   ) {
 522     unless ( defined($cust_main_invoice) ) {
 523       warn "WARNING: something's wrong with qsearch";
 524       next;
 525     }
 526     my %hash = $cust_main_invoice->hash;
 527     $hash{'dest'} = $self->email;
 528     my $new = new FS::cust_main_invoice \%hash;
 529     my $error = $new->replace($cust_main_invoice);
 530     if ( $error ) {
 531       $dbh->rollback if $oldAutoCommit;
 532       return $error;
 533     }
 534   }
 535
 536   foreach my $svc_domain (
 537     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 538   ) {
 539     my %hash = new FS::svc_domain->hash;
 540     $hash{'catchall'} = '';
 541     my $new = new FS::svc_domain \%hash;
 542     my $error = $new->replace($svc_domain);
 543     if ( $error ) {
 544       $dbh->rollback if $oldAutoCommit;
 545       return $error;
 546     }
 547   }
 548
 549   my $error = $self->SUPER::delete;
 550   if ( $error ) {
 551     $dbh->rollback if $oldAutoCommit;
 552     return $error;
 553   }
 554
 555   my( $username, $dir ) = (
 556     $self->username,
 557     $self->dir,
 558   );
 559   if ( $username && $shellmachine && ! $nossh_hack ) {
 560     my $queue = new FS::queue { 'job' => 'Net::SSH::ssh_cmd' };
 561     $error = $queue->insert("root\@$shellmachine", eval qq("$userdel") );
 562     if ( $error ) {
 563       $dbh->rollback if $oldAutoCommit;
 564       return "queueing job (transaction rolled back): $error";
 565     }
 566
 567   }
 568
 569   if ( $cyrus_server ) {
 570     my $queue = new FS::queue { 'job' => 'FS::svc_acct::cyrus_delete' };
 571     $error = $queue->insert($self->username);
 572     if ( $error ) {
 573       $dbh->rollback if $oldAutoCommit;
 574       return "queueing job (transaction rolled back): $error";
 575     }
 576   }
 577
 578   if ( $cp_server ) {
 579     my $queue = new FS::queue { 'job' => 'FS::svc_acct::cp_delete' };
 580     $error = $queue->insert($self->username);
 581     if ( $error ) {
 582       $dbh->rollback if $oldAutoCommit;
 583       return "queueing job (transaction rolled back): $error";
 584     }
 585   }
 586
 587   if ( $icradius_dbh ) {
 588
 589     my $radcheck_queue =
 590       new FS::queue { 'job' => 'FS::svc_acct::icradius_rc_delete' };
 591     $error = $radcheck_queue->insert( $self->username );
 592     if ( $error ) {
 593       $dbh->rollback if $oldAutoCommit;
 594       return "queueing job (transaction rolled back): $error";
 595     }
 596
 597     my $radreply_queue =
 598       new FS::queue { 'job' => 'FS::svc_acct::icradius_rr_delete' };
 599     $error = $radreply_queue->insert( $self->username );
 600     if ( $error ) {
 601       $dbh->rollback if $oldAutoCommit;
 602       return "queueing job (transaction rolled back): $error";
 603     }
 604
 605   }
 606
 607   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 608   '';
 609 }
 610
 611 sub cyrus_delete {
 612   my $username = shift;
 613
 614   my $client = Cyrus::IMAP::Admin->new($cyrus_server);
 615   $client->authenticate(
 616     -user      => $cyrus_admin_user,
 617     -mechanism => "login",
 618     -password  => $cyrus_admin_pass
 619   );
 620
 621   my $rc = $client->setacl("user.$username", $cyrus_admin_user => 'all' );
 622   my $error = $client->error;
 623   die $error if $error;
 624
 625   $rc = $client->delete("user.$username");
 626   $error = $client->error;
 627   die $error if $error;
 628
 629   1;
 630 }
 631
 632 sub cp_delete {
 633   my( $username ) = @_;
 634   my $app = new Net::APP ( $cp_server,
 635                         User     => $cp_user,
 636                         Password => $cp_pass,
 637                         Domain   => $mydomain,
 638                         Timeout  => 60,
 639                         #Debug    => 1,
 640                       ) or die "$@\n";
 641
 642   $app->delete_mailbox(
 643                         Mailbox   => $username,
 644                         Domain    => $mydomain,
 645                       );
 646
 647   die $app->message."\n" unless $app->ok;
 648 }
 649
 650 sub icradius_rc_delete {
 651   my $username = shift;
 652
 653   my $sth = $icradius_dbh->prepare(
 654     'DELETE FROM radcheck WHERE UserName = ?'
 655   );
 656   $sth->execute($username)
 657     or die "can't delete from radcheck table: ". $sth->errstr;
 658
 659   1;
 660 }
 661
 662 sub icradius_rr_delete {
 663   my $username = shift;
 664
 665   my $sth = $icradius_dbh->prepare(
 666     'DELETE FROM radreply WHERE UserName = ?'
 667   );
 668   $sth->execute($username)
 669     or die "can't delete from radreply table: ". $sth->errstr;
 670
 671   1;
 672 }
 673
 674 =item replace OLD_RECORD
 675
 676 Replaces OLD_RECORD with this one in the database.  If there is an error,
 677 returns the error, otherwise returns false.
 678
 679 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 680 dir field has changed, the command(s) specified in the shellmachine-usermod
 681 configuraiton file are added to the job queue (see L<FS::queue> and
 682 L<freeside-queued>) to be executed on shellmachine via ssh.  This behavior can
 683 be surpressed by setting $FS::svc-acct::nossh_hack true.  If the
 684 shellmachine-userdel configuration file does not exist or is empty,
 685
 686   [ -d $old_dir ] && mv $old_dir $new_dir || (
 687     chmod u+t $old_dir;
 688     mkdir $new_dir;
 689     cd $old_dir;
 690     find . -depth -print | cpio -pdm $new_dir;
 691     chmod u-t $new_dir;
 692     chown -R $uid.$gid $new_dir;
 693     rm -rf $old_dir
 694   )
 695
 696 is the default.  This behaviour can be surpressed by setting
 697 $FS::svc_acct::nossh_hack true.
 698
 699 =cut
 700
 701 sub replace {
 702   my ( $new, $old ) = ( shift, shift );
 703   my $error;
 704
 705   return "Username in use"
 706     if $old->username ne $new->username &&
 707       qsearchs( 'svc_acct', { 'username' => $new->username,
 708                                'domsvc'   => $new->domsvc,
 709                              } );
 710   {
 711     #no warnings 'numeric';  #alas, a 5.006-ism
 712     local($^W) = 0;
 713     return "Can't change uid!" if $old->uid != $new->uid;
 714   }
 715
 716   return "can't change username using Cyrus"
 717     if $cyrus_server && $old->username ne $new->username;
 718
 719   #change homdir when we change username
 720   $new->setfield('dir', '') if $old->username ne $new->username;
 721
 722   local $SIG{HUP} = 'IGNORE';
 723   local $SIG{INT} = 'IGNORE';
 724   local $SIG{QUIT} = 'IGNORE';
 725   local $SIG{TERM} = 'IGNORE';
 726   local $SIG{TSTP} = 'IGNORE';
 727   local $SIG{PIPE} = 'IGNORE';
 728
 729   my $oldAutoCommit = $FS::UID::AutoCommit;
 730   local $FS::UID::AutoCommit = 0;
 731   my $dbh = dbh;
 732
 733   $error = $new->SUPER::replace($old);
 734   if ( $error ) {
 735     $dbh->rollback if $oldAutoCommit;
 736     return $error if $error;
 737   }
 738
 739   my ( $old_dir, $new_dir, $uid, $gid ) = (
 740     $old->getfield('dir'),
 741     $new->getfield('dir'),
 742     $new->getfield('uid'),
 743     $new->getfield('gid'),
 744   );
 745   if ( $old_dir && $new_dir && $old_dir ne $new_dir && ! $nossh_hack ) {
 746     my $queue = new FS::queue {
 747       'svcnum' => $new->svcnum,
 748       'job' => 'Net::SSH::ssh_cmd'
 749     };
 750     $error = $queue->insert("root\@$shellmachine", eval qq("$usermod") );
 751     if ( $error ) {
 752       $dbh->rollback if $oldAutoCommit;
 753       return "queueing job (transaction rolled back): $error";
 754     }
 755   }
 756
 757   if ( $cp_server && $old->username ne $new->username ) {
 758     my $queue = new FS::queue {
 759       'svcnum' => $new->svcnum,
 760       'job' => 'FS::svc_acct::cp_rename'
 761     };
 762     $error = $queue->insert( $old->username, $new->username );
 763     if ( $error ) {
 764       $dbh->rollback if $oldAutoCommit;
 765       return "queueing job (transaction rolled back): $error";
 766     }
 767   }
 768
 769   if ( $cp_server && $old->_password ne $new->_password ) {
 770     my $queue = new FS::queue {
 771       'svcnum' => $new->svcnum,
 772       'job' => 'FS::svc_acct::cp_change'
 773     };
 774     $error = $queue->insert( $new->username, $new->_password );
 775     if ( $error ) {
 776       $dbh->rollback if $oldAutoCommit;
 777       return "queueing job (transaction rolled back): $error";
 778     }
 779   }
 780
 781   if ( $icradius_dbh ) {
 782     my $queue = new FS::queue {
 783       'svcnum' => $new->svcnum,
 784       'job' => 'FS::svc_acct::icradius_rc_replace'
 785     };
 786     $error = $queue->insert( $new->username,
 787                              $new->_password,
 788                            );
 789     if ( $error ) {
 790       $dbh->rollback if $oldAutoCommit;
 791       return "queueing job (transaction rolled back): $error";
 792     }
 793   }
 794
 795   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 796   ''; #no error
 797 }
 798
 799 sub icradius_rc_replace {
 800   my( $username, $new_password ) = @_;
 801
 802    my $sth = $icradius_dbh->prepare(
 803      "UPDATE radcheck SET Value = ? WHERE UserName = ? and Attribute = ?"
 804    );
 805    $sth->execute($new_password, $username, 'Password' )
 806      or die "can't update radcheck table: ". $sth->errstr;
 807
 808   1;
 809 }
 810
 811 sub cp_rename {
 812   my ( $old_username, $new_username ) = @_;
 813
 814   my $app = new Net::APP ( $cp_server,
 815                         User     => $cp_user,
 816                         Password => $cp_pass,
 817                         Domain   => $mydomain,
 818                         Timeout  => 60,
 819                         #Debug    => 1,
 820                       ) or die "$@\n";
 821
 822   $app->rename_mailbox(
 823                         Domain        => $mydomain,
 824                         Old_Mailbox   => $old_username,
 825                         New_Mailbox   => $new_username,
 826                       );
 827
 828   die $app->message."\n" unless $app->ok;
 829
 830 }
 831
 832 sub cp_change {
 833   my ( $username, $password ) = @_;
 834
 835   my $app = new Net::APP ( $cp_server,
 836                         User     => $cp_user,
 837                         Password => $cp_pass,
 838                         Domain   => $mydomain,
 839                         Timeout  => 60,
 840                         #Debug    => 1,
 841                       ) or die "$@\n";
 842
 843   if ( $password =~ /^\*SUSPENDED\* (.*)$/ ) {
 844     $password = $1;
 845     $app->set_mailbox_status(
 846                               Domain       => $mydomain,
 847                               Mailbox      => $username,
 848                               Other        => 'T',
 849                               Other_Bounce => 'T',
 850                             );
 851   } else {
 852     $app->set_mailbox_status(
 853                               Domain       => $mydomain,
 854                               Mailbox      => $username,
 855                               Other        => 'F',
 856                               Other_Bounce => 'F',
 857                             );
 858   }
 859   die $app->message."\n" unless $app->ok;
 860
 861   $app->change_mailbox(
 862                         Domain    => $mydomain,
 863                         Mailbox   => $username,
 864                         Password  => $password,
 865                       );
 866   die $app->message."\n" unless $app->ok;
 867
 868 }
 869
 870 =item suspend
 871
 872 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 873 error, returns the error, otherwise returns false.
 874
 875 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 876
 877 =cut
 878
 879 sub suspend {
 880   my $self = shift;
 881   my %hash = $self->hash;
 882   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 883            || $hash{_password} eq '*'
 884          ) {
 885     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 886     my $new = new FS::svc_acct ( \%hash );
 887     $new->replace($self);
 888   } else {
 889     ''; #no error (already suspended)
 890   }
 891 }
 892
 893 =item unsuspend
 894
 895 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 896 an error, returns the error, otherwise returns false.
 897
 898 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 899
 900 =cut
 901
 902 sub unsuspend {
 903   my $self = shift;
 904   my %hash = $self->hash;
 905   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 906     $hash{_password} = $1;
 907     my $new = new FS::svc_acct ( \%hash );
 908     $new->replace($self);
 909   } else {
 910     ''; #no error (already unsuspended)
 911   }
 912 }
 913
 914 =item cancel
 915
 916 Just returns false (no error) for now.
 917
 918 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 919
 920 =item check
 921
 922 Checks all fields to make sure this is a valid service.  If there is an error,
 923 returns the error, otherwise returns false.  Called by the insert and replace
 924 methods.
 925
 926 Sets any fixed values; see L<FS::part_svc>.
 927
 928 =cut
 929
 930 sub check {
 931   my $self = shift;
 932
 933   my($recref) = $self->hashref;
 934
 935   my $x = $self->setfixed;
 936   return $x unless ref($x);
 937   my $part_svc = $x;
 938
 939   my $error = $self->ut_numbern('svcnum')
 940               || $self->ut_number('domsvc')
 941   ;
 942   return $error if $error;
 943
 944   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 945   if ( $username_uppercase ) {
 946     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 947       or return "Illegal username: ". $recref->{username};
 948     $recref->{username} = $1;
 949   } else {
 950     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 951       or return "Illegal username: ". $recref->{username};
 952     $recref->{username} = $1;
 953   }
 954
 955   if ( $username_letterfirst ) {
 956     $recref->{username} =~ /^[a-z]/ or return "Illegal username";
 957   } elsif ( $username_letter ) {
 958     $recref->{username} =~ /[a-z]/ or return "Illegal username";
 959   }
 960   if ( $username_noperiod ) {
 961     $recref->{username} =~ /\./ and return "Illegal username";
 962   }
 963   unless ( $username_ampersand ) {
 964     $recref->{username} =~ /\&/ and return "Illegal username";
 965   }
 966
 967   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 968   $recref->{popnum} = $1;
 969   return "Unknown popnum" unless
 970     ! $recref->{popnum} ||
 971     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 972
 973   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 974
 975     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 976     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 977
 978     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 979     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 980     #not all systems use gid=uid
 981     #you can set a fixed gid in part_svc
 982
 983     return "Only root can have uid 0"
 984       if $recref->{uid} == 0 && $recref->{username} ne 'root';
 985
 986 #    $error = $self->ut_textn('finger');
 987 #    return $error if $error;
 988     $self->getfield('finger') =~
 989       /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\*\<\>]*)$/
 990         or return "Illegal finger: ". $self->getfield('finger');
 991     $self->setfield('finger', $1);
 992
 993     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 994       or return "Illegal directory";
 995     $recref->{dir} = $1;
 996     return "Illegal directory"
 997       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 998     return "Illegal directory"
 999       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1000     unless ( $recref->{dir} ) {
1001       $recref->{dir} = $dir_prefix . '/';
1002       if ( $dirhash > 0 ) {
1003         for my $h ( 1 .. $dirhash ) {
1004           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1005         }
1006       } elsif ( $dirhash < 0 ) {
1007         for my $h ( reverse $dirhash .. -1 ) {
1008           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1009         }
1010       }
1011       $recref->{dir} .= $recref->{username};
1012     ;
1013     }
1014
1015     unless ( $recref->{username} eq 'sync' ) {
1016       if ( grep $_ eq $recref->{shell}, @shells ) {
1017         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1018       } else {
1019         return "Illegal shell \`". $self->shell. "\'; ".
1020                $conf->dir. "/shells contains: @shells";
1021       }
1022     } else {
1023       $recref->{shell} = '/bin/sync';
1024     }
1025
1026     $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)";
1027     $recref->{quota} = $1;
1028
1029   } else {
1030     $recref->{gid} ne '' ?
1031       return "Can't have gid without uid" : ( $recref->{gid}='' );
1032     $recref->{finger} ne '' ?
1033       return "Can't have finger-name without uid" : ( $recref->{finger}='' );
1034     $recref->{dir} ne '' ?
1035       return "Can't have directory without uid" : ( $recref->{dir}='' );
1036     $recref->{shell} ne '' ?
1037       return "Can't have shell without uid" : ( $recref->{shell}='' );
1038     $recref->{quota} ne '' ?
1039       return "Can't have quota without uid" : ( $recref->{quota}='' );
1040   }
1041
1042   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1043     unless ( $recref->{slipip} eq '0e0' ) {
1044       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1045         or return "Illegal slipip". $self->slipip;
1046       $recref->{slipip} = $1;
1047     } else {
1048       $recref->{slipip} = '0e0';
1049     }
1050
1051   }
1052
1053   #arbitrary RADIUS stuff; allow ut_textn for now
1054   foreach ( grep /^radius_/, fields('svc_acct') ) {
1055     $self->ut_textn($_);
1056   }
1057
1058   #generate a password if it is blank
1059   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1060     unless ( $recref->{_password} );
1061
1062   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1063   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1064     $recref->{_password} = $1.$3;
1065     #uncomment this to encrypt password immediately upon entry, or run
1066     #bin/crypt_pw in cron to give new users a window during which their
1067     #password is available to techs, for faxing, etc.  (also be aware of
1068     #radius issues!)
1069     #$recref->{password} = $1.
1070     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
1071     #;
1072   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$]{13,34})$/ ) {
1073     $recref->{_password} = $1.$3;
1074   } elsif ( $recref->{_password} eq '*' ) {
1075     $recref->{_password} = '*';
1076   } elsif ( $recref->{_password} eq '!!' ) {
1077     $recref->{_password} = '!!';
1078   } else {
1079     #return "Illegal password";
1080     return "Illegal password: ". $recref->{_password};
1081   }
1082
1083   ''; #no error
1084 }
1085
1086 =item radius
1087
1088 Depriciated, use radius_reply instead.
1089
1090 =cut
1091
1092 sub radius {
1093   carp "FS::svc_acct::radius depriciated, use radius_reply";
1094   $_[0]->radius_reply;
1095 }
1096
1097 =item radius_reply
1098
1099 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1100 reply attributes of this record.
1101
1102 Note that this is now the preferred method for reading RADIUS attributes -
1103 accessing the columns directly is discouraged, as the column names are
1104 expected to change in the future.
1105
1106 =cut
1107
1108 sub radius_reply {
1109   my $self = shift;
1110   my %reply =
1111     map {
1112       /^(radius_(.*))$/;
1113       my($column, $attrib) = ($1, $2);
1114       #$attrib =~ s/_/\-/g;
1115       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1116     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1117   if ( $self->ip && $self->ip ne '0e0' ) {
1118     $reply{'Framed-IP-Address'} = $self->ip;
1119   }
1120   %reply;
1121 }
1122
1123 =item radius_check
1124
1125 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1126 check attributes of this record.
1127
1128 Accessing RADIUS attributes directly is not supported and will break in the
1129 future.
1130
1131 =cut
1132
1133 sub radius_check {
1134   my $self = shift;
1135   map {
1136     /^(rc_(.*))$/;
1137     my($column, $attrib) = ($1, $2);
1138     #$attrib =~ s/_/\-/g;
1139     ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1140   } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1141 }
1142
1143 =item domain
1144
1145 Returns the domain associated with this account.
1146
1147 =cut
1148
1149 sub domain {
1150   my $self = shift;
1151   if ( $self->domsvc ) {
1152     #$self->svc_domain->domain;
1153     my $svc_domain = $self->svc_domain
1154       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1155     $svc_domain->domain;
1156   } else {
1157     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
1158   }
1159 }
1160
1161 =item svc_domain
1162
1163 Returns the FS::svc_domain record for this account's domain (see
1164 L<FS::svc_domain>.
1165
1166 =cut
1167
1168 sub svc_domain {
1169   my $self = shift;
1170   $self->{'_domsvc'}
1171     ? $self->{'_domsvc'}
1172     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1173 }
1174
1175 =item cust_svc
1176
1177 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1178
1179 sub cust_svc {
1180   my $self = shift;
1181   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1182 }
1183
1184 =item email
1185
1186 Returns an email address associated with the account.
1187
1188 =cut
1189
1190 sub email {
1191   my $self = shift;
1192   $self->username. '@'. $self->domain;
1193 }
1194
1195 =item seconds_since TIMESTAMP
1196
1197 Returns the number of seconds this account has been online since TIMESTAMP.
1198 See L<FS::session>
1199
1200 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1201 L<Time::Local> and L<Date::Parse> for conversion functions.
1202
1203 =cut
1204
1205 #note: POD here, implementation in FS::cust_svc
1206 sub seconds_since {
1207   my $self = shift;
1208   $self->cust_svc->seconds_since(@_);
1209 }
1210
1211 =back
1212
1213 =head1 BUGS
1214
1215 The $recref stuff in sub check should be cleaned up.
1216
1217 The suspend, unsuspend and cancel methods update the database, but not the
1218 current object.  This is probably a bug as it's unexpected and
1219 counterintuitive.
1220
1221 =head1 SEE ALSO
1222
1223 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1224 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1225 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1226 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1227 schema.html from the base documentation.
1228
1229 =cut
1230
1231 1;
1232