diff options
Diffstat (limited to 'base/setup/pkicommon.pm')
| -rwxr-xr-x | base/setup/pkicommon.pm | 3580 |
1 files changed, 3580 insertions, 0 deletions
diff --git a/base/setup/pkicommon.pm b/base/setup/pkicommon.pm new file mode 100755 index 000000000..6ce255303 --- /dev/null +++ b/base/setup/pkicommon.pm @@ -0,0 +1,3580 @@ +#!/usr/bin/perl +# +# --- BEGIN COPYRIGHT BLOCK --- +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; version 2 of the License. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +# +# Copyright (C) 2007-2010 Red Hat, Inc. +# All rights reserved. +# --- END COPYRIGHT BLOCK --- +# + +package pkicommon; +use strict; +use warnings; + +use Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw( + $lib_prefix $obj_ext $path_sep $tmp_dir + $pki_flavor $pki_registry_path + $verbose $dry_run $hostname $default_hardware_platform + $default_system_binaries $default_lockdir $default_system_libraries $default_system_user_binaries + $default_system_user_libraries + $default_java_path $default_pki_java_path $default_x86_64_jni_java_path $default_system_jni_java_path @default_jar_path + $default_security_libraries $default_certutil_command + $default_ldapmodify_command $default_modutil_command + $default_dir_permissions $default_exe_permissions $default_file_permissions + $default_initscripts_path $default_registry_path + $ROOTUID $MAX_WELL_KNOWN_PORT $MAX_RESERVED_PORT $MAX_REGISTERED_PORT $MAX_DYNAMIC_PORT + $FILE_PREFIX $FTP_PREFIX $HTTP_PREFIX $HTTPS_PREFIX $LDAP_PREFIX $LDAPS_PREFIX + $PKI_USER $PKI_GROUP $PKI_UID $PKI_GID + $CA $KRA $OCSP $TKS $RA $TPS + $CA_INITSCRIPT $KRA_INITSCRIPT $OCSP_INITSCRIPT + $TKS_INITSCRIPT $RA_INITSCRIPT $TPS_INITSCRIPT + $install_info_basename $cleanup_basename %installation_info + $semanage $restorecon $SELINUX_PORT_UNDEFINED $SELINUX_PORT_DEFINED $SELINUX_PORT_WRONGLY_DEFINED + + add_install_info remove_install_info get_install_description + format_install_info get_install_info_description + parse_install_info parse_old_cleanup read_old_cleanup + read_install_info read_install_info_from_dir write_install_info_to_dir uninstall + is_Windows is_Linux is_Fedora is_RHEL is_RHEL4 setup_platform_dependent_parameters + set_library_path get_library_path fedora_release + check_for_root_UID user_disallows_shell + user_exists create_user + group_exists create_group user_is_a_member_of_group add_user_as_a_member_of_group + get_UID_from_username + get_FQDN check_for_valid_url_prefix + AreConnectorPortsValid IsLocalPortAvailable IsServerReachable + get_time_stamp generate_random generate_random_string password_quality_checker + LDAP_add LDAP_modify + certutil_create_databases certutil_delete_cert certutil_generate_CSR + certutil_generate_self_signed_cert certutil_import_cert + certutil_print_cert certutil_list_certs modutil_add_token + open_logfile get_logfile_path close_logfile + prompt printFile emit + is_path_valid is_name_valid entity_type entity_exists + file_exists is_file_empty create_empty_file create_file copy_file remove_file + set_permissions set_owner_group set_file_props + get_directory_files normalize_path + directory_exists is_directory_empty create_directory copy_directory remove_directory + set_owner_group_on_directory_contents + symlink_exists create_symlink remove_symlink set_owner_group_on_symlink + run_command get_cs_cfg get_registry_initscript_name + register_pki_instance_with_chkconfig deregister_pki_instance_with_chkconfig + find_jar + check_selinux_port parse_selinux_ports add_selinux_port add_selinux_file_context + ); + + +use File::Slurp qw(read_file write_file); + +############################################################## +# This file contains shared data and subroutines for +# the "pkicreate" and "pkiremove" Perl scripts. +############################################################## + + +############################################################## +# Perl Version +############################################################## + +my $MINIMUM_PERL_VERSION = "5.006001"; + +my $perl_version_error_message = "ERROR: Using Perl version $] ...\n" + . " Must use Perl version " + . "$MINIMUM_PERL_VERSION or later to " + . "run this script!\n"; + +die $perl_version_error_message if $] < $MINIMUM_PERL_VERSION; + + +############################################################## +# Execution Check +############################################################## + +# Check to insure that this script's original +# invocation directory has not been deleted! +my $cwd = `/bin/pwd`; +chomp $cwd; +if (!$cwd) { + emit("Cannot invoke '$0' from non-existent directory!\n", "error"); + exit 255; +} + + +############################################################## +# Environment Variables +############################################################## + +# untaint called subroutines +if (($^O ne 'Windows_NT') && ($^O ne 'MSWin32')) { + $> = $<; # set effective user ID to real UID + $) = $(; # set effective group ID to real GID + $ENV{'PATH'} = '/bin:/usr/bin'; + $ENV{'ENV'} = '' if !defined($ENV{'ENV'}); +} + + +############################################################## +# Perl Modules +############################################################## + +use Sys::Hostname; +use FileHandle; +use Socket; +use File::Copy; +use File::Basename; +use File::Path qw(make_path remove_tree); + +############################################################## +# Global Variables +############################################################## + +# Platform-dependent parameters +our $lib_prefix = undef; +our $obj_ext = undef; +our $path_sep = undef; +our $tmp_dir = undef; + +# Whether or not to do verbose mode +our $verbose = 0; + +# Controls whether actions are executed (dry_run == false) +# or if actions are only reported (dry_run == true). +our $dry_run = 0; + +our $hostname = undef; + +# selinux structures +our %selinux_ports = (); + +############################################################## +# Shared Default Values +############################################################## + +our $pki_flavor = undef; +our $pki_registry_path = undef; + +our $default_hardware_platform = undef; +our $default_system_binaries = undef; +our $default_lockdir = undef; +our $default_system_libraries = undef; +our $default_system_user_binaries = undef; +our $default_system_user_libraries = undef; +our $default_java_path = undef; +our $default_pki_java_path = undef; +our $default_x86_64_jni_java_path = undef; +our $default_system_jni_java_path = undef; +our @default_jar_path = undef; +our $default_security_libraries = undef; +our $default_certutil_command = undef; +our $default_ldapmodify_command = undef; +our $default_modutil_command = undef; +our $default_initscripts_path = undef; +our $default_registry_path = undef; +my $candlepin_java_path = "/usr/share/candlepin/lib"; + +our $default_dir_permissions = 00770; +our $default_exe_permissions = 00770; +our $default_file_permissions = 00660; + +our $semanage = "/usr/sbin/semanage"; +our $restorecon = "/sbin/restorecon"; +our $SELINUX_PORT_UNDEFINED = 0; +our $SELINUX_PORT_DEFINED = 1; +our $SELINUX_PORT_WRONGLY_DEFINED = 2; + + + +# Use a local variable to denote IPv6 +my $is_IPv6 = 0; + +# Compute "hardware platform" of Operating System +if ($^O eq "linux") { + $pki_flavor = "pki"; + $default_registry_path = "/etc/sysconfig"; + $pki_registry_path = "$default_registry_path/$pki_flavor"; + $default_initscripts_path = "/etc/rc.d/init.d"; + $default_lockdir = "/var/lock/$pki_flavor"; + $default_hardware_platform = `uname -i`; + $default_hardware_platform =~ s/\s+$//g; + chomp($default_hardware_platform); + if ($default_hardware_platform eq "i386") { + # 32-bit Linux + $default_system_binaries = "/bin"; + $default_system_libraries = "/lib"; + $default_system_user_binaries = "/usr/bin"; + $default_system_user_libraries = "/usr/lib"; + $default_java_path = "/usr/share/java"; + $default_pki_java_path = "/usr/share/java/pki"; + $default_system_jni_java_path = "/usr/lib/java"; + @default_jar_path = ($default_pki_java_path, $default_java_path, $default_system_jni_java_path, $candlepin_java_path); + } elsif ($default_hardware_platform eq "x86_64") { + # 64-bit Linux + $default_system_binaries = "/bin"; + $default_system_libraries = "/lib64"; + $default_system_user_binaries = "/usr/bin"; + $default_system_user_libraries = "/usr/lib64"; + $default_java_path = "/usr/share/java"; + $default_pki_java_path = "/usr/share/java/pki"; + $default_x86_64_jni_java_path = "/usr/lib64/java"; + $default_system_jni_java_path = "/usr/lib/java"; + @default_jar_path = ($default_pki_java_path, $default_java_path, $default_x86_64_jni_java_path, + $default_system_jni_java_path, $candlepin_java_path); + } else { + emit("Unsupported '$^O' hardware platform '$default_hardware_platform'!", "error"); + exit 255; + } + + # Retrieve hostname + if (defined($ENV{'PKI_HOSTNAME'})) { + # IPv6: Retrieve hostname from environment variable + $hostname = $ENV{'PKI_HOSTNAME'}; + $is_IPv6 = 1; + } else { + # IPv4: Retrieve hostname using Sys::Hostname + $hostname = hostname; + } +} else { + emit("Unsupported platform '$^O'!\n", "error"); + exit 255; +} + + +$default_security_libraries = "$default_system_user_libraries/dirsec"; + +$default_certutil_command = "$default_system_user_binaries/certutil"; +$default_ldapmodify_command = "$default_system_user_binaries/ldapmodify"; +$default_modutil_command = "$default_system_user_binaries/modutil"; + + +############################################################## +# Global Constants +############################################################## + +our $ROOTUID = 0; + +our $MAX_WELL_KNOWN_PORT = 511; # well-known ports = 0 through 511 +our $MAX_RESERVED_PORT = 1023; # reserved ports = 512 through 1023 +our $MAX_REGISTERED_PORT = 49151; # registered ports = 1024 through 49151 +our $MAX_DYNAMIC_PORT = 65535; # dynamic/private ports = 49152 through 65535 + +our $FILE_PREFIX = "file://"; +our $FTP_PREFIX = "ftp://"; +our $HTTP_PREFIX = "http://"; +our $HTTPS_PREFIX = "https://"; +our $LDAP_PREFIX = "ldap://"; +our $LDAPS_PREFIX = "ldaps://"; + +# Identity values +our $PKI_USER = "pkiuser"; +our $PKI_GROUP = "pkiuser"; +our $PKI_UID = 17; +our $PKI_GID = 17; + +# Subsystem names +our $CA = "ca"; +our $KRA = "kra"; +our $OCSP = "ocsp"; +our $TKS = "tks"; +our $RA = "ra"; +our $TPS = "tps"; + +# Subsystem init scripts +our $CA_INITSCRIPT = "pki-cad"; +our $KRA_INITSCRIPT = "pki-krad"; +our $OCSP_INITSCRIPT = "pki-ocspd"; +our $TKS_INITSCRIPT = "pki-tksd"; +our $RA_INITSCRIPT = "pki-rad"; +our $TPS_INITSCRIPT = "pki-tpsd"; + + +############################################################## +# Local Variables +############################################################## + +# "identity" parameters +my $fqdn = undef; + +# "logging" parameters +my $logfd = undef; +my $logfile_path = undef; + + + +############################################################## +# Routines & data structures used to track & +# manage installation information +############################################################## + +# Basename of the installation info file. +our $install_info_basename = "install_info"; + +# Basename of the old clean up file. +our $cleanup_basename = ".cleanup.dat"; + +# Global hash table of installation actions +# Each filesystem path which is modified during installation +# is entered into this table as a key. The value associated +# with the key is an anonymous hash table of key/value pairs, +# e.g. the installation metadata associated with the path. +# This table should not be directly modified, rather use +# the utility subroutines which know how to operate on +# on an installation info table. The utility routines can +# operate on any installation table, but default to using +# this single global table. +our %installation_info = (); + +# Table to validate an installation type +my %valid_install_types = ('file' => 1, + 'symlink' => 1, + 'dir' => 1); + +# Table to validate a install action +my %valid_install_action = ('create' => 1, + 'move' => 1, + 'remove' => 1); + +# Table to validate an uninstall action +my %valid_uninstall_action = ('remove' => 1, + 'preserve' => 1); + +# Capture information about items modified during installation +# +# add_install_info(path, [type='file'], [uninstall_action='remove], +# [install_action='create]) +# +# path the path name of the object +# type what kind of object +# (file, symlink, dir) +# uninstall_action - during uninstall what should be done +# (remove, preserve) +# install_action what was done during install +# (create, move, remove) +# +# The data structure used to capture the information is a hash +# table whose keys are path names and whose value is a hash +# table of key/value attributes belonging to the path object. +sub add_install_info { + my ($path, $type, $uninstall_action, $install_action) = @_; + my ($install_info) = \%installation_info; + $type = 'file' unless defined($type); + $uninstall_action = 'remove' unless defined($uninstall_action); + $install_action = 'create' unless defined($install_action); + my $info; + + die "invalid install type ($type) for path ($path)" + if (!exists($valid_install_types{$type})); + + die "invalid uninstall action ($uninstall_action) for path ($path)" + if (!exists($valid_uninstall_action{$uninstall_action})); + + die "invalid install action ($install_action) for path ($path)" + if (!exists($valid_install_action{$install_action})); + + if (exists($install_info->{$path})) { + $info = $install_info->{$path}; + } else { + $install_info->{$path} = $info = {}; + } + + $info->{'type'} = $type; + $info->{'install_action'} = $install_action; + $info->{'uninstall_action'} = $uninstall_action; +} + +# Removes the install info for the given path. +# Used primarily after an error occurs. +sub remove_install_info { + my ($path) = @_; + my ($install_info) = \%installation_info; + + delete $install_info->{$path}; +} + +# return text description of installed files and directories +sub get_install_description +{ + my ($install_info) = \%installation_info; + + return get_install_info_description($install_info); +} + +# Given a hash of installation information format it into text. +# Each path name is in brackets at the beginning of a line +# followed by the path's attributes, which is an indented line of +# key = value, for each attribute +# +# The formatted text is referred to as a "Installation Manifest". +# +# returns formatted text +# +# Example: +# +# [/etc/pki-ca] +# install_action = create +# type = dir +# uninstall_action = remove +# [/etc/pki-ca/CS.cfg] +# install_action = create +# type = file +# uninstall_action = remove +# +sub format_install_info +{ + my ($install_info) = @_; + my ($text, @paths, $path, $info, @key_names, $key, $value); + + $text = ""; + @paths = sort(keys %$install_info); + foreach $path (@paths) { + $info = $install_info->{$path}; + $text .= sprintf("[%s]\n", $path); + @key_names = sort(keys %$info); + foreach $key (@key_names) { + $value = $info->{$key}; + $text .= sprintf(" %s = %s\n", $key, $value); + } + } + return $text; +} + +# Given a hash of installation information format it into +# into friendly description of what was installed. +# +# Brief Example: +# +# Installed Files: +# /etc/pki-ca/CS.cfg +# /var/log/pki-ca-install.log +# Installed Directories: +# /etc/pki-ca +# /var/log/pki-ca +# Installed Symbolic Links: +# /var/lib/pki-ca/logs +# Removed Items: +# /etc/pki-ca/noise +# +sub get_install_info_description +{ + my ($install_info) = @_; + my ($text, @paths, @filtered_paths, $path); + + $text = ''; + @paths = sort(keys %$install_info); + + @filtered_paths = grep {my ($info) = $install_info->{$_}; + $info->{'type'} eq 'file' && + $info->{'install_action'} ne 'remove'} @paths; + if (@filtered_paths) { + $text .= "Installed Files:\n"; + foreach $path (@filtered_paths) { + $text .= " ${path}\n"; + } + } + + @filtered_paths = grep {my ($info) = $install_info->{$_}; + $info->{'type'} eq 'dir' && + $info->{'install_action'} ne 'remove'} @paths; + if (@filtered_paths) { + $text .= "Installed Directories:\n"; + foreach $path (@filtered_paths) { + $text .= " ${path}\n"; + } + } + + @filtered_paths = grep {my ($info) = $install_info->{$_}; + $info->{'type'} eq 'symlink' && + $info->{'install_action'} ne 'remove'} @paths; + if (@filtered_paths) { + $text .= "Installed Symbolic Links:\n"; + foreach $path (@filtered_paths) { + $text .= " ${path}\n"; + } + } + + @filtered_paths = grep {my ($info) = $install_info->{$_}; + $info->{'install_action'} eq 'remove'} @paths; + if (@filtered_paths) { + $text .= "Removed Items:\n"; + foreach $path (@filtered_paths) { + $text .= " ${path}\n"; + } + } + + return $text; + +} + +# Given text as formatted by format_install_info() parse it into +# a install info hash table where each key is a path name and whose +# value is a hash table of key/value pairs. +# +# E.g. this routine parses an "Installation Manifest". +# +# Returns pointer to an install info hash table +sub parse_install_info +{ + my ($text) = @_; + my ($install_info, @lines, $line, $line_num, $path, $info, $key, $value); + + $install_info = {}; + @lines = split(/\n/, $text); + $line_num = 0; + $path = undef; + $info = undef; + + foreach $line (@lines) { + $line_num++; + $line =~ s/#.*//; # nuke comments + $line =~ s/\s+$//; # strip trailing whitespace + next if !$line; # skip blank lines + + # Look for quoted path at beginning of line + if ($line =~ /^\s*\[(.+)\]\s*$/) { + $path = $1; + $info = {}; + $install_info->{$path} = $info; + next; + } + + if (defined($path)) { + # Look for key = value in section, must be preceded by whitespace + undef($key); + if ($line =~ /^\s+(\w+)\s*=\s*(.*)/) { + # quoted name followed by a colon followed by an action + $key = $1; + $value = $2; + $info->{$key} = $value; + } + } + } + return $install_info; +} + +# Formerly the installation info was written as an ini style +# file, a section for files and a section for directories. +# Everything in the file was meant to be removed upon uninstall. +# +# Returns an install info style hash table (see parse_install_info) +sub parse_old_cleanup +{ + my ($text) = @_; + my ($install_info, @lines, $line, $section, $info, $path); + + $install_info = {}; + @lines = split(/\n/, $text); + + foreach $line (@lines) { + $line =~ s/#.*//; # nuke comments + $line =~ s/^\s+//; # strip leading whitespace + $line =~ s/\s+$//; # strip trailing whitespace + next if !$line; # skip blank lines + + # Look for section markers + if ($line =~ /^\s*\[\s*(\w+)\s*\]\s*$/) { + $section = $1; + next; + } + + # Must be path name + $path = $line; + $info = {}; + $install_info->{$path} = $info; + $info->{'uninstall_action'} = 'remove'; + if ($section eq 'files') { + $info->{'type'} = 'file'; + } elsif ($section eq 'directories') { + $info->{'type'} = 'dir'; + } else { + die "unknown cleanup section = \"$section\"\n"; + } + } + return $install_info; +} + +# Get the contents of the old cleanup file +sub read_old_cleanup +{ + my ($path) = @_; + my ($text); + + $text = read_file($path); + return parse_old_cleanup($text); +} + +# Get the contents of an install info file +sub read_install_info +{ + my ($path) = @_; + my ($text); + + $text = read_file($path); + return parse_install_info($text); +} + +# Get the contents of installation info from a directory. +# Supports both the new install info format and the older +# cleanup format. First checks for the presence of the newer +# install info format file, if that's absent reads the older +# cleanup format but returns it as the new install info hash table. +sub read_install_info_from_dir +{ + my ($dir) = @_; + my ($path); + + $path = "${dir}/${install_info_basename}"; + if (-e $path) { + return read_install_info($path); + } + + $path = "${dir}/${cleanup_basename}"; + if (-e $path) { + return read_old_cleanup($path); + } + + return undef; +} + +# Give an install info hash table writes it formated as a +# "Installation Manifest" into specified directory under +# the name $install_info_basename +# +# Returns pathname of manifest if successful, undef otherwise. +sub write_install_info_to_dir +{ + my ($dir, $install_info) = @_; + my ($path, $formatted); + + if (! defined($dir)) { + emit("Cannot write installation manifest, directory unspecified", "error"); + return undef; + } + + if (! defined($install_info_basename)) { + emit("Cannot write installation manifest, file basename unspecified", "error"); + return undef; + } + + if (! -e $dir) { + emit("Cannot write installation manifest, directory ($dir) does not exist", "error"); + return undef; + } + + if (! -d $dir) { + emit("Cannot write installation manifest, directory ($dir) is not a directory", "error"); + return undef; + } + + if (! -w $dir) { + emit("Cannot write installation manifest, directory ($dir) is not writable", "error"); + return undef; + } + + $path = "${dir}/${install_info_basename}"; + $formatted = format_install_info($install_info); + write_file($path, \$formatted); + + return $path; +} + +# Given an Installation Manifest (e.g. install_info) remove the items in +# the manifest marked for removal. +# +# 1) Remove all files and symlinks we created. +# +# 2) Attempt to remove all directories we created, even if they are non-empty. +# +sub uninstall +{ + my ($install_info) = @_; + my ($result, @paths, @filtered_paths, $path, @dirs); + + $result = 1; + + @paths = sort(keys %$install_info); + + # Get a list of files marked for removal. + @filtered_paths = grep {my ($info) = $install_info->{$_}; + ($info->{'type'} eq 'file' || $info->{'type'} eq 'symlink') && + $info->{'install_action'} ne 'remove' && + $info->{'uninstall_action'} eq 'remove'} @paths; + # Remove the files + if (@filtered_paths) { + foreach $path (@filtered_paths) { + $result = 0 if !remove_file($path); + } + } + + # Get a list of directories marked for removal. + @filtered_paths = grep {my ($info) = $install_info->{$_}; + $info->{'type'} eq 'dir' && + $info->{'uninstall_action'} eq 'remove'} @paths; + + # We need to removed directories starting at the deepest level + # and progressively work upward, otherwise the directory might + # not be empty. To accomplish this we sort the directory array + # based on the number of path components. + + # Primary sort by number of path components, longest first. + # When the number of path components is the same the secondary sort + # is lexical string comparision. + @dirs = sort {my ($r, @a, @b); + @a = split("/", $a); + @b = split("/", $b); + $r = @b <=> @a; + $r == 0 ? $a cmp $b : $r} @filtered_paths; + + foreach $path (@dirs) { + $result = 0 if !remove_directory($path, 1); + } + + return $result; +} + +############################################################## +# Generic "platform" Subroutines +############################################################## + +# no args +# return 1 - true, or +# return 0 - false +sub is_Windows +{ + if (($^O eq "Windows_NT") || ($^O eq "MSWin32")) { + return 1; + } + + return 0; +} + + +# no args +# return 1 - true, or +# return 0 - false +sub is_Linux +{ + if ($^O eq "linux") { + return 1; + } + + return 0; +} + + +# no args +# return 1 - true, or +# return 0 - false +sub is_Fedora +{ + if (is_Linux() && (-e "/etc/fedora-release")) { + return 1; + } + + return 0; +} + + +# no args +# return 1 - true, or +# return 0 - false +sub is_RHEL { + if ((! is_Fedora()) && (-e "/etc/redhat-release")) { + return 1; + } + + return 0; +} + + +# no args +# return 1 - true, or +# return 0 - false +sub is_RHEL4 { + if (is_RHEL()) { + my $releasefd = new FileHandle; + if ($releasefd->open("< /etc/redhat-release")) { + while (defined(my $line = <$releasefd>)) { + if ($line =~ /Nahant/i) { + return 1; + } + } + } + } + + return 0; +} + +# no args +# return release_number +# return 0 if not found +sub fedora_release { + my $releasefd = new FileHandle; + if ($releasefd->open("< /etc/fedora-release")) { + while (defined(my $line = <$releasefd>)) { + if ($line =~ /Fedora release (\d*)/) { + return $1; + } + } + } + return 0; +} + + +# no args +# no return value +sub setup_platform_dependent_parameters +{ + # Setup path separators, et. al., based upon platform + if (is_Windows()) { + $lib_prefix = ""; + $obj_ext = ".dll"; + $path_sep = ";"; + $tmp_dir = "c:\\temp"; + } elsif ($^O eq "hpux") { + $lib_prefix = "lib"; + $obj_ext = ".sl"; + $path_sep = ":"; + $tmp_dir = "/tmp"; + } else { + $lib_prefix = "lib"; + $obj_ext = ".so"; + $path_sep = ":"; + $tmp_dir = "/tmp"; + } + + return; +} + + +# Takes an array reference containing a list of paths. +# Any item in the list which is undefined will be ignored. +# no return value +sub set_library_path +{ + my ($paths) = @_; + my ($path); + + $path = join($path_sep, grep(defined($_), @$paths)); + + if (is_Windows()) { + $ENV{'PATH'} = $path; + } elsif ($^O eq "hpux") { + $ENV{'SHLIB_PATH'} = $path; + } else { + $ENV{'LD_LIBRARY_PATH'} = $path; + } + + return; +} + + +# no args +# return Library Path Environment variable +sub get_library_path +{ + if (is_Windows()) { + return $ENV{'PATH'}; + } elsif ($^O eq "hpux") { + return $ENV{'SHLIB_PATH'}; + } else { + return $ENV{'LD_LIBRARY_PATH'}; + } +} + + +############################################################## +# Generic "identity" Subroutines +############################################################## + +# no args +# return 1 - success, or +# return 0 - failure +sub check_for_root_UID +{ + my $result = 0; + + # On Linux/UNIX, insure that this script is being run as "root"; + # First check the "Real" UID, and then check the "Effective" UID. + if (!is_Windows()) { + if (($< != $ROOTUID) && + ($> != $ROOTUID)) { + emit("This script must be run as root!\n", "error"); + $result = 0; + } else { + # Success -- running script as root + $result = 1; + } + } else { + emit("Root UID makes no sense on Windows machines!\n", "error"); + $result = 0; + } + + return $result; +} + + +# return 1 - exists, or +# return 0 - DOES NOT exist +sub user_exists +{ + my ($username) = @_; + + return defined(getpwnam($username)); +} + + +# Return 1 if success, 0 if failure +sub create_user +{ + my ($username, $groupname) = @_; + my $command; + + emit(sprintf("create_user(%s)\n", join(", ", @_)), "debug"); + + return 1 if $dry_run; + + if (($username eq $PKI_USER) && + ($groupname eq $PKI_GROUP)) { + # Attempt to create $PKI_USER with $PKI_UID + emit("create_user(): Adding default PKI user '$username' " + . "(uid=$PKI_UID) to '/etc/passwd'.\n", "debug"); + if ($^O eq "linux") { + $command = "/usr/sbin/useradd " + . "-g $groupname " + . "-d /usr/share/pki " + . "-s /sbin/nologin " + . "-c 'Certificate System' " + . "-u $PKI_UID " + . "-r " + . $username; + } elsif ($^O eq "solaris") { + $command = "/usr/sbin/useradd " + . "-g $groupname " + . "-d /usr/share/pki " + . "-s /bin/false " + . "-c 'Certificate System' " + . "-u $PKI_UID " + . $username; + } else { + $command = "/usr/sbin/useradd " + . "-g $groupname " + . "-d /usr/share/pki " + . "-s '' " + . "-c 'Certificate System' " + . "-u $PKI_UID " + . $username; + } + } else { + # Attempt to create $username with random UID + emit("create_user(): Adding default PKI user '$username' " + . "(uid=random) to '/etc/passwd'.\n", "debug"); + if ($^O eq "linux") { + $command = "/usr/sbin/useradd " + . "-g $groupname " + . "-d /usr/share/pki " + . "-s /sbin/nologin " + . "-c 'Certificate System' " + . $username; + } elsif ($^O eq "solaris") { + $command = "/usr/sbin/useradd " + . "-g $groupname " + . "-d /usr/share/pki " + . "-s /bin/false " + . "-c 'Certificate System' " + . $username; + } else { + $command = "/usr/sbin/useradd " + . "-g $groupname " + . "-d /usr/share/pki " + . "-s '' " + . "-c 'Certificate System' " + . $username; + } + } + + return 0 if !run_command($command); + return user_exists($username); +} + + +# return 1 - exists, or +# return 0 - DOES NOT exist +sub group_exists +{ + my ($groupname) = @_; + + return defined(getgrnam($groupname)); +} + + +# Return 1 if success, 0 if failure +sub create_group +{ + my ($groupname) = @_; + my $command; + + emit(sprintf("create_group(%s)\n", join(", ", @_)), "debug"); + + return 1 if $dry_run; + + if ($groupname eq $PKI_GROUP) { + # Attempt to create $PKI_GROUP with $PKI_GID + emit("Adding default PKI group '$groupname' " + . "(gid=$PKI_GID) to '/etc/group'.\n", "debug"); + if ($^O eq "linux") { + $command = "/usr/sbin/groupadd " + . "-g $PKI_GID " + . "-r " + . $groupname; + } elsif ($^O eq "solaris") { + $command = "/usr/sbin/groupadd " + . "-g $PKI_GID " + . $groupname; + } else { + $command = "/usr/sbin/groupadd " + . "-g $PKI_GID " + . $groupname; + } + } else { + # Attempt to create $groupname with random GID + emit("Adding default PKI group '$groupname' " + . "(gid=random) to '/etc/group'.\n", "debug"); + if ($^O eq "linux") { + $command = "/usr/sbin/groupadd " + . $groupname; + } elsif ($^O eq "solaris") { + $command = "/usr/sbin/groupadd " + . $groupname; + } else { + $command = "/usr/sbin/groupadd " + . $groupname; + } + } + + return 0 if !run_command($command); + return group_exists($groupname); +} + + +# return 1 - disallows shell, or +# return 0 - allows shell +sub user_disallows_shell +{ + my ($username) = @_; + + my $result = 0; + my $sans_shell = ""; + + if ($^O eq "linux") { + $sans_shell="/sbin/nologin"; + $result = 0; + } elsif ($^O eq "solaris") { + $sans_shell="/bin/false"; + $result = 0; + } else { + $sans_shell=""; + return 1; + } + + if (!user_exists($username)) { + return $result; + } + + my ($name, $passwd, $uid, $gid, $quota, + $comment, $gcos, $dir, $shell, $expire) = getpwnam($username); + + if (!$shell) { + $result = 1; + } elsif ($shell eq $sans_shell) { + $result = 1; + } else { + # issue a warning and continue + emit("WARNING: Potential security hole - user '$username' is\n" + . " using '$shell' instead of '$sans_shell'!\n", "warning"); + } + + return $result; +} + + +# return 1 - is a member, or +# return 0 - is NOT a member +sub user_is_a_member_of_group +{ + my ($username, $groupname) = @_; + + return 0 if !user_exists($username); + return 0 if !group_exists($groupname); + + # The members list returned by getgrname may not contain the user's primary group. + # This is OS dependent and is typically the case when the primary gid is a + # "user private group". Therefore testing the group member list is insufficient, + # we must also test the primary group. + my ($pw_name, $pw_passwd, $pw_uid, $pw_gid) = getpwnam($username); + if (defined $pw_gid) { + my $primary_groupname = getgrgid($pw_gid); + + return 1 if $primary_groupname eq $groupname; + } + + # Now get the list of users in the specified group + # and test to see if the specified user is in that list. + my ($gr_name, $gr_passwd, $gr_gid, $gr_members) = getgrnam($groupname); + for my $member (split(' ', $gr_members)) { + return 1 if $member eq $username; + } + + return 0; +} + + +# return 1 - success, or +# return 0 - failure +sub add_user_as_a_member_of_group +{ + my ($username, $groupname) = @_; + + my $command = ""; + my $result = 0; + + emit(sprintf("add_user_as_a_member_of_group(%s)\n", join(", ", @_)), "debug"); + + return 1 if $dry_run; + + return 0 if !user_exists($username); + return 0 if !group_exists($groupname); + return 1 if user_is_a_member_of_group($username, $groupname); + + # Attempt to add user to be a member of group + emit("Adding user '$username' to be a member of group " + . "'$groupname'.\n", "debug"); + if ($^O eq "linux") { + $command = "/usr/sbin/usermod " + . "-G $groupname " + . $username; + } elsif ($^O eq "solaris") { + $command = "/usr/sbin/usermod " + . "-G $groupname " + . $username; + } else { + $command = "/usr/sbin/usermod " + . "-G $groupname " + . $username; + } + + return 0 if !run_command($command); + return user_is_a_member_of_group($username, $groupname); +} + + +# return UID, or +# return (-1) - user is not in password file +sub get_UID_from_username +{ + my ($username) = @_; + + my ($name, $passwd, $uid) = getpwnam($username); + + return $uid if defined($uid); + return (-1); + } + + +# Return fully-qualified domain name (FQDN) given +# either a hostname or an IP address +sub get_FQDN +{ + my ($addr) = @_; + + if (!$is_IPv6) { + if ($addr !~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { + # Retrieve FQDN via a "mnemonic" hostname + ($fqdn) = gethostbyname($addr); + } else { + # Retrieve FQDN via a "4-tuple" IP address + $fqdn = gethostbyaddr(pack('C4', $1, $2, $3, $4), 2); + } + } else { + # IPv6: Don't rely upon "Socket6.pm" being present! + $fqdn = $addr; + } + + return($fqdn); +} + + +############################################################## +# Generic "availability" Subroutines +############################################################## + +# return 1 - URL prefix is known (success) +# return 0 - URL prefix is unknown (failure) +sub check_for_valid_url_prefix +{ + my ($url_prefix) = @_; + + if (($url_prefix eq $FILE_PREFIX) || + ($url_prefix eq $FTP_PREFIX) || + ($url_prefix eq $HTTP_PREFIX) || + ($url_prefix eq $HTTPS_PREFIX) || + ($url_prefix eq $LDAP_PREFIX) || + ($url_prefix eq $LDAPS_PREFIX)) { + return 1; + } + + return 0; +} + +# return 1 - ports are valid (success) +# return 0 - ports have a conflict (failure) +sub AreConnectorPortsValid +{ + # parse parameters + my ($secure_port, $unsecure_port, $agent_secure_port, + $ee_secure_port, $admin_secure_port, $proxy_secure_port, + $proxy_unsecure_port, $ajp_port) = @_; + + + if ($secure_port == -1 && $agent_secure_port == -1) + { + return 0; + } + + if ($secure_port >= 0 && $agent_secure_port >= 0) + { + return 0; + } + + if ($secure_port >= 0) + { + if ($secure_port == $unsecure_port) + { + return 0; + } + return 1; + } + + if (!portsUnique($agent_secure_port,$ee_secure_port, $admin_secure_port, $proxy_secure_port, + $proxy_unsecure_port, $ajp_port)) { + return 0; + } + + return 1; + +} + +#return 1 - if non-negative ports are uique +#return 0 - otherwise (failure) +sub portsUnique +{ + my @ports = sort @_; + my $last_port = -1; + for my $port (@ports) { + next if ($port < 0); + if ($port == $last_port) { + return 0; + } + $last_port = $port; + } + return 1; +} + +# return 1 - port is available (success) +# return 0 - port is unavailable; report an error (failure) +sub IsLocalPortAvailable +{ + # parse parameters + my ($user, $port) = @_; + + # On Linux/UNIX, check well-known/reserved ports + if (!is_Windows()) { + my $uid = -1; + + # retrieve the UID given the username + $uid = get_UID_from_username($user); + if ($uid == -1) { + emit("User '$user' is NOT in the password file!\n", "error"); + return 0; + } + + # insure that well-known ports cannot be used by a non-root user + if (($port <= $MAX_WELL_KNOWN_PORT) && ($uid != $ROOTUID)) { + emit("User '$user' is not allowed to bind to well-known " + . "port $port!\n", "error"); + return 0; + } + + # insure that reserved ports cannot be used by a non-root user + if (($port <= $MAX_RESERVED_PORT) && ($uid != $ROOTUID)) { + emit("User '$user' is not allowed to bind to reserved " + . "port $port!\n", "error"); + return 0; + } + + # insure that the user has not specified a port greater than + # the number of dynamic/private ports + if ($port > $MAX_DYNAMIC_PORT) { + emit("User '$user' is not allowed to bind to a " + . "port greater than $MAX_DYNAMIC_PORT!\n", "error"); + return 0; + } + + # if the user has specified a port greater than the number + # of registered ports, issue a warning and continue + if ($port > $MAX_REGISTERED_PORT) { + emit("WARNING: User '$user' is binding to port $port; use of " + . "a dynamic/private port is discouraged!\n", "warning"); + } + } + + # initialize local variables + my $rv = 0; + my $status = "AVAILABLE"; + + # make a local TCP server socket + my $proto = getprotobyname('tcp'); + socket(SERVER, PF_INET, SOCK_STREAM, $proto); + + # create a local server socket address + my $server_address = sockaddr_in($port, INADDR_ANY); + + # attempt to bind this local server socket + # to this local server socket address + bind(SERVER, $server_address) or $status = $!; + + # identify the status of this attempt to bind + if ($status eq "AVAILABLE") { + # this port is inactive + $rv = 1; + } elsif ($status eq "Address already in use") { + emit("Unable to bind to local port $port : $status\n", "error"); + $rv = 0; + } else { + emit("Unable to bind to local port $port : $status\n", "error"); + $rv = 0; + } + + # close local server socket + close(SERVER); + + # return result + return $rv; +} + + +# return 2 - warn that server is unreachable (continue) +# return 1 - server is reachable (success) +# return 0 - server is unreachable; report an error (failure) +sub IsServerReachable +{ + # parse parameters + my ($prefix, $host, $port) = @_; + + # check the validity of the prefix + my $result = 0; + + $result = check_for_valid_url_prefix($prefix); + if (!$result) { + emit("Specified unknown url prefix '$prefix'!\n", "error"); + return $result; + } + + # create a URL from the passed-in parameters + my $url = $prefix . $host . ":" . $port; + + # initialize the state of the Server referred to by this URL + my $rv = 0; + my $status = "ACTIVE"; + + # retrieve the remote host IP address + my $iaddr = inet_aton($host) or $status = $!; + if ($status ne "ACTIVE") { + emit("Unable to contact the Server at '$url' ($status)", "error"); + return $rv; + } + + # create a remote server socket address + my $server_address = sockaddr_in($port, $iaddr); + + # make a local TCP client socket + my $proto = getprotobyname('tcp'); + socket(CLIENT, PF_INET, SOCK_STREAM, $proto); + + # attempt to connect this local client socket + # to the remote server socket address + connect(CLIENT, $server_address) or $status = $!; + + # identify the status of this connection + if ($status eq "ACTIVE") { + # this '$host:$port' is reachable + $rv = 1; + } else { + emit("WARNING: Unable to contact the Server at '$url' ($status)", "warning"); + } + + # close local client socket + close(CLIENT); + + # return result + return $rv; +} + + +############################################################## +# Generic "time" Subroutines +############################################################## + +# no args +# return time stamp +sub get_time_stamp +{ + my ($sec, $min, $hour, $mday, + $mon, $year, $wday, $yday, $isdst) = localtime(time); + + my $stamp = sprintf "%4d-%02d-%02d %02d:%02d:%02d", + $year+1900, $mon+1, $mday, $hour, $min, $sec; + + return $stamp; +} + + +############################################################## +# Generic "random" Subroutines +############################################################## + +# return random number between low & high +sub generate_random +{ + my ($low, $high) = @_; + + my $number = 0; + + if ($low >= $high || $low < 0 || $high < 0) { + return -1; + } + + $number = int(rand($high -$low +1)) + $low; + + return $number; +} + + +# return random string of specified length +sub generate_random_string +{ + my ($length_of_randomstring) = @_; + + my @chars=('a'..'z','A'..'Z','0'..'9'); + my $random_string; + + foreach (1..$length_of_randomstring) { + $random_string .= $chars[rand @chars]; + } + + return $random_string; +} + + +############################################################## +# Generic "password" Subroutines +############################################################## + +# return 1 - success +# return 0 - failure; report an error +sub password_quality_checker +{ + my ($password) = @_; + my ($i, $letter); + + # Test #1: $password MUST be > 8 characters + if (length($password) < 8) { + print("\n"); + print("Password entered is less than 8 characters. Try again.\n"); + return 0; + } + + + # Test #2: $password MUST contain at least one non-alphabetic character + my @alphabet = ("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", + "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", + "U", "V", "W", "X", "Y", "Z", "a", "b", "c", "d", + "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", + "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", + "y", "z"); + + my $non_alphabetic_characters = 0; + for ($i = 0; $i < length($password); $i++) { + # always reset character type + my $found_alphabetic_character = 0; + + # extract the next character from the $password + my $character = substr($password, $i, 1); + + # check to see if this character is "alphabetic" + for $letter (@alphabet) { + if ($character eq $letter) { + $found_alphabetic_character = 1; + last; + } + } + + # keep a count of "non-alphabetic" characters + if ($found_alphabetic_character == 0) { + $non_alphabetic_characters++; + } + } + + # pass Test #2 if the $password contains any "non-alphabetic" characters + if ($non_alphabetic_characters > 0) { + return 1; + } else { + print("\n"); + print("Password entered contains 0 non-alphabetic characters. " + . "Try again.\n"); + return 0; + } +} + + +############################################################## +# Generic "LDAP" Subroutines +############################################################## + +# hostname - LDAP server name or IP address (default: localhost) +# port - LDAP server TCP port number (default: 389) +# password - bind passwd (for simple authentication) +# file - read modifications from file (default: standard input) +# no return value +sub LDAP_add +{ + my ($tokendb_hostname, $tokendb_port, $tokendb_password, $file) = @_; + + my $command = ""; + + my $original_library_path = get_library_path(); + + emit(sprintf("LDAP_add(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + $command = "$default_ldapmodify_command " + . "-h '$tokendb_hostname' " + . "-p '$tokendb_port' " + . "-D 'cn=directory manager' " + . "-w '$tokendb_password' " + . "-a " + . "-f '$file'"; + + system($command); + + set_library_path([$original_library_path]); + + return; +} + + +# hostname - LDAP server name or IP address (default: localhost) +# port - LDAP server TCP port number (default: 389) +# password - bind passwd (for simple authentication) +# file - read modifications from file (default: standard input) +# no return value +sub LDAP_modify +{ + my ($tokendb_hostname, $tokendb_port, $tokendb_password, $file) = @_; + + my $command = ""; + + my $original_library_path = get_library_path(); + + emit(sprintf("LDAP_modify(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + $command = "$default_ldapmodify_command " + . "-h '$tokendb_hostname' " + . "-p '$tokendb_port' " + . "-D 'cn=directory manager' " + . "-w '$tokendb_password' " + . "-f '$file'"; + + system($command); + + set_library_path([$original_library_path]); + + return; +} + + +############################################################## +# Generic "Security Databases" Subroutines +############################################################## + +# instance path - Security databases directory (default is ~/.netscape) +# password file - Specify the password file +# no return value +sub certutil_create_databases +{ + my ($instance_path, $pwdfile) = @_; + + my $command = ""; + + my $original_library_path = get_library_path(); + + emit(sprintf("certutil_create_databases(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + if (!$pwdfile) { + $command = "$default_certutil_command " + . "-N " + . "-d $instance_path"; + } else { + $command = "$default_certutil_command " + . "-N " + . "-d $instance_path " + . "-f $pwdfile"; + } + + system($command); + + set_library_path([$original_library_path]); + + return; +} + + +# instance path - Security databases directory (default is ~/.netscape) +# token - Name of token in which to look for cert (default is internal, +# use "all" to look for cert on all tokens) +# nickname - The nickname of the cert to delete +# no return value +sub certutil_delete_cert +{ + my ($instance_path, $token, $nickname) = @_; + + my $command = ""; + + my $original_library_path = get_library_path(); + + emit(sprintf("certutil_delete_cert(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + $command = "$default_certutil_command " + . "-D " + . "-d $instance_path " + . "-h '$token' " + . "-n '$nickname'"; + + system($command); + + set_library_path([$original_library_path]); + + return; +} + + +# instance path - Security databases directory (default is ~/.netscape) +# token - Name of token in which to generate key (default is internal) +# subject - Specify the subject name (using RFC1485) +# password file - Specify the password file +# no return value +sub certutil_generate_CSR +{ + my ($instance_path, $token, $subject, $pwdfile) = @_; + + my $command = ""; + + my $original_library_path = get_library_path(); + + emit(sprintf("certutil_generate_CSR(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + if (!$pwdfile) { + $command = "$default_certutil_command " + . "-R " + . "-d $instance_path " + . "-h '$token' " + . "-s '$subject' " + . "-a"; + } else { + $command = "$default_certutil_command " + . "-R " + . "-d $instance_path " + . "-h '$token' " + . "-s '$subject' " + . "-a " + . "-f $pwdfile"; + } + + system($command); + + set_library_path([$original_library_path]); + + return; +} + + +# instance path - Security databases directory (default is ~/.netscape) +# token - Name of token in which to store the certificate +# (default is internal) +# serial number - Cert serial number +# validity period - Months valid (default is 3) +# subject - Specify the subject name (using RFC1485) +# issuer name - The nickname of the issuer cert +# nickname - Specify the nickname of the server certificate +# trust args - Set the certificate trust attributes: +# p valid peer +# P trusted peer (implies p) +# c valid CA +# T trusted CA to issue client certs (implies c) +# C trusted CA to issue server certs (implies c) +# u user cert +# w send warning +# g make step-up cert +# noise file - Specify the noise file to be used +# (to introduce randomness during key generation) +# password file - Specify the password file +# no return value +sub certutil_generate_self_signed_cert +{ + my ($instance_path, $token, $serial_number, $validity_period, + $subject, $issuer_name, $nickname, $trustargs, $noise_file, + $pwdfile) = @_; + + my $command = ""; + + my $original_library_path = get_library_path(); + + emit(sprintf("certutil_generate_self_signed_cert(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + if (!$pwdfile) { + $command = "$default_certutil_command " + . "-S " + . "-d $instance_path " + . "-h '$token' " + . "-m $serial_number " + . "-v $validity_period " + . "-x " + . "-s '$subject' " + . "-c '$issuer_name' " + . "-n '$nickname' " + . "-t '$trustargs' " + . "-z $noise_file " + . "> /dev/null " + . "2>&1"; + } else { + $command = "$default_certutil_command " + . "-S " + . "-d $instance_path " + . "-h '$token' " + . "-f $pwdfile " + . "-m $serial_number " + . "-v $validity_period " + . "-x " + . "-s '$subject' " + . "-c '$issuer_name' " + . "-n '$nickname' " + . "-t '$trustargs' " + . "-z $noise_file " + . "> /dev/null " + . "2>&1"; + } + + system($command); + + set_library_path([$original_library_path]); + + return; +} + + +# instance path - Security databases directory (default is ~/.netscape) +# token - Name of token in which to store the certificate +# (default is internal) +# nickname - Specify the nickname of the server certificate +# trust args - Set the certificate trust attributes: +# p valid peer +# P trusted peer (implies p) +# c valid CA +# T trusted CA to issue client certs (implies c) +# C trusted CA to issue server certs (implies c) +# u user cert +# w send warning +# g make step-up cert +# (e. g. - Server Cert 'u,u,u', CA Cert 'CT,CT,CT') +# cert - The certificate encoded in ASCII (RFC1113) +# no return value +sub certutil_import_cert +{ + my ($instance_path, $token, $nickname, $trustargs, $cert) = @_; + + my $original_library_path = get_library_path(); + + emit(sprintf("certutil_import_cert(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + open(F, + "|$default_certutil_command " + . "-A " + . "-d $instance_path " + . "-h '$token' " + . "-n '$nickname' " + . "-t '$trustargs' " + . "-a"); + print(F $cert); + close(F); + + set_library_path([$original_library_path]); + + return; +} + + +# instance path - Security databases directory (default is ~/.netscape) +# token - Name of token in which to look for cert (default is internal, +# use "all" to look for cert on all tokens) +# nickname - Pretty print named cert (list all if unspecified) +# no return value +sub certutil_print_cert +{ + my ($instance_path, $token, $nickname) = @_; + + my $command = ""; + + my $original_library_path = get_library_path(); + + emit(sprintf("certutil_print_cert(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + if ($token) { + # Raidzilla Bug #57616 - certutil is not being consistent, nickname + # requires token name for no reason. + $command = "$default_certutil_command " + . "-L " + . "-d $instance_path " + . "-h '$token' " + . "-n '$token:$nickname'"; + } else { + $command = "$default_certutil_command " + . "-L " + . "-d $instance_path " + . "-h '$token' " + . "-n '$nickname'"; + } + + system($command); + + set_library_path([$original_library_path]); + + return; +} + + +# no return value +# instance path - Security databases directory (default is ~/.netscape) +# token - Name of token in which to look for certs (default is internal, +# use "all" to list certs on all tokens) +sub certutil_list_certs +{ + my ($instance_path, $token) = @_; + + my $command = ""; + + my $original_library_path = get_library_path(); + + emit(sprintf("certutil_list_certs(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + $command = "$default_certutil_command " + . "-L " + . "-d $instance_path " + . "-h '$token'"; + + system($command); + + set_library_path([$original_library_path]); + + return; +} + + +# instance path - Security databases directory (default is ~/.netscape) +# token - Add the named token to the module database +# library - The name of the file (.so or .dll) containing the +# implementation of PKCS #11 +# no return value +sub modutil_add_token +{ + my ($instance_path, $token, $library) = @_; + + my $command = ""; + + my $original_library_path = get_library_path(); + + emit(sprintf("modutil_add_token(%s)\n", join(", ", @_)), "debug"); + + return if $dry_run; + + set_library_path([$default_security_libraries, + $default_system_user_libraries, + $default_system_libraries, + $original_library_path]); + + $command = "$default_modutil_command " + . "-force " + . "-dbdir $instance_path " + . "-add $token " + . "-libfile $library " + . "-nocertdb"; + + system("$command > /dev/null 2>&1"); + + set_library_path([$original_library_path]); + + return; +} + + +############################################################## +# Generic "logging" Subroutines +############################################################## + +# Return 1 if success, 0 if failure +sub open_logfile +{ + my ($path, $permissions, $owner, $group) = @_; + + + $logfd = FileHandle->new("> $path"); + + if (defined($logfd)) { + $logfile_path = $path; + } else { + return 0; + } + + if (defined($permissions)) { + return 0 if !set_permissions($logfile_path, $permissions); + } + + if (defined($owner) && defined($group)) { + return 0 if !set_owner_group($logfile_path, $owner, $group); + } + + return 1; +} + +# no return value +sub get_logfile_path +{ + return $logfile_path; +} + +# no return value +sub close_logfile +{ + if (defined($logfd)) { + $logfd->close(); + } + + $logfd = undef; + return; +} + + +############################################################## +# Generic "response" Subroutines +############################################################## + +# return answer +sub prompt +{ + my ($promptStr) = @_; + + my $answer = ""; + + print(STDOUT "$promptStr "); + + $| = 1; + $answer = <STDIN>; + + chomp $answer; + + print(STDOUT "\n"); + + return $answer; +} + + +############################################################## +# Generic "reply" Subroutines +############################################################## + +# no return value +sub printFile +{ + my ($fileHandle) = @_; + + while (<$fileHandle>) { + my $line = $_; + chomp($line); + print(STDOUT "$line\n"); + } + + return; +} + + +# no return value +sub emit +{ + my ($string, $type) = @_; + + my $force_emit = 0; + my $log_entry = ""; + + $type = "debug" if !defined($type); + + if ($type eq "error" || $type eq "warning" || $type eq "info") { + $force_emit = 1; + } + + return if !$string; + + chomp($string); + my $stamp = get_time_stamp(); + + if ($verbose || $force_emit) { + # print to stdout + if ($type ne "log") { + print(STDERR "[$type] $string\n"); + } + } + + # If a log file exists, write all types + # ("debug", "error", "info", or "log") + # to this specified log file + if (defined($logfd)) { + $log_entry = "[$stamp] [$type] $string\n"; + $logfd->print($log_entry); + } + + return; +} + + +############################################################## +# Generic "validity" Subroutines +############################################################## + +# return 1 - valid, or +# return 0 - invalid +sub is_path_valid +{ + my ($path) = @_; + + my @pathname = split("/", $path); + + shift @pathname unless $pathname[0]; + + my $valid = 0; + my $split_path; + + foreach $split_path (@pathname) { + chomp($split_path); + + if (!($split_path !~ /^[-_.a-zA-Z0-9\[\]\@]+$/)) { + $valid = 1; + } else { + $valid = 0; + last; + } + } + + return $valid; +} + + +# return 1 - valid, or +# return 0 - invalid +sub is_name_valid +{ + my ($name) = @_; + + my $result = 0; + + if (!($name !~ /^[-_.a-zA-Z0-9]+$/)) { + $result = 1; + } + + return $result; +} + + +############################################################## +# Generic "entity" Subroutines +############################################################## + +# return type of entity +sub entity_type +{ + my ($entity) = @_; + + if (-b $entity) { + return "block special file"; + } elsif (-c $entity) { + return "character special file"; + } elsif (-d $entity) { + return "directory"; + } elsif (-f $entity) { + if (-B $entity) { + return "binary file"; + } elsif (-T $entity) { + return "text file"; + } else { + return "plain file"; + } + } elsif (-l $entity) { + return "symbolic link"; + } elsif (-p $entity) { + return "named pipe"; + } elsif (-S $entity) { + return "socket"; + } + + return "UNKNOWN"; +} + + +# return 1 - exists, or +# return 0 - DOES NOT exist +sub entity_exists +{ + my ($entity) = @_; + + my $result = 0; + + if (-e $entity) { + my $type = entity_type($entity); + $result = 1; + } + + return $result; +} + + +############################################################## +# Generic "file" Subroutines +############################################################## + +# return 1 - exists, or +# return 0 - DOES NOT exist +sub file_exists +{ + my ($file) = @_; + + my $result = 0; + + if (-f $file) { + $result = 1; + } elsif (-e $file) { + my $type = entity_type($file); + emit("File $file DOES NOT exist because $file is a $type!\n", + "error"); + $result = 0; + } + + + return $result; +} + + +# return 1 - empty, or +# return 0 - NOT empty +sub is_file_empty +{ + my ($file) = @_; + + my $result = 0; + + if (-z $file) { + $result = 1; + } + + return $result; +} + + +# Return 1 if success, 0 if failure +sub create_empty_file +{ + my ($path, $permissions, $owner, $group, $uninstall_action) = @_; + + $uninstall_action = 'remove' unless defined($uninstall_action); + + emit(sprintf("create_empty_file(%s, %s, %s, %s, %s)\n", + $path, + defined($permissions) ? sprintf("%o", $permissions) : "", + $owner, $group, $uninstall_action), "debug"); + + add_install_info($path, 'file', $uninstall_action); + + if (!$dry_run) { + if (!open(FILE, "> $path")) { + emit("Cannot create empty file \"$path\" ($!)", 'error'); + return 0; + } + close(FILE); + } + + if (defined($permissions)) { + return 0 if !set_permissions($path, $permissions); + } + + if (defined($owner) && defined($group)) { + return 0 if !set_owner_group($path, $owner, $group); + } + + return 1; +} + + +# Return 1 if success, 0 if failure +sub create_file +{ + my ($path, $contents, $permissions, $owner, $group, $uninstall_action) = @_; + + $uninstall_action = 'remove' unless defined($uninstall_action); + + emit(sprintf("create_file(%s, %s, %s, %s, %s)\n", + $path, + defined($permissions) ? sprintf("%o", $permissions) : "", + $owner, $group, $uninstall_action), "debug"); + + add_install_info($path, 'file', $uninstall_action); + + if (!$dry_run) { + if (!open(FILE, "> $path")) { + emit("could not create file \"$path\" ($!)\n", 'error'); + return 0; + } + print(FILE $contents); + close(FILE); + } + + if (defined($permissions)) { + return 0 if !set_permissions($path, $permissions); + } + + if (defined($owner) && defined($group)) { + return 0 if !set_owner_group($path, $owner, $group); + } + + return 1; +} + + +# Return 1 if success, 0 if failure +sub copy_file +{ + my ($src_path, $dst_path, $permissions, $owner, $group, $uninstall_action) = @_; + + $uninstall_action = 'remove' unless defined($uninstall_action); + + emit(sprintf("copy_file(%s, %s, %s, %s, %s, %s)\n", + $src_path, $dst_path, + defined($permissions) ? sprintf("%o", $permissions) : "", + $owner, $group, $uninstall_action), "debug"); + + add_install_info($dst_path, 'file', $uninstall_action); + + if (!is_path_valid($src_path)) { + emit("copy_file(): illegal src path => \"$src_path\".\n", + "error"); + remove_install_info($dst_path); + return 0; + } + + if (!is_path_valid($dst_path)) { + emit("copy_file(): illegal dst path => \"$dst_path\".\n", + "error"); + remove_install_info($dst_path); + return 0; + } + + if (!$dry_run) { + if (!copy($src_path, $dst_path)) { + emit("copy_file(): \"$src_path\" => \"$dst_path\" ($!)\n", "error"); + remove_install_info($dst_path); + return 0; + } + } + + if (defined($permissions)) { + return 0 if !set_permissions($dst_path, $permissions); + } + + if (defined($owner) && defined($group)) { + return 0 if !set_owner_group($dst_path, $owner, $group); + } + + return 1; +} + + +# Return 1 if success, 0 if failure +sub remove_file +{ + my ($path) = @_; + my $result = 0; + + emit(sprintf("remove_file(%s)\n", join(", ", @_)), "debug"); + + add_install_info($path, 'file', 'remove', 'remove'); + + return 1 if $dry_run; + + if (!unlink($path)) { + emit("remove_file(): failed to remove file \"$path\" ($!)\n", "error"); + return 0; + } + + return 1; + } + +# set_permissions(path_glob, permissions) +# Return 1 if success, 0 if failure +sub set_permissions +{ + my ($path_glob, $permissions) = @_; + my (@paths, $errstr, $result, $count); + + $errstr = undef; + $count = 0; + $result = 1; + + emit(sprintf("set_permissions(%s, %s)\n", + $path_glob, + defined($permissions) ? sprintf("%o", $permissions) : ""), "debug"); + + return 1 if $dry_run; + + @paths = glob($path_glob); + + if (($count = chmod($permissions, @paths)) != @paths) { + $errstr = "$!"; + $result = 0; + emit(sprintf("failed to set permission (%o) on \"%s\" => (%s), %d out of %d failed, \"%s\"\n", + $permissions, $path_glob, "@paths", @paths - $count, @paths+0, $errstr), 'error'); + } + return $result; + } + +# set_owner_group(path_glob, owner, group) +# Return 1 if success, 0 if failure +sub set_owner_group +{ + my ($path_glob, $owner, $group) = @_; + my (@paths, $errstr, $result, $count); + my ($uid, $gid); + + $errstr = undef; + $count = 0; + $result = 1; + + emit(sprintf("set_owner_group(%s)\n", join(", ", @_)), "debug"); + + return 1 if $dry_run; + + $uid = getpwnam($owner); + $gid = getgrnam($group); + @paths = glob($path_glob); + + if (($count = chown($uid, $gid, @paths)) != @paths) { + $errstr = "$!"; + $result = 0; + emit(sprintf("failed to set ownership (%s) on \"%s\" => (%s), %d out of %d failed, \"%s\"\n", + "${owner}:${group}", $path_glob, "@paths", @paths - $count, @paths+0, $errstr), 'error'); + } + return $result; +} + +# set_file_props(path_glob, permissions, owner, group) +# Return 1 if success, 0 if failure +sub set_file_props +{ + my ($path_glob, $permissions, $owner, $group) = @_; + my (@paths, $tmp_result, $result); + + $result = 1; + + emit(sprintf("set_file_props(%s %s %s %s)\n", + $path_glob, + defined($permissions) ? sprintf("%o", $permissions) : "", + $owner, $group), "debug"); + + return 1 if $dry_run; + + $tmp_result = set_permissions($path_glob, $permissions); + $result = 0 if !$tmp_result; + + $tmp_result = set_owner_group($path_glob, $owner, $group); + $result = 0 if !$tmp_result; + + return $result; + } + + + +############################################################## +# Generic "directory" Subroutines +############################################################## + +# Callback for walk_dir(), see walk_dir() for documentation +sub walk_callback { + my ($dir, $basename, $is_dir, $prune, $opts) = @_; + + if ($is_dir) { + my ($include_dirs, $mark_dir, $add_to_list, $regexp, $regexps); + + # Don't descend into directories unless recursive. + $$prune = ! $opts->{'recursive'}; + + # If include filter is provided, basename must match + # at least one regexp in filter list. + if (defined($regexps = $opts->{'dir_includes'})) { + $add_to_list = 0; + for $regexp (@$regexps) { + if ($basename =~ /$regexp/) { + $add_to_list = 1; + last; + } + } + } else { + $add_to_list = 1; + } + + if (!$add_to_list) { + $$prune = 1; + return; + } + + # If exclude filter is provided, basename cannot match + # any regexp in filter list. + if (defined($regexps = $opts->{'dir_excludes'})) { + for $regexp (@$regexps) { + if ($basename =~ /$regexp/) { + $add_to_list = 0; + last; + } + } + } + + if (!$add_to_list) { + $$prune = 1; + return; + } + + # Are we collecting directories? + $include_dirs = $opts->{'include_dirs'} // 0; + return if ! $include_dirs; + + if ($opts->{'mark_dir'}) { + push(@{$opts->{'file_list'}}, "${dir}/${basename}/"); + } else { + push(@{$opts->{'file_list'}}, "${dir}/${basename}"); + } + } + else { + my ($include_files, $add_to_list, $regexp, $regexps); + + # If include filter is provided, basename must match + # at least one regexp in filter list. + if (defined($regexps = $opts->{'file_includes'})) { + $add_to_list = 0; + for $regexp (@$regexps) { + if ($basename =~ /$regexp/) { + $add_to_list = 1; + last; + } + } + } else { + $add_to_list = 1; + } + + return if !$add_to_list; + + # If exclude filter is provided, basename cannot match + # any regexp in filter list. + if (defined($regexps = $opts->{'file_excludes'})) { + for $regexp (@$regexps) { + if ($basename =~ /$regexp/) { + $add_to_list = 0; + last; + } + } + } + + return if !$add_to_list; + + # Are we collecting files? + $include_files = $opts->{'include_files'} // 0; + return if ! $include_files; + + push(@{$opts->{'file_list'}}, "${dir}/${basename}"); + } +} + +# Walk directory structure invoking a callback on each +# item found. Optionally prune traversal. +# +# walk_dir($dir, $callback, $prune, $user_data) +# +# dir Path of directory to examine. +# callback Pointer to callback function. +# prune Pointer to boolean variable. +# Callback can set to avoid descending into a directory. +# Ignored for non-directory callback invocations. +# opts Hash table of key/value pairs which controls execution and +# can be used to pass user values to the walk callback. +# See get_directory_files() for definitions. +# +# The signature of the callback is: +# +# callback($dir, $basename, $is_dir, $prune, $user_data) +# +# dir Current directory path. +# basename Entry in directory. +# is_dir Boolean, true if basename is a directory +# prune Pointer to boolean variable. +# Callback can set to avoid descending into a directory. +# Ignored for non-directory callback invocations. +# opts Hash table of key/value pairs which controls execution and +# can be used to pass user values to the walk callback. +# See get_directory_files() for definitions. +# +sub walk_dir { + my ($dir, $callback, $prune, $opts) = @_; + my ($basename); + + # Get the list of files in the current directory. + opendir(DIR, $dir) || (warn "Can't open $dir: $!\n", return); + my (@entries) = sort readdir(DIR); + closedir(DIR); + + foreach $basename (@entries) { + next if $basename eq '.'; + next if $basename eq '..'; + $$prune = 0; + + my $path = "${dir}/${basename}"; + if ((-d $path) && + ((! $opts->{'preserve_links'}) || (! -l $path))) { # yes it is a directory + &$callback($dir, $basename, 1, $prune, $opts); + if (!$$prune) { + walk_dir($path, $callback, $prune, $opts); + } + } + else { # not a directory + &$callback($dir, $basename, 0, $prune, $opts); + last if $$prune; + } + } +} + +# Given a directory path return a sorted array of it's contents. +# The opts parameter is a hash of key/value pairs which controls +# execution and can be used to pass user values to the walk callback. +# +# The options are: +# +# strip_dir (default = false) +# If true strip the leading $dir from returned paths, +# otherwise preserve $dir in each returned path. +# recursive (default = true) +# If true then recusively descend into each directory, +# otherwise just examine the starting directory +# preserve_links (default = true) +# If true symbolic links are preserved. +# If false symbolic links are traversed. +# include_dirs (default = false) +# If true include directories in the returned array, +# otherwise directories are omitted. +# include_files (default = true) +# If true include files in the returned array, +# otherwise files are omitted. +# mark_dir (default = false) +# If true paths which are directories (include_dirs must be true) +# are indicated by a trailing slash, otherwise the basename of +# the directory is left bare. +# +# Filtering +# +# You may specify a set of include/exclude filters on both directories and +# files. An entry will be added to the returned list if it's in the include +# list and not in the exclude list. If either the include or exclude list +# is undefined it has no effect. Each filter is an array of regular +# expressions. The basename (directory entry) is tested against the regular +# expression. For the include filter the basename must match at least one +# of the regular expressions. For the exclude filter if the basename +# matches any of the regular expressions it will be excluded. +# +# In addition if the traversal is recursive and a directory is excluded via +# filtering then that directory is not descended into during the recursive +# traversal. +# +# dir_includes (default = undef) +# Array of regular expressions. If defined a directory must match at +# least one regular expression in the array to be included. +# dir_excludes (default = undef) +# Array of regular expressions. If defined a directory will be excluded +# if it matches any regular expression in the array. +# file_includes (default = undef) +# Array of regular expressions. If defined a file must match at +# least one regular expression in the array to be included. +# file_excludes (default = undef) +# Array of regular expressions. If defined a file will be excluded +# if it matches any regular expression in the array. +# +sub get_directory_files +{ + my ($dir, $opts) = @_; + my ($strip_dir, $mark_dir, $recursive, $preserve_links, $include_dirs, $include_files); + my ($dir_includes, $dir_excludes, $file_includes, $file_excludes); + my ($files, $prune, $pat); + + $strip_dir = $opts->{'strip_dir'} // 0; + $mark_dir = $opts->{'mark_dir'} // 0; + $recursive = $opts->{'recursive'} // 1; + $preserve_links = $opts->{'preserve_links'} // 1; + $include_dirs = $opts->{'include_dirs'} // 0; + $include_files = $opts->{'include_files'} // 1; + $dir_includes = $opts->{'dir_includes'} // undef; + $dir_excludes = $opts->{'dir_excludes'} // undef; + $file_includes = $opts->{'file_includes'} // undef; + $file_excludes = $opts->{'file_excludes'} // undef; + + $files = []; + $prune = 0; + + walk_dir($dir, \&walk_callback, \$prune, + {'file_list' => $files, + 'mark_dir' => $mark_dir, + 'recursive' => $recursive, + 'preserve_links' => $preserve_links, + 'include_dirs' => $include_dirs, + 'include_files' => $include_files, + 'dir_includes' => $dir_includes, + 'dir_excludes' => $dir_excludes, + 'file_includes' => $file_includes, + 'file_excludes' => $file_excludes, + }); + + if ($strip_dir) { + $pat = "^${dir}/"; + map {s/$pat//; $_} @$files; + } + + return $files; +} + +# Normalize paths such that: +# Multiple slashes are collapsed into one slash +# Trailing slash is stripped. +# Strip "." path components. +# Strip previous path component for ".." +# Returns normalized path. +sub normalize_path +{ + my ($path) = @_; + my (@src_components, @dst_components, $component, $leading_slash, $new_path); + + $leading_slash = $path =~ m!^/! ? "/" : ""; + + @src_components = split("/", $path); + + foreach $component (@src_components) { + next if !$component; + next if $component eq "."; + if ($component eq "..") { + die "no directory component to pop \"..\" for in \"$path\"" if !@dst_components; + pop @dst_components; + next; + } + push @dst_components, $component; + } + + $new_path = join("/", @dst_components); + + return $leading_slash . $new_path; +} + +# return 1 - exists, or +# return 0 - DOES NOT exist +sub directory_exists +{ + my ($dir) = @_; + + my $result = 0; + + if (-d $dir) { + $result = 1; + } elsif (-e $dir) { + my $type = entity_type($dir); + emit("Directory $dir DOES NOT exist because $dir is a $type!\n", + "error"); + $result = 0; + } + + return $result; +} + + +# return 1 - empty, or +# return 0 - NOT empty +sub is_directory_empty +{ + my ($dir) = @_; + + my $empty = 1; + my $entity = ""; + + if (!directory_exists($dir)) { + return 1; + } + + opendir(DIR, $dir); + while (defined($entity = readdir(DIR)) && ($empty == 1)) { + if ($entity ne "." && $entity ne "..") { + # NOTE: This is not necessarily an error! + # + # my $type = entity_type("$dir/$entity"); + # emit(" Found $type $entity in directory $dir.\n", + # "debug"); + + $empty = 0; + } + } + closedir(DIR); + + return $empty; +} + + +# Return 1 if success, 0 if failure +sub create_directory +{ + my ($dir, $permissions, $owner, $group, $uninstall_action) = @_; + my $result = 1; + my $errors; + + $uninstall_action = 'remove' unless defined($uninstall_action); + + emit(sprintf("create_directory(%s, %s, %s, %s, %s)\n", + $dir, + defined($permissions) ? sprintf("%o", $permissions) : "", + $owner, $group, $uninstall_action), "debug"); + + add_install_info($dir, 'dir', $uninstall_action); + + return 1 if $dry_run; + + if (!directory_exists($dir)) { + make_path($dir, {error => \$errors}); + if (@$errors) { + my ($error, $path, $errstr); + $result = 0; + for $error (@$errors) { + ($path, $errstr) = %$error; + if ($path eq '') { + emit("create_directory(): dir=\"$dir\" \"$errstr\"\n", "error"); +} + else { + remove_install_info($path); + emit("create_directory(): dir=\"$dir\" path=\"$path\" \"$errstr\"\n", "error"); + } + } + } + } + + if ($result) { + if (defined($permissions)) { + return 0 if !set_permissions($dir, $permissions); + } + + if (defined($owner) && defined($group)) { + return 0 if !set_owner_group($dir, $owner, $group); + } + } + + return $result; +} + +# Return 1 if success, 0 if failure +sub copy_directory +{ + my ($src_dir_path, $dst_dir_path, + $dir_permissions, $file_permissions, + $owner, $group, $uninstall_action) = @_; + my($result); + my ($files, $sub_dirs, $path, $src_path, $dst_path); + + $uninstall_action = 'remove' unless defined($uninstall_action); + $result = 1; + + $src_dir_path = normalize_path($src_dir_path); + $dst_dir_path = normalize_path($dst_dir_path); + + emit(sprintf("copy_directory(%s, %s, %s, %s, %s, %s, %s)\n", + $src_dir_path, $dst_dir_path, + defined($dir_permissions) ? sprintf("%o", $dir_permissions) : "", + defined($dir_permissions) ? sprintf("%o", $dir_permissions) : "", + $owner, $group, $uninstall_action), "debug"); + + if (!is_path_valid($src_dir_path)) { + emit("copy_directory(): illegal src path => $src_dir_path.\n", + "error"); + return 0; + } + + if (!is_path_valid($dst_dir_path)) { + emit("copy_directory(): illegal dst path ($dst_dir_path)\n", "error"); + return 0; + } + + if (!directory_exists($src_dir_path)) { + # Take the case where this directory does not exist + # Just return true + emit("copy_directory(): non-existent src path ($src_dir_path)\n", "error"); + return 1; + } + + # Get list of directories under the src dir + $sub_dirs = get_directory_files($src_dir_path, + {'strip_dir' => 1, 'include_dirs' => 1, 'include_files' => 0}); + + # Get list of files under the src dir + $files = get_directory_files($src_dir_path, + {'strip_dir' => 1, 'include_dirs' => 0, 'include_files' => 1}); + + # Assure each destination directory exists + return 0 if !create_directory($dst_dir_path, + $dir_permissions, $owner, $group, $uninstall_action); + for $path (@$sub_dirs) { + $dst_path = "${dst_dir_path}/${path}"; + return 0 if !create_directory($dst_path, $dir_permissions, + $owner, $group, $uninstall_action); + } + + # Copy each file + for $path (@$files) { + $src_path = "${src_dir_path}/${path}"; + $dst_path = "${dst_dir_path}/${path}"; + + # Emulate cp's behavior with respect to symbolic links, + # symbolic links are NOT followed when copying recursively. + # During recursive copies symbolic links are recreated. + if (-l $src_path) { # src is a symbolic link + if (!copy_symlink($src_path, $dst_path, + $owner, $group, $uninstall_action)) { + $result = 0; + } + } else { # src is not a symbolic link + if (!copy_file($src_path, $dst_path, + $file_permissions, $owner, $group, $uninstall_action)) { + $result = 0; + } + } + } + + if (!$result) { + emit("copy_directory(): failed $src_dir_path => $dst_dir_path.\n", + "error"); + } + + return $result; +} + + +# Removes given directory. By default only the directory is removed and +# only if it is empty. To remove the directory and all of it's contents +# you must provide the $remove_contents parameter and set it to true, +# it defaults to false. +# +# Return 1 if success, 0 if failure +sub remove_directory +{ + my($dir, $remove_contents) = @_; + my($errors, $result); + + emit(sprintf("remove_directory(%s)\n", join(", ", @_)), "debug"); + + $remove_contents = 0 unless defined($remove_contents); + $result = 1; + + add_install_info($dir, 'dir', 'remove', 'remove'); + + return 1 if $dry_run; + + if (!is_path_valid($dir)) { + emit("remove_directory(): specified invalid directory $dir.\n", + "error"); + return 0; + } + + if ($dir eq "/") { + emit("remove_directory(): don't even think about removing root!.\n", + "error"); + return 0; + } + + if (!directory_exists($dir)) { + return 1; + } + + if ($remove_contents) { + remove_tree($dir, {error => \$errors}); + if (@$errors) { + my($error, $path, $errstr); + $result = 0; + for $error (@$errors) { + ($path, $errstr) = %$error; + if ($path eq '') { + emit("remove_directory(): tree=\"$dir\" ($errstr)\n", "error"); + } + else { + emit("remove_directory(): tree=\"$dir\" path=\"$path\" ($errstr)\n", "error"); + } + } + } + } else { + if (!rmdir($dir)) { + $result = 0; + emit("remove_directory(): dir=\"$dir\" ($!) \n", "error"); + } + } + + return $result; +} + + +# Return 1 if success, 0 if failure +sub set_owner_group_on_directory_contents +{ + my ($dir, $owner, $group, $recursive) = @_; + my ($result, $paths, $path); + + $recursive = $recursive // 1; + $result = 1; + + emit(sprintf("set_owner_group_on_directory_contents(%s)\n", join(", ", @_)), "debug"); + + return 1 if $dry_run; + + if (!$dir || !directory_exists($dir)) { + emit("set_owner_group_on_directory_contents(): invalid directory specified.\n", + "error"); + return 0; + } + + if (!$owner || !$group) { + emit("set_owner_group_on_directory_contents(): directory $dir needs a user and group!\n", + "error"); + return 0; + } + + $paths = get_directory_files($dir, {'recursive' => $recursive, + 'include_dirs' => 1}); + + for $path (@$paths) { + $result = 0 if !set_owner_group($path, $owner, $group); + } + + return $result; +} + + +############################################################## +# Generic "symbolic link" Subroutines +############################################################## + +# return 1 - exists, or +# return 0 - DOES NOT exist +sub symlink_exists +{ + my ($symlink) = @_; + + my $result = 0; + + if (-l $symlink) { + $result = 1; + } elsif (-e $symlink) { + my $type = entity_type($symlink); + emit("Symbolic link $symlink DOES NOT exist because $symlink " + . "is a $type!\n", + "error"); + $result = 0; + } + + + return $result; +} + + +# Return 1 if success, 0 if failure +sub create_symlink +{ + my ($symlink, $dst_path, $owner, $group, $uninstall_action) = @_; + + $uninstall_action = 'remove' unless defined($uninstall_action); + + emit(sprintf("create_symlink(%s)\n", join(", ", @_)), "debug"); + + add_install_info($symlink, 'symlink', $uninstall_action); + + return 1 if $dry_run; + + if (symlink_exists($symlink)) { + # delete symbolic link so that we can recreate link for upgrades + if (unlink($symlink) != 1) { + emit("create_symlink(): could not remove existing link \"$symlink\"\n", 'error'); + remove_install_info($symlink); + return 0; + } + } + + if (!is_path_valid($symlink)) { + emit("create_symlink(): invalid path \"$symlink\"\n", "error"); + remove_install_info($symlink); + return 0; + } + + if (!is_path_valid($dst_path) || !entity_exists($dst_path)) { + emit("create_symlink(): illegal dst path \"$dst_path\"\n", "error"); + remove_install_info($symlink); + return 0; + } + + if (!symlink($dst_path, $symlink)) { + emit("create_symlink(): failed \"$symlink\" => \"$dst_path\" ($!)\n", "error"); + remove_install_info($symlink); + return 0; + } + + if (defined($owner) && defined($group)) { + # The Perl Lchown package implements lchown, but it's not currently available + # as an RPM so use a system command instead. :-( + return 0 if !set_owner_group_on_symlink($symlink, $owner, $group); + } + return 1; +} + +# Return 1 if success, 0 if failure +sub copy_symlink +{ + my ($src_path, $dst_path, $owner, $group, $uninstall_action) = @_; + my ($target); + + $uninstall_action = 'remove' unless defined($uninstall_action); + + emit(sprintf("copy_symlink(%s)\n", join(", ", @_)), "debug"); + + add_install_info($dst_path, 'symlink', $uninstall_action); + + if (!is_path_valid($src_path)) { + emit("copy_symlink(): illegal src path => \"$src_path\".\n", + "error"); + remove_install_info($dst_path); + return 0; + } + + if (!is_path_valid($dst_path)) { + emit("copy_symlink(): illegal dst path => \"$dst_path\".\n", + "error"); + remove_install_info($dst_path); + return 0; + } + + if (! -l $src_path) { + emit("copy_symlink(): $src_path is not a symbolic link\n"); + return 0; + } + + return 1 if $dry_run; + + $target = readlink($src_path); + + if (!symlink($target, $dst_path)) { + emit("could not symbolically link $target dst_path", "error"); + remove_install_info($dst_path); + return 0; + } + + if (defined($owner) && defined($group)) { + return 0 if !set_owner_group_on_symlink($dst_path, $owner, $group); + } + + return 1; +} + + +# Return 1 if success, 0 if failure +sub remove_symlink +{ + my ($symlink) = @_; + my $result = 0; + + emit(sprintf("remove_symlink(%s)\n", join(", ", @_)), "debug"); + + add_install_info($symlink, 'symlink', 'remove', 'remove'); + + return 1 if $dry_run; + + if (!$symlink) { + # symlink is NULL + return 1; + } + + if (!symlink_exists($symlink)) { + return 1; + } + + if (unlink($symlink) != 1) { + emit("remove_symlink(): failed \"$symlink\" ($!)\n", "error"); + return 0; + } + + return 1; +} + + +# Return 1 if success, 0 if failure +sub set_owner_group_on_symlink +{ + my ($symlink, $owner, $group) = @_; + + emit(sprintf("set_owner_group_on_symlink(%s)\n", join(", ", @_)), "debug"); + + return 1 if $dry_run; + + if (!$symlink || !symlink_exists($symlink)) { + emit("set_owner_group_on_symlink(): invalid symbolic link specified \"$symlink\"\n", + "error"); + return 1; + } + + if (!$owner || !$group) { + emit("set_owner_group_on_symlink(): symbolic link \"$symlink\" needs a user and group!\n", + "error"); + return 0; + } + + # The Perl Lchown package implements lchown, but it's not currently available + # as an RPM so use a system command instead. :-( + return run_command("chown --no-dereference ${owner}:${group} $symlink"); +} + + +############################################################## +# Generic "chkconfig" Subroutines (Linux ONLY) +############################################################## + +if ($^O eq "linux") { + # Return 1 if success, 0 if failure + sub register_pki_instance_with_chkconfig + { + my ($pki_instance_name) = @_; + my ($command, $exit_status, $result); + + $result = 1; + $command = "/sbin/chkconfig --add $pki_instance_name"; + if (run_command($command)) { + emit("Registered '$pki_instance_name' with '/sbin/chkconfig'.\n"); + } else { + $result = 0; + emit("Failed to register '$pki_instance_name' with '/sbin/chkconfig'.\n", 'error'); + } + return $result; + } + + # Return 1 if success, 0 if failure + sub deregister_pki_instance_with_chkconfig + { + my ($pki_instance_name) = @_; + my ($command, $exit_status, $result); + + $result = 1; + $command = "/sbin/chkconfig --del $pki_instance_name"; + if (run_command($command)) { + emit("Registered '$pki_instance_name' with '/sbin/chkconfig'.\n"); + } else { + $result = 0; + emit("Failed to deregister '$pki_instance_name' with '/sbin/chkconfig'.\n", 'error'); + } + return $result; + } +} + +############################################################## +# Generic Subprocess Subroutines +############################################################## + +# Runs the supplied command in a sub-shell. The command is subject +# to shell interpretation. +# +# WARNING: Do not supply shell IO redirection in the command. +# +# Return 1 if success, 0 if failure +# +# The critical aspect of running a command is determining if the +# command succeeded or failed. The proper way to determine this is by +# checking exit status of command. Perl's subprocess mechansims are +# less than ideal. In simplicity you would want to run the subprocess, +# indpendently capture stdout & stderr, wait for termination and then +# get the exit status. However most of the mechanisms discard +# stderr. The advantages & disadvantages of each approach is nicely +# documented here: +# +# http://blog.0x1fff.com/2009/09/howto-execute-system-commands-in-perl.html +# +# Ideally we would like to capture stdout and stderr +# independently. The best way to do this is with Perl's IPC::Cmd +# package which is part of the standard Perl distribution (whose +# installation may be optional on a given system. RPM can detect our +# use of this package and force it's installation as a +# dependency). One disadvantage of IPC::Cmd is that it does not return +# the actual exit status, just an indication if it was non-zero or not +# (e.g. success). If we chose to use IPC::Cmd at a future date the +# implementation would look like this: +# +# # Note: IPC::Cmd is in the perl-IPC-Cmd RPM +# use IPC::Cmd qw[run]; +# +# my ($success, $error_code, $full_buf, $stdout_buf, $stderr_buf) = +# run(command => $cmd, verbose => 0); +# +# if (!$success) { +# my ($err_msg); +# +# $err_msg = join("", @$stderr_buf); +# chomp($err_msg); +# +# emit(sprintf("FAILED run_command(\"%s\"), output=\"%s\"\n", +# $cmd, $err_msg), "error"); +# +# return 0; +# } +# +sub run_command +{ + my ($cmd) = @_; + my ($output, $wait_status, $exit_status); + + emit(sprintf("run_command(%s)\n", join(", ", @_)), "debug"); + + return 1 if $dry_run; + + # Perl backtick only captures stdout. + # stderr goes to the existing stderr file descriptor, probably the console. + # Capture stderr along with stdout via shell redirection (e.g. 2>&1) + + $output = `$cmd 2>&1`; + $wait_status = $?; + + # The low order 8 bits of the status is the terminating signal + # for the process, the actual exit status is obtained by + # shifting the low order 8 bits out. + $exit_status = $wait_status >> 8; + + if ($exit_status != 0) { + chomp($output); + emit(sprintf("FAILED run_command(\"%s\"), exit status=%d output=\"%s\"\n", + $cmd, $exit_status, $output), "error"); + return 0; + } + + return 1; +} + +############################################################## +# Generic Java Subroutines +############################################################## + +# Given a jar's base name locate it in the file system +# using standard Java jar path for this system. +# Return the path to the jar if found, undef otherwise. +sub find_jar +{ + my($jar_name) = @_; + my($jar_dir, $jar_path); + + for $jar_dir (@default_jar_path) { + $jar_path = "$jar_dir/$jar_name"; + if (-e $jar_path) { + return $jar_path; + } + } + return undef; +} + +############################################################## +# Generic PKI Subroutines +############################################################## + +# Get parameter value(s) from CS.cfg file +# +# get_cs_cfg(config_path, search) +# +# There are 3 ways the parameters can be returned, as a string, as a +# set of variables, or as a hash table depending on the search +# parameter type. +# +# If search is string then the parameter value is returned as a string +# if it was found, otherwise if it wasn't found then undef is +# returned. +# +# If search is a reference to a hash then each key in the hash will be +# searched for and the key's value will be used as a reference to +# assign the value of the parameter to. If the key was not found then +# the reference will be assigned the value of undef. +# +# If search is reference to an array then every parameter in the +# array will be searched for and a hash will be returned with a key +# for every parameter found, the key's value is the parameter value. +# +# Examples: +# +# my ($subsystem_type, $uri, $table); +# +# # Get a single string: $subsystem_type is assigned the string "CA" +# $subsystem_type = get_cs_cfg("/etc/pki-ca/CS.cfg", "cs.type"); +# +# # Assign a set of variables: $subsystem_type and $uri are assigned +# get_cs_cfg($config_path, {"cs.type" => \$subsystem_type, +# "ee.interface.uri" => \$uri}); +# +# # Get a lookup table: +# $table = get_cs_cfg("/etc/pki-ca/CS.cfg", ["cs.type", "ee.interface.uri"]); +# # returns the hash: +# # {"cs.type" => "CA", +# # "ee.interface.uri" => "ca/ee/ca"} +# +sub get_cs_cfg +{ + my ($config_path, $search) = @_; + my ($text, $key, $value, $num_found); + + $text = read_file($config_path); + + if (ref($search) eq "HASH") { + my $num_found = 0; + while (my ($key, $ref) = each(%$search)) { + if ($text =~ /^\s*\Q$key\E\s*=\s*(.*)/m) { + $value = $1; + $$ref = $value; + $num_found += 1; + } else { + $$ref = undef; + } + } + return $num_found; + } elsif (ref($search) eq "ARRAY") { + my $result = {}; + my $keys = $search; + + foreach $key (@$keys) { + if ($text =~ /^\s*\Q$key\E\s*=\s*(.*)/m) { + $value = $1; + $result->{$key} = $value; + } + } + + return $result; + + } else { + my $result = undef; + $key = $search; + + if ($text =~ /^\s*\Q$key\E\s*=\s*(.*)/m) { + $value = $1; + $result = $value; + } + + return $result; + + } +} + +sub get_registry_initscript_name +{ + my ($subsystem_type) = @_; + my ($pki_initscript); + + if ($subsystem_type eq $CA) { + $pki_initscript = $CA_INITSCRIPT; + } elsif($subsystem_type eq $KRA) { + $pki_initscript = $KRA_INITSCRIPT; + } elsif($subsystem_type eq $OCSP) { + $pki_initscript = $OCSP_INITSCRIPT; + } elsif($subsystem_type eq $RA) { + $pki_initscript = $RA_INITSCRIPT; + } elsif($subsystem_type eq $TKS) { + $pki_initscript = $TKS_INITSCRIPT; + } elsif($subsystem_type eq $TPS) { + $pki_initscript = $TPS_INITSCRIPT; + } else { + die "unknown subsystem type \"$subsystem_type\""; + } + +} + +####################################### +# Generic selinux routines +####################################### + +sub check_selinux_port +{ + my ($setype, $seport) = @_; + + return $SELINUX_PORT_UNDEFINED if $dry_run; + + if (defined $selinux_ports{$seport}) { + if ($selinux_ports{$seport} eq $setype) { + return $SELINUX_PORT_DEFINED; + } else { + return $SELINUX_PORT_WRONGLY_DEFINED; + } + } else { + return $SELINUX_PORT_UNDEFINED; + } +} + +sub parse_selinux_ports +{ + open SM, '/usr/sbin/semanage port -l |grep tcp |sed \'s/tcp/___/g\'|sed \'s/\s//g\'|'; + while (<SM>) { + chomp($_); + my ($type, $portstr) = split /___/, $_; + my @ports = split /,/, $portstr; + foreach my $port (@ports) { + if ($port =~ /(.*)-(.*)/) { + for (my $count = $1; $count <= $2; $count++) { + $selinux_ports{$count} = $type; + } + } else { + $selinux_ports{$port} = $type; + } + } + } + close(SM); +} + +sub add_selinux_port +{ + my ($setype, $seport, $cmds_ref) = @_; + my $status = check_selinux_port($setype, $seport); + + if ($status == $SELINUX_PORT_UNDEFINED) { + if ($cmds_ref) { + $$cmds_ref .= "port -a -t $setype -p tcp $seport\n"; + } else { + my $cmd = "$semanage port -a -t $setype -p tcp $seport\n"; + if (! run_command($cmd)) { + emit("Failed to set selinux context for $seport", "error"); + } + } + + } elsif ($status == $SELINUX_PORT_WRONGLY_DEFINED) { + emit("Failed setting selinux context $setype for $seport. " . + "Port already defined otherwise.\n", "error"); + } +} + +sub add_selinux_file_context +{ + my ($fcontext, $fname, $ftype, $cmds_ref) = @_; + my ($result); + + emit(sprintf("add_selinux_file_context(%s)\n", join(", ", @_)), "debug"); + + #check if fcontext has already been set + my $tmp = `$semanage fcontext -l -n |grep $fname |grep ":$fcontext:" | wc -l`; + chomp $tmp; + if ($tmp ne "0") { + emit("selinux fcontext for $fname already defined\n", "debug"); + return; + } + + if ($ftype eq "f") { + $$cmds_ref .= "fcontext -a -t $fcontext -f -- $fname\n"; + } else { + $$cmds_ref .= "fcontext -a -t $fcontext $fname\n"; + } +} + +1; |