depend on Storable 2.09
[freeside.git] / FS / FS / svc_acct.pm
1 package FS::svc_acct;
2
3 use strict;
4 use vars qw( @ISA $DEBUG $me $conf
5              $dir_prefix @shells $usernamemin
6              $usernamemax $passwordmin $passwordmax
7              $username_ampersand $username_letter $username_letterfirst
8              $username_noperiod $username_nounderscore $username_nodash
9              $username_uppercase
10              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
11              $smtpmachine
12              $radius_password $radius_ip
13              $dirhash
14              @saltset @pw_set );
15 use Carp;
16 use Fcntl qw(:flock);
17 use Crypt::PasswdMD5;
18 use FS::UID qw( datasrc );
19 use FS::Conf;
20 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
21 use FS::svc_Common;
22 use FS::cust_svc;
23 use FS::part_svc;
24 use FS::svc_acct_pop;
25 use FS::cust_main_invoice;
26 use FS::svc_domain;
27 use FS::raddb;
28 use FS::queue;
29 use FS::radius_usergroup;
30 use FS::export_svc;
31 use FS::part_export;
32 use FS::Msgcat qw(gettext);
33
34 @ISA = qw( FS::svc_Common );
35
36 $DEBUG = 0;
37 #$DEBUG = 1;
38 $me = '[FS::svc_acct]';
39
40 #ask FS::UID to run this stuff for us later
41 $FS::UID::callback{'FS::svc_acct'} = sub { 
42   $conf = new FS::Conf;
43   $dir_prefix = $conf->config('home');
44   @shells = $conf->config('shells');
45   $usernamemin = $conf->config('usernamemin') || 2;
46   $usernamemax = $conf->config('usernamemax');
47   $passwordmin = $conf->config('passwordmin') || 6;
48   $passwordmax = $conf->config('passwordmax') || 8;
49   $username_letter = $conf->exists('username-letter');
50   $username_letterfirst = $conf->exists('username-letterfirst');
51   $username_noperiod = $conf->exists('username-noperiod');
52   $username_nounderscore = $conf->exists('username-nounderscore');
53   $username_nodash = $conf->exists('username-nodash');
54   $username_uppercase = $conf->exists('username-uppercase');
55   $username_ampersand = $conf->exists('username-ampersand');
56   $dirhash = $conf->config('dirhash') || 0;
57   if ( $conf->exists('welcome_email') ) {
58     $welcome_template = new Text::Template (
59       TYPE   => 'ARRAY',
60       SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
61     ) or warn "can't create welcome email template: $Text::Template::ERROR";
62     $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
63     $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
64     $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
65   } else {
66     $welcome_template = '';
67     $welcome_from = '';
68     $welcome_subject = '';
69     $welcome_mimetype = '';
70   }
71   $smtpmachine = $conf->config('smtpmachine');
72   $radius_password = $conf->config('radius-password') || 'Password';
73   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
74 };
75
76 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
77 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
78
79 sub _cache {
80   my $self = shift;
81   my ( $hashref, $cache ) = @_;
82   if ( $hashref->{'svc_acct_svcnum'} ) {
83     $self->{'_domsvc'} = FS::svc_domain->new( {
84       'svcnum'   => $hashref->{'domsvc'},
85       'domain'   => $hashref->{'svc_acct_domain'},
86       'catchall' => $hashref->{'svc_acct_catchall'},
87     } );
88   }
89 }
90
91 =head1 NAME
92
93 FS::svc_acct - Object methods for svc_acct records
94
95 =head1 SYNOPSIS
96
97   use FS::svc_acct;
98
99   $record = new FS::svc_acct \%hash;
100   $record = new FS::svc_acct { 'column' => 'value' };
101
102   $error = $record->insert;
103
104   $error = $new_record->replace($old_record);
105
106   $error = $record->delete;
107
108   $error = $record->check;
109
110   $error = $record->suspend;
111
112   $error = $record->unsuspend;
113
114   $error = $record->cancel;
115
116   %hash = $record->radius;
117
118   %hash = $record->radius_reply;
119
120   %hash = $record->radius_check;
121
122   $domain = $record->domain;
123
124   $svc_domain = $record->svc_domain;
125
126   $email = $record->email;
127
128   $seconds_since = $record->seconds_since($timestamp);
129
130 =head1 DESCRIPTION
131
132 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
133 FS::svc_Common.  The following fields are currently supported:
134
135 =over 4
136
137 =item svcnum - primary key (assigned automatcially for new accounts)
138
139 =item username
140
141 =item _password - generated if blank
142
143 =item sec_phrase - security phrase
144
145 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
146
147 =item uid
148
149 =item gid
150
151 =item finger - GECOS
152
153 =item dir - set automatically if blank (and uid is not)
154
155 =item shell
156
157 =item quota - (unimplementd)
158
159 =item slipip - IP address
160
161 =item seconds - 
162
163 =item domsvc - svcnum from svc_domain
164
165 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
166
167 =back
168
169 =head1 METHODS
170
171 =over 4
172
173 =item new HASHREF
174
175 Creates a new account.  To add the account to the database, see L<"insert">.
176
177 =cut
178
179 sub table { 'svc_acct'; }
180
181 =item insert [ , OPTION => VALUE ... ]
182
183 Adds this account to the database.  If there is an error, returns the error,
184 otherwise returns false.
185
186 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be 
187 defined.  An FS::cust_svc record will be created and inserted.
188
189 The additional field I<usergroup> can optionally be defined; if so it should
190 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
191 sqlradius export only)
192
193 The additional field I<child_objects> can optionally be defined; if so it
194 should contain an arrayref of FS::tablename objects.  They will have their
195 svcnum fields set and will be inserted after this record, but before any
196 exports are run.
197
198 Currently available options are: I<depend_jobnum>
199
200 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
201 jobnums), all provisioning jobs will have a dependancy on the supplied
202 jobnum(s) (they will not run until the specific job(s) complete(s)).
203
204 (TODOC: L<FS::queue> and L<freeside-queued>)
205
206 (TODOC: new exports!)
207
208 =cut
209
210 sub insert {
211   my $self = shift;
212   my %options = @_;
213   my $error;
214
215   local $SIG{HUP} = 'IGNORE';
216   local $SIG{INT} = 'IGNORE';
217   local $SIG{QUIT} = 'IGNORE';
218   local $SIG{TERM} = 'IGNORE';
219   local $SIG{TSTP} = 'IGNORE';
220   local $SIG{PIPE} = 'IGNORE';
221
222   my $oldAutoCommit = $FS::UID::AutoCommit;
223   local $FS::UID::AutoCommit = 0;
224   my $dbh = dbh;
225
226   $error = $self->check;
227   return $error if $error;
228
229   #no, duplicate checking just got a whole lot more complicated
230   #(perhaps keep this check with a config option to turn on?)
231
232   #return gettext('username_in_use'). ": ". $self->username
233   #  if qsearchs( 'svc_acct', { 'username' => $self->username,
234   #                             'domsvc'   => $self->domsvc,
235   #                           } );
236
237   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
238     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
239     unless ( $cust_svc ) {
240       $dbh->rollback if $oldAutoCommit;
241       return "no cust_svc record found for svcnum ". $self->svcnum;
242     }
243     $self->pkgnum($cust_svc->pkgnum);
244     $self->svcpart($cust_svc->svcpart);
245   }
246
247   #new duplicate username checking
248
249   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
250   unless ( $part_svc ) {
251     $dbh->rollback if $oldAutoCommit;
252     return 'unknown svcpart '. $self->svcpart;
253   }
254
255   my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
256   my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
257                                               'domsvc'   => $self->domsvc } );
258   my @dup_uid;
259   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
260        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
261     @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
262   } else {
263     @dup_uid = ();
264   }
265
266   if ( @dup_user || @dup_userdomain || @dup_uid ) {
267     my $exports = FS::part_export::export_info('svc_acct');
268     my %conflict_user_svcpart;
269     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
270
271     foreach my $part_export ( $part_svc->part_export ) {
272
273       #this will catch to the same exact export
274       my @svcparts = map { $_->svcpart }
275         qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
276
277       #this will catch to exports w/same exporthost+type ???
278       #my @other_part_export = qsearch('part_export', {
279       #  'machine'    => $part_export->machine,
280       #  'exporttype' => $part_export->exporttype,
281       #} );
282       #foreach my $other_part_export ( @other_part_export ) {
283       #  push @svcparts, map { $_->svcpart }
284       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
285       #}
286
287       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
288       #silly kludge to avoid uninitialized value errors
289       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
290                      ? $exports->{$part_export->exporttype}{'nodomain'}
291                      : '';
292       if ( $nodomain =~ /^Y/i ) {
293         $conflict_user_svcpart{$_} = $part_export->exportnum
294           foreach @svcparts;
295       } else {
296         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
297           foreach @svcparts;
298       }
299     }
300
301     foreach my $dup_user ( @dup_user ) {
302       my $dup_svcpart = $dup_user->cust_svc->svcpart;
303       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
304         $dbh->rollback if $oldAutoCommit;
305         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
306                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
307       }
308     }
309
310     foreach my $dup_userdomain ( @dup_userdomain ) {
311       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
312       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
313         $dbh->rollback if $oldAutoCommit;
314         return "duplicate username\@domain: conflicts with svcnum ".
315                $dup_userdomain->svcnum. " via exportnum ".
316                $conflict_userdomain_svcpart{$dup_svcpart};
317       }
318     }
319
320     foreach my $dup_uid ( @dup_uid ) {
321       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
322       if ( exists($conflict_user_svcpart{$dup_svcpart})
323            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
324         $dbh->rollback if $oldAutoCommit;
325         return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
326                "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
327                                  || $conflict_userdomain_svcpart{$dup_svcpart};
328       }
329     }
330
331   }
332
333   #see?  i told you it was more complicated
334
335   my @jobnums;
336   $error = $self->SUPER::insert(
337     'jobnums'       => \@jobnums,
338     'child_objects' => $self->child_objects,
339     %options,
340   );
341   if ( $error ) {
342     $dbh->rollback if $oldAutoCommit;
343     return $error;
344   }
345
346   if ( $self->usergroup ) {
347     foreach my $groupname ( @{$self->usergroup} ) {
348       my $radius_usergroup = new FS::radius_usergroup ( {
349         svcnum    => $self->svcnum,
350         groupname => $groupname,
351       } );
352       my $error = $radius_usergroup->insert;
353       if ( $error ) {
354         $dbh->rollback if $oldAutoCommit;
355         return $error;
356       }
357     }
358   }
359
360   #false laziness with sub replace (and cust_main)
361   my $queue = new FS::queue {
362     'svcnum' => $self->svcnum,
363     'job'    => 'FS::svc_acct::append_fuzzyfiles'
364   };
365   $error = $queue->insert($self->username);
366   if ( $error ) {
367     $dbh->rollback if $oldAutoCommit;
368     return "queueing job (transaction rolled back): $error";
369   }
370
371   my $cust_pkg = $self->cust_svc->cust_pkg;
372
373   if ( $cust_pkg ) {
374     my $cust_main = $cust_pkg->cust_main;
375
376     if ( $conf->exists('emailinvoiceauto') ) {
377       my @invoicing_list = $cust_main->invoicing_list;
378       push @invoicing_list, $self->email;
379       $cust_main->invoicing_list(\@invoicing_list);
380     }
381
382     #welcome email
383     my $to = '';
384     if ( $welcome_template && $cust_pkg ) {
385       my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
386       if ( $to ) {
387         my $wqueue = new FS::queue {
388           'svcnum' => $self->svcnum,
389           'job'    => 'FS::svc_acct::send_email'
390         };
391         my $error = $wqueue->insert(
392           'to'       => $to,
393           'from'     => $welcome_from,
394           'subject'  => $welcome_subject,
395           'mimetype' => $welcome_mimetype,
396           'body'     => $welcome_template->fill_in( HASH => {
397                           'custnum'  => $self->custnum,
398                           'username' => $self->username,
399                           'password' => $self->_password,
400                           'first'    => $cust_main->first,
401                           'last'     => $cust_main->getfield('last'),
402                           'pkg'      => $cust_pkg->part_pkg->pkg,
403                         } ),
404         );
405         if ( $error ) {
406           $dbh->rollback if $oldAutoCommit;
407           return "error queuing welcome email: $error";
408         }
409
410         if ( $options{'depend_jobnum'} ) {
411           warn "$me depend_jobnum found; adding to welcome email dependancies"
412             if $DEBUG;
413           if ( ref($options{'depend_jobnum'}) ) {
414             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
415                  "to welcome email dependancies"
416               if $DEBUG;
417             push @jobnums, @{ $options{'depend_jobnum'} };
418           } else {
419             warn "$me adding job $options{'depend_jobnum'} ".
420                  "to welcome email dependancies"
421               if $DEBUG;
422             push @jobnums, $options{'depend_jobnum'};
423           }
424         }
425
426         foreach my $jobnum ( @jobnums ) {
427           my $error = $wqueue->depend_insert($jobnum);
428           if ( $error ) {
429             $dbh->rollback if $oldAutoCommit;
430             return "error queuing welcome email job dependancy: $error";
431           }
432         }
433
434       }
435
436     }
437
438   } # if ( $cust_pkg )
439
440   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
441   ''; #no error
442 }
443
444 =item delete
445
446 Deletes this account from the database.  If there is an error, returns the
447 error, otherwise returns false.
448
449 The corresponding FS::cust_svc record will be deleted as well.
450
451 (TODOC: new exports!)
452
453 =cut
454
455 sub delete {
456   my $self = shift;
457
458   return "can't delete system account" if $self->_check_system;
459
460   return "Can't delete an account which is a (svc_forward) source!"
461     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
462
463   return "Can't delete an account which is a (svc_forward) destination!"
464     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
465
466   return "Can't delete an account with (svc_www) web service!"
467     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
468
469   # what about records in session ? (they should refer to history table)
470
471   local $SIG{HUP} = 'IGNORE';
472   local $SIG{INT} = 'IGNORE';
473   local $SIG{QUIT} = 'IGNORE';
474   local $SIG{TERM} = 'IGNORE';
475   local $SIG{TSTP} = 'IGNORE';
476   local $SIG{PIPE} = 'IGNORE';
477
478   my $oldAutoCommit = $FS::UID::AutoCommit;
479   local $FS::UID::AutoCommit = 0;
480   my $dbh = dbh;
481
482   foreach my $cust_main_invoice (
483     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
484   ) {
485     unless ( defined($cust_main_invoice) ) {
486       warn "WARNING: something's wrong with qsearch";
487       next;
488     }
489     my %hash = $cust_main_invoice->hash;
490     $hash{'dest'} = $self->email;
491     my $new = new FS::cust_main_invoice \%hash;
492     my $error = $new->replace($cust_main_invoice);
493     if ( $error ) {
494       $dbh->rollback if $oldAutoCommit;
495       return $error;
496     }
497   }
498
499   foreach my $svc_domain (
500     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
501   ) {
502     my %hash = new FS::svc_domain->hash;
503     $hash{'catchall'} = '';
504     my $new = new FS::svc_domain \%hash;
505     my $error = $new->replace($svc_domain);
506     if ( $error ) {
507       $dbh->rollback if $oldAutoCommit;
508       return $error;
509     }
510   }
511
512   foreach my $radius_usergroup (
513     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
514   ) {
515     my $error = $radius_usergroup->delete;
516     if ( $error ) {
517       $dbh->rollback if $oldAutoCommit;
518       return $error;
519     }
520   }
521
522   my $error = $self->SUPER::delete;
523   if ( $error ) {
524     $dbh->rollback if $oldAutoCommit;
525     return $error;
526   }
527
528   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
529   '';
530 }
531
532 =item replace OLD_RECORD
533
534 Replaces OLD_RECORD with this one in the database.  If there is an error,
535 returns the error, otherwise returns false.
536
537 The additional field I<usergroup> can optionally be defined; if so it should
538 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
539 sqlradius export only)
540
541 =cut
542
543 sub replace {
544   my ( $new, $old ) = ( shift, shift );
545   my $error;
546   warn "$me replacing $old with $new\n" if $DEBUG;
547
548   return "can't modify system account" if $old->_check_system;
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   #change homdir when we change username
562   $new->setfield('dir', '') if $old->username ne $new->username;
563
564   local $SIG{HUP} = 'IGNORE';
565   local $SIG{INT} = 'IGNORE';
566   local $SIG{QUIT} = 'IGNORE';
567   local $SIG{TERM} = 'IGNORE';
568   local $SIG{TSTP} = 'IGNORE';
569   local $SIG{PIPE} = 'IGNORE';
570
571   my $oldAutoCommit = $FS::UID::AutoCommit;
572   local $FS::UID::AutoCommit = 0;
573   my $dbh = dbh;
574
575   # redundant, but so $new->usergroup gets set
576   $error = $new->check;
577   return $error if $error;
578
579   $old->usergroup( [ $old->radius_groups ] );
580   warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
581   warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
582   if ( $new->usergroup ) {
583     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
584     my @newgroups = @{$new->usergroup};
585     foreach my $oldgroup ( @{$old->usergroup} ) {
586       if ( grep { $oldgroup eq $_ } @newgroups ) {
587         @newgroups = grep { $oldgroup ne $_ } @newgroups;
588         next;
589       }
590       my $radius_usergroup = qsearchs('radius_usergroup', {
591         svcnum    => $old->svcnum,
592         groupname => $oldgroup,
593       } );
594       my $error = $radius_usergroup->delete;
595       if ( $error ) {
596         $dbh->rollback if $oldAutoCommit;
597         return "error deleting radius_usergroup $oldgroup: $error";
598       }
599     }
600
601     foreach my $newgroup ( @newgroups ) {
602       my $radius_usergroup = new FS::radius_usergroup ( {
603         svcnum    => $new->svcnum,
604         groupname => $newgroup,
605       } );
606       my $error = $radius_usergroup->insert;
607       if ( $error ) {
608         $dbh->rollback if $oldAutoCommit;
609         return "error adding radius_usergroup $newgroup: $error";
610       }
611     }
612
613   }
614
615   $error = $new->SUPER::replace($old);
616   if ( $error ) {
617     $dbh->rollback if $oldAutoCommit;
618     return $error if $error;
619   }
620
621   if ( $new->username ne $old->username ) {
622     #false laziness with sub insert (and cust_main)
623     my $queue = new FS::queue {
624       'svcnum' => $new->svcnum,
625       'job'    => 'FS::svc_acct::append_fuzzyfiles'
626     };
627     $error = $queue->insert($new->username);
628     if ( $error ) {
629       $dbh->rollback if $oldAutoCommit;
630       return "queueing job (transaction rolled back): $error";
631     }
632   }
633
634   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
635   ''; #no error
636 }
637
638 =item suspend
639
640 Suspends this account by calling export-specific suspend hooks.  If there is
641 an error, returns the error, otherwise returns false.
642
643 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
644
645 =cut
646
647 sub suspend {
648   my $self = shift;
649   return "can't suspend system account" if $self->_check_system;
650   $self->SUPER::suspend;
651 }
652
653 =item unsuspend
654
655 Unsuspends this account by by calling export-specific suspend hooks.  If there
656 is an error, returns the error, otherwise returns false.
657
658 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
659
660 =cut
661
662 sub unsuspend {
663   my $self = shift;
664   my %hash = $self->hash;
665   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
666     $hash{_password} = $1;
667     my $new = new FS::svc_acct ( \%hash );
668     my $error = $new->replace($self);
669     return $error if $error;
670   }
671
672   $self->SUPER::unsuspend;
673 }
674
675 =item cancel
676
677 Just returns false (no error) for now.
678
679 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
680
681 =item check
682
683 Checks all fields to make sure this is a valid service.  If there is an error,
684 returns the error, otherwise returns false.  Called by the insert and replace
685 methods.
686
687 Sets any fixed values; see L<FS::part_svc>.
688
689 =cut
690
691 sub check {
692   my $self = shift;
693
694   my($recref) = $self->hashref;
695
696   my $x = $self->setfixed;
697   return $x unless ref($x);
698   my $part_svc = $x;
699
700   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
701     $self->usergroup(
702       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
703   }
704
705   my $error = $self->ut_numbern('svcnum')
706               #|| $self->ut_number('domsvc')
707               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
708               || $self->ut_textn('sec_phrase')
709   ;
710   return $error if $error;
711
712   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
713   if ( $username_uppercase ) {
714     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
715       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
716     $recref->{username} = $1;
717   } else {
718     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
719       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
720     $recref->{username} = $1;
721   }
722
723   if ( $username_letterfirst ) {
724     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
725   } elsif ( $username_letter ) {
726     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
727   }
728   if ( $username_noperiod ) {
729     $recref->{username} =~ /\./ and return gettext('illegal_username');
730   }
731   if ( $username_nounderscore ) {
732     $recref->{username} =~ /_/ and return gettext('illegal_username');
733   }
734   if ( $username_nodash ) {
735     $recref->{username} =~ /\-/ and return gettext('illegal_username');
736   }
737   unless ( $username_ampersand ) {
738     $recref->{username} =~ /\&/ and return gettext('illegal_username');
739   }
740
741   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
742   $recref->{popnum} = $1;
743   return "Unknown popnum" unless
744     ! $recref->{popnum} ||
745     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
746
747   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
748
749     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
750     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
751
752     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
753     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
754     #not all systems use gid=uid
755     #you can set a fixed gid in part_svc
756
757     return "Only root can have uid 0"
758       if $recref->{uid} == 0
759          && $recref->{username} ne 'root'
760          && $recref->{username} ne 'toor';
761
762
763     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
764       or return "Illegal directory: ". $recref->{dir};
765     $recref->{dir} = $1;
766     return "Illegal directory"
767       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
768     return "Illegal directory"
769       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
770     unless ( $recref->{dir} ) {
771       $recref->{dir} = $dir_prefix . '/';
772       if ( $dirhash > 0 ) {
773         for my $h ( 1 .. $dirhash ) {
774           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
775         }
776       } elsif ( $dirhash < 0 ) {
777         for my $h ( reverse $dirhash .. -1 ) {
778           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
779         }
780       }
781       $recref->{dir} .= $recref->{username};
782     ;
783     }
784
785     unless ( $recref->{username} eq 'sync' ) {
786       if ( grep $_ eq $recref->{shell}, @shells ) {
787         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
788       } else {
789         return "Illegal shell \`". $self->shell. "\'; ".
790                $conf->dir. "/shells contains: @shells";
791       }
792     } else {
793       $recref->{shell} = '/bin/sync';
794     }
795
796   } else {
797     $recref->{gid} ne '' ? 
798       return "Can't have gid without uid" : ( $recref->{gid}='' );
799     $recref->{dir} ne '' ? 
800       return "Can't have directory without uid" : ( $recref->{dir}='' );
801     $recref->{shell} ne '' ? 
802       return "Can't have shell without uid" : ( $recref->{shell}='' );
803   }
804
805   #  $error = $self->ut_textn('finger');
806   #  return $error if $error;
807   $self->getfield('finger') =~
808     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
809       or return "Illegal finger: ". $self->getfield('finger');
810   $self->setfield('finger', $1);
811
812   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
813   $recref->{quota} = $1;
814
815   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
816     if ( $recref->{slipip} eq '' ) {
817       $recref->{slipip} = '';
818     } elsif ( $recref->{slipip} eq '0e0' ) {
819       $recref->{slipip} = '0e0';
820     } else {
821       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
822         or return "Illegal slipip: ". $self->slipip;
823       $recref->{slipip} = $1;
824     }
825
826   }
827
828   #arbitrary RADIUS stuff; allow ut_textn for now
829   foreach ( grep /^radius_/, fields('svc_acct') ) {
830     $self->ut_textn($_);
831   }
832
833   #generate a password if it is blank
834   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
835     unless ( $recref->{_password} );
836
837   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
838   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
839     $recref->{_password} = $1.$3;
840     #uncomment this to encrypt password immediately upon entry, or run
841     #bin/crypt_pw in cron to give new users a window during which their
842     #password is available to techs, for faxing, etc.  (also be aware of 
843     #radius issues!)
844     #$recref->{password} = $1.
845     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
846     #;
847   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
848     $recref->{_password} = $1.$3;
849   } elsif ( $recref->{_password} eq '*' ) {
850     $recref->{_password} = '*';
851   } elsif ( $recref->{_password} eq '!' ) {
852     $recref->{_password} = '!';
853   } elsif ( $recref->{_password} eq '!!' ) {
854     $recref->{_password} = '!!';
855   } else {
856     #return "Illegal password";
857     return gettext('illegal_password'). " $passwordmin-$passwordmax ".
858            FS::Msgcat::_gettext('illegal_password_characters').
859            ": ". $recref->{_password};
860   }
861
862   $self->SUPER::check;
863 }
864
865 =item _check_system
866
867 =cut
868
869 sub _check_system {
870   my $self = shift;
871   scalar( grep { $self->username eq $_ || $self->email eq $_ }
872                $conf->config('system_usernames')
873         );
874 }
875
876 =item radius
877
878 Depriciated, use radius_reply instead.
879
880 =cut
881
882 sub radius {
883   carp "FS::svc_acct::radius depriciated, use radius_reply";
884   $_[0]->radius_reply;
885 }
886
887 =item radius_reply
888
889 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
890 reply attributes of this record.
891
892 Note that this is now the preferred method for reading RADIUS attributes - 
893 accessing the columns directly is discouraged, as the column names are
894 expected to change in the future.
895
896 =cut
897
898 sub radius_reply { 
899   my $self = shift;
900   my %reply =
901     map {
902       /^(radius_(.*))$/;
903       my($column, $attrib) = ($1, $2);
904       #$attrib =~ s/_/\-/g;
905       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
906     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
907   if ( $self->slipip && $self->slipip ne '0e0' ) {
908     $reply{$radius_ip} = $self->slipip;
909   }
910   %reply;
911 }
912
913 =item radius_check
914
915 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
916 check attributes of this record.
917
918 Note that this is now the preferred method for reading RADIUS attributes - 
919 accessing the columns directly is discouraged, as the column names are
920 expected to change in the future.
921
922 =cut
923
924 sub radius_check {
925   my $self = shift;
926   my $password = $self->_password;
927   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
928   ( $pw_attrib => $password,
929     map {
930       /^(rc_(.*))$/;
931       my($column, $attrib) = ($1, $2);
932       #$attrib =~ s/_/\-/g;
933       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
934     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
935   );
936 }
937
938 =item domain
939
940 Returns the domain associated with this account.
941
942 =cut
943
944 sub domain {
945   my $self = shift;
946   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
947   my $svc_domain = $self->svc_domain
948     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
949   $svc_domain->domain;
950 }
951
952 =item svc_domain
953
954 Returns the FS::svc_domain record for this account's domain (see
955 L<FS::svc_domain>).
956
957 =cut
958
959 sub svc_domain {
960   my $self = shift;
961   $self->{'_domsvc'}
962     ? $self->{'_domsvc'}
963     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
964 }
965
966 =item cust_svc
967
968 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
969
970 =cut
971
972 sub cust_svc {
973   my $self = shift;
974   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
975 }
976
977 =item email
978
979 Returns an email address associated with the account.
980
981 =cut
982
983 sub email {
984   my $self = shift;
985   $self->username. '@'. $self->domain;
986 }
987
988 =item acct_snarf
989
990 Returns an array of FS::acct_snarf records associated with the account.
991 If the acct_snarf table does not exist or there are no associated records,
992 an empty list is returned
993
994 =cut
995
996 sub acct_snarf {
997   my $self = shift;
998   return () unless dbdef->table('acct_snarf');
999   eval "use FS::acct_snarf;";
1000   die $@ if $@;
1001   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1002 }
1003
1004 =item seconds_since TIMESTAMP
1005
1006 Returns the number of seconds this account has been online since TIMESTAMP,
1007 according to the session monitor (see L<FS::Session>).
1008
1009 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1010 L<Time::Local> and L<Date::Parse> for conversion functions.
1011
1012 =cut
1013
1014 #note: POD here, implementation in FS::cust_svc
1015 sub seconds_since {
1016   my $self = shift;
1017   $self->cust_svc->seconds_since(@_);
1018 }
1019
1020 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1021
1022 Returns the numbers of seconds this account has been online between
1023 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1024 external SQL radacct table, specified via sqlradius export.  Sessions which
1025 started in the specified range but are still open are counted from session
1026 start to the end of the range (unless they are over 1 day old, in which case
1027 they are presumed missing their stop record and not counted).  Also, sessions
1028 which end in the range but started earlier are counted from the start of the
1029 range to session end.  Finally, sessions which start before the range but end
1030 after are counted for the entire range.
1031
1032 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1033 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1034 functions.
1035
1036 =cut
1037
1038 #note: POD here, implementation in FS::cust_svc
1039 sub seconds_since_sqlradacct {
1040   my $self = shift;
1041   $self->cust_svc->seconds_since_sqlradacct(@_);
1042 }
1043
1044 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1045
1046 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1047 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1048 TIMESTAMP_END (exclusive).
1049
1050 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1051 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1052 functions.
1053
1054 =cut
1055
1056 #note: POD here, implementation in FS::cust_svc
1057 sub attribute_since_sqlradacct {
1058   my $self = shift;
1059   $self->cust_svc->attribute_since_sqlradacct(@_);
1060 }
1061
1062 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1063
1064 Returns an array of hash references of this customers login history for the
1065 given time range.  (document this better)
1066
1067 =cut
1068
1069 sub get_session_history_sqlradacct {
1070   my $self = shift;
1071   $self->cust_svc->get_session_history_sqlradacct(@_);
1072 }
1073
1074 =item radius_groups
1075
1076 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1077
1078 =cut
1079
1080 sub radius_groups {
1081   my $self = shift;
1082   if ( $self->usergroup ) {
1083     #when provisioning records, export callback runs in svc_Common.pm before
1084     #radius_usergroup records can be inserted...
1085     @{$self->usergroup};
1086   } else {
1087     map { $_->groupname }
1088       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1089   }
1090 }
1091
1092 =item clone_suspended
1093
1094 Constructor used by FS::part_export::_export_suspend fallback.  Document
1095 better.
1096
1097 =cut
1098
1099 sub clone_suspended {
1100   my $self = shift;
1101   my %hash = $self->hash;
1102   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1103   new FS::svc_acct \%hash;
1104 }
1105
1106 =item clone_kludge_unsuspend 
1107
1108 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1109 better.
1110
1111 =cut
1112
1113 sub clone_kludge_unsuspend {
1114   my $self = shift;
1115   my %hash = $self->hash;
1116   $hash{_password} = '';
1117   new FS::svc_acct \%hash;
1118 }
1119
1120 =item check_password 
1121
1122 Checks the supplied password against the (possibly encrypted) password in the
1123 database.  Returns true for a sucessful authentication, false for no match.
1124
1125 Currently supported encryptions are: classic DES crypt() and MD5
1126
1127 =cut
1128
1129 sub check_password {
1130   my($self, $check_password) = @_;
1131
1132   #remove old-style SUSPENDED kludge, they should be allowed to login to
1133   #self-service and pay up
1134   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1135
1136   #eventually should check a "password-encoding" field
1137   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1138     return 0;
1139   } elsif ( length($password) < 13 ) { #plaintext
1140     $check_password eq $password;
1141   } elsif ( length($password) == 13 ) { #traditional DES crypt
1142     crypt($check_password, $password) eq $password;
1143   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1144     unix_md5_crypt($check_password, $password) eq $password;
1145   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1146     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1147          $self->svcnum. "\n";
1148     0;
1149   } else {
1150     warn "Can't check password: Unrecognized encryption for svcnum ".
1151          $self->svcnum. "\n";
1152     0;
1153   }
1154
1155 }
1156
1157 =back
1158
1159 =head1 SUBROUTINES
1160
1161 =over 4
1162
1163 =item send_email
1164
1165 This is the FS::svc_acct job-queue-able version.  It still uses
1166 FS::Misc::send_email under-the-hood.
1167
1168 =cut
1169
1170 sub send_email {
1171   my %opt = @_;
1172
1173   eval "use FS::Misc qw(send_email)";
1174   die $@ if $@;
1175
1176   $opt{mimetype} ||= 'text/plain';
1177   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1178
1179   my $error = send_email(
1180     'from'         => $opt{from},
1181     'to'           => $opt{to},
1182     'subject'      => $opt{subject},
1183     'content-type' => $opt{mimetype},
1184     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
1185   );
1186   die $error if $error;
1187 }
1188
1189 =item check_and_rebuild_fuzzyfiles
1190
1191 =cut
1192
1193 sub check_and_rebuild_fuzzyfiles {
1194   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1195   -e "$dir/svc_acct.username"
1196     or &rebuild_fuzzyfiles;
1197 }
1198
1199 =item rebuild_fuzzyfiles
1200
1201 =cut
1202
1203 sub rebuild_fuzzyfiles {
1204
1205   use Fcntl qw(:flock);
1206
1207   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1208
1209   #username
1210
1211   open(USERNAMELOCK,">>$dir/svc_acct.username")
1212     or die "can't open $dir/svc_acct.username: $!";
1213   flock(USERNAMELOCK,LOCK_EX)
1214     or die "can't lock $dir/svc_acct.username: $!";
1215
1216   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1217
1218   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1219     or die "can't open $dir/svc_acct.username.tmp: $!";
1220   print USERNAMECACHE join("\n", @all_username), "\n";
1221   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1222
1223   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1224   close USERNAMELOCK;
1225
1226 }
1227
1228 =item all_username
1229
1230 =cut
1231
1232 sub all_username {
1233   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1234   open(USERNAMECACHE,"<$dir/svc_acct.username")
1235     or die "can't open $dir/svc_acct.username: $!";
1236   my @array = map { chomp; $_; } <USERNAMECACHE>;
1237   close USERNAMECACHE;
1238   \@array;
1239 }
1240
1241 =item append_fuzzyfiles USERNAME
1242
1243 =cut
1244
1245 sub append_fuzzyfiles {
1246   my $username = shift;
1247
1248   &check_and_rebuild_fuzzyfiles;
1249
1250   use Fcntl qw(:flock);
1251
1252   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1253
1254   open(USERNAME,">>$dir/svc_acct.username")
1255     or die "can't open $dir/svc_acct.username: $!";
1256   flock(USERNAME,LOCK_EX)
1257     or die "can't lock $dir/svc_acct.username: $!";
1258
1259   print USERNAME "$username\n";
1260
1261   flock(USERNAME,LOCK_UN)
1262     or die "can't unlock $dir/svc_acct.username: $!";
1263   close USERNAME;
1264
1265   1;
1266 }
1267
1268
1269
1270 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1271
1272 =cut
1273
1274 sub radius_usergroup_selector {
1275   my $sel_groups = shift;
1276   my %sel_groups = map { $_=>1 } @$sel_groups;
1277
1278   my $selectname = shift || 'radius_usergroup';
1279
1280   my $dbh = dbh;
1281   my $sth = $dbh->prepare(
1282     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1283   ) or die $dbh->errstr;
1284   $sth->execute() or die $sth->errstr;
1285   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1286
1287   my $html = <<END;
1288     <SCRIPT>
1289     function ${selectname}_doadd(object) {
1290       var myvalue = object.${selectname}_add.value;
1291       var optionName = new Option(myvalue,myvalue,false,true);
1292       var length = object.$selectname.length;
1293       object.$selectname.options[length] = optionName;
1294       object.${selectname}_add.value = "";
1295     }
1296     </SCRIPT>
1297     <SELECT MULTIPLE NAME="$selectname">
1298 END
1299
1300   foreach my $group ( @all_groups ) {
1301     $html .= '<OPTION';
1302     if ( $sel_groups{$group} ) {
1303       $html .= ' SELECTED';
1304       $sel_groups{$group} = 0;
1305     }
1306     $html .= ">$group</OPTION>\n";
1307   }
1308   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1309     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1310   };
1311   $html .= '</SELECT>';
1312
1313   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1314            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1315
1316   $html;
1317 }
1318
1319 =back
1320
1321 =head1 BUGS
1322
1323 The $recref stuff in sub check should be cleaned up.
1324
1325 The suspend, unsuspend and cancel methods update the database, but not the
1326 current object.  This is probably a bug as it's unexpected and
1327 counterintuitive.
1328
1329 radius_usergroup_selector?  putting web ui components in here?  they should
1330 probably live somewhere else...
1331
1332 insertion of RADIUS group stuff in insert could be done with child_objects now
1333 (would probably clean up export of them too)
1334
1335 =head1 SEE ALSO
1336
1337 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1338 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1339 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1340 L<freeside-queued>), L<FS::svc_acct_pop>,
1341 schema.html from the base documentation.
1342
1343 =cut
1344
1345 1;
1346