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 $username_letter $username_letterfirst
   6              $shellmachine $useradd $usermod $userdel
   7              @saltset @pw_set);
   8 use Carp;
   9 use FS::Conf;
  10 use FS::Record qw( qsearch qsearchs fields );
  11 use FS::svc_Common;
  12 use Net::SSH qw(ssh);
  13 use FS::part_svc;
  14 use FS::svc_acct_pop;
  15 use FS::svc_acct_sm;
  16
  17 @ISA = qw( FS::svc_Common );
  18
  19 #ask FS::UID to run this stuff for us later
  20 $FS::UID::callback{'FS::svc_acct'} = sub {
  21   $conf = new FS::Conf;
  22   $dir_prefix = $conf->config('home');
  23   @shells = $conf->config('shells');
  24   $shellmachine = $conf->config('shellmachine');
  25   $usernamemin = $conf->config('usernamemin') || 2;
  26   $usernamemax = $conf->config('usernamemax');
  27   $passwordmin = $conf->config('passwordmin') || 6;
  28   if ( $shellmachine ) {
  29     if ( $conf->exists('shellmachine-useradd') ) {
  30       $useradd = join("\n", $conf->config('shellmachine-useradd') )
  31                  || 'cp -pr /etc/skel $dir; chown -R $uid.$gid $dir';
  32     } else {
  33       $useradd = 'useradd -d $dir -m -s $shell -u $uid $username';
  34     }
  35     if ( $conf->exists('shellmachine-userdel') ) {
  36       $userdel = join("\n", $conf->config('shellmachine-userdel') )
  37                  || 'rm -rf $dir';
  38     } else {
  39       $userdel = 'userdel $username';
  40     }
  41     $usermod = join("\n", $conf->config('shellmachine-usermod') )
  42                || '[ -d $old_dir ] && mv $old_dir $new_dir || ( '.
  43                     'chmod u+t $old_dir; mkdir $new_dir; cd $old_dir; '.
  44                     'find . -depth -print | cpio -pdm $new_dir; '.
  45                     'chmod u-t $new_dir; chown -R $uid.$gid $new_dir; '.
  46                     'rm -rf $old_dir'.
  47                   ')';
  48   }
  49   $username_letter = $conf->exists('username-letter');
  50   $username_letterfirst = $conf->exists('username-letterfirst');
  51 };
  52
  53 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  54 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  55
  56 #not needed in 5.004 #srand($$|time);
  57
  58 =head1 NAME
  59
  60 FS::svc_acct - Object methods for svc_acct records
  61
  62 =head1 SYNOPSIS
  63
  64   use FS::svc_acct;
  65
  66   $record = new FS::svc_acct \%hash;
  67   $record = new FS::svc_acct { 'column' => 'value' };
  68
  69   $error = $record->insert;
  70
  71   $error = $new_record->replace($old_record);
  72
  73   $error = $record->delete;
  74
  75   $error = $record->check;
  76
  77   $error = $record->suspend;
  78
  79   $error = $record->unsuspend;
  80
  81   $error = $record->cancel;
  82
  83   %hash = $record->radius;
  84
  85   %hash = $record->radius_reply;
  86
  87   %hash = $record->radius_check;
  88
  89 =head1 DESCRIPTION
  90
  91 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
  92 FS::svc_Common.  The following fields are currently supported:
  93
  94 =over 4
  95
  96 =item svcnum - primary key (assigned automatcially for new accounts)
  97
  98 =item username
  99
 100 =item _password - generated if blank
 101
 102 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 103
 104 =item uid
 105
 106 =item gid
 107
 108 =item finger - GECOS
 109
 110 =item dir - set automatically if blank (and uid is not)
 111
 112 =item shell
 113
 114 =item quota - (unimplementd)
 115
 116 =item slipip - IP address
 117
 118 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 119
 120 =item domsvc - service number of svc_domain with which to associate
 121
 122 =back
 123
 124 =head1 METHODS
 125
 126 =over 4
 127
 128 =item new HASHREF
 129
 130 Creates a new account.  To add the account to the database, see L<"insert">.
 131
 132 =cut
 133
 134 sub table { 'svc_acct'; }
 135
 136 =item insert
 137
 138 Adds this account to the database.  If there is an error, returns the error,
 139 otherwise returns false.
 140
 141 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 142 defined.  An FS::cust_svc record will be created and inserted.
 143
 144 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 145 username, uid, and dir fields are defined, the command(s) specified in
 146 the shellmachine-useradd configuration are exectued on shellmachine via ssh.
 147 This behaviour can be surpressed by setting $FS::svc_acct::nossh_hack true.
 148 If the shellmachine-useradd configuration file does not exist,
 149
 150   useradd -d $dir -m -s $shell -u $uid $username
 151
 152 is the default.  If the shellmachine-useradd configuration file exists but
 153 it empty,
 154
 155   cp -pr /etc/skel $dir; chown -R $uid.$gid $dir
 156
 157 is the default instead.  Otherwise the contents of the file are treated as
 158 a double-quoted perl string, with the following variables available:
 159 $username, $uid, $gid, $dir, and $shell.
 160
 161 =cut
 162
 163 sub insert {
 164   my $self = shift;
 165   my $error;
 166
 167   local $SIG{HUP} = 'IGNORE';
 168   local $SIG{INT} = 'IGNORE';
 169   local $SIG{QUIT} = 'IGNORE';
 170   local $SIG{TERM} = 'IGNORE';
 171   local $SIG{TSTP} = 'IGNORE';
 172   local $SIG{PIPE} = 'IGNORE';
 173
 174   $error = $self->check;
 175   return $error if $error;
 176
 177   return "Username ". $self->username. " in use"
 178     if qsearchs( 'svc_acct', { 'username' => $self->username,
 179                                'domsvc'   => $self->domsvc,
 180                              } );
 181
 182   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 183   return "Unknown svcpart" unless $part_svc;
 184   return "uid in use"
 185     if $part_svc->svc_acct__uid_flag ne 'F'
 186       && qsearchs( 'svc_acct', { 'uid' => $self->uid } )
 187       && $self->username !~ /^(hyla)?fax$/
 188     ;
 189
 190   $error = $self->SUPER::insert;
 191   return $error if $error;
 192
 193   my( $username, $uid, $gid, $dir, $shell ) = (
 194     $self->username,
 195     $self->uid,
 196     $self->gid,
 197     $self->dir,
 198     $self->shell,
 199   );
 200   if ( $username && $uid && $dir && $shellmachine && ! $nossh_hack ) {
 201     ssh("root\@$shellmachine", eval qq("$useradd") );
 202   }
 203
 204   ''; #no error
 205 }
 206
 207 =item delete
 208
 209 Deletes this account from the database.  If there is an error, returns the
 210 error, otherwise returns false.
 211
 212 The corresponding FS::cust_svc record will be deleted as well.
 213
 214 If the configuration value (see L<FS::Conf>) shellmachine exists, the
 215 command(s) specified in the shellmachine-userdel configuration file are
 216 executed on shellmachine via ssh.  This behavior can be surpressed by setting
 217 $FS::svc_acct::nossh_hack true.  If the shellmachine-userdel configuration
 218 file does not exist,
 219
 220   userdel $username
 221
 222 is the default.  If the shellmachine-userdel configuration file exists but
 223 is empty,
 224
 225   rm -rf $dir
 226
 227 is the default instead.  Otherwise the contents of the file are treated as a
 228 double-quoted perl string, with the following variables available:
 229 $username and $dir.
 230
 231 =cut
 232
 233 sub delete {
 234   my $self = shift;
 235   my $error;
 236
 237   return "Can't delete an account which has mail aliases pointed to it!"
 238     if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
 239
 240   local $SIG{HUP} = 'IGNORE';
 241   local $SIG{INT} = 'IGNORE';
 242   local $SIG{QUIT} = 'IGNORE';
 243   local $SIG{TERM} = 'IGNORE';
 244   local $SIG{TSTP} = 'IGNORE';
 245   local $SIG{PIPE} = 'IGNORE';
 246
 247   $error = $self->SUPER::delete;
 248   return $error if $error;
 249
 250   my( $username, $dir ) = (
 251     $self->username,
 252     $self->dir,
 253   );
 254   if ( $username && $shellmachine && ! $nossh_hack ) {
 255     ssh("root\@$shellmachine", eval qq("$userdel") );
 256   }
 257
 258   '';
 259 }
 260
 261 =item replace OLD_RECORD
 262
 263 Replaces OLD_RECORD with this one in the database.  If there is an error,
 264 returns the error, otherwise returns false.
 265
 266 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 267 dir field has changed, the command(s) specified in the shellmachine-usermod
 268 configuraiton file are executed on shellmachine via ssh.  This behavior can
 269 be surpressed by setting $FS::svc-acct::nossh_hack true.  If the
 270 shellmachine-userdel configuration file does not exist or is empty, :
 271
 272   [ -d $old_dir ] && mv $old_dir $new_dir || (
 273     chmod u+t $old_dir;
 274     mkdir $new_dir;
 275     cd $old_dir;
 276     find . -depth -print | cpio -pdm $new_dir;
 277     chmod u-t $new_dir;
 278     chown -R $uid.$gid $new_dir;
 279     rm -rf $old_dir
 280   )
 281
 282 is executed on shellmachine via ssh.  This behaviour can be surpressed by
 283 setting $FS::svc_acct::nossh_hack true.
 284
 285 =cut
 286
 287 sub replace {
 288   my ( $new, $old ) = ( shift, shift );
 289   my $error;
 290
 291   return "Username in use"
 292     if $old->username ne $new->username &&
 293       qsearchs( 'svc_acct', { 'username' => $new->username } );
 294
 295   return "Can't change uid!" if $old->uid != $new->uid;
 296
 297   #change homdir when we change username
 298   $new->setfield('dir', '') if $old->username ne $new->username;
 299
 300   local $SIG{HUP} = 'IGNORE';
 301   local $SIG{INT} = 'IGNORE';
 302   local $SIG{QUIT} = 'IGNORE';
 303   local $SIG{TERM} = 'IGNORE';
 304   local $SIG{TSTP} = 'IGNORE';
 305   local $SIG{PIPE} = 'IGNORE';
 306
 307   $error = $new->SUPER::replace($old);
 308   return $error if $error;
 309
 310   my ( $old_dir, $new_dir, $uid, $gid ) = (
 311     $old->getfield('dir'),
 312     $new->getfield('dir'),
 313     $new->getfield('uid'),
 314     $new->getfield('gid'),
 315   );
 316   if ( $old_dir && $new_dir && $old_dir ne $new_dir && ! $nossh_hack ) {
 317     ssh("root\@$shellmachine", eval qq("$usermod") );
 318   }
 319
 320   ''; #no error
 321 }
 322
 323 =item suspend
 324
 325 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 326 error, returns the error, otherwise returns false.
 327
 328 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 329
 330 =cut
 331
 332 sub suspend {
 333   my $self = shift;
 334   my %hash = $self->hash;
 335   unless ( $hash{_password} =~ /^\*SUSPENDED\* / ) {
 336     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 337     my $new = new FS::svc_acct ( \%hash );
 338     $new->replace($self);
 339   } else {
 340     ''; #no error (already suspended)
 341   }
 342 }
 343
 344 =item unsuspend
 345
 346 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 347 an error, returns the error, otherwise returns false.
 348
 349 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 350
 351 =cut
 352
 353 sub unsuspend {
 354   my $self = shift;
 355   my %hash = $self->hash;
 356   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 357     $hash{_password} = $1;
 358     my $new = new FS::svc_acct ( \%hash );
 359     $new->replace($self);
 360   } else {
 361     ''; #no error (already unsuspended)
 362   }
 363 }
 364
 365 =item cancel
 366
 367 Just returns false (no error) for now.
 368
 369 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 370
 371 =item check
 372
 373 Checks all fields to make sure this is a valid service.  If there is an error,
 374 returns the error, otherwise returns false.  Called by the insert and replace
 375 methods.
 376
 377 Sets any fixed values; see L<FS::part_svc>.
 378
 379 =cut
 380
 381 sub check {
 382   my $self = shift;
 383
 384   my($recref) = $self->hashref;
 385
 386   my $x = $self->setfixed;
 387   return $x unless ref($x);
 388   my $part_svc = $x;
 389
 390   my $error = $self->ut_number('domsvc');
 391   return $error if $error;
 392
 393   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 394   $recref->{username} =~ /^([a-z0-9_\-\.]{$usernamemin,$ulen})$/
 395     or return "Illegal username";
 396   $recref->{username} = $1;
 397   if ( $username_letterfirst ) {
 398     $recref->{username} =~ /^[a-z]/ or return "Illegal username";
 399   } elsif ( $username_letter ) {
 400     $recref->{username} =~ /[a-z]/ or return "Illegal username";
 401   }
 402
 403   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 404   $recref->{popnum} = $1;
 405   return "Unknown popnum" unless
 406     ! $recref->{popnum} ||
 407     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 408
 409   unless ( $part_svc->getfield('svc_acct__uid_flag') eq 'F' ) {
 410
 411     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 412     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 413
 414     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 415     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 416     #not all systems use gid=uid
 417     #you can set a fixed gid in part_svc
 418
 419     return "Only root can have uid 0"
 420       if $recref->{uid} == 0 && $recref->{username} ne 'root';
 421
 422     $error = $self->ut_textn('finger');
 423     return $error if $error;
 424
 425     $recref->{dir} =~ /^([\/\w\-]*)$/
 426       or return "Illegal directory";
 427     $recref->{dir} = $1 ||
 428       $dir_prefix . '/' . $recref->{username}
 429       #$dir_prefix . '/' . substr($recref->{username},0,1). '/' . $recref->{username}
 430     ;
 431
 432     unless ( $recref->{username} eq 'sync' ) {
 433       if ( grep $_ eq $recref->{shell}, @shells ) {
 434         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 435       } else {
 436         return "Illegal shell \`". $self->shell. "\'; ".
 437                $conf->dir. "/shells contains: @shells";
 438       }
 439     } else {
 440       $recref->{shell} = '/bin/sync';
 441     }
 442
 443     $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)";
 444     $recref->{quota} = $1;
 445
 446   } else {
 447     $recref->{gid} ne '' ?
 448       return "Can't have gid without uid" : ( $recref->{gid}='' );
 449     $recref->{finger} ne '' ?
 450       return "Can't have finger-name without uid" : ( $recref->{finger}='' );
 451     $recref->{dir} ne '' ?
 452       return "Can't have directory without uid" : ( $recref->{dir}='' );
 453     $recref->{shell} ne '' ?
 454       return "Can't have shell without uid" : ( $recref->{shell}='' );
 455     $recref->{quota} ne '' ?
 456       return "Can't have quota without uid" : ( $recref->{quota}='' );
 457   }
 458
 459   unless ( $part_svc->getfield('svc_acct__slipip_flag') eq 'F' ) {
 460     unless ( $recref->{slipip} eq '0e0' ) {
 461       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 462         or return "Illegal slipip". $self->slipip;
 463       $recref->{slipip} = $1;
 464     } else {
 465       $recref->{slipip} = '0e0';
 466     }
 467
 468   }
 469
 470   #arbitrary RADIUS stuff; allow ut_textn for now
 471   foreach ( grep /^radius_/, fields('svc_acct') ) {
 472     $self->ut_textn($_);
 473   }
 474
 475   #generate a password if it is blank
 476   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 477     unless ( $recref->{_password} );
 478
 479   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 480   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,8})$/ ) {
 481     $recref->{_password} = $1.$3;
 482     #uncomment this to encrypt password immediately upon entry, or run
 483     #bin/crypt_pw in cron to give new users a window during which their
 484     #password is available to techs, for faxing, etc.  (also be aware of
 485     #radius issues!)
 486     #$recref->{password} = $1.
 487     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 488     #;
 489   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$]{13,34})$/ ) {
 490     $recref->{_password} = $1.$3;
 491   } elsif ( $recref->{_password} eq '*' ) {
 492     $recref->{_password} = '*';
 493   } elsif ( $recref->{_password} eq '!!' ) {
 494     $recref->{_password} = '!!';
 495   } else {
 496     return "Illegal password";
 497   }
 498
 499   ''; #no error
 500 }
 501
 502 =item radius
 503
 504 Depriciated, use radius_reply instead.
 505
 506 =cut
 507
 508 sub radius {
 509   carp "FS::svc_acct::radius depriciated, use radius_reply";
 510   $_[0]->radius_reply;
 511 }
 512
 513 =item radius_reply
 514
 515 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 516 reply attributes of this record.
 517
 518 Note that this is now the preferred method for reading RADIUS attributes -
 519 accessing the columns directly is discouraged, as the column names are
 520 expected to change in the future.
 521
 522 =cut
 523
 524 sub radius_reply {
 525   my $self = shift;
 526   map {
 527     /^(radius_(.*))$/;
 528     my($column, $attrib) = ($1, $2);
 529     $attrib =~ s/_/\-/g;
 530     ( $attrib, $self->getfield($column) );
 531   } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 532 }
 533
 534 =item radius_check
 535
 536 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 537 check attributes of this record.
 538
 539 Accessing RADIUS attributes directly is not supported and will break in the
 540 future.
 541
 542 =cut
 543
 544 sub radius_check {
 545   my $self = shift;
 546   map {
 547     /^(rc_(.*))$/;
 548     my($column, $attrib) = ($1, $2);
 549     $attrib =~ s/_/\-/g;
 550     ( $attrib, $self->getfield($column) );
 551   } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
 552 }
 553
 554 =back
 555
 556 =head1 VERSION
 557
 558 $Id: svc_acct.pm,v 1.23 2001-08-19 08:18:01 ivan Exp $
 559
 560 =head1 BUGS
 561
 562 The bits which ssh should fork before doing so (or maybe queue jobs for a
 563 daemon).
 564
 565 The $recref stuff in sub check should be cleaned up.
 566
 567 The suspend, unsuspend and cancel methods update the database, but not the
 568 current object.  This is probably a bug as it's unexpected and
 569 counterintuitive.
 570
 571 =head1 SEE ALSO
 572
 573 L<FS::svc_Common>, L<FS::Record>, L<FS::Conf>, L<FS::cust_svc>,
 574 L<FS::part_svc>, L<FS::cust_pkg>, L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
 575 schema.html from the base documentation.
 576
 577 =cut
 578
 579 1;
 580