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                               Other => 'T',
 847                               Other_Bounce => 'T',
 848                             );
 849   } else {
 850     $app->set_mailbox_status(
 851                               Other => 'F',
 852                               Other_Bounce => 'F',
 853                             );
 854   }
 855   die $app->message."\n" unless $app->ok;
 856
 857   $app->change_mailbox(
 858                         Domain    => $mydomain,
 859                         Mailbox   => $username,
 860                         Password  => $password,
 861                       );
 862   die $app->message."\n" unless $app->ok;
 863
 864 }
 865
 866 =item suspend
 867
 868 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 869 error, returns the error, otherwise returns false.
 870
 871 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 872
 873 =cut
 874
 875 sub suspend {
 876   my $self = shift;
 877   my %hash = $self->hash;
 878   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 879            || $hash{_password} eq '*'
 880          ) {
 881     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 882     my $new = new FS::svc_acct ( \%hash );
 883     $new->replace($self);
 884   } else {
 885     ''; #no error (already suspended)
 886   }
 887 }
 888
 889 =item unsuspend
 890
 891 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 892 an error, returns the error, otherwise returns false.
 893
 894 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 895
 896 =cut
 897
 898 sub unsuspend {
 899   my $self = shift;
 900   my %hash = $self->hash;
 901   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 902     $hash{_password} = $1;
 903     my $new = new FS::svc_acct ( \%hash );
 904     $new->replace($self);
 905   } else {
 906     ''; #no error (already unsuspended)
 907   }
 908 }
 909
 910 =item cancel
 911
 912 Just returns false (no error) for now.
 913
 914 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 915
 916 =item check
 917
 918 Checks all fields to make sure this is a valid service.  If there is an error,
 919 returns the error, otherwise returns false.  Called by the insert and replace
 920 methods.
 921
 922 Sets any fixed values; see L<FS::part_svc>.
 923
 924 =cut
 925
 926 sub check {
 927   my $self = shift;
 928
 929   my($recref) = $self->hashref;
 930
 931   my $x = $self->setfixed;
 932   return $x unless ref($x);
 933   my $part_svc = $x;
 934
 935   my $error = $self->ut_numbern('svcnum')
 936               || $self->ut_number('domsvc')
 937   ;
 938   return $error if $error;
 939
 940   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 941   if ( $username_uppercase ) {
 942     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 943       or return "Illegal username: ". $recref->{username};
 944     $recref->{username} = $1;
 945   } else {
 946     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 947       or return "Illegal username: ". $recref->{username};
 948     $recref->{username} = $1;
 949   }
 950
 951   if ( $username_letterfirst ) {
 952     $recref->{username} =~ /^[a-z]/ or return "Illegal username";
 953   } elsif ( $username_letter ) {
 954     $recref->{username} =~ /[a-z]/ or return "Illegal username";
 955   }
 956   if ( $username_noperiod ) {
 957     $recref->{username} =~ /\./ and return "Illegal username";
 958   }
 959   unless ( $username_ampersand ) {
 960     $recref->{username} =~ /\&/ and return "Illegal username";
 961   }
 962
 963   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 964   $recref->{popnum} = $1;
 965   return "Unknown popnum" unless
 966     ! $recref->{popnum} ||
 967     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 968
 969   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 970
 971     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 972     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 973
 974     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 975     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 976     #not all systems use gid=uid
 977     #you can set a fixed gid in part_svc
 978
 979     return "Only root can have uid 0"
 980       if $recref->{uid} == 0 && $recref->{username} ne 'root';
 981
 982 #    $error = $self->ut_textn('finger');
 983 #    return $error if $error;
 984     $self->getfield('finger') =~
 985       /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\*\<\>]*)$/
 986         or return "Illegal finger: ". $self->getfield('finger');
 987     $self->setfield('finger', $1);
 988
 989     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 990       or return "Illegal directory";
 991     $recref->{dir} = $1;
 992     return "Illegal directory"
 993       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 994     return "Illegal directory"
 995       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 996     unless ( $recref->{dir} ) {
 997       $recref->{dir} = $dir_prefix . '/';
 998       if ( $dirhash > 0 ) {
 999         for my $h ( 1 .. $dirhash ) {
1000           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1001         }
1002       } elsif ( $dirhash < 0 ) {
1003         for my $h ( reverse $dirhash .. -1 ) {
1004           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1005         }
1006       }
1007       $recref->{dir} .= $recref->{username};
1008     ;
1009     }
1010
1011     unless ( $recref->{username} eq 'sync' ) {
1012       if ( grep $_ eq $recref->{shell}, @shells ) {
1013         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1014       } else {
1015         return "Illegal shell \`". $self->shell. "\'; ".
1016                $conf->dir. "/shells contains: @shells";
1017       }
1018     } else {
1019       $recref->{shell} = '/bin/sync';
1020     }
1021
1022     $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)";
1023     $recref->{quota} = $1;
1024
1025   } else {
1026     $recref->{gid} ne '' ?
1027       return "Can't have gid without uid" : ( $recref->{gid}='' );
1028     $recref->{finger} ne '' ?
1029       return "Can't have finger-name without uid" : ( $recref->{finger}='' );
1030     $recref->{dir} ne '' ?
1031       return "Can't have directory without uid" : ( $recref->{dir}='' );
1032     $recref->{shell} ne '' ?
1033       return "Can't have shell without uid" : ( $recref->{shell}='' );
1034     $recref->{quota} ne '' ?
1035       return "Can't have quota without uid" : ( $recref->{quota}='' );
1036   }
1037
1038   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1039     unless ( $recref->{slipip} eq '0e0' ) {
1040       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1041         or return "Illegal slipip". $self->slipip;
1042       $recref->{slipip} = $1;
1043     } else {
1044       $recref->{slipip} = '0e0';
1045     }
1046
1047   }
1048
1049   #arbitrary RADIUS stuff; allow ut_textn for now
1050   foreach ( grep /^radius_/, fields('svc_acct') ) {
1051     $self->ut_textn($_);
1052   }
1053
1054   #generate a password if it is blank
1055   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1056     unless ( $recref->{_password} );
1057
1058   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1059   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1060     $recref->{_password} = $1.$3;
1061     #uncomment this to encrypt password immediately upon entry, or run
1062     #bin/crypt_pw in cron to give new users a window during which their
1063     #password is available to techs, for faxing, etc.  (also be aware of
1064     #radius issues!)
1065     #$recref->{password} = $1.
1066     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
1067     #;
1068   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$]{13,34})$/ ) {
1069     $recref->{_password} = $1.$3;
1070   } elsif ( $recref->{_password} eq '*' ) {
1071     $recref->{_password} = '*';
1072   } elsif ( $recref->{_password} eq '!!' ) {
1073     $recref->{_password} = '!!';
1074   } else {
1075     #return "Illegal password";
1076     return "Illegal password: ". $recref->{_password};
1077   }
1078
1079   ''; #no error
1080 }
1081
1082 =item radius
1083
1084 Depriciated, use radius_reply instead.
1085
1086 =cut
1087
1088 sub radius {
1089   carp "FS::svc_acct::radius depriciated, use radius_reply";
1090   $_[0]->radius_reply;
1091 }
1092
1093 =item radius_reply
1094
1095 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1096 reply attributes of this record.
1097
1098 Note that this is now the preferred method for reading RADIUS attributes -
1099 accessing the columns directly is discouraged, as the column names are
1100 expected to change in the future.
1101
1102 =cut
1103
1104 sub radius_reply {
1105   my $self = shift;
1106   my %reply =
1107     map {
1108       /^(radius_(.*))$/;
1109       my($column, $attrib) = ($1, $2);
1110       #$attrib =~ s/_/\-/g;
1111       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1112     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1113   if ( $self->ip && $self->ip ne '0e0' ) {
1114     $reply{'Framed-IP-Address'} = $self->ip;
1115   }
1116   %reply;
1117 }
1118
1119 =item radius_check
1120
1121 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1122 check attributes of this record.
1123
1124 Accessing RADIUS attributes directly is not supported and will break in the
1125 future.
1126
1127 =cut
1128
1129 sub radius_check {
1130   my $self = shift;
1131   map {
1132     /^(rc_(.*))$/;
1133     my($column, $attrib) = ($1, $2);
1134     #$attrib =~ s/_/\-/g;
1135     ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1136   } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1137 }
1138
1139 =item domain
1140
1141 Returns the domain associated with this account.
1142
1143 =cut
1144
1145 sub domain {
1146   my $self = shift;
1147   if ( $self->domsvc ) {
1148     #$self->svc_domain->domain;
1149     my $svc_domain = $self->svc_domain
1150       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1151     $svc_domain->domain;
1152   } else {
1153     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
1154   }
1155 }
1156
1157 =item svc_domain
1158
1159 Returns the FS::svc_domain record for this account's domain (see
1160 L<FS::svc_domain>.
1161
1162 =cut
1163
1164 sub svc_domain {
1165   my $self = shift;
1166   $self->{'_domsvc'}
1167     ? $self->{'_domsvc'}
1168     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1169 }
1170
1171 =item cust_svc
1172
1173 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1174
1175 sub cust_svc {
1176   my $self = shift;
1177   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1178 }
1179
1180 =item email
1181
1182 Returns an email address associated with the account.
1183
1184 =cut
1185
1186 sub email {
1187   my $self = shift;
1188   $self->username. '@'. $self->domain;
1189 }
1190
1191 =item seconds_since TIMESTAMP
1192
1193 Returns the number of seconds this account has been online since TIMESTAMP.
1194 See L<FS::session>
1195
1196 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1197 L<Time::Local> and L<Date::Parse> for conversion functions.
1198
1199 =cut
1200
1201 #note: POD here, implementation in FS::cust_svc
1202 sub seconds_since {
1203   my $self = shift;
1204   $self->cust_svc->seconds_since(@_);
1205 }
1206
1207 =back
1208
1209 =head1 BUGS
1210
1211 The $recref stuff in sub check should be cleaned up.
1212
1213 The suspend, unsuspend and cancel methods update the database, but not the
1214 current object.  This is probably a bug as it's unexpected and
1215 counterintuitive.
1216
1217 =head1 SEE ALSO
1218
1219 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1220 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1221 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1222 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1223 schema.html from the base documentation.
1224
1225 =cut
1226
1227 1;
1228