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