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 { 'job' => 'FS::svc_acct::ssh' };
 285     $error = $queue->insert("root\@$shellmachine", eval qq("$useradd") );
 286     if ( $error ) {
 287       $dbh->rollback if $oldAutoCommit;
 288       return "queueing job (transaction rolled back): $error";
 289     }
 290   }
 291
 292   if ( $cyrus_server ) {
 293     my $queue = new FS::queue { 'job' => 'FS::svc_acct::cyrus_insert' };
 294     $error = $queue->insert($self->username, $self->quota);
 295     if ( $error ) {
 296       $dbh->rollback if $oldAutoCommit;
 297       return "queueing job (transaction rolled back): $error";
 298     }
 299   }
 300
 301   if ( $cp_server ) {
 302     my $queue = new FS::queue { 'job' => 'FS::svc_acct::cp_insert' };
 303     $error = $queue->insert($self->username, $self->_password);
 304     if ( $error ) {
 305       $dbh->rollback if $oldAutoCommit;
 306       return "queueing job (transaction rolled back): $error";
 307     }
 308   }
 309
 310   if ( $icradius_dbh ) {
 311
 312     my $radcheck_queue =
 313       new FS::queue { 'job' => 'FS::svc_acct::icradius_rc_insert' };
 314     $error = $radcheck_queue->insert( $self->username,
 315                                       $self->_password,
 316                                       $self->radius_check
 317                                     );
 318     if ( $error ) {
 319       $dbh->rollback if $oldAutoCommit;
 320       return "queueing job (transaction rolled back): $error";
 321     }
 322
 323     my $radreply_queue =
 324       new FS::queue { 'job' => 'FS::svc_acct::icradius_rr_insert' };
 325     $error = $radreply_queue->insert( $self->username,
 326                                       $self->_password,
 327                                       $self->radius_reply
 328                                     );
 329     if ( $error ) {
 330       $dbh->rollback if $oldAutoCommit;
 331       return "queueing job (transaction rolled back): $error";
 332     }
 333
 334   }
 335
 336   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 337   ''; #no error
 338 }
 339
 340 sub cyrus_insert {
 341   my( $username, $quota ) = @_;
 342
 343   warn "cyrus_insert: starting for user $username, quota $quota\n";
 344
 345   warn "cyrus_insert: connecting to $cyrus_server\n";
 346   my $client = Cyrus::IMAP::Admin->new($cyrus_server);
 347
 348   warn "cyrus_insert: authentication as $cyrus_admin_user\n";
 349   $client->authenticate(
 350     -user      => $cyrus_admin_user,
 351     -mechanism => "login",
 352     -password  => $cyrus_admin_pass
 353   );
 354
 355   warn "cyrus_insert: creating user.$username\n";
 356   my $rc = $client->create("user.$username");
 357   my $error = $client->error;
 358   die "cyrus_insert: error creating user.$username: $error" if $error;
 359
 360   warn "cyrus_insert: setacl user.$username, $username => all\n";
 361   $rc = $client->setacl("user.$username", $username => 'all' );
 362   $error = $client->error;
 363   die "cyrus_insert: error setacl user.$username: $error" if $error;
 364
 365   if ( $quota ) {
 366     warn "cyrus_insert: setquota user.$username, STORAGE => $quota\n";
 367     $rc = $client->setquota("user.$username", 'STORAGE' => $quota );
 368     $error = $client->error;
 369     die "cyrus_insert: error setquota user.$username: $error" if $error;
 370   }
 371
 372   1;
 373 }
 374
 375 sub cp_insert {
 376   my( $username, $password ) = @_;
 377
 378   my $app = new Net::APP ( $cp_server,
 379                         User     => $cp_user,
 380                         Password => $cp_pass,
 381                         Domain   => $mydomain,
 382                         Timeout  => 60,
 383                         #Debug    => 1,
 384                       ) or die $@;
 385
 386   $app->create_mailbox(
 387                         Mailbox   => $username,
 388                         Password  => $password,
 389                         Workgroup => $cp_workgroup,
 390                         Domain    => $mydomain,
 391                       );
 392
 393   die $app->message unless $app->ok;
 394 }
 395
 396 sub icradius_rc_insert {
 397   my( $username, $password, %radcheck ) = @_;
 398
 399   my $sth = $icradius_dbh->prepare(
 400     "INSERT INTO radcheck ( id, UserName, Attribute, Value ) VALUES ( ".
 401     join(", ", map { $icradius_dbh->quote($_) } (
 402       '',
 403       $username,
 404       "Password",
 405       $password,
 406     ) ). " )"
 407   );
 408   $sth->execute or die "can't insert into radcheck table: ". $sth->errstr;
 409
 410   foreach my $attribute ( keys %radcheck ) {
 411     my $sth = $icradius_dbh->prepare(
 412       "INSERT INTO radcheck ( id, UserName, Attribute, Value ) VALUES ( ".
 413       join(", ", map { $icradius_dbh->quote($_) } (
 414         '',
 415         $username,
 416         $attribute,
 417         $radcheck{$attribute},
 418       ) ). " )"
 419     );
 420     $sth->execute or die "can't insert into radcheck table: ". $sth->errstr;
 421   }
 422
 423   1;
 424 }
 425
 426 sub icradius_rr_insert {
 427   my( $username, $password, %radreply ) = @_;
 428
 429   foreach my $attribute ( keys %radreply ) {
 430     my $sth = $icradius_dbh->prepare(
 431       "INSERT INTO radreply ( id, UserName, Attribute, Value ) VALUES ( ".
 432       join(", ", map { $icradius_dbh->quote($_) } (
 433         '',
 434         $username,
 435         $attribute,
 436         $radreply{$attribute},
 437       ) ). " )"
 438     );
 439     $sth->execute or die "can't insert into radreply table: ". $sth->errstr;
 440   }
 441
 442   1;
 443 }
 444
 445 =item delete
 446
 447 Deletes this account from the database.  If there is an error, returns the
 448 error, otherwise returns false.
 449
 450 The corresponding FS::cust_svc record will be deleted as well.
 451
 452 If the configuration value (see L<FS::Conf>) shellmachine exists, the
 453 command(s) specified in the shellmachine-userdel configuration file are
 454 added to the job queue (see L<FS::queue> and L<freeside-queued>) to be executed
 455 on shellmachine via ssh.  This behavior can be surpressed by setting
 456 $FS::svc_acct::nossh_hack true.  If the shellmachine-userdel configuration
 457 file does not exist,
 458
 459   userdel $username
 460
 461 is the default.  If the shellmachine-userdel configuration file exists but
 462 is empty,
 463
 464   rm -rf $dir
 465
 466 is the default instead.  Otherwise the contents of the file are treated as a
 467 double-quoted perl string, with the following variables available:
 468 $username and $dir.
 469
 470 (TODOC: cyrus config file)
 471
 472 =cut
 473
 474 sub delete {
 475   my $self = shift;
 476
 477   if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
 478     return "Can't delete an account which has (svc_acct_sm) mail aliases!"
 479       if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
 480   }
 481
 482   return "Can't delete an account which is a (svc_forward) source!"
 483     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 484
 485   return "Can't delete an account which is a (svc_forward) destination!"
 486     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 487
 488   return "Can't delete an account with (svc_www) web service!"
 489     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 490
 491   # what about records in session ?
 492
 493   local $SIG{HUP} = 'IGNORE';
 494   local $SIG{INT} = 'IGNORE';
 495   local $SIG{QUIT} = 'IGNORE';
 496   local $SIG{TERM} = 'IGNORE';
 497   local $SIG{TSTP} = 'IGNORE';
 498   local $SIG{PIPE} = 'IGNORE';
 499
 500   my $oldAutoCommit = $FS::UID::AutoCommit;
 501   local $FS::UID::AutoCommit = 0;
 502   my $dbh = dbh;
 503
 504   foreach my $cust_main_invoice (
 505     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 506   ) {
 507     unless ( defined($cust_main_invoice) ) {
 508       warn "WARNING: something's wrong with qsearch";
 509       next;
 510     }
 511     my %hash = $cust_main_invoice->hash;
 512     $hash{'dest'} = $self->email;
 513     my $new = new FS::cust_main_invoice \%hash;
 514     my $error = $new->replace($cust_main_invoice);
 515     if ( $error ) {
 516       $dbh->rollback if $oldAutoCommit;
 517       return $error;
 518     }
 519   }
 520
 521   foreach my $svc_domain (
 522     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 523   ) {
 524     my %hash = new FS::svc_domain->hash;
 525     $hash{'catchall'} = '';
 526     my $new = new FS::svc_domain \%hash;
 527     my $error = $new->replace($svc_domain);
 528     if ( $error ) {
 529       $dbh->rollback if $oldAutoCommit;
 530       return $error;
 531     }
 532   }
 533
 534   my $error = $self->SUPER::delete;
 535   if ( $error ) {
 536     $dbh->rollback if $oldAutoCommit;
 537     return $error;
 538   }
 539
 540   my( $username, $dir ) = (
 541     $self->username,
 542     $self->dir,
 543   );
 544   if ( $username && $shellmachine && ! $nossh_hack ) {
 545     my $queue = new FS::queue { 'job' => 'FS::svc_acct::ssh' };
 546     $error = $queue->insert("root\@$shellmachine", eval qq("$userdel") );
 547     if ( $error ) {
 548       $dbh->rollback if $oldAutoCommit;
 549       return "queueing job (transaction rolled back): $error";
 550     }
 551
 552   }
 553
 554   if ( $cyrus_server ) {
 555     my $queue = new FS::queue { 'job' => 'FS::svc_acct::cyrus_delete' };
 556     $error = $queue->insert($self->username);
 557     if ( $error ) {
 558       $dbh->rollback if $oldAutoCommit;
 559       return "queueing job (transaction rolled back): $error";
 560     }
 561   }
 562
 563   if ( $cp_server ) {
 564     my $queue = new FS::queue { 'job' => 'FS::svc_acct::cp_delete' };
 565     $error = $queue->insert($self->username);
 566     if ( $error ) {
 567       $dbh->rollback if $oldAutoCommit;
 568       return "queueing job (transaction rolled back): $error";
 569     }
 570   }
 571
 572   if ( $icradius_dbh ) {
 573
 574     my $radcheck_queue =
 575       new FS::queue { 'job' => 'FS::svc_acct::icradius_rc_delete' };
 576     $error = $radcheck_queue->insert( $self->username );
 577     if ( $error ) {
 578       $dbh->rollback if $oldAutoCommit;
 579       return "queueing job (transaction rolled back): $error";
 580     }
 581
 582     my $radreply_queue =
 583       new FS::queue { 'job' => 'FS::svc_acct::icradius_rr_delete' };
 584     $error = $radreply_queue->insert( $self->username );
 585     if ( $error ) {
 586       $dbh->rollback if $oldAutoCommit;
 587       return "queueing job (transaction rolled back): $error";
 588     }
 589
 590   }
 591
 592   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 593   '';
 594 }
 595
 596 sub cyrus_delete {
 597   my $username = shift;
 598
 599   my $client = Cyrus::IMAP::Admin->new($cyrus_server);
 600   $client->authenticate(
 601     -user      => $cyrus_admin_user,
 602     -mechanism => "login",
 603     -password  => $cyrus_admin_pass
 604   );
 605
 606   my $rc = $client->setacl("user.$username", $cyrus_admin_user => 'all' );
 607   my $error = $client->error;
 608   die $error if $error;
 609
 610   $rc = $client->delete("user.$username");
 611   $error = $client->error;
 612   die $error if $error;
 613
 614   1;
 615 }
 616
 617 sub cp_delete {
 618   my( $username ) = @_;
 619   my $app = new Net::APP ( $cp_server,
 620                         User     => $cp_user,
 621                         Password => $cp_pass,
 622                         Domain   => $mydomain,
 623                         Timeout  => 60,
 624                         #Debug    => 1,
 625                       ) or die $@;
 626
 627   $app->delete_mailbox(
 628                         Mailbox   => $username,
 629                         Domain    => $mydomain,
 630                       );
 631
 632   die $app->message unless $app->ok;
 633 }
 634
 635 sub icradius_rc_delete {
 636   my $username = shift;
 637
 638   my $sth = $icradius_dbh->prepare(
 639     'DELETE FROM radcheck WHERE UserName = ?'
 640   );
 641   $sth->execute($username)
 642     or die "can't delete from radcheck table: ". $sth->errstr;
 643
 644   1;
 645 }
 646
 647 sub icradius_rr_delete {
 648   my $username = shift;
 649
 650   my $sth = $icradius_dbh->prepare(
 651     'DELETE FROM radreply WHERE UserName = ?'
 652   );
 653   $sth->execute($username)
 654     or die "can't delete from radreply table: ". $sth->errstr;
 655
 656   1;
 657 }
 658
 659 =item replace OLD_RECORD
 660
 661 Replaces OLD_RECORD with this one in the database.  If there is an error,
 662 returns the error, otherwise returns false.
 663
 664 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 665 dir field has changed, the command(s) specified in the shellmachine-usermod
 666 configuraiton file are added to the job queue (see L<FS::queue> and
 667 L<freeside-queued>) to be executed on shellmachine via ssh.  This behavior can
 668 be surpressed by setting $FS::svc-acct::nossh_hack true.  If the
 669 shellmachine-userdel configuration file does not exist or is empty,
 670
 671   [ -d $old_dir ] && mv $old_dir $new_dir || (
 672     chmod u+t $old_dir;
 673     mkdir $new_dir;
 674     cd $old_dir;
 675     find . -depth -print | cpio -pdm $new_dir;
 676     chmod u-t $new_dir;
 677     chown -R $uid.$gid $new_dir;
 678     rm -rf $old_dir
 679   )
 680
 681 is the default.  This behaviour can be surpressed by setting
 682 $FS::svc_acct::nossh_hack true.
 683
 684 =cut
 685
 686 sub replace {
 687   my ( $new, $old ) = ( shift, shift );
 688   my $error;
 689
 690   return "Username in use"
 691     if $old->username ne $new->username &&
 692       qsearchs( 'svc_acct', { 'username' => $new->username,
 693                                'domsvc'   => $new->domsvc,
 694                              } );
 695   {
 696     #no warnings 'numeric';  #alas, a 5.006-ism
 697     local($^W) = 0;
 698     return "Can't change uid!" if $old->uid != $new->uid;
 699   }
 700
 701   return "can't change username using Cyrus"
 702     if $cyrus_server && $old->username ne $new->username;
 703
 704   #change homdir when we change username
 705   $new->setfield('dir', '') if $old->username ne $new->username;
 706
 707   local $SIG{HUP} = 'IGNORE';
 708   local $SIG{INT} = 'IGNORE';
 709   local $SIG{QUIT} = 'IGNORE';
 710   local $SIG{TERM} = 'IGNORE';
 711   local $SIG{TSTP} = 'IGNORE';
 712   local $SIG{PIPE} = 'IGNORE';
 713
 714   my $oldAutoCommit = $FS::UID::AutoCommit;
 715   local $FS::UID::AutoCommit = 0;
 716   my $dbh = dbh;
 717
 718   $error = $new->SUPER::replace($old);
 719   if ( $error ) {
 720     $dbh->rollback if $oldAutoCommit;
 721     return $error if $error;
 722   }
 723
 724   my ( $old_dir, $new_dir, $uid, $gid ) = (
 725     $old->getfield('dir'),
 726     $new->getfield('dir'),
 727     $new->getfield('uid'),
 728     $new->getfield('gid'),
 729   );
 730   if ( $old_dir && $new_dir && $old_dir ne $new_dir && ! $nossh_hack ) {
 731     my $queue = new FS::queue { 'job' => 'FS::svc_acct::ssh' };
 732     $error = $queue->insert("root\@$shellmachine", eval qq("$usermod") );
 733     if ( $error ) {
 734       $dbh->rollback if $oldAutoCommit;
 735       return "queueing job (transaction rolled back): $error";
 736     }
 737   }
 738
 739   if ( $cp_server && $old->username ne $new->username ) {
 740     my $queue = new FS::queue { 'job' => 'FS::svc_acct::cp_rename' };
 741     $error = $queue->insert( $old->username, $new->username );
 742     if ( $error ) {
 743       $dbh->rollback if $oldAutoCommit;
 744       return "queueing job (transaction rolled back): $error";
 745     }
 746   }
 747
 748   if ( $cp_server && $old->_password ne $new->_password ) {
 749     my $queue = new FS::queue { 'job' => 'FS::svc_acct::cp_change' };
 750     $error = $queue->insert( $new->username, $new->_password );
 751     if ( $error ) {
 752       $dbh->rollback if $oldAutoCommit;
 753       return "queueing job (transaction rolled back): $error";
 754     }
 755   }
 756
 757   if ( $icradius_dbh ) {
 758     my $queue = new FS::queue { 'job' => 'FS::svc_acct::icradius_rc_replace' };
 759     $error = $queue->insert( $new->username,
 760                              $new->_password,
 761                            );
 762     if ( $error ) {
 763       $dbh->rollback if $oldAutoCommit;
 764       return "queueing job (transaction rolled back): $error";
 765     }
 766   }
 767
 768   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 769   ''; #no error
 770 }
 771
 772 sub icradius_rc_replace {
 773   my( $username, $new_password ) = @_;
 774
 775    my $sth = $icradius_dbh->prepare(
 776      "UPDATE radcheck SET Value = ? WHERE UserName = ? and Attribute = ?"
 777    );
 778    $sth->execute($new_password, $username, 'Password' )
 779      or die "can't update radcheck table: ". $sth->errstr;
 780
 781   1;
 782 }
 783
 784 sub cp_rename {
 785   my ( $old_username, $new_username );
 786
 787   my $app = new Net::APP ( $cp_server,
 788                         User     => $cp_user,
 789                         Password => $cp_pass,
 790                         Domain   => $mydomain,
 791                         Timeout  => 60,
 792                         #Debug    => 1,
 793                       ) or die $@;
 794
 795   $app->rename_mailbox(
 796                         Domain        => $mydomain,
 797                         Old_Mailbox   => $old_username,
 798                         New_Mailbox   => $new_username,
 799                       );
 800
 801   die $app->message unless $app->ok;
 802
 803 }
 804
 805 sub cp_change {
 806   my ( $username, $password );
 807
 808   my $app = new Net::APP ( $cp_server,
 809                         User     => $cp_user,
 810                         Password => $cp_pass,
 811                         Domain   => $mydomain,
 812                         Timeout  => 60,
 813                         #Debug    => 1,
 814                       ) or die $@;
 815
 816   $app->change_mailbox(
 817                         Domain    => $mydomain,
 818                         Mailbox   => $username,
 819                         Password  => $password,
 820                       );
 821
 822   die $app->message unless $app->ok;
 823
 824 }
 825
 826 =item suspend
 827
 828 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 829 error, returns the error, otherwise returns false.
 830
 831 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 832
 833 =cut
 834
 835 sub suspend {
 836   my $self = shift;
 837   my %hash = $self->hash;
 838   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 839            || $hash{_password} eq '*'
 840          ) {
 841     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 842     my $new = new FS::svc_acct ( \%hash );
 843     $new->replace($self);
 844   } else {
 845     ''; #no error (already suspended)
 846   }
 847 }
 848
 849 =item unsuspend
 850
 851 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 852 an error, returns the error, otherwise returns false.
 853
 854 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 855
 856 =cut
 857
 858 sub unsuspend {
 859   my $self = shift;
 860   my %hash = $self->hash;
 861   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 862     $hash{_password} = $1;
 863     my $new = new FS::svc_acct ( \%hash );
 864     $new->replace($self);
 865   } else {
 866     ''; #no error (already unsuspended)
 867   }
 868 }
 869
 870 =item cancel
 871
 872 Just returns false (no error) for now.
 873
 874 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 875
 876 =item check
 877
 878 Checks all fields to make sure this is a valid service.  If there is an error,
 879 returns the error, otherwise returns false.  Called by the insert and replace
 880 methods.
 881
 882 Sets any fixed values; see L<FS::part_svc>.
 883
 884 =cut
 885
 886 sub check {
 887   my $self = shift;
 888
 889   my($recref) = $self->hashref;
 890
 891   my $x = $self->setfixed;
 892   return $x unless ref($x);
 893   my $part_svc = $x;
 894
 895   my $error = $self->ut_numbern('svcnum')
 896               || $self->ut_number('domsvc')
 897   ;
 898   return $error if $error;
 899
 900   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 901   if ( $username_uppercase ) {
 902     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 903       or return "Illegal username: ". $recref->{username};
 904     $recref->{username} = $1;
 905   } else {
 906     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 907       or return "Illegal username: ". $recref->{username};
 908     $recref->{username} = $1;
 909   }
 910
 911   if ( $username_letterfirst ) {
 912     $recref->{username} =~ /^[a-z]/ or return "Illegal username";
 913   } elsif ( $username_letter ) {
 914     $recref->{username} =~ /[a-z]/ or return "Illegal username";
 915   }
 916   if ( $username_noperiod ) {
 917     $recref->{username} =~ /\./ and return "Illegal username";
 918   }
 919   unless ( $username_ampersand ) {
 920     $recref->{username} =~ /\&/ and return "Illegal username";
 921   }
 922
 923   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 924   $recref->{popnum} = $1;
 925   return "Unknown popnum" unless
 926     ! $recref->{popnum} ||
 927     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 928
 929   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 930
 931     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 932     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 933
 934     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 935     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 936     #not all systems use gid=uid
 937     #you can set a fixed gid in part_svc
 938
 939     return "Only root can have uid 0"
 940       if $recref->{uid} == 0 && $recref->{username} ne 'root';
 941
 942 #    $error = $self->ut_textn('finger');
 943 #    return $error if $error;
 944     $self->getfield('finger') =~
 945       /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\*\<\>]*)$/
 946         or return "Illegal finger: ". $self->getfield('finger');
 947     $self->setfield('finger', $1);
 948
 949     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 950       or return "Illegal directory";
 951     $recref->{dir} = $1;
 952     return "Illegal directory"
 953       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 954     return "Illegal directory"
 955       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 956     unless ( $recref->{dir} ) {
 957       $recref->{dir} = $dir_prefix . '/';
 958       if ( $dirhash > 0 ) {
 959         for my $h ( 1 .. $dirhash ) {
 960           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 961         }
 962       } elsif ( $dirhash < 0 ) {
 963         for my $h ( reverse $dirhash .. -1 ) {
 964           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 965         }
 966       }
 967       $recref->{dir} .= $recref->{username};
 968     ;
 969     }
 970
 971     unless ( $recref->{username} eq 'sync' ) {
 972       if ( grep $_ eq $recref->{shell}, @shells ) {
 973         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 974       } else {
 975         return "Illegal shell \`". $self->shell. "\'; ".
 976                $conf->dir. "/shells contains: @shells";
 977       }
 978     } else {
 979       $recref->{shell} = '/bin/sync';
 980     }
 981
 982     $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)";
 983     $recref->{quota} = $1;
 984
 985   } else {
 986     $recref->{gid} ne '' ?
 987       return "Can't have gid without uid" : ( $recref->{gid}='' );
 988     $recref->{finger} ne '' ?
 989       return "Can't have finger-name without uid" : ( $recref->{finger}='' );
 990     $recref->{dir} ne '' ?
 991       return "Can't have directory without uid" : ( $recref->{dir}='' );
 992     $recref->{shell} ne '' ?
 993       return "Can't have shell without uid" : ( $recref->{shell}='' );
 994     $recref->{quota} ne '' ?
 995       return "Can't have quota without uid" : ( $recref->{quota}='' );
 996   }
 997
 998   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 999     unless ( $recref->{slipip} eq '0e0' ) {
1000       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1001         or return "Illegal slipip". $self->slipip;
1002       $recref->{slipip} = $1;
1003     } else {
1004       $recref->{slipip} = '0e0';
1005     }
1006
1007   }
1008
1009   #arbitrary RADIUS stuff; allow ut_textn for now
1010   foreach ( grep /^radius_/, fields('svc_acct') ) {
1011     $self->ut_textn($_);
1012   }
1013
1014   #generate a password if it is blank
1015   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1016     unless ( $recref->{_password} );
1017
1018   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1019   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1020     $recref->{_password} = $1.$3;
1021     #uncomment this to encrypt password immediately upon entry, or run
1022     #bin/crypt_pw in cron to give new users a window during which their
1023     #password is available to techs, for faxing, etc.  (also be aware of
1024     #radius issues!)
1025     #$recref->{password} = $1.
1026     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
1027     #;
1028   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$]{13,34})$/ ) {
1029     $recref->{_password} = $1.$3;
1030   } elsif ( $recref->{_password} eq '*' ) {
1031     $recref->{_password} = '*';
1032   } elsif ( $recref->{_password} eq '!!' ) {
1033     $recref->{_password} = '!!';
1034   } else {
1035     #return "Illegal password";
1036     return "Illegal password: ". $recref->{_password};
1037   }
1038
1039   ''; #no error
1040 }
1041
1042 =item radius
1043
1044 Depriciated, use radius_reply instead.
1045
1046 =cut
1047
1048 sub radius {
1049   carp "FS::svc_acct::radius depriciated, use radius_reply";
1050   $_[0]->radius_reply;
1051 }
1052
1053 =item radius_reply
1054
1055 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1056 reply attributes of this record.
1057
1058 Note that this is now the preferred method for reading RADIUS attributes -
1059 accessing the columns directly is discouraged, as the column names are
1060 expected to change in the future.
1061
1062 =cut
1063
1064 sub radius_reply {
1065   my $self = shift;
1066   my %reply =
1067     map {
1068       /^(radius_(.*))$/;
1069       my($column, $attrib) = ($1, $2);
1070       #$attrib =~ s/_/\-/g;
1071       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1072     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1073   if ( $self->ip && $self->ip ne '0e0' ) {
1074     $reply{'Framed-IP-Address'} = $self->ip;
1075   }
1076   %reply;
1077 }
1078
1079 =item radius_check
1080
1081 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1082 check attributes of this record.
1083
1084 Accessing RADIUS attributes directly is not supported and will break in the
1085 future.
1086
1087 =cut
1088
1089 sub radius_check {
1090   my $self = shift;
1091   map {
1092     /^(rc_(.*))$/;
1093     my($column, $attrib) = ($1, $2);
1094     #$attrib =~ s/_/\-/g;
1095     ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1096   } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1097 }
1098
1099 =item domain
1100
1101 Returns the domain associated with this account.
1102
1103 =cut
1104
1105 sub domain {
1106   my $self = shift;
1107   if ( $self->domsvc ) {
1108     #$self->svc_domain->domain;
1109     my $svc_domain = $self->svc_domain
1110       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1111     $svc_domain->domain;
1112   } else {
1113     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
1114   }
1115 }
1116
1117 =item svc_domain
1118
1119 Returns the FS::svc_domain record for this account's domain (see
1120 L<FS::svc_domain>.
1121
1122 =cut
1123
1124 sub svc_domain {
1125   my $self = shift;
1126   $self->{'_domsvc'}
1127     ? $self->{'_domsvc'}
1128     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1129 }
1130
1131 =item cust_svc
1132
1133 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1134
1135 sub cust_svc {
1136   my $self = shift;
1137   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1138 }
1139
1140 =item email
1141
1142 Returns an email address associated with the account.
1143
1144 =cut
1145
1146 sub email {
1147   my $self = shift;
1148   $self->username. '@'. $self->domain;
1149 }
1150
1151 =item seconds_since TIMESTAMP
1152
1153 Returns the number of seconds this account has been online since TIMESTAMP.
1154 See L<FS::session>
1155
1156 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1157 L<Time::Local> and L<Date::Parse> for conversion functions.
1158
1159 =cut
1160
1161 #note: POD here, implementation in FS::cust_svc
1162 sub seconds_since {
1163   my $self = shift;
1164   $self->cust_svc->seconds_since(@_);
1165 }
1166
1167 =item ssh
1168
1169 =cut
1170
1171 sub ssh {
1172   my ( $host, @cmd_and_args ) = @_;
1173
1174   use IO::File;
1175   my $reader = IO::File->new();
1176   my $writer = IO::File->new();
1177   my $error = IO::File->new();
1178
1179   &Net::SSH::sshopen3( $host, $reader, $writer, $error, @cmd_and_args) or die $!;
1180
1181   local $/ = undef;
1182   my $output_stream = <$writer>;
1183   my $error_stream = <$error>;
1184   if ( length $error_stream ) {
1185     #warn "[FS::svc_acct::ssh] STDERR $error_stream";
1186     die "[FS::svc_acct::ssh] STDERR $error_stream";
1187   }
1188   if ( length $output_stream ) {
1189     warn "[FS::svc_acct::ssh] STDOUT $output_stream";
1190   }
1191
1192 #  &Net::SSH::ssh(@args,">>/usr/local/etc/freeside/sshoutput 2>&1");
1193 }
1194
1195 =back
1196
1197 =head1 BUGS
1198
1199 The $recref stuff in sub check should be cleaned up.
1200
1201 The suspend, unsuspend and cancel methods update the database, but not the
1202 current object.  This is probably a bug as it's unexpected and
1203 counterintuitive.
1204
1205 =head1 SEE ALSO
1206
1207 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1208 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1209 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1210 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1211 schema.html from the base documentation.
1212
1213 =cut
1214
1215 1;
1216