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