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