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 $radcheck_queue =
 515       new FS::queue { 'job' => 'FS::svc_acct::icradius_rc_delete' };
 516     $error = $radcheck_queue->insert( $self->username );
 517     if ( $error ) {
 518       $dbh->rollback if $oldAutoCommit;
 519       return "queueing job (transaction rolled back): $error";
 520     }
 521
 522     my $radreply_queue =
 523       new FS::queue { 'job' => 'FS::svc_acct::icradius_rr_delete' };
 524     $error = $radreply_queue->insert( $self->username );
 525     if ( $error ) {
 526       $dbh->rollback if $oldAutoCommit;
 527       return "queueing job (transaction rolled back): $error";
 528     }
 529
 530   }
 531
 532   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 533   '';
 534 }
 535
 536 sub cyrus_delete {
 537   my $username = shift;
 538
 539   my $client = Cyrus::IMAP::Admin->new($cyrus_server);
 540   $client->authenticate(
 541     -user      => $cyrus_admin_user,
 542     -mechanism => "login",
 543     -password  => $cyrus_admin_pass
 544   );
 545
 546   my $rc = $client->setacl("user.$username", $cyrus_admin_user => 'all' );
 547   my $error = $client->error;
 548   die $error if $error;
 549
 550   $rc = $client->delete("user.$username");
 551   $error = $client->error;
 552   die $error if $error;
 553
 554   1;
 555 }
 556
 557 sub icradius_rc_delete {
 558   my $username = shift;
 559
 560   my $sth = $icradius_dbh->prepare(
 561     'DELETE FROM radcheck WHERE UserName = ?'
 562   );
 563   $sth->execute($username)
 564     or die "can't delete from radcheck table: ". $sth->errstr;
 565
 566   1;
 567 }
 568
 569 sub icradius_rr_delete {
 570   my $username = shift;
 571
 572   my $sth = $icradius_dbh->prepare(
 573     'DELETE FROM radreply WHERE UserName = ?'
 574   );
 575   $sth->execute($username)
 576     or die "can't delete from radreply table: ". $sth->errstr;
 577
 578   1;
 579 }
 580
 581 =item replace OLD_RECORD
 582
 583 Replaces OLD_RECORD with this one in the database.  If there is an error,
 584 returns the error, otherwise returns false.
 585
 586 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 587 dir field has changed, the command(s) specified in the shellmachine-usermod
 588 configuraiton file are added to the job queue (see L<FS::queue> and
 589 L<freeside-queued>) to be executed on shellmachine via ssh.  This behavior can
 590 be surpressed by setting $FS::svc-acct::nossh_hack true.  If the
 591 shellmachine-userdel configuration file does not exist or is empty,
 592
 593   [ -d $old_dir ] && mv $old_dir $new_dir || (
 594     chmod u+t $old_dir;
 595     mkdir $new_dir;
 596     cd $old_dir;
 597     find . -depth -print | cpio -pdm $new_dir;
 598     chmod u-t $new_dir;
 599     chown -R $uid.$gid $new_dir;
 600     rm -rf $old_dir
 601   )
 602
 603 is the default.  This behaviour can be surpressed by setting
 604 $FS::svc_acct::nossh_hack true.
 605
 606 =cut
 607
 608 sub replace {
 609   my ( $new, $old ) = ( shift, shift );
 610   my $error;
 611
 612   return "Username in use"
 613     if $old->username ne $new->username &&
 614       qsearchs( 'svc_acct', { 'username' => $new->username,
 615                                'domsvc'   => $new->domsvc,
 616                              } );
 617   {
 618     #no warnings 'numeric';  #alas, a 5.006-ism
 619     local($^W) = 0;
 620     return "Can't change uid!" if $old->uid != $new->uid;
 621   }
 622
 623   return "can't change username using Cyrus"
 624     if $cyrus_server && $old->username ne $new->username;
 625
 626   #change homdir when we change username
 627   $new->setfield('dir', '') if $old->username ne $new->username;
 628
 629   local $SIG{HUP} = 'IGNORE';
 630   local $SIG{INT} = 'IGNORE';
 631   local $SIG{QUIT} = 'IGNORE';
 632   local $SIG{TERM} = 'IGNORE';
 633   local $SIG{TSTP} = 'IGNORE';
 634   local $SIG{PIPE} = 'IGNORE';
 635
 636   my $oldAutoCommit = $FS::UID::AutoCommit;
 637   local $FS::UID::AutoCommit = 0;
 638   my $dbh = dbh;
 639
 640   $error = $new->SUPER::replace($old);
 641   if ( $error ) {
 642     $dbh->rollback if $oldAutoCommit;
 643     return $error if $error;
 644   }
 645
 646   my ( $old_dir, $new_dir, $uid, $gid ) = (
 647     $old->getfield('dir'),
 648     $new->getfield('dir'),
 649     $new->getfield('uid'),
 650     $new->getfield('gid'),
 651   );
 652   if ( $old_dir && $new_dir && $old_dir ne $new_dir && ! $nossh_hack ) {
 653     my $queue = new FS::queue { 'job' => 'FS::svc_acct::ssh' };
 654     $error = $queue->insert("root\@$shellmachine", eval qq("$usermod") );
 655     if ( $error ) {
 656       $dbh->rollback if $oldAutoCommit;
 657       return "queueing job (transaction rolled back): $error";
 658     }
 659   }
 660
 661   if ( $icradius_dbh ) {
 662     my $queue = new FS::queue { 'job' => 'FS::svc_acct::icradius_rc_replace' };
 663     $error = $queue->insert( $new->username,
 664                              $new->_password,
 665                            );
 666     if ( $error ) {
 667       $dbh->rollback if $oldAutoCommit;
 668       return "queueing job (transaction rolled back): $error";
 669     }
 670   }
 671
 672   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 673   ''; #no error
 674 }
 675
 676 sub icradius_rc_replace {
 677   my( $username, $new_password ) = @_;
 678
 679    my $sth = $icradius_dbh->prepare(
 680      "UPDATE radcheck SET Value = ? WHERE UserName = ? and Attribute = ?"
 681    );
 682    $sth->execute($new_password, $username, 'Password' )
 683      or die "can't update radcheck table: ". $sth->errstr;
 684
 685   1;
 686 }
 687
 688 =item suspend
 689
 690 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 691 error, returns the error, otherwise returns false.
 692
 693 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 694
 695 =cut
 696
 697 sub suspend {
 698   my $self = shift;
 699   my %hash = $self->hash;
 700   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 701            || $hash{_password} eq '*'
 702          ) {
 703     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 704     my $new = new FS::svc_acct ( \%hash );
 705     $new->replace($self);
 706   } else {
 707     ''; #no error (already suspended)
 708   }
 709 }
 710
 711 =item unsuspend
 712
 713 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 714 an error, returns the error, otherwise returns false.
 715
 716 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 717
 718 =cut
 719
 720 sub unsuspend {
 721   my $self = shift;
 722   my %hash = $self->hash;
 723   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 724     $hash{_password} = $1;
 725     my $new = new FS::svc_acct ( \%hash );
 726     $new->replace($self);
 727   } else {
 728     ''; #no error (already unsuspended)
 729   }
 730 }
 731
 732 =item cancel
 733
 734 Just returns false (no error) for now.
 735
 736 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 737
 738 =item check
 739
 740 Checks all fields to make sure this is a valid service.  If there is an error,
 741 returns the error, otherwise returns false.  Called by the insert and replace
 742 methods.
 743
 744 Sets any fixed values; see L<FS::part_svc>.
 745
 746 =cut
 747
 748 sub check {
 749   my $self = shift;
 750
 751   my($recref) = $self->hashref;
 752
 753   my $x = $self->setfixed;
 754   return $x unless ref($x);
 755   my $part_svc = $x;
 756
 757   my $error = $self->ut_numbern('svcnum')
 758               || $self->ut_number('domsvc')
 759   ;
 760   return $error if $error;
 761
 762   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 763   if ( $username_uppercase ) {
 764     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 765       or return "Illegal username: ". $recref->{username};
 766     $recref->{username} = $1;
 767   } else {
 768     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 769       or return "Illegal username: ". $recref->{username};
 770     $recref->{username} = $1;
 771   }
 772
 773   if ( $username_letterfirst ) {
 774     $recref->{username} =~ /^[a-z]/ or return "Illegal username";
 775   } elsif ( $username_letter ) {
 776     $recref->{username} =~ /[a-z]/ or return "Illegal username";
 777   }
 778   if ( $username_noperiod ) {
 779     $recref->{username} =~ /\./ and return "Illegal username";
 780   }
 781   unless ( $username_ampersand ) {
 782     $recref->{username} =~ /\&/ and return "Illegal username";
 783   }
 784
 785   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 786   $recref->{popnum} = $1;
 787   return "Unknown popnum" unless
 788     ! $recref->{popnum} ||
 789     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 790
 791   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 792
 793     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 794     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 795
 796     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 797     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 798     #not all systems use gid=uid
 799     #you can set a fixed gid in part_svc
 800
 801     return "Only root can have uid 0"
 802       if $recref->{uid} == 0 && $recref->{username} ne 'root';
 803
 804 #    $error = $self->ut_textn('finger');
 805 #    return $error if $error;
 806     $self->getfield('finger') =~
 807       /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\*\<\>]*)$/
 808         or return "Illegal finger: ". $self->getfield('finger');
 809     $self->setfield('finger', $1);
 810
 811     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 812       or return "Illegal directory";
 813     $recref->{dir} = $1;
 814     return "Illegal directory"
 815       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 816     return "Illegal directory"
 817       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 818     unless ( $recref->{dir} ) {
 819       $recref->{dir} = $dir_prefix . '/';
 820       if ( $dirhash > 0 ) {
 821         for my $h ( 1 .. $dirhash ) {
 822           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 823         }
 824       } elsif ( $dirhash < 0 ) {
 825         for my $h ( reverse $dirhash .. -1 ) {
 826           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 827         }
 828       }
 829       $recref->{dir} .= $recref->{username};
 830     ;
 831     }
 832
 833     unless ( $recref->{username} eq 'sync' ) {
 834       if ( grep $_ eq $recref->{shell}, @shells ) {
 835         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 836       } else {
 837         return "Illegal shell \`". $self->shell. "\'; ".
 838                $conf->dir. "/shells contains: @shells";
 839       }
 840     } else {
 841       $recref->{shell} = '/bin/sync';
 842     }
 843
 844     $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)";
 845     $recref->{quota} = $1;
 846
 847   } else {
 848     $recref->{gid} ne '' ?
 849       return "Can't have gid without uid" : ( $recref->{gid}='' );
 850     $recref->{finger} ne '' ?
 851       return "Can't have finger-name without uid" : ( $recref->{finger}='' );
 852     $recref->{dir} ne '' ?
 853       return "Can't have directory without uid" : ( $recref->{dir}='' );
 854     $recref->{shell} ne '' ?
 855       return "Can't have shell without uid" : ( $recref->{shell}='' );
 856     $recref->{quota} ne '' ?
 857       return "Can't have quota without uid" : ( $recref->{quota}='' );
 858   }
 859
 860   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 861     unless ( $recref->{slipip} eq '0e0' ) {
 862       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 863         or return "Illegal slipip". $self->slipip;
 864       $recref->{slipip} = $1;
 865     } else {
 866       $recref->{slipip} = '0e0';
 867     }
 868
 869   }
 870
 871   #arbitrary RADIUS stuff; allow ut_textn for now
 872   foreach ( grep /^radius_/, fields('svc_acct') ) {
 873     $self->ut_textn($_);
 874   }
 875
 876   #generate a password if it is blank
 877   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 878     unless ( $recref->{_password} );
 879
 880   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 881   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 882     $recref->{_password} = $1.$3;
 883     #uncomment this to encrypt password immediately upon entry, or run
 884     #bin/crypt_pw in cron to give new users a window during which their
 885     #password is available to techs, for faxing, etc.  (also be aware of
 886     #radius issues!)
 887     #$recref->{password} = $1.
 888     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 889     #;
 890   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$]{13,34})$/ ) {
 891     $recref->{_password} = $1.$3;
 892   } elsif ( $recref->{_password} eq '*' ) {
 893     $recref->{_password} = '*';
 894   } elsif ( $recref->{_password} eq '!!' ) {
 895     $recref->{_password} = '!!';
 896   } else {
 897     #return "Illegal password";
 898     return "Illegal password: ". $recref->{_password};
 899   }
 900
 901   ''; #no error
 902 }
 903
 904 =item radius
 905
 906 Depriciated, use radius_reply instead.
 907
 908 =cut
 909
 910 sub radius {
 911   carp "FS::svc_acct::radius depriciated, use radius_reply";
 912   $_[0]->radius_reply;
 913 }
 914
 915 =item radius_reply
 916
 917 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 918 reply attributes of this record.
 919
 920 Note that this is now the preferred method for reading RADIUS attributes -
 921 accessing the columns directly is discouraged, as the column names are
 922 expected to change in the future.
 923
 924 =cut
 925
 926 sub radius_reply {
 927   my $self = shift;
 928   my %reply =
 929     map {
 930       /^(radius_(.*))$/;
 931       my($column, $attrib) = ($1, $2);
 932       #$attrib =~ s/_/\-/g;
 933       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 934     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 935   if ( $self->ip && $self->ip ne '0e0' ) {
 936     $reply{'Framed-IP-Address'} = $self->ip;
 937   }
 938   %reply;
 939 }
 940
 941 =item radius_check
 942
 943 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 944 check attributes of this record.
 945
 946 Accessing RADIUS attributes directly is not supported and will break in the
 947 future.
 948
 949 =cut
 950
 951 sub radius_check {
 952   my $self = shift;
 953   map {
 954     /^(rc_(.*))$/;
 955     my($column, $attrib) = ($1, $2);
 956     #$attrib =~ s/_/\-/g;
 957     ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 958   } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
 959 }
 960
 961 =item domain
 962
 963 Returns the domain associated with this account.
 964
 965 =cut
 966
 967 sub domain {
 968   my $self = shift;
 969   if ( $self->domsvc ) {
 970     #$self->svc_domain->domain;
 971     my $svc_domain = $self->svc_domain
 972       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 973     $svc_domain->domain;
 974   } else {
 975     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 976   }
 977 }
 978
 979 =item svc_domain
 980
 981 Returns the FS::svc_domain record for this account's domain (see
 982 L<FS::svc_domain>.
 983
 984 =cut
 985
 986 sub svc_domain {
 987   my $self = shift;
 988   $self->{'_domsvc'}
 989     ? $self->{'_domsvc'}
 990     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
 991 }
 992
 993 =item email
 994
 995 Returns an email address associated with the account.
 996
 997 =cut
 998
 999 sub email {
1000   my $self = shift;
1001   $self->username. '@'. $self->domain;
1002 }
1003
1004 =item ssh
1005
1006 =cut
1007
1008 sub ssh {
1009   my ( $host, @cmd_and_args ) = @_;
1010
1011   use IO::File;
1012   my $reader = IO::File->new();
1013   my $writer = IO::File->new();
1014   my $error = IO::File->new();
1015
1016   &Net::SSH::sshopen3( $host, $reader, $writer, $error, @cmd_and_args) or die $!;
1017
1018   local $/ = undef;
1019   my $output_stream = <$writer>;
1020   my $error_stream = <$error>;
1021   if ( length $error_stream ) {
1022     #warn "[FS::svc_acct::ssh] STDERR $error_stream";
1023     die "[FS::svc_acct::ssh] STDERR $error_stream";
1024   }
1025   if ( length $output_stream ) {
1026     warn "[FS::svc_acct::ssh] STDOUT $output_stream";
1027   }
1028
1029 #  &Net::SSH::ssh(@args,">>/usr/local/etc/freeside/sshoutput 2>&1");
1030 }
1031
1032 =back
1033
1034 =head1 VERSION
1035
1036 $Id: svc_acct.pm,v 1.63 2002-01-22 14:53:26 ivan Exp $
1037
1038 =head1 BUGS
1039
1040 The bits which ssh should fork before doing so (or maybe queue jobs for a
1041 daemon).
1042
1043 The $recref stuff in sub check should be cleaned up.
1044
1045 The suspend, unsuspend and cancel methods update the database, but not the
1046 current object.  This is probably a bug as it's unexpected and
1047 counterintuitive.
1048
1049 =head1 SEE ALSO
1050
1051 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1052 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1053 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1054 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1055 schema.html from the base documentation.
1056
1057 =cut
1058
1059 1;
1060