File Coverage

blib/lib/Bot/Cobalt/Plugin/Auth.pm
Criterion Covered Total %
statement 28 562 4.9
branch 0 194 0.0
condition 0 103 0.0
subroutine 10 53 18.8
pod 0 13 0.0
total 38 925 4.1


line stmt bran cond sub pod time code
1             package Bot::Cobalt::Plugin::Auth;
2             $Bot::Cobalt::Plugin::Auth::VERSION = '0.021002';
3 1     1   1599 use strictures 2;
  1         5  
  1         29  
4              
5             ## "Standard" Auth module
6             ##
7             ## Commands:
8             ## PRIVMSG:
9             ## login
10             ## chpass
11             ## user add
12             ## user del
13             ## user list
14             ## user search
15             ## user chpass
16             ##
17             ##
18             ## Fairly basic access level system:
19             ##
20             ## - Users can have any numeric level.
21             ## Generally unauthenticated users will be level 0
22             ## Higher levels trump lower levels.
23             ## SuperUsers (auth.conf) get access level 9999.
24             ##
25             ## - Plugins determine required levels for their respective commands
26             ##
27             ## Passwords are hashed via bcrypt and stored in YAML
28             ## Location of the authdb is determined by auth.conf
29             ##
30             ## Loaded authdb exists in memory in $self->AccessList:
31             ## ->AccessList = {
32             ## $context => {
33             ## $username => {
34             ## Masks => ARRAY,
35             ## Password => STRING (passwd hash),
36             ## Level => INT (9999 if superuser),
37             ## Flags => HASH,
38             ## },
39             ## },
40             ## }
41             ##
42             ## Also see Bot::Cobalt::Core::ContextMeta::Auth
43              
44              
45 1     1   134 use Bot::Cobalt;
  1         1  
  1         5  
46 1     1   906 use Bot::Cobalt::Common;
  1         2  
  1         5  
47 1     1   335 use Bot::Cobalt::Error;
  1         2  
  1         21  
48 1     1   344 use Bot::Cobalt::Serializer;
  1         2  
  1         32  
49              
50 1     1   6 use Scalar::Util 'reftype';
  1         1  
  1         38  
51 1     1   561 use Storable 'dclone';
  1         2984  
  1         55  
52              
53 1     1   5 use Try::Tiny;
  1         1  
  1         39  
54              
55 1     1   4 use File::Spec;
  1         1  
  1         5471  
56              
57              
58             ### Constants, mostly for internal retvals:
59             sub ACCESS_LIST() { 0 }
60             sub DB_PATH() { 1 }
61              
62              
63             sub new {
64 1     1 0 1066 bless [
65             +{}, ## ACCESS_LIST
66             '', ## DB_PATH
67             ], shift
68             }
69              
70             sub Cobalt_register {
71 0     0 0   my ($self, $core) = splice @_, 0, 2;
72              
73 0           my $p_cfg = plugin_cfg( $self );
74              
75             my $relative_path = $p_cfg->{Opts}->{AuthDB} ||
76 0   0       File::Spec->catfile( 'db', 'authdb.yml');
77              
78 0           my $authdb = File::Spec->catfile(
79             $core->var,
80             File::Spec->splitpath($relative_path)
81             );
82              
83 0           logger->debug("Using authdb path $authdb");
84              
85 0           $self->_db_path($authdb);
86              
87             ## Read in main authdb:
88 0           my $alist = $self->_read_access_list;
89              
90 0 0         unless ($alist) {
91 0           die "initial _read_access_list failed, check log\n";
92             }
93              
94 0           $self->AccessList( $alist );
95              
96 0           $self->_init_superusers;
97              
98 0           register($self, 'SERVER',
99             'connected',
100             'disconnected',
101              
102             'user_quit',
103             'user_left',
104             'self_left',
105              
106             'self_kicked',
107             'user_kicked',
108              
109             'nick_changed',
110              
111             'private_msg',
112             );
113              
114             ## clear any remaining auth states.
115             ## (assuming the plugin unloaded cleanly, there should be none)
116 0           $self->_clear_all;
117              
118 0           logger->info("Loaded");
119              
120 0           return PLUGIN_EAT_NONE
121             }
122              
123             sub Cobalt_unregister {
124 0     0 0   my ($self, $core) = splice @_, 0, 2;
125              
126 0           logger->info("Unregistering core IRC plugin");
127              
128 0           $self->_clear_all;
129              
130 0           return PLUGIN_EAT_NONE
131             }
132              
133             sub _init_superusers {
134 0     0     my ($self) = @_;
135 0           my $p_cfg = plugin_cfg($self);
136              
137             ## Read in configured superusers to AccessList
138             ## These will override existing usernames
139 0           my $superusers = $p_cfg->{SuperUsers};
140 0 0 0       unless (ref $superusers && reftype $superusers eq 'HASH') {
141 0           logger->error("Configuration may be broken . . .");
142 0           logger->error("SuperUsers directive is not a hash, skipping");
143             return
144 0           }
145              
146 0           my %su = %$superusers;
147              
148 0           SERVER: for my $context (keys %su) {
149 0 0 0       unless (ref $su{$context} && reftype $su{$context} eq 'HASH') {
150 0           logger->error("Skipping $context; configuration is not a hash");
151             next SERVER
152 0           }
153              
154 0           USER: for my $user (keys %{$su{$context}}) {
  0            
155 0 0 0       unless (ref $su{$context}->{$user}
156             && reftype $su{$context}->{$user} eq 'HASH') {
157 0           logger->error("Skipping $user; configuration is not a hash");
158             next USER
159 0           }
160              
161             ## Usernames on accesslist automatically get lowercased
162             ## per rfc1459 rules, aka CASEMAPPING=rfc1459
163             ## (we probably don't even know the server's CASEMAPPING= yet)
164 0           my $lc_user = lc_irc($user);
165              
166             my $flags = ref $su{$context}->{$user}->{Flags}
167             && reftype $su{$context}->{$user}->{Flags} eq 'HASH' ?
168             $su{$context}->{$user}->{Flags}
169 0 0 0       : +{} ;
170              
171 0           $flags->{SUPERUSER} = 1;
172              
173             $self->AccessList->{$context}->{$lc_user} = {
174             Password => $su{$context}->{$user}->{Password}
175 0   0       // $self->_mkpasswd(rand 10),
176             Level => 9999,
177             Flags => $flags,
178             };
179              
180             ## Mask and Masks are both valid directives, Mask trumps Masks
181 0 0 0       if (exists $su{$context}->{$user}->{Masks}
182             && !exists $su{$context}->{$user}->{Mask} )
183             {
184             $su{$context}->{$user}->{Mask} =
185 0           delete $su{$context}->{$user}->{Masks};
186             }
187              
188             ## the Mask specification in cfg may be an array or a string:
189 0 0         if (ref $su{$context}->{$user}->{Mask}) {
190 0 0         unless (reftype $su{$context}->{$user}->{Mask} eq 'ARRAY') {
191 0           logger->error(
192             "Expected a string or list of masks in 'Mask:' for $user"
193             );
194             # FIXME currently leaves user with no Masks ...
195             next USER
196 0           }
197             $self->AccessList->{$context}->{$lc_user}->{Masks} = [
198             ## normalize masks into full, matchable masks:
199 0           map {; normalize_mask($_) } @{ $su{$context}->{$user}->{Mask} }
  0            
  0            
200             ];
201             } else {
202             $self->AccessList->{$context}->{$lc_user}->{Masks} = [
203             normalize_mask( $su{$context}->{$user}->{Mask} )
204 0           ];
205             }
206              
207 0           logger->debug("added superuser: $user (context: $context)");
208             } ## USER
209              
210             } ## SERVER
211              
212             1
213 0           }
214              
215              
216             ### Bot_* events:
217             sub Bot_connected {
218 0     0 0   my ($self, $core) = splice @_, 0, 2;
219             ## Bot's freshly connected to a context
220             ## Clear any auth entries for this pkg + context
221 0           my $context = ${$_[0]};
  0            
222              
223 0           $self->_clear_context($context);
224              
225 0           return PLUGIN_EAT_NONE
226             }
227              
228             sub Bot_disconnected {
229 0     0 0   my ($self, $core) = splice @_, 0, 2;
230 0           my $context = ${$_[0]};
  0            
231              
232 0           $self->_clear_context($context);
233              
234 0           return PLUGIN_EAT_NONE
235             }
236              
237             sub Bot_user_left {
238 0     0 0   my ($self, $core) = splice @_, 0, 2;
239             ## User left a channel
240             ## If we don't share other channels, this user can't be tracked
241             ## (therefore clear any auth entries for user belonging to us)
242 0           my $left = ${$_[0]};
  0            
243 0           my $context = $left->context;
244              
245 0           my $channel = $left->channel;
246 0           my $nick = $left->src_nick;
247              
248             ## Call _remove_if_lost to see if we can still track this user:
249 0           $self->_remove_if_lost($context, $nick);
250              
251 0           return PLUGIN_EAT_NONE
252             }
253              
254             sub Bot_self_left {
255 0     0 0   my ($self, $core) = splice @_, 0, 2;
256 0           my $context = ${$_[0]};
  0            
257 0           my $channel = ${$_[1]};
  0            
258             ## The bot left a channel. Check auth status of all users.
259             ## This method may be unreliable on nets w/ busted CASEMAPPING=
260              
261 0           $self->_remove_if_lost($context);
262              
263 0           return PLUGIN_EAT_NONE
264             }
265              
266             sub Bot_self_kicked {
267 0     0 0   my ($self, $core) = splice @_, 0, 2;
268 0           my $context = ${$_[0]};
  0            
269              
270 0           $self->_remove_if_lost($context);
271              
272 0           return PLUGIN_EAT_NONE
273             }
274              
275             sub Bot_user_kicked {
276 0     0 0   my ($self, $core) = splice @_, 0, 2;
277 0           my $kick = ${ $_[0] };
  0            
278 0           my $context = $kick->context;
279 0           my $nick = $kick->src_nick;
280              
281 0           $self->_remove_if_lost($context, $nick);
282              
283 0           return PLUGIN_EAT_NONE
284             }
285              
286             sub Bot_user_quit {
287 0     0 0   my ($self, $core) = splice @_, 0, 2;
288 0           my $quit = ${$_[0]};
  0            
289 0           my $context = $quit->context;
290 0           my $nick = $quit->src_nick;
291             ## User quit, clear relevant auth entries
292             ## We can call _do_logout directly here:
293              
294 0           $self->_do_logout($context, $nick);
295              
296 0           return PLUGIN_EAT_NONE
297             }
298              
299             sub Bot_nick_changed {
300 0     0 0   my ($self, $core) = splice @_, 0, 2;
301 0           my $nchg = ${$_[0]};
  0            
302              
303 0           my $old = $nchg->old_nick;
304 0           my $new = $nchg->new_nick;
305 0           my $context = $nchg->context;
306              
307             ## a nickname changed, adjust Auth accordingly:
308 0           core->auth->move($context, $old, $new);
309              
310 0           return PLUGIN_EAT_NONE
311             }
312              
313              
314             sub Bot_private_msg {
315 0     0 0   my ($self, $core) = splice @_, 0, 2;
316 0           my $msg = ${$_[0]};
  0            
317 0           my $context = $msg->context;
318              
319 0   0       my $command = $msg->message_array->[0] // return PLUGIN_EAT_NONE;
320 0           $command = lc $command;
321              
322             ## simple method check/dispatch:
323 0           my $resp;
324 0           my $method = "_cmd_".$command;
325 0 0         if ( $self->can($method) ) {
326 0           logger->debug("dispatching '$command' for ".$msg->src_nick);
327 0           $resp = $self->$method($context, $msg);
328             }
329              
330 0 0         if (defined $resp) {
331 0           my $target = $msg->src_nick;
332 0           broadcast( 'message', $context, $target, $resp );
333             }
334              
335 0           return PLUGIN_EAT_NONE
336             }
337              
338              
339             ### Frontends:
340              
341             sub _cmd_login {
342             ## interact with _do_login and set up response RPLs
343             ## _do_login does the heavy lifting, we just talk to the user
344             ## this is stupid, but I'm too lazy to fix
345 0     0     my ($self, $context, $msg) = @_;
346              
347 0           my (undef, $l_user, $l_pass) = @{ $msg->message_array };
  0            
348              
349 0           my $origin = $msg->src;
350 0           my $nick = $msg->src_nick;
351              
352 0 0 0       unless (defined $l_user && defined $l_pass) {
353             ## bad syntax resp, currently takes no args ...
354 0           return core->rpl( q{AUTH_BADSYN_LOGIN} );
355             }
356              
357             ## NOTE: usernames in accesslist are stored lowercase per rfc1459 rules:
358 0           $l_user = lc_irc($l_user);
359              
360             ## IMPORTANT:
361             ## nicknames (for auth hash) remain unmolested
362             ## case changes are managed by tracking actual nickname changes
363             ## (that way we don't have to worry about it when checking access levels)
364              
365 0           my $rplvars = {
366             context => $context,
367             src => $origin,
368             nick => $nick,
369             user => $l_user,
370             };
371              
372 0           my $resp;
373              
374             try {
375 0     0     $self->_do_login($context, $nick, $l_user, $l_pass, $origin);
376              
377 0           $rplvars->{lev} = core->auth->level($context, $nick);
378              
379 0           $resp = core->rpl( q{AUTH_SUCCESS}, $rplvars );
380             } catch {
381 0     0     my %rplmap = (
382             E_NOSUCH => 'AUTH_FAIL_NO_SUCH',
383             E_BADPASS => 'AUTH_FAIL_BADPASS',
384             E_BADHOST => 'AUTH_FAIL_BADHOST',
385             E_NOCHANS => 'AUTH_FAIL_NO_CHANS',
386             );
387              
388 0           my $rpl = $rplmap{$_};
389              
390 0 0         logger->error("BUG; unknown retval from _do_login")
391             unless defined $rpl;
392              
393 0           $resp = core->rpl( $rpl, $rplvars );
394 0           };
395              
396 0 0         broadcast( 'notice', $context, $nick, $resp ) if defined $resp;
397              
398             return
399 0           }
400              
401             sub _cmd_chpass {
402 0     0     my ($self, $context, $msg) = @_;
403             ## 'self' chpass for logged-in users
404             ## chpass OLD NEW
405              
406 0           my $nick = $msg->src_nick;
407              
408 0           my $auth_for_nick = core->auth->username($context, $nick);
409              
410 0 0         unless (defined $auth_for_nick) {
411 0           return core->rpl( q{RPL_NO_ACCESS},
412             nick => $nick,
413             )
414             }
415              
416 0           my $passwd_old = $msg->message_array->[1];
417 0           my $passwd_new = $msg->message_array->[2];
418 0 0 0       unless (defined $passwd_old && defined $passwd_new) {
419 0           return core->rpl( q{AUTH_BADSYN_CHPASS} );
420             }
421              
422 0           my $user_rec = $self->_get_user_rec($context, $auth_for_nick);
423              
424 0 0         if ($user_rec->{Flags}->{SUPERUSER}) {
425 0           return "Superusers are hard-coded and cannot chpass"
426             }
427              
428 0           my $stored_pass = $user_rec->{Password};
429 0 0         unless ( passwdcmp($passwd_old, $stored_pass) ) {
430 0           return core->rpl( q{AUTH_CHPASS_BADPASS},
431             context => $context,
432             nick => $nick,
433             user => $auth_for_nick,
434             src => $msg->src,
435             )
436             }
437              
438 0           $user_rec->{Password} = $self->_mkpasswd($passwd_new);
439              
440 0 0         unless ( $self->_write_access_list ) {
441 0           logger->warn(
442             "Couldn't _write_access_list in _cmd_chpass",
443             );
444              
445 0           broadcast( 'message', $context, $nick,
446             "Failed access list write! Admin should check logs."
447             );
448             }
449              
450 0           return core->rpl( q{AUTH_CHPASS_SUCCESS},
451             context => $context,
452             nick => $nick,
453             user => $auth_for_nick,
454             src => $msg->src,
455             )
456             }
457              
458             sub _cmd_whoami {
459 0     0     my ($self, $context, $msg) = @_;
460             ## return current auth status
461 0           my $nick = $msg->src_nick;
462              
463 0           my $auth_lev = core->auth->level($context, $nick);
464 0   0       my $auth_usr = core->auth->username($context, $nick)
465             // 'Not Authorized';
466              
467 0           return core->rpl( q{AUTH_STATUS},
468             user => $auth_usr,
469             nick => $nick,
470             lev => $auth_lev,
471             )
472             }
473              
474             sub _cmd_user {
475 0     0     my ($self, $context, $msg) = @_;
476              
477             ## user add
478             ## user del
479             ## user list
480             ## user search
481 0   0       my $cmd = lc( $msg->message_array->[1] // '');
482              
483 0           my $resp;
484              
485 0 0         unless ($cmd) {
486 0           return 'No command specified'
487             }
488              
489             ## All of these need *some* access level
490             ## Bail early if we don't know this user
491 0           my $auth_lev = core->auth->level($context, $msg->src_nick);
492 0 0         unless ($auth_lev) {
493 0           return core->rpl( q{RPL_NO_ACCESS},
494             nick => $msg->src_nick,
495             )
496             }
497              
498 0           my $method = "_user_".$cmd;
499 0 0         if ( $self->can($method) ) {
500 0           logger->debug("dispatching $method for ".$msg->src_nick);
501              
502 0           return $self->$method($context, $msg)
503             }
504              
505             return
506 0           }
507              
508              
509              
510             ### Auth routines:
511              
512             sub _do_login {
513             ## backend handler for _cmd_login
514             ## $username should've already been normalized via lc_irc:
515 0     0     my ($self, $context, $nick, $username, $passwd, $host) = @_;
516              
517 0           my $user_rec;
518 0 0         unless ($user_rec = $self->_get_user_rec($context, $username) ) {
519 0           logger->info(
520             "[$context] authfail; no such user: $username ($host)"
521             );
522              
523             ## auth_failed_login ($context, $nick, $username, $host, $error_str)
524 0           broadcast( 'auth_failed_login',
525             $context,
526             $nick, $username, $host,
527             'NO_SUCH_USER',
528             );
529              
530 0           die Bot::Cobalt::Error->new("E_NOSUCH")
531             }
532              
533             ## fail if we don't share channels with this user
534 0           my $irc = core->get_irc_obj($context);
535 0 0         unless ($irc->nick_channels($nick)) {
536 0           logger->info(
537             "[$context] authfail; no shared chans: $username ($host)"
538             );
539              
540 0           broadcast( 'auth_failed_login',
541             $context,
542             $nick, $username, $host,
543             'NO_SHARED_CHANS',
544             );
545              
546 0           die Bot::Cobalt::Error->new("E_NOCHANS")
547             }
548              
549             ## masks should be normalized already:
550 0           my @matched_masks;
551 0           for my $mask (@{ $user_rec->{Masks} }) {
  0            
552 0 0         push(@matched_masks, $mask) if matches_mask($mask, $host);
553             }
554              
555 0 0         unless (@matched_masks) {
556 0           logger->info("[$context] authfail; no host match: $username ($host)");
557              
558 0           broadcast( 'auth_failed_login',
559             $context,
560             $nick, $username, $host,
561             'BAD_HOST',
562             );
563              
564 0           die Bot::Cobalt::Error->new("E_BADHOST")
565             }
566              
567 0 0         unless ( passwdcmp($passwd, $user_rec->{Password}) ) {
568 0           logger->info("[$context] authfail; bad passwd: $username ($host)");
569              
570 0           broadcast( 'auth_failed_login',
571             $context,
572             $nick, $username, $host,
573             'BAD_PASS',
574             );
575              
576 0           die Bot::Cobalt::Error->new("E_BADPASS")
577             }
578              
579 0           my $level = $user_rec->{Level};
580 0   0       my %flags = %{ $user_rec->{Flags} // {} };
  0            
581              
582 0           core->auth->add(
583             Context => $context,
584             Username => $username,
585             Nickname => $nick,
586             Host => $host,
587             Level => $level,
588             Flags => \%flags,
589             Alias => core->get_plugin_alias($self),
590             );
591              
592 0           logger->info(
593             "[$context] successful auth: $username (lev $level) ($host)"
594             );
595              
596             ## send Bot_auth_user_login ($context, $nick, $host, $username, $lev):
597 0           broadcast( 'auth_user_login',
598             $context,
599             $nick, $username, $host,
600             $level,
601             );
602              
603 0           1
604             }
605              
606              
607             sub _user_add {
608 0     0     my ($self, $context, $msg) = @_;
609 0           my $nick = $msg->src_nick;
610 0           my $auth_lev = core->auth->level($context, $nick);
611 0           my $auth_usr = core->auth->username($context, $nick);
612              
613 0 0         unless ($auth_usr) {
614             ## not logged in, return rpl
615 0           logger->info("Failed user add attempt by $nick on $context");
616 0           return core->rpl( q{RPL_NO_ACCESS},
617             nick => $nick,
618             )
619             }
620              
621 0           my $pcfg = plugin_cfg($self);
622              
623 0   0       my $required_base_lev = $pcfg->{RequiredPrivs}->{AddingUsers} // 2;
624              
625 0 0         unless ($auth_lev >= $required_base_lev) {
626             ## doesn't match configured required base level
627             ## otherwise this user can add users with lower access levs than theirs
628 0           logger->info(
629             "Failed user add; $nick ($auth_usr) has insufficient perms"
630             );
631              
632 0           return core->rpl( q{AUTH_NOT_ENOUGH_ACCESS},
633             nick => $nick,
634             lev => $auth_lev,
635             )
636             }
637              
638             ## user add ?
639 0           my @message = @{ $msg->message_array };
  0            
640 0           my @args = @message[2 .. $#message];
641 0           my ($target_usr, $target_lev, $mask, $passwd) = @args;
642 0 0 0       unless ($target_usr && $target_lev && $mask && $passwd) {
      0        
      0        
643 0           return "Usage: user add "
644             }
645              
646 0           $target_usr = lc_irc($target_usr);
647              
648 0 0         unless ($target_lev =~ /^\d+$/) {
649 0           return "Usage: user add "
650             }
651              
652 0 0         if ( exists $self->AccessList->{'-ALL'}->{$target_usr} ) {
653 0           logger->warn(
654             "Failed user add ($nick); $target_usr already exists in -ALL"
655             );
656              
657 0           return core->rpl( q{AUTH_USER_EXISTS},
658             nick => $nick,
659             user => $target_usr,
660             )
661             }
662              
663 0 0         if ( exists $self->AccessList->{$context}->{$target_usr} ) {
664 0           logger->warn(
665             "Failed user add ($nick); $target_usr already exists on $context"
666             );
667              
668 0           return core->rpl( q{AUTH_USER_EXISTS},
669             nick => $nick,
670             user => $target_usr,
671             )
672             }
673              
674 0 0         unless ($target_lev < $auth_lev) {
675             ## user doesn't have enough access to add this level
676             ## (superusers have to be hardcoded in auth.conf)
677 0           logger->info(
678             "Failed user add; lev ($target_lev) too high for $auth_usr ($nick)"
679             );
680              
681 0           return core->rpl( q{AUTH_NOT_ENOUGH_ACCESS},
682             nick => $nick,
683             lev => $auth_lev,
684             )
685             }
686              
687 0           $mask = normalize_mask($mask);
688              
689             ## add to AccessList
690 0           $self->AccessList->{$context}->{$target_usr} = {
691             Masks => [ $mask ],
692             Password => $self->_mkpasswd($passwd),
693             Level => $target_lev,
694             Flags => {},
695             };
696              
697 0           logger->info("New user added by $nick ($auth_usr)");
698 0           logger->info("New user $target_usr ($mask) level $target_lev");
699              
700 0 0         unless ( $self->_write_access_list ) {
701             ## added to AccessList but couldn't be written out
702 0           logger->warn("Couldn't _write_access_list in _user_add");
703              
704 0           broadcast( 'message', $context, $nick,
705             "Failed access list write! Admin should check logs."
706             );
707             }
708              
709 0           return core->rpl( q{AUTH_USER_ADDED},
710             nick => $nick,
711             user => $target_usr,
712             mask => $mask,
713             lev => $target_lev,
714             )
715             }
716              
717 0     0     sub _user_delete { _user_del(@_) }
718             sub _user_del {
719 0     0     my ($self, $context, $msg) = @_;
720 0           my $nick = $msg->src_nick;
721 0           my $auth_lev = core->auth->level($context, $nick);
722 0           my $auth_usr = core->auth->username($context, $nick);
723              
724 0 0         unless ($auth_usr) {
725 0           logger->info("Failed user del attempt by $nick on $context");
726 0           return core->rpl( q{RPL_NO_ACCESS},
727             nick => $nick,
728             )
729             }
730              
731 0           my $pcfg = plugin_cfg($self);
732              
733 0   0       my $required_base_lev = $pcfg->{RequiredPrivs}->{DeletingUsers} // 2;
734              
735 0 0         unless ($auth_lev >= $required_base_lev) {
736 0           logger->info(
737             "Failed user del; $nick ($auth_usr) has insufficient perms"
738             );
739              
740 0           return core->rpl( q{AUTH_NOT_ENOUGH_ACCESS},
741             nick => $nick,
742             lev => $auth_lev,
743             )
744             }
745              
746             ## user del
747 0           my $target_usr = $msg->message_array->[2];
748 0 0         unless ($target_usr) {
749 0           return "Usage: user del "
750             }
751              
752 0           $target_usr = lc_irc($target_usr);
753              
754             ## check if exists
755 0           my $this_alist = $self->AccessList->{$context};
756 0 0         unless (exists $this_alist->{$target_usr}) {
757 0           return core->rpl( q{AUTH_USER_NOSUCH},
758             nick => $nick,
759             user => $target_usr
760             )
761             }
762              
763             ## get target user's auth_level
764             ## check if authed user has a higher identified level
765 0           my $target_lev = $this_alist->{$target_usr}->{Level};
766 0 0         unless ($target_lev < $auth_lev) {
767 0           logger->info(
768             "Failed user del; $nick ($auth_usr) has insufficient perms"
769             );
770              
771 0           return core->rpl( q{AUTH_NOT_ENOUGH_ACCESS},
772             nick => $nick,
773             lev => $auth_lev
774             )
775             }
776              
777             ## delete users from AccessList
778 0           delete $this_alist->{$target_usr};
779              
780 0           logger->info("User deleted: $target_usr ($target_lev) on $context");
781 0           logger->info("Deletion issued by $nick ($auth_usr)");
782              
783             ## see if user is logged in, log them out if so
784 0           my $auth_context = core->auth->list($context);
785 0           for my $authnick (keys %$auth_context) {
786 0           my $this_username = $auth_context->{$authnick}->{Username};
787              
788 0 0         next unless $this_username eq $target_usr;
789              
790 0           $self->_do_logout($context, $authnick);
791             }
792              
793 0 0         unless ( $self->_write_access_list ) {
794 0           logger->warn("Couldn't _write_access_list in _user_add");
795              
796 0           broadcast( 'message', $context, $nick,
797             "Failed access list write! Admin should check logs."
798             );
799             }
800              
801 0           return core->rpl( q{AUTH_USER_DELETED},
802             nick => $nick,
803             user => $target_usr
804             )
805             }
806              
807             sub _user_list {
808 0     0     my ($self, $context, $msg) = @_;
809              
810 0           my $nick = $msg->src_nick;
811 0           my $auth_lev = core->auth->level($context, $nick);
812 0           my $auth_usr = core->auth->username($context, $nick);
813              
814 0 0         return core->rpl( q{RPL_NO_ACCESS}, nick => $nick )
815             unless $auth_lev;
816              
817             ## FIXME extra opt for users w/ add perms to list -ALL ?
818 0   0       my $alist = $self->AccessList->{$context} // {};
819              
820 0           my $respstr = "Users ($context): ";
821              
822 0           USER: for my $username (keys %$alist) {
823 0           my $lev = $alist->{$username}->{Level};
824 0           $respstr .= "$username ($lev) ";
825              
826 0 0         if ( length($respstr) > 250 ) {
827 0           broadcast( 'message', $context, $nick,
828             $respstr
829             );
830              
831 0           $respstr = '';
832             }
833              
834             } ## USER
835              
836 0 0         return $respstr if $respstr
837             }
838              
839             sub _user_whois {
840 0     0     my ($self, $context, $msg) = @_;
841 0           my $nick = $msg->src_nick;
842              
843 0           my $auth_lev = core->auth->level($context, $nick);
844 0           my $auth_usr = core->auth->username($context, $nick);
845              
846 0 0         return core->rpl( q{RPL_NO_ACCESS}, nick => $nick )
847             unless $auth_lev;
848              
849 0           my $target_nick = $msg->message_array->[2];
850              
851 0 0         if ( my $target_lev = core->auth->level($context, $target_nick) ) {
852 0           my $target_usr = core->auth->username($context, $target_nick);
853              
854 0           return "$target_nick is user $target_usr with level $target_lev"
855             } else {
856 0           return "$target_nick is not currently logged in"
857             }
858             }
859              
860             sub _user_info {
861 0     0     my ($self, $context, $msg) = @_;
862 0           my $nick = $msg->src_nick;
863              
864 0           my $auth_lev = core->auth->level($context, $nick);
865 0           my $auth_usr = core->auth->username($context, $nick);
866              
867 0 0         unless ($auth_lev) {
868 0           return core->rpl( q{RPL_NO_ACCESS}, nick => $nick );
869             }
870              
871 0           my $target_usr = $msg->message_array->[2];
872 0 0         unless (defined $target_usr) {
873 0           return 'Usage: user info '
874             }
875              
876 0           $target_usr = lc_irc($target_usr);
877              
878 0           my $user_rec;
879 0 0         unless ( $user_rec = $self->_get_user_rec($context, $target_usr) ) {
880 0           return core->rpl( q{AUTH_USER_NOSUCH},
881             nick => $nick,
882             user => $target_usr
883             );
884             }
885              
886 0           my $usr_lev = $user_rec->{Level};
887 0           my $usr_maskref = $user_rec->{Masks};
888              
889 0           my $maskcount = @$usr_maskref;
890              
891 0           broadcast( 'message', $context, $nick,
892             "User $target_usr is level $usr_lev, $maskcount masks listed"
893             );
894              
895 0           my @flags = keys %{ $user_rec->{Flags} };
  0            
896              
897 0           my $flag_repl = "Flags: ";
898              
899 0           while (my $this_flag = shift @flags) {
900 0           $flag_repl .= " ".$this_flag;
901              
902 0 0 0       if (length $flag_repl > 300 || !@flags) {
903 0           broadcast('message', $context, $nick, $flag_repl);
904 0           $flag_repl = '';
905             }
906             }
907              
908 0           my $mask_repl = "Masks: ";
909 0           my @masks = @$usr_maskref;
910              
911 0           while (my $this_mask = shift @masks) {
912 0           $mask_repl .= " ".$this_mask;
913 0 0 0       if (length $mask_repl > 300 || !@masks) {
914 0           broadcast('message', $context, $nick, $mask_repl);
915 0           $mask_repl = '';
916             }
917             }
918              
919             return
920 0           }
921              
922             sub _user_search {
923 0     0     my ($self, $context, $msg) = @_;
924 0           my $nick = $msg->src_nick;
925              
926             ## Auth should've already been checked in user_* dispatcher
927              
928             ## FIXME
929              
930             ## search by: username, host, ... ?
931             ## limit results ?
932              
933             }
934              
935             sub _user_chflags {
936 0     0     my ($self, $context, $msg) = @_;
937 0           my $nick = $msg->src_nick;
938              
939 0           my $auth_lev = core->auth->level($context, $nick);
940 0           my $auth_usr = core->auth->username($context, $nick);
941              
942 0           my $pcfg = plugin_cfg($self);
943 0           my $req_lev = $pcfg->{RequiredPrivs}->{DeletingUsers};
944              
945 0           my @message = @{ $msg->message_array };
  0            
946 0           my $target_usr = $message[2];
947 0           my @flags = @message[3 .. $#message];
948              
949 0 0 0       unless ($target_usr && @flags) {
950 0           return "Syntax: user chflags <+/-flag> ..."
951             }
952              
953 0           my $alist_ref;
954 0 0         unless ($alist_ref = $self->_get_user_rec($context, $target_usr) ) {
955 0           return core->rpl( q{AUTH_USER_NOSUCH},
956             nick => $nick,
957             user => $target_usr,
958             )
959             }
960              
961 0           my $target_usr_lev = $alist_ref->{Level};
962              
963 0           my $auth_flags = core->auth->flags($context, $nick);
964              
965 0 0 0       unless ($auth_lev >= $req_lev
      0        
966             && ($auth_lev > $target_usr_lev || $auth_usr eq $target_usr
967             || $auth_flags->{SUPERUSER}) ) {
968              
969 0           my $src = $msg->src;
970 0           logger->warn(
971             "Access denied in chflags: $src tried to chflags $target_usr"
972             );
973              
974 0           return core->rpl( q{AUTH_NOT_ENOUGH_ACCESS},
975             nick => $nick,
976             lev => $auth_lev,
977             )
978             }
979              
980 0           my $resp;
981 0           FLAG: for my $this_flag (@flags) {
982 0           my $first = substr($this_flag, 0, 1, '');
983 0   0       $this_flag = uc($this_flag||'');
984              
985 0 0 0       unless ($first && $this_flag) {
986 0           return "Bad syntax; flags should be in the form of -/+FLAG"
987             }
988              
989 0 0         if ($this_flag eq 'SUPERUSER') {
990 0           return "Cannot set SUPERUSER flag manually"
991             }
992              
993 0 0         if ($first eq '+') {
    0          
994 0           logger->debug("$nick ($auth_usr) flag add $target_usr $this_flag");
995 0           $alist_ref->{Flags}->{$this_flag} = 1;
996             next FLAG
997 0           } elsif ($first eq '-') {
998 0           logger->debug("$nick ($auth_usr) flag drop $target_usr $this_flag");
999 0           delete $alist_ref->{Flags}->{$this_flag};
1000             next FLAG
1001 0           }
1002              
1003 0           return "Bad syntax; flags should be prefixed by + or -"
1004             } ## FLAG
1005              
1006 0 0         if ( $self->_write_access_list ) {
1007 0           broadcast( 'message', $context, $nick,
1008             "Adjusted flags for $target_usr"
1009             );
1010             } else {
1011 0           broadcast( 'message', $context, $nick,
1012             "List write failed in _user_chflags, admin should check logs"
1013             );
1014             }
1015              
1016             return
1017 0           }
1018              
1019             sub _user_chmask {
1020 0     0     my ($self, $context, $msg) = @_;
1021 0           my $nick = $msg->src_nick;
1022 0           my $auth_lev = core->auth->level($context, $nick);
1023 0           my $auth_usr = core->auth->username($context, $nick);
1024              
1025 0           my $pcfg = plugin_cfg($self);
1026             ## If you can't delete users, you probably shouldn't be permitted
1027             ## to delete their masks, either
1028 0           my $req_lev = $pcfg->{RequiredPrivs}->{DeletingUsers};
1029              
1030             ## You also should have higher access than your target
1031             ## (unless you're a superuser)
1032 0           my $target_usr = $msg->message_array->[2];
1033 0           my $mask_specified = $msg->message_array->[3];
1034              
1035 0 0 0       unless ($target_usr && $mask_specified) {
1036 0           return "Usage: user chmask [+/-]"
1037             }
1038              
1039 0           my $alist_ref;
1040 0 0         unless ( $alist_ref = $self->_get_user_rec($context, $target_usr) ) {
1041 0           return core->rpl( q{AUTH_USER_NOSUCH},
1042             nick => $nick,
1043             user => $target_usr,
1044             )
1045             }
1046              
1047 0           my $target_usr_lev = $alist_ref->{Level};
1048 0           my $flags = core->auth->flags($context, $nick);
1049              
1050             ## Must be:
1051             ## higher than target user's lev
1052             ## or adjusting your own mask
1053             ## or superuser
1054 0 0 0       unless ($auth_lev >= $req_lev
      0        
1055             && ($auth_lev > $target_usr_lev || $auth_usr eq $target_usr
1056             || $flags->{SUPERUSER}) ) {
1057              
1058 0           my $src = $msg->src;
1059              
1060 0           logger->warn(
1061             "Access denied in chmask: $src tried to chmask $target_usr"
1062             );
1063              
1064 0           return core->rpl( q{AUTH_NOT_ENOUGH_ACCESS},
1065             nick => $nick,
1066             lev => $auth_lev
1067             );
1068             }
1069              
1070 0           my ($oper, $host) = $mask_specified =~ /^(\+|\-)(\S+)/;
1071 0 0 0       unless ($oper && $host) {
1072 0           return "Bad mask specification, should be operator (+ or -) followed by mask"
1073             }
1074              
1075 0           $host = normalize_mask($host);
1076              
1077 0           my $resp;
1078 0 0         if ($oper eq '+') {
1079 0           push(@{ $alist_ref->{Masks} }, $host)
1080 0 0         unless grep { $_ eq $host } @{ $alist_ref->{Masks} };
  0            
  0            
1081 0           $resp = core->rpl( q{AUTH_MASK_ADDED},
1082             nick => $nick,
1083             user => $target_usr,
1084             mask => $host,
1085             );
1086             } else {
1087             ## Remove a mask (the inefficient way, at the moment - lazy)
1088              
1089 0           my @masks = grep { $_ ne $host } @{ $alist_ref->{Masks} };
  0            
  0            
1090 0 0         if (@masks == @{$alist_ref->{Masks}}) {
  0            
1091 0           return "Mask not found."
1092             }
1093              
1094 0           $alist_ref->{Masks} = \@masks;
1095 0           $resp = core->rpl( q{AUTH_MASK_DELETED},
1096             nick => $nick,
1097             user => $target_usr,
1098             mask => $host
1099             );
1100             }
1101              
1102             ## call a list sync
1103 0 0         if ( $self->_write_access_list ) {
1104 0           broadcast( 'message', $context, $nick, $resp );
1105             } else {
1106 0           broadcast( 'message', $context, $nick,
1107             "List write failed in _user_chmask, admin should check logs"
1108             );
1109             }
1110              
1111             return
1112 0           }
1113              
1114             sub _user_chpass {
1115 0     0     my ($self, $context, $msg) = @_;
1116 0           my $nick = $msg->src_nick;
1117 0           my $auth_lev = core->auth->level($context, $nick);
1118 0           my $auth_usr = core->auth->username($context, $nick);
1119              
1120 0 0         unless (core->auth->has_flag($context, $nick, 'SUPERUSER')) {
1121 0           return "Must be flagged SUPERUSER to use user chpass"
1122             }
1123              
1124 0           my $target_usr = $msg->message_array->[2];
1125 0           my $new_passwd = $msg->message_array->[3];
1126              
1127 0 0 0       unless ($target_usr && $new_passwd) {
1128 0           return "Usage: user chpass "
1129             }
1130              
1131 0           my $user_rec;
1132 0 0         unless ($user_rec = $self->_get_user_rec($context, $target_usr) ) {
1133 0           return core->rpl( q{AUTH_USER_NOSUCH},
1134             nick => $nick,
1135             user => $target_usr,
1136             )
1137             }
1138              
1139 0           my $hashed = $self->_mkpasswd($new_passwd);
1140              
1141 0           logger->info(
1142             "$nick ($auth_usr) CHPASS for $target_usr"
1143             );
1144              
1145 0           $user_rec->{Password} = $hashed;
1146              
1147 0 0         if ( $self->_write_access_list ) {
1148 0           return core->rpl( q{AUTH_CHPASS_SUCCESS},
1149             nick => $nick,
1150             user => $target_usr,
1151             );
1152             } else {
1153 0           logger->warn(
1154             "Couldn't _write_access_list in _cmd_chpass",
1155             );
1156              
1157 0           return "Failed access list write! Admin should check logs."
1158             }
1159             }
1160              
1161              
1162             ### Utility methods:
1163              
1164             sub _get_user_rec {
1165 0     0     my ($self, $context, $user) = @_;
1166              
1167             ## Return user AccessList record, preferring hardcoded -ALL:
1168              
1169 0 0 0       confess "_get_user_rec called without required arguments"
1170             unless defined $context and defined $user;
1171              
1172             return unless exists $self->AccessList->{'-ALL'}->{$user}
1173             or exists $self->AccessList->{$context}
1174 0 0 0       and exists $self->AccessList->{$context}->{$user};
      0        
1175              
1176             exists $self->AccessList->{'-ALL'}->{$user} ?
1177             $self->AccessList->{'-ALL'}->{$user}
1178 0 0         : $self->AccessList->{$context}->{$user}
1179             }
1180              
1181             sub _remove_if_lost {
1182 0     0     my ($self, $context, $nick) = @_;
1183             ## $self->_remove_if_lost( $context );
1184             ## $self->_remove_if_lost( $context, $nickname );
1185             ##
1186             ## called by event handlers that track users (or the bot) leaving
1187             ##
1188             ## if a nickname is specified, ask _check_for_shared if we still see
1189             ## this user, otherwise remove relevant Auth
1190             ##
1191             ## if no nickname is specified, do the above for all Auth'd users
1192             ## in the specified context
1193             ##
1194             ## return list of removed users
1195              
1196             ## no auth for specified context? then we don't care:
1197 0           my $authref;
1198 0 0         return unless $authref = core->auth->list($context);
1199              
1200 0           my @removed;
1201              
1202 0 0         if ($nick) {
1203             ## ...does auth for this nickname in this context?
1204 0 0         return unless exists $authref->{$nick};
1205              
1206 0 0         unless ( $self->_check_for_shared($context, $nick) ) {
1207             ## we no longer share channels with this user
1208             ## if they're auth'd and their authorization is "ours", kill it
1209             ## call _do_logout to log them out and notify the pipeline
1210             ##
1211             ## _do_logout handles the messy details, incl. checking to make sure
1212             ## that we are the "owner" of this auth:
1213 0 0         push(@removed, $nick) if $self->_do_logout($context, $nick);
1214             }
1215              
1216             } else {
1217             ## no nickname specified
1218             ## check trackable status for all known
1219 0           for $nick (keys %$authref) {
1220 0 0         unless ( $self->_check_for_shared($context, $nick) ) {
1221 0 0         push(@removed, $nick) if $self->_do_logout($context, $nick);
1222             }
1223             }
1224              
1225             }
1226              
1227             return @removed
1228 0           }
1229              
1230             sub _check_for_shared {
1231             ## $self->_check_for_shared( $context, $nickname );
1232             ##
1233             ## Query the IRC component to see if we share channels with a user.
1234             ## Actually just a simple frontend to get_irc_obj & PoCo::IRC::State
1235             ##
1236             ## Returns boolean true or false.
1237             ## Typically called after either the bot or a user leave a channel
1238             ## ( normally by _remove_if_lost() )
1239             ##
1240             ## Tells Auth whether or not we can sanely track this user.
1241             ## If we don't share channels it's difficult to get nick change
1242             ## notifications and generally validate authenticated users.
1243 0     0     my ($self, $context, $nick) = @_;
1244 0           my $irc = core->get_irc_obj( $context );
1245 0           my @shared = $irc->nick_channels( $nick );
1246 0 0         return @shared ? 1 : 0 ;
1247             }
1248              
1249             sub _clear_context {
1250 0     0     my ($self, $context) = @_;
1251              
1252             ## $self->_clear_context( $context )
1253 0           for my $nick ( core->auth->list($context) ) {
1254 0           $self->_do_logout($context, $nick);
1255             }
1256             }
1257              
1258             sub _clear_all {
1259 0     0     my ($self) = @_;
1260             ## $self->_clear_all()
1261             ## clear any states belonging to us
1262 0           for my $context ( core->auth->list() ) {
1263              
1264 0           NICK: for my $nick ( core->auth->list($context) ) {
1265              
1266 0 0         next NICK unless core->auth->alias($context, $nick)
1267             eq core->get_plugin_alias($self);
1268              
1269 0           logger->debug("clearing: $nick [$context]");
1270 0           $self->_do_logout($context, $nick)
1271             }
1272              
1273             }
1274             }
1275              
1276             sub _do_logout {
1277 0     0     my ($self, $context, $nick) = @_;
1278             ## $self->_do_logout( $context, $nick )
1279             ## handles logout routines for 'lost' users
1280             ## normally called by method _remove_if_lost
1281             ##
1282             ## sends auth_user_logout event in addition to clearing auth hash
1283             ##
1284             ## returns the deleted user auth hash (or nothing)
1285 0           my $auth_context = core->auth->list($context);
1286              
1287 0 0         if (exists $auth_context->{$nick}) {
1288 0           my $auth_pkg = core->auth->alias($context, $nick);
1289 0           my $current_pkg = core->get_plugin_alias($self);
1290              
1291 0 0         if ($auth_pkg eq $current_pkg) {
1292 0           my $host = core->auth->host($context, $nick);
1293 0           my $username = core->auth->username($context, $nick);
1294 0           my $level = core->auth->level($context, $nick);
1295              
1296             ## Bot_auth_user_logout ($context, $nick, $host, $username, $lev, $pkg):
1297 0           broadcast( 'auth_user_logout',
1298             $context,
1299             $nick, $host, $username,
1300             $level,
1301             $auth_pkg,
1302             );
1303              
1304 0           logger->debug(
1305             "cleared auth state: $username ($nick on $context)"
1306             );
1307              
1308 0           return core->auth->del($context, $nick)
1309             } else {
1310 0           logger->debug(
1311             "skipped auth state, not ours: $nick [$context]"
1312             );
1313             }
1314             }
1315             return
1316 0           }
1317              
1318             sub _mkpasswd {
1319 0     0     my ($self, $passwd) = @_;
1320 0 0         return unless $passwd;
1321             ## $self->_mkpasswd( $passwd );
1322             ## simple frontend to Bot::Cobalt::Utils::mkpasswd()
1323             ## handles grabbing cfg opts for us:
1324              
1325 0           my $cfg = plugin_cfg( $self );
1326              
1327 0   0       my $crypt_method = $cfg->{Method} // 'bcrypt';
1328 0   0       my $bcrypt_cost = $cfg->{Bcrypt_Cost} || '08';
1329              
1330 0           mkpasswd($passwd, $crypt_method, $bcrypt_cost)
1331             }
1332              
1333             sub _db_path {
1334 0     0     my ($self, $dbpath) = @_;
1335              
1336 0 0         return $self->[DB_PATH] = $dbpath if defined $dbpath;
1337              
1338 0           $self->[DB_PATH]
1339             }
1340              
1341             sub AccessList {
1342 0     0 0   my ($self, $alist) = @_;
1343              
1344 0 0         if (defined $alist) {
1345 0 0 0       confess "AccessList is not a hashref"
1346             unless ref $alist
1347             and reftype $alist eq 'HASH';
1348              
1349 0           return $self->[ACCESS_LIST] = $alist
1350             }
1351              
1352 0           $self->[ACCESS_LIST]
1353             }
1354              
1355              
1356             ### Access list rw methods (serialize to YAML)
1357             ### These can also be used to read/write arbitrary authdbs
1358              
1359             sub _read_access_list {
1360 0     0     my ($self, $authdb) = @_;
1361             ## Default to $self->_db_path
1362 0 0         $authdb = $self->_db_path unless $authdb;
1363             ## read authdb, spit out hash
1364              
1365 0 0         unless (-f $authdb) {
1366 0           logger->debug("did not find authdb at $authdb");
1367 0           logger->info("No existing authdb, creating empty access list.");
1368              
1369             return { }
1370 0           }
1371              
1372 0           my $serializer = Bot::Cobalt::Serializer->new();
1373              
1374 0           my $accesslist;
1375             try {
1376 0     0     $accesslist = $serializer->readfile($authdb);
1377             } catch {
1378 0     0     logger->error("readfile() failure; $authdb $_");
1379 0           };
1380              
1381 0           return $accesslist
1382             }
1383              
1384             sub _write_access_list {
1385 0     0     my ($self, $authdb, $alist) = @_;
1386 0 0         $authdb = $self->_db_path unless $authdb;
1387 0 0         $alist = $self->AccessList unless $alist;
1388              
1389             ## we don't want to write superusers back out
1390             ## copy from ref to a fresh hash:
1391 0           my $cloned = dclone($alist);
1392 0           delete $cloned->{'-ALL'};
1393              
1394 0           for my $context (keys %$cloned) {
1395 0           for my $user (keys %{ $cloned->{$context} }) {
  0            
1396 0 0         if ( $cloned->{$context}->{$user}->{Flags}->{SUPERUSER} ) {
1397             ## FIXME
1398             ## sync superusers too so we can preserve flags?
1399             ## need to check/delete them at load time if there's a change
1400 0           delete $cloned->{$context}->{$user};
1401             }
1402             }
1403             ## don't need to write empty contexts either:
1404 0 0         delete $cloned->{$context} unless keys %{ $cloned->{$context} };
  0            
1405             }
1406              
1407             ## don't need to write empty access lists to disk ...
1408 0 0         return $authdb unless keys %$cloned;
1409              
1410 0           my $serializer = Bot::Cobalt::Serializer->new();
1411              
1412             return $authdb if try {
1413 0     0     $serializer->writefile($authdb, $cloned);
1414              
1415 0           my $p_cfg = plugin_cfg( $self );
1416 0   0       my $perms = oct( $p_cfg->{Opts}->{AuthDB_Perms} // '0600' );
1417 0           chmod($perms, $authdb);
1418 0           1
1419 0 0         };
1420              
1421 0           logger->error("writefile() failure; $authdb $_");
1422             return
1423 0           }
1424              
1425             1;
1426             __END__