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