← Back
Editing: acl-lib.pl
=head1 acl-lib.pl Library for editing webmin users, passwords and access rights. foreign_require("acl", "acl-lib.pl"); @users = acl::list_users(); $newguy = { 'name' => 'newguy', 'pass' => acl::encrypt_password('smeg'), 'modules' => [ 'useradmin' ] }; acl::create_user($newguy); =cut BEGIN { push(@INC, ".."); }; ## no critic use strict; use warnings; no warnings 'redefine'; no warnings 'uninitialized'; use WebminCore; &init_config(); do 'md5-lib.pl'; our ($module_root_directory, %text, %sessiondb, %config, %gconfig, $base_remote_user, %hash_session_id_cache, $session_hmac_key, $loaded_session_keyfile, $use_hmac_sha256); eval { require Digest::SHA; Digest::SHA::hmac_sha256_hex('x', 'y'); 1; }; $use_hmac_sha256 = 1 if (!$@); our %access = &get_module_acl(); $access{'switch'} = 0 if (&is_readonly_mode()); =head2 list_users([&only-users]) Returns a list of hashes containing Webmin user details. Useful keys include : =item name - Login name =item pass - Encrypted password =item modules - Array references of modules =item theme - Custom theme, if any If the only-users parameter is given, limit the list to just users with those usernames. =cut sub list_users { my ($only) = @_; my (%miniserv, @rv, %acl, %logout); &read_acl(undef, \%acl); &get_miniserv_config(\%miniserv); if ($miniserv{'logouttimes'}) { foreach my $a (split(/\s+/, $miniserv{'logouttimes'})) { if ($a =~ /^([^=]+)=(\S+)$/) { $logout{$1} = $2; } } } my $fh = "PWFILE"; &open_readfile($fh, $miniserv{'userfile'}); while(my $l = <$fh>) { $l =~ s/\r|\n//g; my @user = split(/:/, $l); if (@user) { my %user; next if ($only && &indexof($user[0], @$only) < 0); while(@user < 11) { push(@user, ""); } # Prevent warnings $user{'name'} = $user[0]; $user{'pass'} = $user[1]; $user{'sync'} = $user[2]; $user{'cert'} = $user[3]; if ($user[4] =~ /^(allow|deny)\s+(.*)/) { $user{$1} = $2; $user{$1} =~ s/;/:/g; } if ($user[5] =~ /days\s+(\S+)/) { $user{'days'} = $1; } if ($user[5] =~ /hours\s+(\d+\.\d+)-(\d+\.\d+)/) { $user{'hoursfrom'} = $1; $user{'hoursto'} = $2; } $user{'lastchange'} = $user[6]; $user{'olds'} = $user[7] ? [ split(/\s+/, $user[7]) ] : [ ]; $user{'minsize'} = $user[8]; $user{'nochange'} = int($user[9] || 0); $user{'temppass'} = int($user[10] || 0); $user{'twofactor_provider'} = $user[11]; $user{'twofactor_id'} = $user[12]; $user{'twofactor_apikey'} = $user[13]; $user{'modules'} = $acl{$user[0]}; $user{'lang'} = $gconfig{"lang_$user[0]"}; $user{'langauto'} = $gconfig{"langauto_$user[0]"}; $user{'langneutral'} = $gconfig{"langneutral_$user[0]"}; $user{'locale'} = $gconfig{"locale_$user[0]"}; $user{'dateformat'} = $gconfig{"dateformat_$user[0]"}; $user{'notabs'} = $gconfig{"notabs_$user[0]"}; if ($gconfig{"theme_$user[0]"}) { ($user{'theme'}, $user{'overlay'}) = split(/\s+/, $gconfig{"theme_$user[0]"}); } elsif (defined($gconfig{"theme_$user[0]"})) { $user{'theme'} = ""; } $user{'readonly'} = $gconfig{"readonly_$user[0]"}; $user{'ownmods'} = [ split(/\s+/, $gconfig{"ownmods_$user[0]"} || "") ]; $user{'logouttime'} = $logout{$user[0]}; $user{'real'} = $gconfig{"realname_$user[0]"}; $user{'email'} = $user[14]; push(@rv, \%user); } } close($fh); # If a user DB is enabled, get users from it too if ($miniserv{'userdb'}) { my ($dbh, $proto, $prefix, $args) =&connect_userdb($miniserv{'userdb'}); &error("Failed to connect to user database : $dbh") if (!ref($dbh)); if ($proto eq "mysql" || $proto eq "postgresql") { # Fetch users with SQL my %userid; my $cmd = $dbh->prepare( "select id,name,pass from webmin_user". ($only ? " where name in (". join(",", map { "'$_'" } @$only).")" : "")); $cmd && $cmd->execute() || &error("Failed to query users : ".$dbh->errstr); while(my ($id, $name, $pass) = $cmd->fetchrow()) { my $u = { 'name' => $name, 'pass' => $pass, 'proto' => $proto, 'id' => $id }; push(@rv, $u); $userid{$id} = $u; } $cmd->finish(); # Add user attributes $cmd = $dbh->prepare( "select id,attr,value from webmin_user_attr ". ($only && %userid ? " where id in (".join(",", keys %userid).")" : "")); $cmd && $cmd->execute() || &error("Failed to query user attrs : ".$dbh->errstr); while(my ($id, $attr, $value) = $cmd->fetchrow()) { if ($attr eq "olds" || $attr eq "modules" || $attr eq "ownmods") { $value = [ split(/\s+/, $value) ]; } $userid{$id}->{$attr} = $value; } $cmd->finish(); } elsif ($proto eq "ldap") { # Find users with LDAP query my $filter = '(objectClass='.$args->{'userclass'}.')'; if ($only) { my $ufilter = "(|".join("", map { "(cn=$_)" } @$only).")"; $filter = "(&".$filter.$ufilter.")"; } my $rv = $dbh->search( base => $prefix, filter => $filter, scope => 'sub'); if (!$rv || $rv->code) { &error("Failed to search users : ". ($rv ? $rv->error : "Unknown error")); } foreach my $l ($rv->all_entries) { my $u = { 'name' => $l->get_value('cn'), 'pass' => $l->get_value('webminPass'), 'proto' => $proto, 'id' => $l->dn() }; foreach my $la ($l->get_value('webminAttr')) { my ($attr, $value) = split(/=/, $la, 2); if ($attr eq "olds" || $attr eq "ownmods") { $value = [ split(/\s+/, $value) ]; } $u->{$attr} = $value; } $u->{'modules'} = [ $l->get_value('webminModule') ]; push(@rv, $u); } } &disconnect_userdb($miniserv{'userdb'}, $dbh); } return @rv; } =head2 get_user(username) Returns a hash ref of details of the user with some name, in the same format as list_users. Returns undef if not found =cut sub get_user { my ($username) = @_; my @rv = &list_users([ $username ]); my ($user) = grep { $_->{'name'} eq $username } @rv; return $user; } =head2 list_groups([&only-groups]) Returns a list of hashes, one per Webmin group. Group membership is stored in /etc/webmin/webmin.groups, and other attributes in the config file. Useful keys include : =item name - Group name =item members - Array reference of member users =item modules - Modules to grant to members If the only-groups parameter is given, limit the list to just groups with those group names. =cut sub list_groups { my ($only) = @_; my @rv; my %miniserv; &get_miniserv_config(\%miniserv); # Add groups from local files if ( -r "$config_directory/webmin.groups" ) { my $lref = &read_file_lines("$config_directory/webmin.groups", 1); foreach my $l (@$lref) { $l =~ s/\r|\n//g; my @g = split(/:/, $l); if (@g) { next if ($only && &indexof($g[0], @$only) < 0); my $group = { 'name' => $g[0], 'members' => [ split(/\s+/, $g[1] || "") ], 'modules' => [ split(/\s+/, $g[2] || "") ], 'desc' => $g[3], 'ownmods' => [ split(/\s+/, $g[4] || "") ] }; push(@rv, $group); } } } # If a user DB is enabled, get groups from it too if ($miniserv{'userdb'}) { my ($dbh, $proto, $prefix, $args) =&connect_userdb($miniserv{'userdb'}); &error("Failed to connect to group database : $dbh") if (!ref($dbh)); if ($proto eq "mysql" || $proto eq "postgresql") { # Fetch groups with SQL my %groupid; my $cmd = $dbh->prepare( "select id,name,description from webmin_group ". ($only ? " where name in (". join(",", map { "'$_'" } @$only).")" : "")); $cmd && $cmd->execute() || &error("Failed to query groups : ".$dbh->errstr); while(my ($id, $name, $desc) = $cmd->fetchrow()) { my $g = { 'name' => $name, 'desc' => $desc, 'proto' => $proto, 'id' => $id }; push(@rv, $g); $groupid{$id} = $g; } $cmd->finish(); # Add group attributes $cmd = $dbh->prepare( "select id,attr,value from webmin_group_attr ". ($only && %groupid ? " where id in (".join(",", keys %groupid).")" : "")); $cmd && $cmd->execute() || &error("Failed to query group attrs : ".$dbh->errstr); while(my ($id, $attr, $value) = $cmd->fetchrow()) { if ($attr eq "members" || $attr eq "modules" || $attr eq "ownmods") { $value = [ split(/\s+/, $value) ]; } $groupid{$id}->{$attr} = $value; } $cmd->finish(); } elsif ($proto eq "ldap") { # Find groups with LDAP query my $filter = '(objectClass='.$args->{'groupclass'}.')'; if ($only) { my $gfilter = "(|".join("", map { "(cn=$_)" } @$only).")"; $filter = "(&".$filter.$gfilter.")"; } my $rv = $dbh->search( base => $prefix, filter => $filter, scope => 'sub'); if (!$rv || $rv->code) { &error("Failed to search groups : ". ($rv ? $rv->error : "Unknown error")); } foreach my $l ($rv->all_entries) { my $g = { 'name' => $l->get_value('cn'), 'desc' => $l->get_value('webminDesc'), 'proto' => $proto, 'id' => $l->dn() }; foreach my $la ($l->get_value('webminAttr')) { my ($attr, $value) = split(/=/, $la, 2); if ($attr eq "members" || $attr eq "ownmods") { $value = [ split(/\s+/, $value) ]; } $g->{$attr} = $value; } $g->{'modules'} = [ $l->get_value('webminModule') ]; push(@rv, $g); } } &disconnect_userdb($miniserv{'userdb'}, $dbh); } return @rv; } =head2 get_group(groupname) Returns a hash ref of details of the group with some name, in the same format as list_groups. Returns undef if not found =cut sub get_group { my ($groupname) = @_; my @rv = &list_groups([ $groupname ]); my ($group) = grep { $_->{'name'} eq $groupname } @rv; return $group; } =head2 list_modules Returns a list of the dirs of all modules available on this system. =cut sub list_modules { return map { $_->{'dir'} } &list_module_infos(); } =head2 list_module_infos Returns a list of the details of all modules that can be used on this system, each of which is a hash reference in the same format as their module.info files. =cut sub list_module_infos { my @mods = grep { &check_os_support($_) } &get_all_module_infos(); my @sorted = sort { $a->{'desc'} cmp $b->{'desc'} } @mods; return @sorted; } =head2 create_user(&details, [clone]) Creates a new Webmin user, based on the hash reference in the details parameter. This must be in the same format as those returned by list_users. If the clone parameter is given, it must be a username to copy detailed access control settings from for this new user. =cut sub create_user { my ($user, $clone) = @_; my %miniserv; my @mods = &list_modules(); $user->{'name'} eq "webmin" && &error("Invalid username webmin for new user"); &get_miniserv_config(\%miniserv); if ($miniserv{'userdb'} && !$miniserv{'userdb_addto'}) { # Adding to user database my ($dbh, $proto, $prefix, $args) =&connect_userdb($miniserv{'userdb'}); &error("Failed to connect to user database : $dbh") if (!ref($dbh)); if ($proto eq "mysql" || $proto eq "postgresql") { # Add user with SQL my $cmd = $dbh->prepare("insert into webmin_user (name,pass) values (?, ?)"); $cmd && $cmd->execute($user->{'name'}, $user->{'pass'}) || &error("Failed to add user : ".$dbh->errstr); $cmd->finish(); $cmd = $dbh->prepare("select max(id) from webmin_user"); $cmd->execute(); my ($id) = $cmd->fetchrow(); $cmd->finish(); # Add other attributes $cmd = $dbh->prepare("insert into webmin_user_attr (id,attr,value) values (?, ?, ?)"); foreach my $attr (keys %$user) { next if ($attr eq "name" || $attr eq "pass"); my $value = $user->{$attr}; if ($attr eq "olds" || $attr eq "modules" || $attr eq "ownmods") { $value = $value ? join(" ", @$value) : ""; } $cmd->execute($id, $attr, $value) || &error("Failed to add user attribute : ". $dbh->errstr); $cmd->finish(); } $user->{'id'} = $id; $user->{'proto'} = $proto; } elsif ($proto eq "ldap") { # Add user to LDAP my $dn = "cn=".$user->{'name'}.",".$prefix; my @attrs = ( "objectClass", $args->{'userclass'}, "cn", $user->{'name'}, "webminPass", $user->{'pass'} ); my @webminattrs; foreach my $attr (keys %$user) { next if ($attr eq "name" || $attr eq "pass" || $attr eq "modules"); my $value = $user->{$attr}; if ($attr eq "olds" || $attr eq "ownmods") { $value = $value ? join(" ", @$value) : ""; } push(@webminattrs, defined($value) ? $attr."=".$value : $attr); } if (@webminattrs) { push(@attrs, "webminAttr", \@webminattrs); } if ($user->{'modules'} && @{$user->{'modules'}}) { push(@attrs, "webminModule", $user->{'modules'}); } my $rv = $dbh->add($dn, attr => \@attrs); if (!$rv || $rv->code) { &error("Failed to add user to LDAP : ". ($rv ? $rv->error : "Unknown error")); } $user->{'id'} = $dn; $user->{'proto'} = 'ldap'; } &disconnect_userdb($miniserv{'userdb'}, $dbh); $user->{'proto'} = $proto; } else { # Adding to local files &lock_file($ENV{'MINISERV_CONFIG'}); if ($user->{'theme'}) { $miniserv{"preroot_".$user->{'name'}} = $user->{'theme'}.($user->{'overlay'} ? " ".$user->{'overlay'} : ""); } elsif (defined($user->{'theme'})) { $miniserv{"preroot_".$user->{'name'}} = ""; } if (defined($user->{'logouttime'})) { my @logout = split(/\s+/, $miniserv{'logouttimes'}); push(@logout, "$user->{'name'}=$user->{'logouttime'}"); $miniserv{'logouttimes'} = join(" ", @logout); } &put_miniserv_config(\%miniserv); &unlock_file($ENV{'MINISERV_CONFIG'}); my @times; push(@times, "days", $user->{'days'}) if (defined($user->{'days'}) && $user->{'days'} ne ''); push(@times, "hours", $user->{'hoursfrom'}."-".$user->{'hoursto'}) if ($user->{'hoursfrom'}); &lock_file($miniserv{'userfile'}); my $fh = "PWFILE"; &open_tempfile($fh, ">>$miniserv{'userfile'}"); my $allow = $user->{'allow'} || ""; $allow =~ s/:/;/g; my $deny = $user->{'deny'} || ""; $deny =~ s/:/;/g; &print_tempfile($fh, $user->{'name'},":", $user->{'pass'},":", ($user->{'sync'} || ""),":", ($user->{'cert'} || ""),":", ($allow ? "allow $allow" : $deny ? "deny $deny" : ""),":", join(" ", @times),":", ($user->{'lastchange'} || ""),":", join(" ", @{$user->{'olds'} || []}),":", ($user->{'minsize'} || ""),":", ($user->{'nochange'} || ""),":", ($user->{'temppass'} || ""),":", ($user->{'twofactor_provider'} || ""),":", ($user->{'twofactor_id'} || ""),":", ($user->{'twofactor_apikey'} || ""),":", ($user->{'email'} || ""), "\n"); &close_tempfile($fh); &unlock_file($miniserv{'userfile'}); &lock_file(&acl_filename()); $fh = "ACL"; &open_tempfile($fh, ">>".&acl_filename()); &print_tempfile($fh, &acl_line($user, \@mods)); &close_tempfile($fh); &unlock_file(&acl_filename()); delete($gconfig{"lang_".$user->{'name'}}); $gconfig{"lang_".$user->{'name'}} = $user->{'lang'} if ($user->{'lang'}); delete($gconfig{"notabs_".$user->{'name'}}); $gconfig{"notabs_".$user->{'name'}} = $user->{'notabs'} if ($user->{'notabs'}); delete($gconfig{"ownmods_".$user->{'name'}}); $gconfig{"ownmods_".$user->{'name'}} = join(" ", @{$user->{'ownmods'}}) if ($user->{'ownmods'} && @{$user->{'ownmods'}}); delete($gconfig{"theme_".$user->{'name'}}); if ($user->{'theme'}) { $gconfig{"theme_".$user->{'name'}} = $user->{'theme'}.($user->{'overlay'} ? " ".$user->{'overlay'} : ""); } elsif (defined($user->{'theme'})) { $gconfig{"theme_".$user->{'name'}} = ''; } $gconfig{"readonly_".$user->{'name'}} = $user->{'readonly'} if (defined($user->{'readonly'})); $gconfig{"realname_".$user->{'name'}} = $user->{'real'} if (defined($user->{'real'})); &write_file("$config_directory/config", \%gconfig); } # Copy ACLs from user being cloned if ($clone) { ©_acl_files($clone, $user->{'name'}, [ "", @mods ]); } } =head2 modify_user(old-name, &details) Updates an existing Webmin user, identified by the old-name parameter. The details hash must be in the same format as returned by list_users or passed to create_user. =cut sub modify_user { my ($username, $user) = @_; my (%miniserv, @pwfile, @acl, @mods, $m); &get_miniserv_config(\%miniserv); $user->{'name'} eq "webmin" && &error("Invalid username webmin for modified user"); if ($user->{'proto'}) { # In users and groups DB my ($dbh, $proto) = &connect_userdb($miniserv{'userdb'}); &error("Failed to connect to user database : $dbh") if (!ref($dbh)); if ($proto eq "mysql" || $proto eq "postgresql") { # Get old password, for change detection my $cmd = $dbh->prepare( "select pass from webmin_user where id = ?"); $cmd && $cmd->execute($user->{'id'}) || &error("Failed to get old password : ".$dbh->errstr); my ($oldpass) = $cmd->fetchrow(); $cmd->finish(); &add_old_password($user, $oldpass, \%miniserv); # Update primary details $cmd = $dbh->prepare("update webmin_user set name = ?, ". "pass = ? where id = ?"); $cmd && $cmd->execute($user->{'name'}, $user->{'pass'}, $user->{'id'}) || &error("Failed to update user : ".$dbh->errstr); $cmd->finish(); # Re-save attributes $cmd = $dbh->prepare("delete from webmin_user_attr ". "where id = ?"); $cmd && $cmd->execute($user->{'id'}) || &error("Failed to delete attrs : ".$dbh->errstr); $cmd = $dbh->prepare("insert into webmin_user_attr ". "(id,attr,value) values (?, ?, ?)"); foreach my $attr (keys %$user) { next if ($attr eq "name" || $attr eq "pass"); my $value = $user->{$attr}; if ($attr eq "olds" || $attr eq "modules" || $attr eq "ownmods") { $value = $value ? join(" ", @$value) : ""; } $cmd->execute($user->{'id'}, $attr, $value) || &error("Failed to add user attribute : ". $dbh->errstr); $cmd->finish(); } } elsif ($proto eq "ldap") { # Rename in LDAP if needed if ($user->{'name'} ne $username) { my $newdn = $user->{'id'}; $newdn =~ s/^cn=\Q$username\E,/cn=$user->{'name'},/; my $rv = $dbh->moddn($user->{'id'}, newrdn => "cn=$user->{'name'}"); if (!$rv || $rv->code) { &error("Failed to rename user : ". ($rv ? $rv->error : "Unknown error")); } $user->{'id'} = $newdn; } # Re-save all the attributes my @attrs = ( "cn", $user->{'name'}, "webminPass", $user->{'pass'} ); my @webminattrs; foreach my $attr (keys %$user) { next if ($attr eq "name" || $attr eq "desc" || $attr eq "modules"); my $value = $user->{$attr}; if ($attr eq "olds" || $attr eq "ownmods") { $value = $value ? join(" ", @$value) : ""; } push(@webminattrs, defined($value) ? $attr."=".$value : $attr); } push(@attrs, "webminAttr", \@webminattrs); push(@attrs, "webminModule", $user->{'modules'}); my $rv = $dbh->modify($user->{'id'}, replace => { @attrs }); if (!$rv || $rv->code) { &error("Failed to modify user : ". ($rv ? $rv->error : "Unknown error")); } } &disconnect_userdb($miniserv{'userdb'}, $dbh); } else { # In local files &lock_file($ENV{'MINISERV_CONFIG'}); delete($miniserv{"preroot_".$username}); if ($user->{'theme'}) { $miniserv{"preroot_".$user->{'name'}} = $user->{'theme'}.($user->{'overlay'} ? " ".$user->{'overlay'} : ""); } elsif (defined($user->{'theme'})) { $miniserv{"preroot_".$user->{'name'}} = ""; } my @logout = split(/\s+/, $miniserv{'logouttimes'} || ""); @logout = grep { !/^$username=/ } @logout; if (defined($user->{'logouttime'})) { push(@logout, "$user->{'name'}=$user->{'logouttime'}"); } $miniserv{'logouttimes'} = join(" ", @logout); &put_miniserv_config(\%miniserv); &unlock_file($ENV{'MINISERV_CONFIG'}); my @times; push(@times, "days", $user->{'days'}) if ($user->{'days'} && $user->{'days'} ne ''); push(@times, "hours", $user->{'hoursfrom'}."-".$user->{'hoursto'}) if ($user->{'hoursfrom'}); &lock_file($miniserv{'userfile'}); my $fh = "PWFILE"; &open_readfile($fh, $miniserv{'userfile'}); @pwfile = <$fh>; close($fh); &open_tempfile($fh, ">$miniserv{'userfile'}"); my $allow = $user->{'allow'}; $allow =~ s/:/;/g if ($allow); my $deny = $user->{'deny'}; $deny =~ s/:/;/g if ($deny); foreach my $l (@pwfile) { if ($l =~ /^([^:]+):([^:\r\n]*)/ && $1 eq $username) { &add_old_password($user, "$2", \%miniserv); &print_tempfile($fh, $user->{'name'},":", $user->{'pass'},":", ($user->{'sync'} || ""),":", ($user->{'cert'} || ""),":", ($allow ? "allow $allow" : $deny ? "deny $deny" : ""),":", join(" ", @times),":", $user->{'lastchange'},":", join(" ", @{$user->{'olds'} || []}),":", $user->{'minsize'},":", $user->{'nochange'},":", $user->{'temppass'},":", $user->{'twofactor_provider'},":", $user->{'twofactor_id'},":", $user->{'twofactor_apikey'},":", $user->{'email'}, "\n"); } else { &print_tempfile($fh, $l); } } &close_tempfile($fh); &unlock_file($miniserv{'userfile'}); &lock_file(&acl_filename()); @mods = &list_modules(); $fh = "ACL"; &open_readfile($fh, &acl_filename()); @acl = <$fh>; close($fh); &open_tempfile($fh, ">".&acl_filename()); foreach my $l (@acl) { if ($l =~ /^(\S+):/ && $1 eq $username) { &print_tempfile($fh, &acl_line($user, \@mods)); } else { &print_tempfile($fh, $l); } } &close_tempfile($fh); &unlock_file(&acl_filename()); delete($gconfig{"lang_".$username}); $gconfig{"lang_".$user->{'name'}} = $user->{'lang'} if ($user->{'lang'}); delete($gconfig{"langauto_".$username}); $gconfig{"langauto_".$user->{'name'}} = $user->{'langauto'} if (defined($user->{'langauto'})); delete($gconfig{"langneutral_".$username}); $gconfig{"langneutral_".$user->{'name'}} = $user->{'langneutral'} if (defined($user->{'langneutral'})); delete($gconfig{"locale_".$username}); $gconfig{"locale_".$user->{'name'}} = $user->{'locale'} if (defined($user->{'locale'})); delete($gconfig{"dateformat_".$username}); $gconfig{"dateformat_".$user->{'name'}} = $user->{'dateformat'} if (defined($user->{'dateformat'})); delete($gconfig{"notabs_".$username}); $gconfig{"notabs_".$user->{'name'}} = $user->{'notabs'} if ($user->{'notabs'}); delete($gconfig{"ownmods_".$username}); $gconfig{"ownmods_".$user->{'name'}} = join(" ", @{$user->{'ownmods'}}) if ($user->{'ownmods'} && @{$user->{'ownmods'}}); delete($gconfig{"theme_".$username}); if ($user->{'theme'}) { $gconfig{"theme_".$user->{'name'}} = $user->{'theme'}.($user->{'overlay'} ? " ".$user->{'overlay'} : ""); } elsif (defined($user->{'theme'})) { $gconfig{"theme_".$user->{'name'}} = ''; } delete($gconfig{"readonly_".$username}); $gconfig{"readonly_".$user->{'name'}} = $user->{'readonly'} if (defined($user->{'readonly'})); delete($gconfig{"realname_".$username}); $gconfig{"realname_".$user->{'name'}} = $user->{'real'} if (defined($user->{'real'})); &write_file("$config_directory/config", \%gconfig); } if ($username ne $user->{'name'} && !$user->{'proto'}) { # Rename all .acl files if user renamed foreach my $m (@mods, "") { my $file = "$config_directory/$m/$username.acl"; if (-r $file) { &rename_file($file, "$config_directory/$m/$user->{'name'}.acl"); } } my $file = "$config_directory/$username.acl"; if (-r $file) { &rename_file($file, "$config_directory/$user->{'name'}.acl"); } } if ($miniserv{'session'} && $username ne $user->{'name'}) { # Modify all sessions for the renamed user &rename_session_user(\%miniserv, $username, $user->{'name'}); } } =head2 add_old_password(&user, oldpass, &miniserv) Internal function to update the olds list of old passwords for a user =cut sub add_old_password { my ($user, $oldpass, $miniserv) = @_; if ($oldpass ne $user->{'pass'} && "!".$oldpass ne $user->{'pass'} && $oldpass ne "!".$user->{'pass'} && $oldpass ne 'x' && $oldpass ne 'e' && $oldpass ne '*LK*') { # Password change detected .. update change time # and save the old one my $nolock = $oldpass; $nolock =~ s/^\!//; $user->{'olds'} ||= []; if (&indexof($nolock, @{$user->{'olds'}}) < 0) { unshift(@{$user->{'olds'}}, $nolock); if ($miniserv->{'pass_oldblock'}) { while(scalar(@{$user->{'olds'}}) > $miniserv->{'pass_oldblock'}) { pop(@{$user->{'olds'}}); } } $user->{'lastchange'} = time(); } } } =head2 delete_user(name) Deletes the named user, including all .acl files for detailed module access control settings. =cut sub delete_user { my ($username) = @_; my (@pwfile, @acl, %miniserv); &lock_file($ENV{'MINISERV_CONFIG'}); &get_miniserv_config(\%miniserv); delete($miniserv{"preroot_".$username}); my @logout = split(/\s+/, $miniserv{'logouttimes'}); @logout = grep { !/^$username=/ } @logout; $miniserv{'logouttimes'} = join(" ", @logout); &put_miniserv_config(\%miniserv); &unlock_file($ENV{'MINISERV_CONFIG'}); &lock_file($miniserv{'userfile'}); my $fh = "PWFILE"; &open_readfile($fh, $miniserv{'userfile'}); @pwfile = <$fh>; close($fh); &open_tempfile($fh, ">$miniserv{'userfile'}"); foreach my $l (@pwfile) { if ($l !~ /^([^:]+):/ || $1 ne $username) { &print_tempfile($fh, $l); } } &close_tempfile($fh); &unlock_file($miniserv{'userfile'}); &lock_file(&acl_filename()); $fh = "ACL"; &open_readfile($fh, &acl_filename()); @acl = <$fh>; close($fh); &open_tempfile($fh, ">".&acl_filename()); foreach my $l (@acl) { if ($l !~ /^([^:]+):/ || $1 ne $username) { &print_tempfile($fh, $l); } } &close_tempfile($fh); &unlock_file(&acl_filename()); delete($gconfig{"lang_".$username}); delete($gconfig{"notabs_".$username}); delete($gconfig{"ownmods_".$username}); delete($gconfig{"rbacdeny_".$username}); delete($gconfig{"theme_".$username}); delete($gconfig{"overlay_".$username}); delete($gconfig{"readonly_".$username}); delete($gconfig{"realname_".$username}); &write_file("$config_directory/config", \%gconfig); # Delete all module .acl files &unlink_file(map { "$config_directory/$_/$username.acl" } &list_modules()); &unlink_file("$config_directory/$username.acl"); if ($miniserv{'session'}) { # Delete all sessions for the deleted user &delete_session_user(\%miniserv, $username); } if ($miniserv{'userdb'}) { # Also delete from user database my ($dbh, $proto, $prefix, $args) =&connect_userdb($miniserv{'userdb'}); &error("Failed to connect to user database : $dbh") if (!ref($dbh)); if ($proto eq "mysql" || $proto eq "postgresql") { # Find the user with SQL query my $cmd = $dbh->prepare( "select id from webmin_user where name = ?"); $cmd && $cmd->execute($username) || &error("Failed to find user : ".$dbh->errstr); my ($id) = $cmd->fetchrow(); $cmd->finish(); if (defined($id)) { # Delete the user my $cmd = $dbh->prepare( "delete from webmin_user where id = ?"); $cmd && $cmd->execute($id) || &error("Failed to delete user : ".$dbh->errstr); $cmd->finish(); # Delete attributes $cmd = $dbh->prepare( "delete from webmin_user_attr where id = ?"); $cmd && $cmd->execute($id) || &error("Failed to delete user attrs : ". $dbh->errstr); $cmd->finish(); # Delete ACLs $cmd = $dbh->prepare( "delete from webmin_user_acl where id = ?"); $cmd && $cmd->execute($id) || &error("Failed to delete user acls : ". $dbh->errstr); $cmd->finish(); } } elsif ($proto eq "ldap") { # Find user with LDAP query my $rv = $dbh->search( base => $prefix, filter => '(&(cn='.$username.')(objectClass='. $args->{'userclass'}.'))', scope => 'sub'); if (!$rv || $rv->code) { &error("Failed to find user : ". ($rv ? $rv->error : "Unknown error")); } my ($user) = $rv->all_entries; if ($user) { # Delete sub-objects my $rv = $dbh->search( base => $user->dn(), filter => '(objectClass=*)', scope => 'sub'); if (!$rv || $rv->code) { &error("Failed to delete LDAP user : ". ($rv ? $rv->error : "Unknown error")); } foreach my $so ($rv->all_entries) { next if ($so->dn() eq $user->dn()); my $drv = $dbh->delete($so->dn()); if ($drv->code) { &error("Failed to delete LDAP ". "sub-object : ".$drv->error); } } # Delete the user from LDAP $rv = $dbh->delete($user->dn()); if (!$rv || $rv->code) { &error("Failed to delete LDAP user : ". ($rv ? $rv->error : "Unknown error")); } } } &disconnect_userdb($miniserv{'userdb'}, $dbh); } } =head2 create_group(&group, [clone]) Add a new webmin group, based on the details in the group hash. The required keys are : =item name - Unique name of the group =item modules - An array reference of module names =item members - An array reference of group member names. Sub-groups must have their names prefixed with an @. =cut sub create_group { my ($group, $clone) = @_; my %miniserv; &get_miniserv_config(\%miniserv); if ($miniserv{'userdb'} && !$miniserv{'userdb_addto'}) { # Adding to group database my ($dbh, $proto, $prefix, $args) =&connect_userdb($miniserv{'userdb'}); &error("Failed to connect to group database : $dbh") if (!ref($dbh)); if ($proto eq "mysql" || $proto eq "postgresql") { # Add group with SQL my $cmd = $dbh->prepare("insert into webmin_group (name,description) values (?, ?)"); $cmd && $cmd->execute($group->{'name'}, $group->{'desc'}) || &error("Failed to add group : ".$dbh->errstr); $cmd->finish(); $cmd = $dbh->prepare("select max(id) from webmin_group"); $cmd->execute(); my ($id) = $cmd->fetchrow(); $cmd->finish(); # Add other attributes $cmd = $dbh->prepare("insert into webmin_group_attr (id,attr,value) values (?, ?, ?)"); foreach my $attr (keys %$group) { next if ($attr eq "name" || $attr eq "desc"); my $value = $group->{$attr}; if ($attr eq "members" || $attr eq "modules" || $attr eq "ownmods") { $value = $value ? join(" ", @$value) : ""; } $cmd->execute($id, $attr, $value) || &error("Failed to add group attribute : ". $dbh->errstr); $cmd->finish(); } $_[0]->{'id'} = $id; $_[0]->{'proto'} = $proto; } elsif ($proto eq "ldap") { # Add group to LDAP my $dn = "cn=".$group->{'name'}.",".$prefix; my @attrs = ( "objectClass", $args->{'groupclass'}, "cn", $group->{'name'}, "webminDesc", $group->{'desc'} ); my @webminattrs; foreach my $attr (keys %$group) { next if ($attr eq "name" || $attr eq "desc" || $attr eq "modules"); my $value = $group->{$attr}; if ($attr eq "members" || $attr eq "ownmods") { $value = $value ? join(" ", @$value) : ""; } push(@webminattrs, $attr."=".$value); } if (@webminattrs) { push(@attrs, "webminAttr", \@webminattrs); } if ($group->{'modules'} && @{$group->{'modules'}}) { push(@attrs, "webminModule", $group->{'modules'}); } my $rv = $dbh->add($dn, attr => \@attrs); if (!$rv || $rv->code) { &error("Failed to add group to LDAP : ". ($rv ? $rv->error : "Unknown error")); } $_[0]->{'id'} = $dn; $_[0]->{'proto'} = 'ldap'; } &disconnect_userdb($miniserv{'userdb'}, $dbh); $group->{'proto'} = $proto; } else { # Adding to local files &lock_file("$config_directory/webmin.groups"); my $fh = "GROUP"; &open_tempfile($fh, ">>$config_directory/webmin.groups"); &print_tempfile($fh, &group_line($group),"\n"); close($fh); &unlock_file("$config_directory/webmin.groups"); } if ($clone) { # Clone ACLs from original group ©_acl_files($clone, $group->{'name'}, [ "", &list_modules() ], "group", "group"); } } =head2 modify_group(old-name, &group) Update a webmin group, identified by the name parameter. The group's new details are in the group hash ref, which must be in the same format as returned by list_groups. =cut sub modify_group { my ($groupname, $group) = @_; my %miniserv; &get_miniserv_config(\%miniserv); if ($group->{'proto'}) { # In users and groups DB my ($dbh, $proto) = &connect_userdb($miniserv{'userdb'}); &error("Failed to connect to group database : $dbh") if (!ref($dbh)); if ($proto eq "mysql" || $proto eq "postgresql") { # Update primary details my $cmd = $dbh->prepare("update webmin_group set name = ?, ". "description = ? where id = ?"); $cmd && $cmd->execute($group->{'name'}, $group->{'desc'}, $group->{'id'}) || &error("Failed to update group : ".$dbh->errstr); $cmd->finish(); # Re-save attributes $cmd = $dbh->prepare("delete from webmin_group_attr ". "where id = ?"); $cmd && $cmd->execute($group->{'id'}) || &error("Failed to delete attrs : ".$dbh->errstr); $cmd = $dbh->prepare("insert into webmin_group_attr ". "(id,attr,value) values (?, ?, ?)"); foreach my $attr (keys %$group) { next if ($attr eq "name" || $attr eq "desc"); my $value = $group->{$attr}; if ($attr eq "members" || $attr eq "modules" || $attr eq "ownmods") { $value = $value ? join(" ", @$value) : ""; } $cmd->execute($group->{'id'}, $attr, $value) || &error("Failed to add group attribute : ". $dbh->errstr); $cmd->finish(); } } elsif ($proto eq "ldap") { # Rename in LDAP if needed if ($group->{'name'} ne $groupname) { my $newdn = $group->{'id'}; $newdn =~ s/^cn=\Q$groupname\E,/cn=$group->{'name'},/; my $rv = $dbh->moddn($group->{'id'}, newrdn => "cn=$group->{'name'}"); if (!$rv || $rv->code) { &error("Failed to rename group : ". ($rv ? $rv->error : "Unknown error")); } $group->{'id'} = $newdn; } # Re-save all the attributes my @attrs = ( "cn", $group->{'name'}, "webminDesc", $group->{'desc'} ); my @webminattrs; foreach my $attr (keys %$group) { next if ($attr eq "name" || $attr eq "desc" || $attr eq "modules"); my $value = $group->{$attr}; if ($attr eq "members" || $attr eq "ownmods") { $value = $value ? join(" ", @$value) : ""; } push(@webminattrs, $attr."=".$value); } push(@attrs, "webminAttr", \@webminattrs); push(@attrs, "webminModule", $group->{'modules'}); my $rv = $dbh->modify($group->{'id'}, replace => { @attrs }); if (!$rv || $rv->code) { &error("Failed to modify group : ". ($rv ? $rv->error : "Unknown error")); } } &disconnect_userdb($miniserv{'userdb'}, $dbh); } else { # Update local file &lock_file("$config_directory/webmin.groups"); my $lref = &read_file_lines("$config_directory/webmin.groups"); foreach my $l (@$lref) { if ($l =~ /^([^:]+):/ && $1 eq $groupname) { $l = &group_line($group); } } &flush_file_lines("$config_directory/webmin.groups"); &unlock_file("$config_directory/webmin.groups"); } if ($groupname ne $group->{'name'} && !$group->{'proto'}) { # Rename all .gacl files if group renamed foreach my $m (@{$group->{'modules'}}, "") { my $file = "$config_directory/$m/$groupname.gacl"; if (-r $file) { &rename_file($file, "$config_directory/$m/$group->{'name'}.gacl"); } } } } =head2 delete_group(name) Delete a webmin group, identified by the name parameter. =cut sub delete_group { my ($groupname) = @_; my %miniserv; &get_miniserv_config(\%miniserv); # Delete from local files &lock_file("$config_directory/webmin.groups"); my $lref = &read_file_lines("$config_directory/webmin.groups"); @$lref = grep { !/^([^:]+):/ || $1 ne $groupname } @$lref; &flush_file_lines(); &unlock_file("$config_directory/webmin.groups"); &unlink_file(map { "$config_directory/$_/$groupname.gacl" } &list_modules()); if ($miniserv{'userdb'}) { # Also delete from group database my ($dbh, $proto, $prefix, $args) =&connect_userdb($miniserv{'userdb'}); &error("Failed to connect to group database : $dbh") if (!ref($dbh)); if ($proto eq "mysql" || $proto eq "postgresql") { # Find the group with SQL query my $cmd = $dbh->prepare( "select id from webmin_group where name = ?"); $cmd && $cmd->execute($groupname) || &error("Failed to find group : ".$dbh->errstr); my ($id) = $cmd->fetchrow(); $cmd->finish(); if (defined($id)) { # Delete the group my $cmd = $dbh->prepare( "delete from webmin_group where id = ?"); $cmd && $cmd->execute($id) || &error("Failed to delete group : ".$dbh->errstr); $cmd->finish(); # Delete attributes $cmd = $dbh->prepare( "delete from webmin_group_attr where id = ?"); $cmd && $cmd->execute($id) || &error("Failed to delete group attrs : ". $dbh->errstr); $cmd->finish(); # Delete ACLs $cmd = $dbh->prepare( "delete from webmin_group_acl where id = ?"); $cmd && $cmd->execute($id) || &error("Failed to delete group acls : ". $dbh->errstr); $cmd->finish(); } } elsif ($proto eq "ldap") { # Find group with LDAP query my $rv = $dbh->search( base => $prefix, filter => '(&(cn='.$groupname.')(objectClass='. $args->{'groupclass'}.'))', scope => 'sub'); if (!$rv || $rv->code) { &error("Failed to find group : ". ($rv ? $rv->error : "Unknown error")); } my ($group) = $rv->all_entries; if ($group) { # Delete sub-objects my $rv = $dbh->search( base => $group->dn(), filter => '(objectClass=*)', scope => 'sub'); if (!$rv || $rv->code) { &error("Failed to delete LDAP group : ". ($rv ? $rv->error : "Unknown error")); } foreach my $so ($rv->all_entries) { next if ($so->dn() eq $group->dn()); my $drv = $dbh->delete($so->dn()); if ($drv->code) { &error("Failed to delete LDAP ". "sub-object : ".$drv->error); } } # Delete the group from LDAP $rv = $dbh->delete($group->dn()); if (!$rv || $rv->code) { &error("Failed to delete LDAP group : ". ($rv ? $rv->error : "Unknown error")); } } } &disconnect_userdb($miniserv{'userdb'}, $dbh); } } =head2 group_line(&group) Internal function to generate a group file line =cut sub group_line { my ($group) = @_; return join(":", $group->{'name'}, join(" ", @{$group->{'members'} || []}), join(" ", @{$group->{'modules'} || []}), $group->{'desc'}, join(" ", @{$group->{'ownmods'} || []}) ); } =head2 acl_line(&user, &allmodules) Internal function to generate an ACL file line. =cut sub acl_line { my ($user) = @_; return "$user->{'name'}: ".join(' ', @{$user->{'modules'} || []})."\n"; } =head2 can_edit_user(user, [&groups]) Returns 1 if the current Webmin user can edit some other user. =cut sub can_edit_user { my ($username, $groups) = @_; return 1 if ($access{'users'} eq '*'); if ($access{'users'} eq '~') { return $base_remote_user eq $username; } my $glist = $groups || [ &list_groups() ]; foreach my $u (split(/\s+/, $access{'users'})) { if ($u =~ /^_(\S+)$/) { foreach my $g (@$glist) { return 1 if ($g->{'name'} eq $1 && &indexof($username, @{$g->{'members'}}) >= 0); } } else { return 1 if ($u eq $username); } } return 0; } =head2 can_module_acl(&mod) Returns 1 if the given module has ability to manage its own ACLs. =cut sub can_module_acl { my ($mod) = @_; my $mdir = &module_root_directory($mod); return 1 if (-f "$mdir/acl_security.pl" || -f "$mdir/config.info"); return 0; } =head2 open_session_db(\%miniserv) Opens the session database, and ties it to the sessiondb hash. Parameters are : =item miniserv - The Webmin miniserv.conf file as a hash ref, as supplied by get_miniserv_config =cut sub open_session_db { my ($miniserv) = @_; my $sfile = $miniserv->{'sessiondb'} ? $miniserv->{'sessiondb'} : $miniserv->{'pidfile'} =~ /^(.*)\/[^\/]+$/ ? "$1/sessiondb" : return; &load_session_hmac_key($miniserv); eval { require SDBM_File; SDBM_File->import; 1 }; dbmopen(%sessiondb, $sfile, 0700); eval { $sessiondb{'1111111111'} = 'foo bar' }; if ($@) { dbmclose(%sessiondb); eval { require NDBM_File; NDBM_File->import; 1 }; dbmopen(%sessiondb, $sfile, 0700); } else { delete($sessiondb{'1111111111'}); } } =head2 load_session_hmac_key(\%miniserv) Loads miniserv's existing session HMAC key, if present. =cut sub load_session_hmac_key { my ($miniserv) = @_; return if (!$use_hmac_sha256); if (!$miniserv) { $miniserv = { }; &get_miniserv_config($miniserv); } my $kf = $miniserv->{'session_keyfile'}; if (!$kf && $miniserv->{'pidfile'} =~ /^(.*)\/[^\/]+$/) { $kf = "$1/session.key"; } return if (!$kf); return if (defined($loaded_session_keyfile) && $loaded_session_keyfile eq $kf); $loaded_session_keyfile = $kf; $session_hmac_key = undef; if (open(my $fh, "<", $kf)) { binmode($fh); local $/; $session_hmac_key = <$fh>; close($fh); } undef(%hash_session_id_cache); } =head2 delete_session_id(\%miniserv, id) Deletes one session from the database. Parameters are : =item miniserv - The Webmin miniserv.conf file as a hash ref, as supplied by get_miniserv_config. =item id - ID of the session to remove. =cut sub delete_session_id { my ($miniserv, $sid) = @_; return 1 if (&is_readonly_mode()); &open_session_db($miniserv); my $ex = exists($sessiondb{$sid}); delete($sessiondb{$sid}); dbmclose(%sessiondb); return $ex; } =head2 delete_session_user(\%miniserv, user) Deletes all sessions for some user. Parameters are : =item miniserv - The Webmin miniserv.conf file as a hash ref, as supplied by get_miniserv_config. =item user - Name of the user whose sessions get removed. =cut sub delete_session_user { my ($miniserv, $username) = @_; return 1 if (&is_readonly_mode()); &open_session_db($miniserv); foreach my $s (keys %sessiondb) { if ($sessiondb{$s}) { my ($u, $t) = split(/\s+/, $sessiondb{$s}); if ($u eq $username) { delete($sessiondb{$s}); } } } dbmclose(%sessiondb); } =head2 rename_session_user(\%miniserv, olduser, newuser) Changes the username in all sessions for some user. Parameters are : =item miniserv - The Webmin miniserv.conf file as a hash ref, as supplied by get_miniserv_config. =item olduser - The original username. =item newuser - The new username. =cut sub rename_session_user { my ($miniserv, $oldusername, $newusername) = @_; return 1 if (&is_readonly_mode()); &open_session_db($miniserv); foreach my $s (keys %sessiondb) { my ($u, $t) = split(/\s+/, $sessiondb{$s}); if ($u eq $oldusername) { $sessiondb{$s} = "$newusername $t"; } } dbmclose(%sessiondb); } =head2 create_session_user(\%miniserv, user, [lifetime]) Creates a new session ID that's already logged in as the given user =cut sub create_session_user { my ($miniserv, $username, $lifetime) = @_; return if (&is_readonly_mode()); &open_session_db($miniserv); my $sid = &generate_random_session_id(); return if (!$sid); my $t = time(); $sessiondb{$sid} = "$username $t 127.0.0.1".($lifetime ? " ".$lifetime : ""); dbmclose(%sessiondb); return $sid; } =head2 set_module_access(&modules, enabled, [&users-groups]) Grants or revokes Webmin module access for users and groups. The modules parameter must be an array ref of module names. The enabled flag should be 1 to grant access, or 0 to revoke access. If the users-groups parameter is not given, all users and groups are updated. Otherwise, it must be an array ref of usernames and group names. Group names may be prefixed with @ to target only a group. Returns the number of directly updated user and group records. =cut sub set_module_access { my ($mods, $enabled, $usersgroups) = @_; $mods ||= []; return 0 if (!@$mods); my $set_module_access_list = sub { my ($obj, $key, $addmods) = @_; $addmods ||= $mods; my @old = @{$obj->{$key} || []}; my @new; if ($enabled) { @new = &unique(@old, @$addmods); } else { my %remove = map { $_, 1 } @$mods; @new = grep { !$remove{$_} } @old; } return 0 if (join("\0", @old) eq join("\0", @new)); $obj->{$key} = \@new; return 1; }; my $own_module_updates = sub { my ($obj, $inherited) = @_; return $mods if (!$enabled); return [] if (!@{$obj->{'ownmods'} || []} && !@$inherited); return [ grep { &indexof($_, @$inherited) < 0 } @$mods ]; }; my @users = &list_users(); my @groups = &list_groups(); my $all = !defined($usersgroups); my (%target_user, %target_group); if (!$all) { foreach my $ug (@$usersgroups) { if ($ug =~ /^\@(.*)$/) { $target_group{$1} = 1; } else { $target_user{$ug} = 1; $target_group{$ug} = 1; } } } my $changed = 0; my (%user_group, %group_parent); foreach my $g (@groups) { foreach my $m (@{$g->{'members'} || []}) { if ($m =~ /^\@(.*)$/) { $group_parent{$1} = $g; } else { $user_group{$m} = $g; } } } my (@ordered_groups, %ordered_group, %ordering_group); my $add_ordered_group; $add_ordered_group = sub { my ($g) = @_; return if (!$g || $ordered_group{$g->{'name'}}); return if ($ordering_group{$g->{'name'}}++); $add_ordered_group->($group_parent{$g->{'name'}}); delete($ordering_group{$g->{'name'}}); push(@ordered_groups, $g); $ordered_group{$g->{'name'}}++; }; foreach my $g (@groups) { $add_ordered_group->($g); } # Update groups first, so member users and sub-groups inherit the new set foreach my $g (@ordered_groups) { next if (!$all && !$target_group{$g->{'name'}}); my $gchanged = 0; my $parent = $group_parent{$g->{'name'}}; my $ownmods = $own_module_updates->( $g, [ @{$parent ? $parent->{'modules'} || [] : []} ]); $gchanged += $set_module_access_list->($g, "modules"); $gchanged += $set_module_access_list->($g, "ownmods", $ownmods); if ($gchanged) { &modify_group($g->{'name'}, $g); &update_members(\@users, \@groups, $g->{'modules'}, $g->{'members'}); $changed++; } } # Update directly targeted users foreach my $u (@users) { next if (!$all && !$target_user{$u->{'name'}}); my $uchanged = 0; my $group = $user_group{$u->{'name'}}; my $ownmods = $own_module_updates->( $u, [ @{$group ? $group->{'modules'} || [] : []} ]); $uchanged += $set_module_access_list->($u, "modules"); $uchanged += $set_module_access_list->($u, "ownmods", $ownmods); if ($uchanged) { &modify_user($u->{'name'}, $u); $changed++; } } if ($changed) { undef(%main::acl_hash_cache); undef(%main::acl_array_cache); } return $changed; } =head2 enable_module_access(&modules, [&users-groups]) Grants users and groups access to one or more modules. This is a wrapper around set_module_access. =cut sub enable_module_access { return &set_module_access($_[0], 1, $_[1]); } =head2 disable_module_access(&modules, [&users-groups]) Revokes users and groups access to one or more modules. This is a wrapper around set_module_access. =cut sub disable_module_access { return &set_module_access($_[0], 0, $_[1]); } =head2 update_members(&allusers, &allgroups, &modules, &members) Update the modules for members users and groups of some group. The parameters are : =item allusers - An array ref of all Webmin users, as returned by list_users. =item allgroups - An array ref of all Webmin groups. =item modules - Modules to assign to members. =item members - An array ref of member user and group names. =cut sub update_members { my ($allusers, $allgroups, $mods, $mems) = @_; foreach my $m (@$mems) { if ($m !~ /^\@(.*)$/) { # Member is a user my ($u) = grep { $_->{'name'} eq $m } @$allusers; if ($u) { $u->{'modules'} = [ @$mods, @{$u->{'ownmods'} || []} ]; &modify_user($u->{'name'}, $u); } } else { # Member is a group my $gname = substr($m, 1); my ($g) = grep { $_->{'name'} eq $gname } @$allgroups; if ($g) { $g->{'modules'} = [ @$mods, @{$g->{'ownmods'} || []} ]; &modify_group($g->{'name'}, $g); &update_members($allusers, $allgroups, $g->{'modules'}, $g->{'members'}); } } } } =head2 copy_acl_files(from, to, &modules, [from-type], [to-type]) Copy all .acl files from some user to another user in a list of modules. The parameters are : =item from - Source user or group name. =item to - Destination user or group name. =item modules - Array ref of module names. =item from-type - Either "user" or "group", defaults to "user" =item to-type - Either "user" or "group", defaults to "user" =cut sub copy_acl_files { my ($from, $to, $mods, $fromtype, $totype) = @_; $fromtype ||= "user"; $totype ||= "user"; my ($dbh, $proto, $fromid, $toid); # Check if the source user/group is in a DB my $userdb = &get_userdb_string(); if ($userdb) { my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb); &error($dbh) if (!ref($dbh)); if ($proto eq "mysql" || $proto eq "postgresql") { # Search in SQL DB my $cmd = $dbh->prepare( "select id from webmin_${fromtype} where name = ?"); $cmd && $cmd->execute($from) || &error($dbh->errstr); ($fromid) = $cmd->fetchrow(); $cmd->finish(); $cmd = $dbh->prepare( "select id from webmin_${totype} where name = ?"); $cmd && $cmd->execute($to) || &error($dbh->errstr); ($toid) = $cmd->fetchrow(); $cmd->finish(); } elsif ($proto eq "ldap") { # Search in LDAP my $fromclass = $fromtype eq "user" ? $args->{'userclass'} : $args->{'groupclass'}; my $rv = $dbh->search( base => $prefix, filter => '(&(cn='.$from.')(objectClass='. $fromclass.'))', scope => 'sub'); $rv->code && &error($rv->error); my ($fromobj) = $rv->all_entries; $fromid = $fromobj ? $fromobj->dn() : undef; my $toclass = $totype eq "user" ? $args->{'userclass'} : $args->{'groupclass'}; $rv = $dbh->search( base => $prefix, filter => '(&(cn='.$to.')(objectClass='. $toclass.'))', scope => 'sub'); $rv->code && &error($rv->error); my ($toobj) = $rv->all_entries; $toid = $toobj ? $toobj->dn() : undef; } } if (defined($fromid) && defined($toid) && ($proto eq "mysql" || $proto eq "postgresql")) { # Copy from database to database my $delcmd = $dbh->prepare("delete from webmin_${totype}_acl where id = ? and module = ?"); my $cmd = $dbh->prepare("insert into webmin_${totype}_acl select ?,module,attr,value from webmin_${fromtype}_acl where id = ? and module = ?"); foreach my $m (@$mods) { $delcmd && $delcmd->execute($toid, $m) || &error("Failed to clear ACLs : ".$dbh->errstr); $delcmd->finish(); $cmd && $cmd->execute($toid, $fromid, $m) || &error("Failed to copy ACLs : ".$dbh->errstr); $cmd->finish(); } } elsif (!defined($fromid) && !defined($toid)) { # Copy files my $fromsuffix = $fromtype eq "user" ? "acl" : "gacl"; my $tosuffix = $totype eq "user" ? "acl" : "gacl"; foreach my $m (@$mods) { &unlink_file("$config_directory/$m/$to.$tosuffix"); my %acl; if (&read_file("$config_directory/$m/$from.$fromsuffix", \%acl)) { &write_file("$config_directory/$m/$to.$tosuffix", \%acl); } } } else { # Source and dest use different storage types foreach my $m (@$mods) { my %caccess; if ($fromtype eq "user") { %caccess = &get_module_acl($from, $m, 1, 1); } else { %caccess = &get_group_module_acl($from, $m, 1); } if (%caccess) { if ($totype eq "user") { &save_module_acl(\%caccess, $to, $m, 1); } else { &save_group_module_acl(\%caccess, $to, $m, 1); } } } } if ($dbh) { &disconnect_userdb($userdb, $dbh); } } =head2 copy_group_acl_files(from, to, &modules) Copy all .gacl files from some group to another in a list of modules. Parameters are : =item from - Source group name. =item to - Destination group name. =item modules - Array ref of module names. =cut sub copy_group_acl_files { my ($from, $to, $mods) = @_; ©_acl_files($from, $to, $mods, "group", "group"); } =head2 copy_group_user_acl_files(from, to, &modules) Copy all .acl files from some group to a user in a list of modules. Parameters are : =item from - Source group name. =item to - Destination user name. =item modules - Array ref of module names. =cut sub copy_group_user_acl_files { my ($from, $to, $mods) = @_; ©_acl_files($from, $to, $mods, "group", "user"); } =head2 set_acl_files(&allusers, &allgroups, module, &members, &access) Recursively update the ACL for all sub-users and groups of a group, by copying detailed access control settings from the group down to users. Parameters are : =item allusers - An array ref of Webmin users, as returned by list_users. =item allgroups - An array ref of Webmin groups. =item module - Name of the module to update ACL for. =item members - Names of group members. =item access - The module ACL hash ref to copy to users. =cut sub set_acl_files { my ($allusers, $allgroups, $mod, $members, $access) = @_; foreach my $m (@$members) { if ($m !~ /^\@(.*)$/) { # Member is a user my ($u) = grep { $_->{'name'} eq $m } @$allusers; if ($u) { my $aclfile = "$config_directory/$mod/$u->{'name'}.acl"; &lock_file($aclfile); &save_module_acl($access, $u->{'name'}, $mod, 1); chmod(0640, $aclfile) if (-r $aclfile); &unlock_file($aclfile); } } else { # Member is a group my $gname = substr($m, 1); my ($g) = grep { $_->{'name'} eq $gname } @$allgroups; if ($g) { my $aclfile = "$config_directory/$mod/$g->{'name'}.gacl"; &lock_file($aclfile); &save_group_module_acl($access, $g->{'name'}, $mod, 1); chmod(0640, $aclfile) if (-r $aclfile); &unlock_file($aclfile); &set_acl_files($allusers, $allgroups, $mod, $g->{'members'}, $access); } } } } =head2 get_ssleay Returns the path to the openssl command (or equivalent) on this system. =cut sub get_ssleay { if (&has_command($config{'ssleay'})) { return &has_command($config{'ssleay'}); } elsif (&has_command("openssl")) { return &has_command("openssl"); } elsif (&has_command("ssleay")) { return &has_command("ssleay"); } else { return; } } =head2 encrypt_password(password, [salt]) Encrypts and returns a Webmin user password. If the optional salt parameter is not given, a salt will be selected randomly. =cut sub encrypt_password { my ($pass, $salt) = @_; $salt ||= ""; my $mode = $salt =~ /^\$1\$/ ? 1 : $salt =~ /^\$6\$/ ? 2 : length($salt) == 13 ? 0 : $gconfig{'md5pass'}; if ($mode == 1) { # Use MD5 encryption return &encrypt_md5($pass, $salt); } elsif ($mode == 2) { # Use SHA512 encryption return &encrypt_sha512($pass, $salt); } else { # Try detecting system default first if (&foreign_installed('useradmin')) { &foreign_require('useradmin'); return &useradmin::encrypt_password($pass, $salt, 1); } else { # Use Unix DES &seed_random(); $salt ||= chr(int(rand(26))+65).chr(int(rand(26))+65); return &unix_crypt($pass, $salt); } } } =head2 get_unixauth(\%miniserv) Returns a list of Unix users/groups/all and the Webmin user that they authenticate as, as array references. =cut sub get_unixauth { my ($miniserv) = @_; my @rv; my @ua = $miniserv->{'unixauth'} ? split(/\s+/, $miniserv->{'unixauth'}) : ( ); foreach my $ua (@ua) { if ($ua =~ /^(\S+)=(\S+)$/) { push(@rv, [ $1, $2 ]); } else { push(@rv, [ "*", $ua ]); } } return @rv; } =head2 save_unixauth(\%miniserv, &authlist) Updates %miniserv with the given Unix auth list, which must be in the format returned by get_unixauth. =cut sub save_unixauth { my ($miniserv, $authlist) = @_; my @ua; foreach my $ua (@$authlist) { if ($ua->[0] ne "*") { push(@ua, "$ua->[0]=$ua->[1]"); } else { push(@ua, $ua->[1]); } } $miniserv->{'unixauth'} = join(" ", @ua); } =head2 delete_from_groups(user|@group) Removes the specified user from all groups. =cut sub delete_from_groups { my ($user) = @_; foreach my $g (&list_groups()) { my @mems = @{$g->{'members'} || []}; my $i = &indexof($user, @mems); if ($i >= 0) { splice(@mems, $i, 1); $g->{'members'} = \@mems; &modify_group($g->{'name'}, $g); } } } =head2 get_users_group(username) Returns the group a user is in, if any =cut sub get_users_group { my ($username) = @_; foreach my $g (&list_groups()) { my @mems = @{$g->{'members'} || []}; if (&indexof($username, @mems) >= 0) { return $g; } } return; } =head2 check_password_restrictions(username, password) Checks if some new password is valid for a user, and if not returns an error message. =cut sub check_password_restrictions { my ($name, $pass) = @_; my %miniserv; &get_miniserv_config(\%miniserv); my ($user) = grep { $_->{'name'} eq $name } &list_users(); my $minsize = $user ? $user->{'minsize'} : undef; $minsize ||= $miniserv{'pass_minsize'}; if (length($pass) < $minsize) { return &text('cpass_minsize', $minsize); } foreach my $re (split(/\t+/, $miniserv{'pass_regexps'})) { if ($re =~ /^\!(.*)$/) { $re = $1; $pass !~ /$re/ || return ($miniserv{'pass_regdesc'} || $text{'cpass_notre'}); } else { $pass =~ /$re/ || return ($miniserv{'pass_regdesc'} || $text{'cpass_re'}); } } if ($miniserv{'pass_nouser'}) { $pass =~ /\Q$name\E/i && return $text{'cpass_name'}; } if ($miniserv{'pass_nodict'}) { &is_dictionary_word($pass) && return $text{'cpass_dict'}; } if ($miniserv{'pass_oldblock'} && $user) { my $c = 0; foreach my $o (@{$user->{'olds'} || []}) { my $enc = &encrypt_password($pass, $o); $enc eq $o && return $text{'cpass_old'}; last if ($c++ > $miniserv{'pass_oldblock'}); } } return; } =head2 hash_session_id(sid) Returns a session DB key for a session ID. =cut sub hash_session_id { my ($sid) = @_; my $use_md5 = &md5_perl_module(); &load_session_hmac_key() if ($use_hmac_sha256 && !$loaded_session_keyfile); if (!$hash_session_id_cache{$sid}) { if ($use_hmac_sha256 && length($session_hmac_key) >= 16) { $hash_session_id_cache{$sid} = Digest::SHA::hmac_sha256_hex($sid, $session_hmac_key); } elsif ($use_md5) { # Take MD5 hash $hash_session_id_cache{$sid} = &hash_md5_session($sid); } else { # Unix crypt $hash_session_id_cache{$sid} = &unix_crypt($sid, "XX"); } } return $hash_session_id_cache{$sid}; } =head2 hash_md5_session(string) Returns a string encrypted in MD5 format. =cut sub hash_md5_session { my ($passwd) = @_; my $use_md5 = &md5_perl_module(); $use_md5 || &error("No Perl MD5 hashing module found!"); # Add the password my $ctx = $use_md5->new; $ctx->add($passwd); # Add some more stuff from the hash of the password and salt my $ctx1 = $use_md5->new; $ctx1->add($passwd); $ctx1->add($passwd); my $final = $ctx1->digest(); for(my $pl=length($passwd); $pl>0; $pl-=16) { $ctx->add($pl > 16 ? $final : substr($final, 0, $pl)); } # This piece of code seems rather pointless, but it's in the C code that # does MD5 in PAM so it has to go in! my $j = 0; my ($i, $l); for(my $i=length($passwd); $i; $i >>= 1) { if ($i & 1) { $ctx->add("\0"); } else { $ctx->add(substr($passwd, $j, 1)); } } $final = $ctx->digest(); # Convert the 16-byte final string into a readable form my $rv; my @final = map { ord($_) } split(//, $final); $l = ($final[ 0]<<16) + ($final[ 6]<<8) + $final[12]; $rv .= &to64($l, 4); $l = ($final[ 1]<<16) + ($final[ 7]<<8) + $final[13]; $rv .= &to64($l, 4); $l = ($final[ 2]<<16) + ($final[ 8]<<8) + $final[14]; $rv .= &to64($l, 4); $l = ($final[ 3]<<16) + ($final[ 9]<<8) + $final[15]; $rv .= &to64($l, 4); $l = ($final[ 4]<<16) + ($final[10]<<8) + $final[ 5]; $rv .= &to64($l, 4); $l = $final[11]; $rv .= &to64($l, 2); return $rv; } =head2 md5_perl_module Returns a Perl module for MD5 hashing, or undef if none. =cut sub md5_perl_module { my $use_md5; eval { require MD5; MD5->import; 1 }; if (!$@) { $use_md5 = "MD5"; } else { eval { require Digest::MD5; Digest::MD5->import; 1 }; if (!$@) { $use_md5 = "Digest::MD5"; } } return $use_md5; } =head2 session_db_key(sid) Returns the session DB key for some session ID. Assumes that open_session_db has already been called. =cut sub session_db_key { my ($sid) = @_; my $hash = &hash_session_id($sid); return $sessiondb{$hash} ? $hash : $sid; } =head2 setup_anonymous_access(path, module) Grants anonymous access to some path. By default, the user for other anonymous access will be used, or if there is none, a user named 'anonymous' will be created and granted access to the module. =cut sub setup_anonymous_access { my ($path, $mod) = @_; # Find out what users and paths we grant access to currently my $miniserv = { }; &get_miniserv_config($miniserv); my @anon = split(/\s+/, $miniserv->{'anonymous'} || ""); my ($user, $found) = &get_anonymous_access($path, $miniserv); return 1 if ($found >= 0); # Already setup my $auser = grep { $_->{'name'} eq $user } &list_users(); if (!$auser) { # Create a user if need be $user = "anonymous"; my $uinfo = { 'name' => $user, 'pass' => '*LK*', 'modules' => [ $mod ], }; &create_user($uinfo); } else { # Make sure the user has the module my ($uinfo) = grep { $_->{'name'} eq $user } &list_users(); if ($uinfo && &indexof($mod, @{$uinfo->{'modules'}}) < 0) { $uinfo->{'modules'} ||= []; push(@{$uinfo->{'modules'}}, $mod); &modify_user($uinfo->{'name'}, $uinfo); } else { print STDERR "Anonymous access attempted to be granted to user $user, but it doesn't exist!\n"; } } # Grant access to the user and path &lock_file(&get_miniserv_config_file()); push(@anon, "$path=$user"); $miniserv->{'anonymous'} = join(" ", @anon); &put_miniserv_config($miniserv); &unlock_file(&get_miniserv_config_file()); &reload_miniserv(); } =head2 remove_anonymous_access(path, module) Remove anon access to some path, taking it away from the anonymous user's modules if needed =cut sub remove_anonymous_access { my ($path, $mod) = @_; # Get current state my $miniserv = { }; &get_miniserv_config($miniserv); my @anon = split(/\s+/, $miniserv->{'anonymous'} || ""); my ($user, $found) = &get_anonymous_access($path, $miniserv); return if ($found < 0); # Already gone # Take out of miniserv &lock_file(&get_miniserv_config_file()); splice(@anon, $found, 1); $miniserv->{'anonymous'} = join(" ", @anon); &put_miniserv_config($miniserv); &unlock_file(&get_miniserv_config_file()); # Take away from the user my ($uinfo) = grep { $_->{'name'} eq $user } &list_users(); if ($uinfo) { my $m = &indexof($mod, @{$uinfo->{'modules'}}); if ($m >= 0) { splice(@{$uinfo->{'modules'}}, $m, 1); &modify_user($uinfo->{'name'}, $uinfo); } } &reload_miniserv(); } =head2 get_anonymous_access(path, [&miniserv]) Returns the anonymous username and index into the anon config if access is setup to some path =cut sub get_anonymous_access { my ($path, $miniserv) = @_; if (!$miniserv) { $miniserv = { }; &get_miniserv_config($miniserv); } my $found = -1; my $user; my @anon = split(/\s+/, $miniserv->{'anonymous'} || ""); for(my $i=0; $i<@anon; $i++) { my ($p, $u) = split(/=/, $anon[$i]); $found = $i if ($p eq $path); $user = $u; } return ($user, $found); } =head2 join_userdb_string(proto, user, pass, host, prefix, &args) Creates a string in the format accepted by split_userdb_string =cut sub join_userdb_string { my ($proto, $user, $pass, $host, $prefix, $args) = @_; return "" if (!$proto); my $argstr; if (keys %$args) { $argstr = "?".join("&", map { $_."=".$args->{$_} } (keys %$args)); } return $proto."://".$user.":".$pass."\@".$host."/".$prefix.$argstr; } =head2 validate_userdb(string, [no-table-check]) Checks if some user database is usable, and if not returns an error message =cut sub validate_userdb { my ($str, $notablecheck) = @_; my ($proto, $user, $pass, $host, $prefix, $args) = &split_userdb_string($str); if ($proto eq "mysql" || $proto eq "postgresql") { # Load DBI driver eval { require DBI; DBI->import; 1 }; return &text('sql_emod', 'DBI') if ($@); if ($proto eq "mysql") { eval { require DBD::mysql; DBD::mysql->import; 1 }; return &text('sql_emod', 'DBD::mysql') if ($@); my $drh = DBI->install_driver("mysql"); return $text{'sql_emysqldriver'} if (!$drh); } else { eval { require DBD::Pg; DBD::Pg->import; 1 }; return &text('sql_emod', 'DBD::Pg') if ($@); my $drh = DBI->install_driver("Pg"); return $text{'sql_epostgresqldriver'} if (!$drh); } # Connect to the database my $dbh = &connect_userdb($str); ref($dbh) || return $dbh; # Validate critical tables if (!$notablecheck) { my %tables = ( "webmin_user" => [ "id", "name", "pass" ], "webmin_group" => [ "id", "name", "description" ], "webmin_user_attr" => [ "id", "attr", "value" ], "webmin_group_attr" => [ "id", "attr", "value" ], "webmin_user_acl" => [ "id", "module", "attr", "value" ], "webmin_group_acl" => [ "id", "module", "attr", "value"], ); foreach my $t (keys %tables) { my @cols = @{$tables{$t}}; my $sql = "select ".join(",", @cols)." from $t limit 1"; my $cmd = $dbh->prepare($sql); if (!$cmd || !$cmd->execute()) { return &text('sql_etable', $t, &html_escape($dbh->errstr)); } $cmd->finish(); } } &disconnect_userdb($str, $dbh); return; } elsif ($proto eq "ldap") { # Load LDAP module eval { require Net::LDAP; Net::LDAP->import; 1 }; return &text('sql_emod', 'Net::LDAP') if ($@); # Try to connect my $dbh = &connect_userdb($str); ref($dbh) || return $dbh; # Check for Webmin object classes my $schema = $dbh->schema(); my @allocs = map { $_->{'name'} } $schema->all_objectclasses(); &indexof($args->{'userclass'}, @allocs) >= 0 || return &text('sql_eclass', $args->{'userclass'}); &indexof($args->{'groupclass'}, @allocs) >= 0 || return &text('sql_eclass', $args->{'groupclass'}); # Check that base DN exists if (!$notablecheck) { my $superprefix = $prefix; $superprefix =~ s/^[^,]+,//; # Make parent DN my $rv = $dbh->search(base => $superprefix, filter => '(objectClass=*)', scope => 'one'); my $niceprefix = lc($prefix); $niceprefix =~ s/\s//g; my $found = 0; foreach my $d ($rv->all_entries) { my $niced = lc($d->dn()); $niced =~ s/\s//g; $found++ if ($niced eq $niceprefix); } $found || return &text('sql_eldapdn', $prefix); } &disconnect_userdb($str, $dbh); return; } else { return "Unknown user database type $proto"; } } =head2 userdb_table_sql(string) Returns SQL statements needed to create all required tables. Mainly for internal use. =cut sub userdb_table_sql { my ($str) = @_; my ($key, $auto, $idattrkey); if ($str =~ /^mysql:/) { return ( "create table webmin_user ". "(id int(20) not null primary key auto_increment, ". "name varchar(255) not null, pass varchar(255))", "create table webmin_group ". "(id int(20) not null primary key auto_increment, ". "name varchar(255) not null, ". "description varchar(255))", "create table webmin_user_attr ". "(id int(20) not null, ". "attr varchar(255) not null, ". "value varchar(4096), ". "primary key(id, attr))", "create table webmin_group_attr ". "(id int(20) not null, ". "attr varchar(255) not null, ". "value varchar(4096), ". "primary key(id, attr))", "create table webmin_user_acl ". "(id int(20) not null, ". "module varchar(32) not null, ". "attr varchar(32) not null, ". "value varchar(255), ". "primary key(id, module, attr))", "create table webmin_group_acl ". "(id int(20) not null, ". "module varchar(32) not null, ". "attr varchar(32) not null, ". "value varchar(255), ". "primary key(id, module, attr))", ); } elsif ($str =~ /^postgresql:/) { return ( "create table webmin_user ". "(id serial not null primary key, ". "name varchar(255), ". "pass varchar(255))", "create table webmin_group ". "(id serial not null primary key, ". "name varchar(255), ". "description varchar(255))", "create table webmin_user_attr ". "(id int8 not null, ". "attr varchar(255) not null, ". "value varchar(4096), ". "primary key(id, attr))", "create table webmin_group_attr ". "(id int8 not null, ". "attr varchar(255) not null, ". "value varchar(4096), ". "primary key(id, attr))", "create table webmin_user_acl ". "(id int8 not null, ". "module varchar(255) not null, ". "attr varchar(255) not null, ". "value varchar(255), ". "primary key(id, module, attr))", "create table webmin_group_acl ". "(id int8 not null, ". "module varchar(255) not null, ". "attr varchar(255) not null, ". "value varchar(255), ". "primary key(id, module, attr))", ); } } # used_for_anonymous(username, [&miniserv]) # Returns a list of modules this user has an anonymous grant to sub used_for_anonymous { my ($user, $miniserv) = @_; my @rv; if (!$miniserv) { $miniserv = { }; &get_miniserv_config($miniserv); } foreach my $tok (split(/\s+/, $miniserv->{'anonymous'})) { if ($tok =~ /^([^=]+)=(\S+)$/ && $2 eq $user) { push(@rv, $1); } } return @rv; } # get_safe_acl(module) # Returns the safe ACL hash ref for a module, if there is one, or undef sub get_safe_acl { my ($m) = @_; my $mdir = &module_root_directory($m); my %rv; &read_file_cached("$mdir/safeacl", \%rv) || return; return \%rv; } =head2 generate_random_session_id() Returns a session ID in the same format as miniserv =cut sub generate_random_session_id { my $sid; # Try /dev/urandom, but with a timeout my $randomfh; $SIG{ALRM} = sub { close($randomfh) if ($randomfh) }; alarm(5); if (open($randomfh, "<", "/dev/urandom")) { my $tmpsid; if (read($randomfh, $tmpsid, 16) == 16) { $sid = lc(unpack('h*',$tmpsid)); if ($sid !~ /^[0-9a-fA-F]{32}$/) { $sid = 'bad'; } } close($randomfh); undef($randomfh); } alarm(0); # Fall back to perl random if (!$sid) { my $offset = int(rand(2048)); my @charset = ('0' ..'9', 'a' .. 'f'); $sid = join('', map { $charset[rand(@charset)] } 1 .. 4096); $sid = substr($sid, $offset, 32); } return $sid eq 'bad' ? undef : $sid; } # generate_random_id() # Generate an ID string that can be used for a password reset link sub generate_random_id { if (open(my $RANDOM, "<", "/dev/urandom")) { my $sid; my $tmpsid; if (read($RANDOM, $tmpsid, 16) == 16) { $sid = lc(unpack('h*',$tmpsid)); } close($RANDOM); return $sid; } # Explicit undef: callers consume this in hash-literal value position, # where bare 'return' would yield () and shift the surrounding pairing. return undef; ## no critic (ProhibitExplicitReturnUndef) } # obsfucate_email(email) # Convert an email like foo@bar.com to f**@b**.com sub obsfucate_email { my ($email) = @_; my ($mailbox, $dom) = split(/\@/, $email); $mailbox = substr($mailbox, 0, 1) . ("*" x (length($mailbox)-1)); my @doms; foreach my $d (split(/\./, $dom)) { push(@doms, substr($d, 0, 1) . ("*" x (length($d)-1))); } return $mailbox."\@".join(".", @doms); } 1;
Save File
Cancel