FS/FS/svc_acct.pm

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