#----------------------------------------------------------------------
# Copyright 1999-2003 Mitel Networks Corporation
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#----------------------------------------------------------------------

package esmith::util;

use strict;

use Text::Template 'fill_in_file';
use POSIX qw (setsid);
use Errno;
use Carp;
use esmith::config;
use esmith::db;
use esmith::DB;
use esmith::ConfigDB;
use Net::IPv4Addr qw(:all);
use Taint::Util;
use File::Basename;
use File::stat;
use FileHandle;
use Data::UUID;
=pod

=head1 NAME

esmith::util - Utilities for e-smith server and gateway development

=head1 VERSION

This file documents C<esmith::util> version B<1.4.0>

=head1 SYNOPSIS

    use esmith::util;

=head1 DESCRIPTION

This module provides general utilities of use to developers of the
e-smith server and gateway.

=head1 GENERAL UTILITIES

=head2 setRealToEffective()

Sets the real UID to the effective UID and the real GID to the effective
GID.

=begin testing

use_ok('esmith::util');

=end testing

=cut

sub setRealToEffective ()
{
    $< = $>;
    $( = $);
}

=pod

=head2 processTemplate({ CONFREF => $conf, TEMPLATE_PATH => $path })

B<Depreacted> interface to esmith::templates::processTemplate().

=cut

sub processTemplate
{
    require esmith::templates;
    goto &esmith::templates::processTemplate;
}

#------------------------------------------------------------

=pod

=head2 chownfile($user, $group, $file)

This routine changes the ownership of a file, automatically converting
usernames and groupnames to UIDs and GIDs respectively.

=cut

sub chownFile ($$$)
{
    my ( $user, $group, $file ) = @_;

    unless ( -e $file )
    {
        warn("can't chownFile $file: $!\n");
        return;
    }
    my $uid = defined $user  ? getpwnam($user)  : stat($file)->uid;
    my $gid = defined $group ? getgrnam($group) : stat($file)->gid;

    chown( $uid, $gid, $file );
}

=pod

=head2 determineRelease()

Returns the current release version of the software.

=cut

sub determineRelease()
{
    my $unknown = "(unknown version)";

    my $db = esmith::ConfigDB->open() or return $unknown;

    my $sysconfig = $db->get("sysconfig") or return $unknown;

    my $release = $sysconfig->prop("ReleaseVersion") || $unknown;

    return $release;
}

=pod

=head1 NETWORK ADDRESS TRANSLATION UTILITIES

=head2 IPquadToAddr($ip)

Convert IP address from "xxx.xxx.xxx.xxx" notation to a 32-bit
integer.

=cut

sub IPquadToAddr ($)
{
    my ($quad) = @_;
    return 0 unless defined $quad;
    if ( $quad =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ )
    {
        return ( $1 << 24 ) + ( $2 << 16 ) + ( $3 << 8 ) + $4;
    }
    return 0;
}

=pod

=head2 IPaddrToQuad($address)

Convert IP address from a 32-bit integer to "xxx.xxx.xxx.xxx"
notation.

=cut

sub IPaddrToQuad ($)
{
    my ($addrBits) = @_;
    return sprintf( "%d.%d.%d.%d",
        ( $addrBits >> 24 ) & 0xff,
        ( $addrBits >> 16 ) & 0xff,
        ( $addrBits >> 8 ) & 0xff,
        $addrBits & 0xff );
}

=pod

=head2 IPaddrToBackwardQuad($address)

Convert IP address from a 32-bit integer to reversed
"xxx.xxx.xxx.xxx.in-addr.arpa" notation for BIND files.

=cut

sub IPaddrToBackwardQuad ($)
{
    my ($addrBits) = @_;
    return sprintf(
        "%d.%d.%d.%d.in-addr.arpa.",
        $addrBits & 0xff,
        ( $addrBits >> 8 ) & 0xff,
        ( $addrBits >> 16 ) & 0xff,
        ( $addrBits >> 24 ) & 0xff
    );
}

=pod

=head2 computeNetworkAndBroadcast($ipaddr, $netmask)

Given an IP address and netmask (both in "xxx.xxx.xxx.xxx" format)
compute the network and broadcast addresses and output them in the
same format.

=cut

sub computeNetworkAndBroadcast ($$)
{
    my ( $ipaddr, $netmask ) = @_;

    my ( $network, $msk ) = ipv4_network( $ipaddr, $netmask );
    my $broadcast = ipv4_broadcast( $ipaddr, $netmask );

    return ( $network, $broadcast );
}

=pod

=head2 computeLocalNetworkPrefix($ipaddr, $netmask)

Given an IP address and netmask, the computeLocalNetworkPrefix
function computes the network prefix for local machines.

i.e. for an IP address of 192.168.8.4 and netmask of 255.255.255.0,
this function will return "192.168.8.".

This string is suitable for use in configuration files (such as
/etc/proftpd.conf) when the more precise notation

    xxx.xxx.xxx.xxx/yyy.yyy.yyy.yyy

is not supported.

=cut

sub computeLocalNetworkPrefix ($$)
{
    my ( $ipaddr, $netmask ) = @_;

    my ( $net, $msk ) = ipv4_network( $ipaddr, $netmask );
    $net =~ s/(\d{1,3}\.\d{1,3}\.\d{1,3}\.)(\d{1,3})/$1/;

    return $net;
}

=pod

=head2 computeAllLocalNetworkPrefixes ($ipaddress, $netmask)

 Given an IP address and netmask, the computeAllLocalNetworkPrefixes
 function computes the network prefix or list of prefixes that
 fully describe the network to which the IP address belongs.

 examples:

 - for an IP address of 192.168.8.4 and netmask of 255.255.255.0,
 will return an array with a first (and only) element of "192.168.8".

 - for an IP address of 192.168.8.4 and netmask of 255.255.254.0,
 will return the array [ '192.168.8', '192.168.9' ].

 This array is suitable for use in configuration of tools such as
 djbdns where other network notations are not supported.

=begin testing

is_deeply(
    [esmith::util::computeAllLocalNetworkPrefixes("192.168.8.4",
                            "255.255.254.0")],
    ['192.168.8', '192.168.9' ],
    "/23 network"
    );

is_deeply(
    [esmith::util::computeAllLocalNetworkPrefixes("192.168.8.4",
                            "255.255.255.255")],
    ['192.168.8.4'],
    "/32 network"
    );

is_deeply(
    [esmith::util::computeAllLocalNetworkPrefixes("192.168.8.4",
                            "255.255.255.0")],
    ['192.168.8'],
    "/24 network"
    );

=end testing

=cut

sub computeAllLocalNetworkPrefixes
{
    my ( $ipaddr, $netmask ) = @_;

    my $ipaddrBits  = IPquadToAddr($ipaddr);
    my $netmaskBits = IPquadToAddr($netmask);
    my $networkBits = $ipaddrBits & $netmaskBits;

    # first, calculate the prefix (/??) given the netmask
    my $len = 0;
    for ( my $bits = $netmaskBits ; $bits & 0xFFFFFFFF ; $bits <<= 1 )
    {
        $len++;
    }

    # Here's where the magic starts...
    #
    # next, calculate the number of networks we expect to generate and
    # the incrementing value for each network.
    my $number_of_nets = 1 << ( ( 32 - $len ) % 8 );
    my $one_net = 1 << ( 3 - ( int $len / 8 ) ) * 8;
    my @networks;
    while ( $number_of_nets-- )
    {
        my $network = IPaddrToQuad($networkBits);

        # we want to strip off the trailing ``.0'' for /24 or larger networks
        if ( $len <= 24 )
        {
            $network =~ s/\.0$//;
        }

        # we want to continue to strip off trailing ``.0'', one more for
        # /9 to /16, two more for /1 to /8
        $network =~ s/\.0$// if ( $len <= 16 );
        $network =~ s/\.0$// if ( $len <= 8 );

        # push the resulting network into an array that we'll return;
        push @networks, $network;

        # increment the network by ``one'', relative to the size of networks
        # we're dealing with
        $networkBits += $one_net;
    }
    return (@networks);
}

=pod

=head2 computeLocalNetworkShortSpec($ipaddr, $netmask)

Given an IP address and netmask, the computeLocalNetworkShortSpec
function computes a valid xxx.xxx.xxx.xxx/yyy specifier where yyy
is the number of bits specifying the network.

i.e. for an IP address of 192.168.8.4 and netmask of 255.255.255.0,
this function will return "192.168.8.0/24".

This string is suitable for use in configuration files (such as
/etc/proftpd.conf) when the more precise notation

    xxx.xxx.xxx.xxx/yyy.yyy.yyy.yyy

is not supported.

=cut

sub computeLocalNetworkShortSpec ($$)
{
    my ( $ipaddr, $netmask ) = @_;
    my ( $net, $mask ) = ipv4_network( $ipaddr, $netmask );
    return "$net/$mask";
}

=pod

=head2 computeLocalNetworkSpec($ipaddr, $netmask)

Given an IP address and netmask, the computeLocalNetworkSpec function
computes a valid xxx.xxx.xxx.xxx/yyy.yyy.yyy.yyy specifier.

=cut

sub computeLocalNetworkSpec ($$)
{
    my ( $ipaddr, $netmask ) = @_;
    my ( $net, $mask ) = ipv4_network( $ipaddr, $netmask );
    $mask = ipv4_cidr2msk($mask);
    return "$net/$mask";
}

=pod

=head2 computeNetmaskFromBits ($bits)

Given a number of bits of network address, calculate the appropriate
netmask.

=cut

sub computeNetmaskFromBits ($)
{
    my ($ones) = @_;

    return ipv4_cidr2msk($ones);
}

=pod

=head2 computeLocalNetworkReversed($ipaddr, $netmask)

Given an IP address and netmask, the computeLocalNetworkReversed
function computes the appropriate DNS domain field.

NOTE: The return value is aligned to the next available byte boundary, i.e.

     192.168.8.4/255.255.255.0 returns "8.168.192.in-addr.arpa."
     192.168.8.4/255.255.252.0 returns "168.192.in-addr.arpa."
     192.168.8.4/255.255.0.0   returns "168.192.in-addr.arpa."
     192.168.8.4/255.252.0.0   returns "192.in-addr.arpa."
     192.168.8.4/255.0.0.0     returns "192.in-addr.arpa."

This string is suitable for use in BIND configuration files.

=cut

sub computeLocalNetworkReversed ($$)
{
    my ( $ipaddr, $netmask ) = @_;

    my @addressBytes = split ( /\./, $ipaddr );
    my @maskBytes    = split ( /\./, $netmask );

    my @result;

    push ( @result, "in-addr.arpa." );

    foreach (@maskBytes)
    {
        last unless ( $_ eq "255" );

        unshift ( @result, shift (@addressBytes) );
    }

    return join ( '.', @result );
}

=pod

=head2 computeHostRange($ipaddr, $netmask)

Given a network specification (IP address and netmask), compute
the total number of hosts in that network, as well as the first
and last IP addresses in the range.

=cut

sub computeHostRange ($$)
{
    my ( $ipaddr, $netmask ) = @_;

    my $ipaddrBits   = IPquadToAddr($ipaddr);
    my $netmaskBits  = IPquadToAddr($netmask);
    my $hostmaskBits = ( ( ~$netmaskBits ) & 0xffffffff );

    my $firstAddrBits = $ipaddrBits & $netmaskBits;
    my $lastAddrBits  = $ipaddrBits | $hostmaskBits;

    my $totalHosts = 1;

    for ( ; $hostmaskBits ; $hostmaskBits /= 2 )
    {
        if ( ( $hostmaskBits & 0x1 ) == 0x1 )
        {
            $totalHosts *= 2;
        }
    }

    return ( $totalHosts, IPaddrToQuad($firstAddrBits),
        IPaddrToQuad($lastAddrBits) );
}

=pod

=head2 ldapBase($domain)

Given a domain name such as foo.bar.com, generate the
LDAP base name "dc=foo,dc=bar,dc=com".

=cut

sub ldapBase ($)
{
    my ($domainName) = @_;
    $domainName =~ s/\./,dc=/g;
    return "dc=" . $domainName;
}

=pod

=head2 backgroundCommand($delaySec, @command)

Run command in background after a specified delay.

=cut

sub backgroundCommand ($@)
{
    my ( $delaySec, @command ) = @_;

    # now would be a good time to flush output buffers, so the partial
    # buffers don't get copied

    $| = 1;
    print "";

    # create child process
    my $pid = fork;

    # if fork failed, bail out
    die "Cannot fork: $!" unless defined($pid);

    # If fork succeeded, make parent process return immediately.
    # We are not waiting on the child, so it will become a zombie
    # process when it completes. However, this subroutine is only
    # intended for use by the e-smith signal-event program, which
    # doesn't run very long. Once the parent terminates, the zombie
    # will become owned by "init" and will be reaped automatically.

    return if ($pid);

    # detach ourselves from the terminal
    setsid || die "Cannot start a new session: $!";

    # change working directory
    chdir "/";

    # clear file creation mask
    umask 0;

    # close STDIN, STDOUT, and STDERR
    close STDIN;
    close STDOUT;
    close STDERR;

    # reopen stderr, stdout, stdin
    open( STDIN, '/dev/null' );

    my $loggerPid = open( STDOUT, "|-" );
    die "Can't fork: $!\n" unless defined $loggerPid;

    unless ($loggerPid)
    {
        exec qw(/usr/bin/logger -p local1.info -t e-smith-bg);
    }

    open( STDERR, '>&STDOUT' );

    # make child wait for specified delay.
    sleep $delaySec;

    # execute command
    exec { $command[0] } @command or warn "Can't @command : $!\n";   
}

=pod

=head1 PASSWORD UTILITIES

Low-level password-changing utilities. These utilities each
change passwords for a single underlying password database,
for example /etc/passwd, /etc/samba/smbpasswd, etc.

=head2 validatePassword($password, $strength)

Validate Unix password.

=cut

sub validatePassword($$)
{
    my ( $password, $strength ) = @_;
    use Crypt::Cracklib;

    $strength ||= 'normal';

    my $reason = 'ok';
    $reason = 'it is too short' unless (length($password) > 6);
    return $reason if ($reason ne 'ok' || $strength eq 'none');

    $reason = 'it does not contain numbers' if (not $password =~ /\d/);
    $reason = 'it does not contain uppercase characters' if (not $password =~ /[A-Z]/);
    $reason = 'it does not contain lowercase characters' if (not $password =~ /[a-z]/);
    $reason = 'it does not contain special characters' if (not $password =~ /\W|_/);
    return $reason if ($reason ne 'ok' && $strength eq 'strong');

    if ( -f '/usr/lib64/cracklib_dict.pwd' ) {
        $reason = fascist_check($password, '/usr/lib64/cracklib_dict');
    } else {
        $reason = fascist_check($password, '/usr/lib/cracklib_dict');
    }
    $reason ||= 'the password check failed';

    return 'ok' if (lc($reason) eq 'ok');
    return $reason;
}

=pod

=head2 setUnixPassword($username, $password)

Set Unix password

=cut

sub setUnixPassword($$)
{
    my ( $username, $password ) = @_;
    setUnixPasswordRequirePrevious( $username, undef, $password );
}

=pod

=head2 authenticateUnixPassword ($username, $password)

Check if the given username/password pair is correct.  
Return 1 if they are correct, return 0 otherwise.

=cut

sub authenticateUnixPassword ($$)
{
    my ( $username, $password ) = @_;

    my $pam_auth_func = sub {
        return ( PAM_SUCCESS(), $password, PAM_SUCCESS() );
    };
    my $pamh = new Authen::PAM( 'passwd', $username, $pam_auth_func );

    unless ( ref($pamh) )
    {
        warn "WARN: Couldn't open Authen::PAM handle for user $username";
        return 0;
    }
    my $res = $pamh->pam_authenticate();
    return ( $res == PAM_SUCCESS() ) || 0;
}

=pod

=head2 setUnixPasswordRequirePrevious($username, $oldpassword, $newpassword)

Set Unix password but require previous password for authentication.

=cut

# setUnixPasswordRequirePrevious is left as an exercise for the reader :-)
sub setUnixPasswordRequirePrevious ($$$)
{
    my ( $username, $oldpassword, $newpassword ) = @_;
    use Authen::PAM;
    my $state;

    my $my_conv_func = sub {
        my @res;
        while (@_)
        {
            my $code = shift;
            my $msg  = shift;
            my $ans  = "";

            $ans = $username if ( $code == PAM_PROMPT_ECHO_ON() );
            if ( $code == PAM_PROMPT_ECHO_OFF() )
            {
                if ( $< == 0 || $state >= 1 )
                {
                    # are we asked for a new password
                    $ans = $newpassword;
                }
                else
                {
                    # asked for old password before we can set a new one.
                    $ans = $oldpassword;
                }
                $state++;
            }

           #print("code is $code, ans is $ans, msg is $msg, state is $state\n");
            push @res, ( PAM_SUCCESS(), $ans );
        }
        push @res, PAM_SUCCESS();
        return @res;
    };

    my $pamh = new Authen::PAM( "passwd", $username, $my_conv_func );
    unless ( ref($pamh) )
    {
        warn "Autopasswd: error code $pamh during PAM init!";
        warn "Failed to set Unix password for account $username.\n";
        return 0;
    }

    # Require the old password to be correct before proceeding to set a new
    # one.
    # This does that, except if you're already root, such as from the
    # bootstrap-console
    $state = 0;
    unless ( $< == 0 or $pamh->pam_authenticate == 0 )
    {
        warn
"PAM authentication failed for user \"$username\", old password invalid!\n";
        return 0;
    }

    $state = 0;
    my $res = $pamh->pam_chauthtok;
    unless ( $res == PAM_SUCCESS() )
    {
        my $err = $pamh->pam_strerror($res);
        warn "Failed to set Unix password for account $username: $err\n";
        return 0;
    }
    return 1;    # success
}

=pod

=head2 setSambaPassword($username, $password)

Set Samba password

=cut

sub setSambaPassword ($$)
{
    my ( $username, $password ) = @_;

    #----------------------------------------
    # then set the password
    #----------------------------------------

    my $smbPasswdProg = '/usr/bin/smbpasswd';

    # see perldoc perlipc (search for 'Safe Pipe Opens')
    my $pid = open( DISCARD, "|-" );

    if ($pid)    # parent
    {
        print DISCARD "$password\n$password\n";
        close(DISCARD) || die "Child exited early.";
    }
    else         # child
    {
        my $retval = system("$smbPasswdProg -a -s $username >/dev/null");
        ( $retval / 256 )
          && die "Failed to set Samba password for account $username.\n";
        exit 0;
    }
    # Now we enable the account
    return system("$smbPasswdProg -e $username >/dev/null") ? 0 : 1;
}

=pod

=head2 cancelSambaPassword($username)

Cancel Samba password

=cut

sub cancelSambaPassword ($)
{
    my ($username) = @_;

    #----------------------------------------
    # Gordon Rowell <gordonr@e-smith.com> June 7, 2000
    # We really should maintain old users, which would mean we can just use
    # smbpasswd -d, but the current policy is to remove them. If we are
    # doing that (see below), there is no need to disable them first.
    #----------------------------------------
    #    my $discard = `/usr/bin/smbpasswd -d -s $username`;
    #    if ($? != 0)
    #    {
    #   die "Failed to disable Samba account $username.\n";
    #    }

    #----------------------------------------
    # Delete the smbpasswd entry. If we don't, re-adding the same
    # username will result in a mismatch of UIDs between /etc/passwd
    # and /etc/smbpasswd
    #----------------------------------------
    # Michael Brader <mbrader@stoic.com.au> June 2, 2000
    # We have a locking problem here.
    # If two copies of this are run at once you could see your entry reappear
    # Proposed solution (file locking):

    # If we do a 'use Fcntl, we'll probably get the locking constants
    # defined, but for now:

    # NB. hard to test

    my $LOCK_EX = 2;
    my $LOCK_UN = 8;

    my $smbPasswdFile = '/etc/samba/smbpasswd';

    open( RDWR, "+<$smbPasswdFile" ) ||    # +< == fopen(path, "r+",...
      die "Cannot open file $smbPasswdFile: $!\n";

    my $nolock = 1;
    my $attempts;
    for ( $attempts = 1 ; ( $attempts <= 5 && $nolock ) ; $attempts++ )
    {
        if ( flock( RDWR, $LOCK_EX ) )
        {
            $nolock = 0;
        }
        else
        {
            sleep $attempts;
        }
    }

    $nolock && die "Could not get exclusive lock on $smbPasswdFile\n";

    my $outputString = '';
    while (<RDWR>)
    {
        (/^$username:/) || ( $outputString .= $_ );
    }

    # clear file and go to beginning
    truncate( RDWR, 0 ) || die "truncate failed";    # not 'strict' safe why???
    seek( RDWR, 0, 0 ) || die "seek failed";
    print RDWR $outputString;
    flock( RDWR, $LOCK_UN )
      || warn "Couldn't remove exclusive lock on $smbPasswdFile\n";
    close RDWR || die "close failed";

    chmod 0600, $smbPasswdFile;

    return 1;                                        # success
}

=pod

=head2 LdapPassword()

Returns the LDAP password from the file C</etc/openldap/ldap.pw>.
If the file does not exist, a suitable password is created, stored
in the file, then returned to the caller.

Returns undef if the password could not be generated/retrieved.

=cut

sub genLdapPassword ()
{

    # Otherwise generate a suitable new password, store it in the
    # correct file, and return it to the caller.

    use MIME::Base64 qw(encode_base64);

    unless ( open( RANDOM, "/dev/urandom" ) )
    {
        warn "Could not open /dev/urandom: $!";
        return undef;
    }

    my $buf = "not set";

    # 57 bytes is a full line of Base64 coding, and contains
    # 456 bits of randomness - given a perfectly random /dev/urandom
    if ( read( RANDOM, $buf, 57 ) != 57 )
    {
        warn("Short read from /dev/urandom: $!");
        return undef;
    }
    close RANDOM;

    my $umask    = umask 0077;
    my $password = encode_base64($buf, "");

    unless ( open( WR, ">/etc/openldap/ldap.pw" ) )
    {
        warn "Could not write LDAP password file.\n";
        return undef;
    }

    print WR "$password\n";
    close WR;
    umask $umask;

    chmod 0600, "/etc/openldap/ldap.pw";

    return $password;
}

sub LdapPassword ()
{

    # Read the password from the file /etc/openldap/ldap.pw if it
    # exists.
    if ( -f "/etc/openldap/ldap.pw" )
    {
        open( LDAPPW, "</etc/openldap/ldap.pw" )
          || die "Could not open LDAP password file.\n";
        my $password = <LDAPPW>;
        chomp $password;
        close LDAPPW;
        return $password;
    }
    else
    {
        return genLdapPassword();
    }
}

=pod

=head2 set_secret()

Shortcut method to create and set a password property on a record without having to extract the record first.

The password creation is based on an UID of 64 bits (Data::UUID). If the optional type option is passed, 
it will be used to create the record if it does not already exist. Otherwise, a default 'service' type 
will be used to create the record.

The $DB is expected to be an already open esmith::DB object, so that an open DB in the caller can be re-used. 
Therefore in a migrate fragment you could just use $DB.

         esmith::util::set_secret($DB, '$key','$property'[,type=>'$type']);

For example in /etc/e-smith/db/configuration/migrate/90roundcube
     {
         esmith::util::set_secret($DB, 'foo','DbPassword',type=>'service');
     }

The password will be generated to the property 'DbPassword' in the 'foo' key.

If you want to change the database then you must open another esmith::DB objet
     {
         my $database = esmith::ConfigDB->open('accounts') or
                die esmith::DB->error;
         esmith::util::set_secret($database, 'foo','DbPassword',type=>'user');
     }

=cut

sub set_secret

{
    my ($db, $key, $prop, %options) = @_;
    %options = (type => 'service', %options);

    my $record = $db->get($key) ||
                 $db->new_record($key, \%options) or
                 die "Error creating new record";

    return if $db->get_prop($key,$prop);

    $record->merge_props(%options, $prop =>
       Data::UUID->new->create_b64());
}



=pod

=head1 HIGH LEVEL PASSWORD UTILITIES

High-level password-changing utilities. These utilities
each change passwords for a single e-smith entity (system,
user or ibay). Each one works by calling the appropriate
low-level password changing utilities.

=head2 setUnixSystemPassword($password)

Set the e-smith system password

=cut

sub setUnixSystemPassword ($)
{
    my ($password) = @_;

    setUnixPassword( "root",  $password );
    setUnixPassword( "admin", $password );
}

=pod

=head2 setServerSystemPassword($password)

Set the samba administrator password.

=cut

sub setServerSystemPassword ($)
{
    my ($password) = @_;

    setSambaPassword( "admin", $password );
}

=pod

=head2 setUserPassword($username, $password)

Set e-smith user password

=cut

sub setUserPassword ($$)
{
    my ( $username, $password ) = @_;

    setUnixPassword( $username, $password );
    setSambaPassword( $username, $password );
}

=pod

=head2 setUserPasswordRequirePrevious($username, $oldpassword, $newpassword)

Set e-smith user password - require previous password

=cut

sub setUserPasswordRequirePrevious ($$$)
{
    my ( $username, $oldpassword, $newpassword ) = @_;

    # We need to suid to the user, instead of root, so that PAM will
    # prompt us for the old password.
    my @pwent = getpwnam($username);
    return 0 unless ( $pwent[2] > 0 );    # uid must be non-zero
    my $uid = $<;
    $< = $pwent[2];

    # Return if this function call fails, we didn't change passwords
    # successfully.
    my $ret =
      setUnixPasswordRequirePrevious( $username, $oldpassword, $newpassword );
    $< = $uid;
    return 0 unless $ret;

    # if we get this far, the old password must have been valid
    setSambaPassword( $username, $newpassword );
}

=pod

=head2 cancelUserPassword

Cancel user password. This is called when a user is deleted from the
system. We assume that the Unix "useradd/userdel" programs are
called separately. Since "userdel" automatically removes the
/etc/passwd entry, we only need to worry about the /etc/samba/smbpasswd
entry.

=cut

sub cancelUserPassword ($)
{
    my ($username) = @_;

    cancelSambaPassword($username);
}

=pod

=head2 setIbayPassword($ibayname, $password)

Set ibay password

=cut

sub setIbayPassword ($$)
{
    my ( $ibayname, $password ) = @_;

    setUnixPassword( $ibayname, $password );
}

=pod

=head1 SERVICE MANAGEMENT UTILITIES

=head2 serviceControl()

Manage services - stop/start/restart/reload/graceful

Returns 1 for success, 0 if something went wrong, fatal exception on bad
arguments.

    serviceControl(
        NAME=>serviceName,
        ACTION=>start|stop|restart|reload|graceful
        [ BACKGROUND=>true|false (default is false) ]
    );

EXAMPLE:

    serviceControl( NAME=>'httpd-e-smith', ACTION=>'reload' );

NOTES:

The BACKGROUND parameter is optional and can be set to true if
start/stop/restart/etc. is to be done in the background (with
backgroundCommand()) rather than synchronously.

CONVENTIONS:

This command is the supported method for action scripts, blade handlers, etc.,
to start/stop/restart their services. Currently this is done via the rc7
symlinks, but this may change one day. Using this function gives us one
location to change this behaviour if desired, instead of hunting all over
every scrap of code. Please use it.

=cut

sub serviceControl
{
    my %params = @_;

    my $serviceName = $params{NAME};
    unless ( defined $serviceName )
    {
        die "serviceControl: NAME must be specified";
    }

    my $serviceAction = $params{ACTION};
    unless (defined $serviceAction)
    {
        die "serviceControl: ACTION must be specified";
    }

    if ( $serviceAction =~ /^(start|stop|restart|reload|graceful|adjust|svdisable|reload-or-restart|try-restart|reload-or-try-restart|enable -now|enable|disable|sig[A-Za-z12]+)$/ )
    {
        my ($startScript) = glob("/etc/rc.d/rc7.d/S*$serviceName") ||'' ;
        my ($systemdScript) = "/usr/lib/systemd/system/$serviceName.service" ||'';
	my ($systemdAlias) = "/etc/systemd/system/$serviceName.service" ||'';
  	my $multiple = "$serviceName.service";
  	($multiple = $serviceName ) =~ s/([a-zA-Z0-9\-_.]+@)(.*)/$1.service/ if ( $serviceName =~ /@/ );

	unless ( -e $startScript or -e $systemdScript or -e "/usr/lib/systemd/system/$multiple" or -e $systemdAlias)
        {
            warn "serviceControl: startScript not found "
              . "for service $serviceName\n";
            return 0;
        }

	 if ( (-e $systemdScript  or -e "/usr/lib/systemd/system/$multiple" or -e $systemdAlias) and ! -e $startScript){
	    # systemd is not aware of adjust, sigusr1, sigusr2, sigterm, sighup
	    $serviceAction = ( $serviceAction =~/^(adjust|graceful|sighup|sigusr1|sigusr2)$/ ) ? "reload-or-restart" : $serviceAction; 
           $serviceAction = ( $serviceAction eq "sigterm" ) ? "restart" : $serviceAction;
	    if ($serviceAction =~/^(sig[A-Za-z12]+)$/) {
		$serviceAction=uc($serviceAction);
		system('/usr/bin/systemctl',"kill","--signal=$serviceAction","$serviceName.service") == '0'
                ||    warn "serviceControl: Couldn't " .
                "system( /usr/bin/systemctl kill --signal=$serviceAction $serviceName.service): $!\n";
            }
	    elsif ($serviceAction =~/^(start|stop|restart|reload|reload-or-restart|try-restart|reload-or-try-restart|enable -now|enable|disable)$/) {
                system('/usr/bin/systemctl',"$serviceAction","$serviceName.service") == '0'
                ||    warn "serviceControl: Couldn't " .
                "system( /usr/bin/systemctl $serviceAction $serviceName.service): $!\n";
            }
            else {
                die "serviceControl: systemd doesn't know : systemctl $serviceAction $serviceName.service";
            }
        }

        elsif (-e $startScript) {
            my  $background = $params{'BACKGROUND'} || 'false';

            die "serviceControl: Unknown serviceAction $serviceAction" if ($serviceAction =~/^(reload-or-restart|try-restart|reload-or-try-restart|enable -now|enable|disable)$/);
            if ( $background eq 'true' )
            {
            backgroundCommand( 0, $startScript, $serviceAction );
            }
            elsif ( $background eq 'false' )
            {
                unless ( system( $startScript, $serviceAction ) == 0 )
                {
                warn "serviceControl: "
                  . "Couldn't system($startScript, $serviceAction): $!\n";
                return 0;
                }
           }
           else
           {
            die "serviceControl: Unsupported BACKGROUND=>$background";
           }
        }
    }
    else
    {
        die "serviceControl: Unknown serviceAction $serviceAction";
    }
    return 1;
}

=head2 getLicenses()

Return all available licenses

In scalar context, returns one string combining all licenses
In array context, returns an array of individual licenses

Optionally takes a language tag to be used for retrieving the licenses,
defaulting to the locale of the server.

=for testing
$ENV{ESMITH_LICENSE_DIR} = "10e-smith-lib/licenses";
ok(-d $ENV{ESMITH_LICENSE_DIR}, "License dir for testing exists");
like($l = esmith::util::getLicenses("fr_CA"), qr/Je suis/, "Found french license");
like($l = esmith::util::getLicenses("en_US"), qr/I am/,    "Found english license");

=cut

sub getLicenses
{
    my ($locale) = @_;

    if ($locale)
    {
        $locale =~ s/-(\S\S)/_\U$1/;
    }
    else
    {
        my $db = esmith::ConfigDB->open();

        my ( $lang, @rest ) = $db->getLocale();

        $lang = $lang || "en_US";

        $locale = $lang;
    }

    my $base_dir = $ENV{ESMITH_LICENSE_DIR} || "/etc/e-smith/licenses";

    $locale = "en_US" unless ( -d "${base_dir}/${locale}" );

    my $dir = "${base_dir}/${locale}";

    my @licenses;

    opendir( DIR, $dir ) || die "Couldn't open licenses directory\n";

    foreach my $license ( readdir(DIR) )
    {
        my $file = "${dir}/${license}";

        next unless ( -f $file );

        open( LICENSE, $file ) || die "Couldn't open license $file\n";

        push @licenses, <LICENSE>;

        close LICENSE;
    }

    return wantarray ? @licenses : "@licenses";
}

=head2 getLicenseFile()

Return the license filename.

Optionally takes a language tag to be used for retrieving the license,
defaulting to the locale of the server.

If more than one license file than return the first alphabetically.

=cut

sub getLicenseFile
{
    my ($locale) = @_;

    if ($locale)
    {
        $locale =~ s/-(\S\S)/_\U$1/s;
    }
    else
    {
        my $db = esmith::ConfigDB->open();

        my ( $lang, @rest ) = $db->getLocale();

        $lang = $lang || 'en_US';

        $locale = $lang;
    }

    my $base_dir = $ENV{ESMITH_LICENSE_DIR} || '/etc/e-smith/licenses';

    $locale = 'en_US' unless ( -d "${base_dir}/${locale}" );

    my $dir = "${base_dir}/${locale}";

    opendir( DIR, $dir ) || die "Couldn't open licenses directory\n";

    my @licenses;
    foreach my $license ( readdir DIR )
    {
        untaint ($license);
        my $file = "${dir}/${license}";
        next unless ( -f $file );
        push @licenses, $file;
    }

    @licenses = sort @licenses;

    return shift @licenses;
}


=item B<initialize_default_databases>

Initialize all databases located at /etc/e-smith/db.

=cut

sub initialize_default_databases
{

    # Optionally take an argument to the db root, for testing purposes.
    my %defaults = (
        dbroot => '/etc/e-smith/db',
        dbhome => '/home/e-smith/db',
        old_dbhome => '/home/e-smith',
    );
    my %args   = ( %defaults, @_ );
    my $dbroot = $args{dbroot};
    my $dbhome = $args{dbhome};
    my $old_dbhome = $args{old_dbhome};

    local *DH;
    opendir DH, $dbroot
      or die "Could not open $dbroot: $!";

    my @dirs = readdir(DH);

    # Move all databases to new home first them migrate data
    # Untaint db names while we are at it.
    foreach my $file ( map { /(.+)/ ; $1 } grep !/^\./, @dirs )
    {
        if (-f "${old_dbhome}/$file")
        {
            if (-l "${old_dbhome}/$file")
            {
                warn "symlink called ${old_dbhome}/$file exists\n";
		next;
            }

            if (-s "${dbhome}/$file")
            {
                warn "${old_dbhome}/$file and ${dbhome}/$file exist\n";
                rename "${dbhome}/$file", "${dbhome}/$file." . time;
            }

	    warn "Rename ${old_dbhome}/$file => ${dbhome}/$file\n";
	    rename "${old_dbhome}/$file", "${dbhome}/$file";
        }
    }

    foreach my $file ( grep !/^\./, @dirs )
    {
        # Untaint the result of readdir. As we're expecting filenames like
        # 'configuration' and 'ipphones', lets restrict input to those.
        if ($file =~ /(^[A-Za-z0-9_\.-]+$)/)
        {
            $file = $1;
        }
        else
        {
	    warn "Not processing unexpected file $file\n";
            next;
        }

        eval
        {
            my $h = esmith::ConfigDB->open($file);
            if ($h)
            {
                warn "Migrating existing database $file\n";

                # Convert old data to new format, and add any new defaults. Note
                # that migrate returns FALSE on fatal errors. Report those to
                # syslog. The error should still be in $@.
                unless ( $h->migrate() )
                {
                    warn "Migration of db $file failed: " . esmith::DB->error;
                }
            }
            else
            {
                warn "Creating database $file and setting defaults\n";

                # create() and load defaults
                unless ( $h = esmith::ConfigDB->create($file) )
                {
                    warn "Could not create $file db: " . esmith::DB->error;
                }
            }

            $h->close;

            esmith::util::chownFile( "root", "admin", "$dbhome/$file" );
        };
        if ($@)
        {
            warn "Fatal error while processing db $file: $@\n";
        }
    }
    return 1;
}


=head1 AUTHOR

Mitel Networks Corp.

For more information, see http://www.e-smith.org/

=cut

1;