#-------------------------------------------------------------------------------
# (C) British Crown Copyright 2006-17 Met Office.
#
# This file is part of FCM, tools for managing and building source code.
#
# FCM 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, either version 3 of the License, or
# (at your option) any later version.
#
# FCM 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 FCM. If not, see .
#-------------------------------------------------------------------------------
use strict;
use warnings;
package FCM::Admin::System;
use Config::IniFiles;
use DBI; # See also: DBD::SQLite
use Exporter qw{import};
use FCM::Admin::Config;
use FCM::Admin::Project;
use FCM::Admin::Runner;
use FCM::Admin::User;
use FCM::Admin::Util qw{
read_file
run_copy
run_create_archive
run_extract_archive
run_mkpath
run_rename
run_rmtree
run_rsync
run_symlink
write_file
};
use Fcntl qw{:mode}; # for S_IRGRP, S_IWGRP, S_IROTH, etc
use File::Basename qw{basename dirname};
use File::Compare qw{compare};
use File::Find qw{find};
use File::Spec::Functions qw{catfile rel2abs};
use File::Temp qw{tempdir tempfile};
use IO::Compress::Gzip qw{gzip};
use IO::Dir;
use IO::Pipe;
use IO::Zlib;
use List::Util qw{first};
use POSIX qw{strftime};
use Text::ParseWords qw{shellwords};
our @EXPORT_OK = qw{
add_svn_repository
add_trac_environment
backup_svn_repository
backup_trac_environment
backup_trac_files
distribute_wc
filter_projects
get_projects_from_svn_backup
get_projects_from_svn_live
get_projects_from_trac_backup
get_projects_from_trac_live
get_users
housekeep_svn_hook_logs
install_svn_hook
manage_users_in_svn_passwd
manage_users_in_trac_passwd
manage_users_in_trac_db_of
recover_svn_repository
recover_trac_environment
recover_trac_files
vacuum_trac_env_db
verify_users
};
our $NO_OVERWRITE = 1;
our $BUFFER_SIZE = 4096;
our @SVN_REPOS_ROOT_HOOK_ITEMS = qw{commit.conf svnperms.conf};
our %USER_INFO_TOOL_OF = (
'ldap' => 'FCM::Admin::Users::LDAP',
'passwd' => 'FCM::Admin::Users::Passwd',
);
our $USER_INFO_TOOL;
our $UTIL = $FCM::Admin::Config::UTIL;
my $CONFIG = FCM::Admin::Config->instance();
my $RUNNER = FCM::Admin::Runner->instance();
# ------------------------------------------------------------------------------
# Adds a new Subversion repository.
sub add_svn_repository {
my ($project_name) = @_;
my $project = FCM::Admin::Project->new({name => $project_name});
if (-e $project->get_svn_live_path()) {
die(sprintf(
"%s: Subversion repository already exists at %s.\n",
$project_name,
$project->get_svn_live_path(),
));
}
my $repos_path = $project->get_svn_live_path();
$RUNNER->run(
"creating Subversion repository at $repos_path",
sub {!system(qw{svnadmin create}, $repos_path)},
);
my $group = $CONFIG->get_svn_group();
if ($group) {
_chgrp_and_chmod($project->get_svn_live_path(), $group);
}
install_svn_hook($project);
housekeep_svn_hook_logs($project);
}
# ------------------------------------------------------------------------------
# Adds a new Trac environment.
sub add_trac_environment {
my ($project_name) = @_;
my $project = FCM::Admin::Project->new({name => $project_name});
if (-e $project->get_trac_live_path()) {
die(sprintf(
"%s: Trac environment already exists at %s.\n",
$project_name,
$project->get_trac_live_path(),
));
}
my @repository_arguments = (q{}, q{});
if (-d $project->get_svn_live_path()) {
@repository_arguments = (q{svn}, $project->get_svn_live_path());
}
my $RUN = sub{$RUNNER->run(@_)};
my $TRAC_ADMIN = sub {
my ($log, @args) = @_;
my @command = (q{trac-admin}, $project->get_trac_live_path(), @args);
$RUN->($log, sub {!system(@command)});
};
my $TRAC_ADMIN_CONT = sub {
my ($log, @args) = @_;
my @command = (q{trac-admin}, $project->get_trac_live_path(), @args);
$RUNNER->run_continue($log, sub {!system(@command)});
};
$TRAC_ADMIN->(
"initialising Trac environment",
q{initenv},
$project_name,
q{sqlite:db/trac.db},
@repository_arguments,
q{--inherit=../../trac.ini},
);
my $group = $CONFIG->get_trac_group();
if ($group) {
_chgrp_and_chmod($project->get_trac_live_path(), $group);
}
# Note: For some reason, the commands to remove example components,
# versions, milestones, priorities fail using the "pip install trac" version
# on Travis CI. It is safe to allow the logic to continue after a failure
# here as they are really unimportant and can easily be configured later.
for my $item (qw{component1 component2}) {
$TRAC_ADMIN_CONT->(
"removing example component $item", q{component remove}, $item,
);
}
for my $item (qw{1.0 2.0}) {
$TRAC_ADMIN_CONT->(
"removing example version $item", q{version remove}, $item,
);
}
for my $item (qw{milestone1 milestone2 milestone3 milestone4}) {
$TRAC_ADMIN_CONT->(
"removing example milestone $item", q{milestone remove}, $item,
);
}
for my $item (
['major' => 'normal' ],
['critical' => 'major' ],
['blocker' => 'critical'],
) {
my ($old, $new) = @{$item};
$TRAC_ADMIN_CONT->(
"changing priority $old to $new", qw{priority change}, $old, $new,
);
}
$TRAC_ADMIN->(
"adding admin permission", qw{permission add admin TRAC_ADMIN},
);
$TRAC_ADMIN->(
"adding admin permission", qw{permission add owner TRAC_ADMIN},
);
my @admin_users = shellwords($CONFIG->get_trac_admin_users());
for my $item (@admin_users) {
$TRAC_ADMIN->(
"adding admin user $item", qw{permission add}, $item, q{admin},
);
}
$TRAC_ADMIN->(
"adding TICKET_EDIT_CC permission to authenticated",
qw{permission add}, 'authenticated', qw{TICKET_EDIT_CC},
);
$TRAC_ADMIN->(
"adding TICKET_EDIT_DESCRIPTION permission to authenticated",
qw{permission add}, 'authenticated', qw{TICKET_EDIT_DESCRIPTION},
);
$RUN->(
"adding names and emails of users",
sub {manage_users_in_trac_db_of($project, get_users())},
);
$RUN->(
"updating configuration file",
sub {
my $trac_ini_path = $project->get_trac_live_ini_path();
my $trac_ini = Config::IniFiles->new(q{-file} => $trac_ini_path);
if (!$trac_ini) {
die("$trac_ini_path: cannot open.\n");
}
for (
#section #key #value
['inherit', 'file' , '../../trac.ini,../../intertrac.ini'],
['project', 'descr' , $project->get_name() ],
['trac' , 'base_url', $project->get_trac_live_url() ],
) {
my ($section, $key, $value) = @{$_};
if (!$trac_ini->SectionExists($section)) {
$trac_ini->AddSection($section);
}
if (!$trac_ini->newval($section, $key, $value)) {
die("$trac_ini_path: $section:$key: cannot set value.\n");
}
}
return $trac_ini->RewriteConfig();
},
);
$RUN->(
"updating InterTrac",
sub {
my $ini_path = catfile(
$CONFIG->get_trac_live_dir(),
'intertrac.ini',
);
if (!-e $ini_path) {
open(my $handle, '>', $ini_path) || die("$ini_path: $!\n");
close($handle) || die("$ini_path: $!\n");
}
my $trac_ini = Config::IniFiles->new(
q{-allowempty} => 1,
q{-file} => $ini_path,
);
if (!defined($trac_ini)) {
die("$ini_path: cannot open.\n");
}
if (!$trac_ini->SectionExists(q{intertrac})) {
$trac_ini->AddSection(q{intertrac});
}
my $name = $project->get_name();
for (
[q{title} , $name ],
[q{url} , $project->get_trac_live_url()],
[q{compat}, 'false' ],
) {
my ($key, $value) = @{$_};
my $option = lc($name) . q{.} . $key;
if (!$trac_ini->newval(q{intertrac}, $option, $value)) {
die("$ini_path: intertrac:$option: cannot set value.\n");
}
}
return $trac_ini->RewriteConfig();
},
);
return 1;
}
# ------------------------------------------------------------------------------
# Backup the SVN repository of a project.
sub backup_svn_repository {
my ($option_hash_ref, $project) = @_;
my $RUN = sub {FCM::Admin::Runner->instance()->run(@_)};
if (!exists($option_hash_ref->{'no-pack'})) {
$RUN->(
sprintf("packing %s", $project->get_svn_live_path()),
sub {!system(qw{svnadmin pack}, $project->get_svn_live_path())},
);
}
my $base_name = $project->get_svn_base_name();
run_mkpath($CONFIG->get_svn_backup_dir());
my $work_dir = tempdir("$base_name.backup.XXXXXX", CLEANUP => 1, TMPDIR => 1);
my $work_path = catfile($work_dir, $base_name);
$RUN->(
sprintf(
"hotcopying %s to %s", $project->get_svn_live_path(), $work_path,
),
sub {!system(
qw{svnadmin hotcopy}, $project->get_svn_live_path(), $work_path,
)},
# Note: "hotcopy" is not yet possible via SVN::Repos
);
if (!exists($option_hash_ref->{'no-verify-integrity'})) {
my $VERIFIED_REVISION_REGEX = qr{\A\*\s+Verified\s+revision\s+\d+\.}xms;
$RUN->(
"verifying integrity of SVN repository of $project",
sub {
my $pipe = IO::Pipe->new();
$pipe->reader(sprintf(
qq{svnadmin verify %s 2>&1}, $work_path,
));
while (my $line = $pipe->getline()) {
if ($line !~ $VERIFIED_REVISION_REGEX) { # don't print
print($line);
}
}
return $pipe->close();
# Note: "verify" is not yet possible via SVN::Repos
},
);
}
_create_backup_archive(
$work_path,
$CONFIG->get_svn_backup_dir(),
$project->get_svn_archive_base_name(),
);
if (!exists($option_hash_ref->{'no-housekeep-dumps'})) {
my $base_name = $project->get_svn_base_name();
my $dump_path = $CONFIG->get_svn_dump_dir();
my $youngest = _svnlook_youngest($work_path);
# Note: could use SVN::Repos for "youngest"
$RUN->(
"housekeeping $dump_path/$base_name-*.gz",
sub {
my @rev_dump_paths;
_get_files_from(
$dump_path,
sub {
my ($dump_base_name, $path) = @_;
my ($name, $rev)
= $dump_base_name =~ qr{\A(.*)-(\d+)\.gz\z}msx;
if ( !$name
|| !$rev
|| $name ne $base_name
|| $rev > $youngest
) {
return;
}
push(@rev_dump_paths, $path);
},
);
for my $rev_dump_path (@rev_dump_paths) {
run_rmtree($rev_dump_path);
}
return 1;
}
);
}
run_rmtree($work_dir);
return 1;
}
# ------------------------------------------------------------------------------
# Backup the Trac environment of a project.
sub backup_trac_environment {
my ($option_hash_ref, $project) = @_;
my $trac_live_path = $project->get_trac_live_path();
my $base_name = $project->get_name();
run_mkpath($CONFIG->get_trac_backup_dir());
my $work_dir = tempdir("$base_name.backup.XXXXXX", CLEANUP => 1, TMPDIR => 1);
my $work_path = catfile($work_dir, $base_name);
$RUNNER->run_with_retries(
sprintf(
qq{hotcopying %s to %s},
$project->get_trac_live_path(),
$work_path,
),
sub {
return !system(
q{trac-admin},
$project->get_trac_live_path(),
q{hotcopy},
$work_path,
);
},
);
if (!exists($option_hash_ref->{'no-verify-integrity'})) {
my $db_path = catfile($work_path, qw{db trac.db});
my $db_name = catfile($project->get_name(), qw{db trac.db});
$RUNNER->run(
"checking $db_name for integrity",
sub {
my $db_handle
= DBI->connect(qq{dbi:SQLite:dbname=$db_path}, q{}, q{});
if (!$db_handle) {
return;
}
my $rc = defined($db_handle->do(q{pragma integrity_check;}));
$db_handle->disconnect();
return $rc;
},
);
}
_create_backup_archive(
$work_path,
$CONFIG->get_trac_backup_dir(),
$project->get_trac_archive_base_name(),
);
run_rmtree($work_dir);
return 1;
}
# ------------------------------------------------------------------------------
# Backup misc files in the Trac live directory to the Trac backup directory.
sub backup_trac_files {
# (no argument)
_copy_files($CONFIG->get_trac_live_dir(), $CONFIG->get_trac_backup_dir());
}
# ------------------------------------------------------------------------------
# Distributes the central FCM working copy to standard locations.
sub distribute_wc {
my $rc = 1;
my @RSYNC_OPTS = qw{--timeout=1800 --exclude=.*};
my @sources;
for my $source_key (shellwords($CONFIG->get_mirror_keys())) {
my $method = "get_$source_key";
if ($CONFIG->can($method)) {
push(@sources, $CONFIG->$method());
}
}
for my $dest (shellwords($CONFIG->get_mirror_dests())) {
$rc = $RUNNER->run_continue(
"distributing FCM to $dest",
sub {
run_rsync(
\@sources, $dest,
[@RSYNC_OPTS, qw{-a --delete-excluded}],
);
},
) && $rc;
}
return $rc;
}
# ------------------------------------------------------------------------------
# Returns a filtered list of projects matching names in a list.
sub filter_projects {
my ($project_list_ref, $filter_list_ref) = @_;
if (!@{$filter_list_ref}) {
return @{$project_list_ref};
}
my %project_of = map {($_->get_name(), $_)} @{$project_list_ref};
my @projects;
my @unmatched_names;
for my $name (@{$filter_list_ref}) {
if (exists($project_of{$name})) {
push(@projects, $project_of{$name});
}
else {
push(@unmatched_names, $name);
}
}
if (@unmatched_names) {
die("@unmatched_names: not found\n");
}
return @projects;
}
# ------------------------------------------------------------------------------
# Returns a list of projects by searching the backup SVN directory.
sub get_projects_from_svn_backup {
# (no dummy argument)
my $SVN_PROJECT_SUFFIX = $CONFIG->get_svn_project_suffix();
my @projects;
_get_files_from(
$CONFIG->get_svn_backup_dir(),
sub {
my ($base_name, $path) = @_;
my $name = $base_name;
if ($name !~ s{$SVN_PROJECT_SUFFIX\.tgz\z}{}xms) {
return;
}
if (!-f $path) {
return;
}
push(@projects, FCM::Admin::Project->new({name => $name}));
},
);
return @projects;
}
# ------------------------------------------------------------------------------
# Returns a list of projects by searching the live SVN directory.
sub get_projects_from_svn_live {
# (no dummy argument)
my $SVN_PROJECT_SUFFIX = $CONFIG->get_svn_project_suffix();
my @projects;
_get_files_from(
$CONFIG->get_svn_live_dir(),
sub {
my ($base_name, $path) = @_;
my $name = $base_name;
$name =~ s{$SVN_PROJECT_SUFFIX\z}{}xms;
if (!-d $path) {
return;
}
push(@projects, FCM::Admin::Project->new({name => $name}));
},
);
return @projects;
}
# ------------------------------------------------------------------------------
# Returns a list of projects by searching the backup Trac directory.
sub get_projects_from_trac_backup {
# (no dummy argument)
my @projects;
_get_files_from(
$CONFIG->get_trac_backup_dir(),
sub {
my ($base_name, $path) = @_;
my $name = $base_name;
if ($name !~ s{\.tgz\z}{}xms) {
return;
}
if (!-f $path) {
return;
}
push(@projects, FCM::Admin::Project->new({name => $name}));
},
);
return @projects;
}
# ------------------------------------------------------------------------------
# Returns a list of projects by searching the live Trac directory.
sub get_projects_from_trac_live {
# (no dummy argument)
my @projects;
_get_files_from(
$CONFIG->get_trac_live_dir(),
sub {
my ($name, $path) = @_;
if (!-d $path) {
return;
}
push(@projects, FCM::Admin::Project->new({name => $name}));
},
);
return @projects;
}
# ------------------------------------------------------------------------------
# Return a HASH of valid users. If @only_users, then return only users matching
# these IDs.
sub get_users {
my @only_users = @_;
my $name = $CONFIG->get_user_info_tool();
if (!defined($USER_INFO_TOOL)) {
my $class = $UTIL->class_load($USER_INFO_TOOL_OF{$name});
$USER_INFO_TOOL = $class->new({util => $UTIL});
}
my $user_hash_ref = $USER_INFO_TOOL->get_users_info(@only_users);
if (!%{$user_hash_ref}) {
die("No user found via $name.\n");
}
return $user_hash_ref;
}
# ------------------------------------------------------------------------------
# Housekeep logs generated by hook scripts of a SVN project.
sub housekeep_svn_hook_logs {
my ($project) = @_;
my $project_path = $project->get_svn_live_path();
my $hook_source_dir = catfile($CONFIG->get_fcm_home(), 'etc', 'svn-hooks');
my $today = strftime("%Y%m%d", gmtime());
my $date_p1w = strftime("%Y%m%d", gmtime(time() - 604800)); # 1 week ago
my $date_p4w = strftime("%Y%m%d", gmtime(time() - 2419200)); # 4 weeks ago
my @hook_names = map {basename($_)} glob(catfile($hook_source_dir, q{*}));
for my $hook_name (sort @hook_names) {
my $log_path = catfile($project_path, 'log', $hook_name . '.log');
my $log_path_cur;
# Determine whether log file is more than a week old
if ( -l $log_path
&& index(readlink($log_path), $hook_name . '.log.') == 0
) {
my $path = readlink($log_path);
my ($date) = $path =~ qr{\.log\.(\d{8}\d*)\z}msx;
if ($date && $date > $date_p1w) {
$log_path_cur = catfile($project_path, 'log', $path);
}
}
# Create latest log, if necessary
if (!$log_path_cur) {
$log_path_cur = "$log_path.$today";
write_file($log_path_cur);
}
if ( !-e $log_path
|| !-l $log_path
|| readlink($log_path) ne basename($log_path_cur)
) {
run_rmtree($log_path);
run_symlink(basename($log_path_cur), $log_path);
}
# Remove logs older than $keep_threshold
for my $path (
sort glob(catfile($project_path, 'log', $hook_name . '*.log.*'))
) {
my ($date, $dot_gz) = $path =~ qr{\.log\.(\d{8}\d*)(\.gz)?\z}msx;
if ( $date && $date <= $date_p4w
|| $date && $date <= $date_p1w && !-s $path
) {
run_rmtree($path);
}
elsif ($date && $date <= $date_p1w && !$dot_gz) {
$RUNNER->run(
"gzip $path",
sub {gzip($path, "$path.gz") && unlink($path)},
);
}
}
}
my $group = $CONFIG->get_svn_group();
if ($group) {
_chgrp_and_chmod(catfile($project_path, 'log'), $group);
}
}
# ------------------------------------------------------------------------------
# Installs hook scripts to a SVN project.
sub install_svn_hook {
my ($project, $clean_mode) = @_;
# Write hook environment configuration
my $project_path = $project->get_svn_live_path();
my $conf_dest = catfile($project_path, qw{conf hooks-env});
write_file(
$conf_dest,
"[default]\n",
map {sprintf("%s=%s\n", @{$_});}
grep {$_->[1];} (
['FCM_HOME', $CONFIG->get_fcm_home()],
['FCM_SITE_HOME', $CONFIG->get_fcm_site_home()],
['FCM_SVN_HOOK_ADMIN_EMAIL', $CONFIG->get_admin_email()],
['FCM_SVN_HOOK_COMMIT_DUMP_DIR', $CONFIG->get_svn_dump_dir()],
['FCM_SVN_HOOK_NOTIFICATION_FROM', $CONFIG->get_notification_from()],
['FCM_SVN_HOOK_REPOS_SUFFIX', $CONFIG->get_svn_project_suffix()],
['FCM_SVN_HOOK_TRAC_ROOT_DIR', $CONFIG->get_trac_live_dir()],
['PATH', $CONFIG->get_svn_hook_path_env()],
['TZ', 'UTC'],
)
);
my %path_of = ();
# Search for hook scripts:
# * default sets
# * selected items from top of repository, e.g. svnperms.conf
# * site overrides
_get_files_from(
catfile($CONFIG->get_fcm_home(), 'etc', 'svn-hooks'),
sub {
my ($base_name, $path) = @_;
if (index($base_name, q{.}) == 0 || -d $path) {
return;
}
$path_of{$base_name} = $path;
},
);
for my $line (qx{svnlook tree -N $project_path}) {
chomp($line);
my ($base_name) = $line =~ qr{\A\s*(.*)\z}msx;
if (grep {$_ eq $base_name} @SVN_REPOS_ROOT_HOOK_ITEMS) {
$path_of{$base_name} = "^/$base_name";
}
}
_get_files_from(
catfile(
$CONFIG->get_fcm_site_home(), 'svn-hooks', $project->get_name(),
),
sub {
my ($base_name, $path) = @_;
if (index($base_name, q{.}) == 0 || -d $path) {
return;
}
$path_of{$base_name} = $path;
},
);
# Install hook scripts and associated files
for my $base_name (sort keys(%path_of)) {
my $hook_source = $path_of{$base_name};
my $hook_dest = catfile($project->get_svn_live_hook_path(), $base_name);
if (index($hook_source, '^/') == 0) {
$RUNNER->run(
"install $hook_dest <- $hook_source",
sub {
my $source = "file://$project_path/$base_name";
!system(qw{svn export -q --force}, $source, $hook_dest)
|| die("\n");
chmod((stat($hook_dest))[2] | S_IRGRP | S_IROTH, $hook_dest);
},
);
}
else {
run_copy($hook_source, $hook_dest);
}
}
# Clean hook destination, if necessary
if ($clean_mode) {
my $hook_path = $project->get_svn_live_hook_path();
for my $path (sort glob(catfile($hook_path, q{*}))) {
if (!exists($path_of{basename($path)})) {
run_rmtree($path);
}
}
}
my $group = $CONFIG->get_svn_group();
if ($group) {
_chgrp_and_chmod($project->get_svn_live_hook_path(), $group);
}
return 1;
}
# ------------------------------------------------------------------------------
# Updates the SVN password file.
sub manage_users_in_svn_passwd {
my ($user_ref) = @_;
if (!$CONFIG->get_svn_passwd_file()) {
return 1;
}
my $svn_passwd_file = catfile(
$CONFIG->get_svn_live_dir(),
$CONFIG->get_svn_passwd_file(),
);
$RUNNER->run(
"updating $svn_passwd_file",
sub {
my $USERS_SECTION = q{users};
my $svn_passwd_ini;
my $is_changed;
if (-f $svn_passwd_file) {
$svn_passwd_ini
= Config::IniFiles->new(q{-file} => $svn_passwd_file);
}
else {
$svn_passwd_ini = Config::IniFiles->new();
$svn_passwd_ini->SetFileName($svn_passwd_file);
$svn_passwd_ini->AddSection($USERS_SECTION);
$is_changed = 1;
}
for my $name (($svn_passwd_ini->Parameters($USERS_SECTION))) {
if (!exists($user_ref->{$name})) {
$RUNNER->run(
"removing $name from $svn_passwd_file",
sub {
return
$svn_passwd_ini->delval($USERS_SECTION, $name);
},
);
$is_changed = 1;
}
}
for my $user (values(%{$user_ref})) {
if (!defined($svn_passwd_ini->val($USERS_SECTION, "$user"))) {
$RUNNER->run(
"adding $user to $svn_passwd_file",
sub {
$svn_passwd_ini->newval(
$USERS_SECTION, $user->get_name(), q{},
),
},
);
$is_changed = 1;
}
}
return ($is_changed ? $svn_passwd_ini->RewriteConfig() : 1);
},
);
return 1;
}
# ------------------------------------------------------------------------------
# Updates the Trac password file.
sub manage_users_in_trac_passwd {
my ($user_ref) = @_;
if (!$CONFIG->get_trac_passwd_file()) {
return 1;
}
my $trac_passwd_file = catfile(
$CONFIG->get_trac_live_dir(),
$CONFIG->get_trac_passwd_file(),
);
$RUNNER->run(
"updating $trac_passwd_file",
sub {
my %old_names;
my %new_names = %{$user_ref};
if (-f $trac_passwd_file) {
read_file(
$trac_passwd_file,
sub {
my ($line) = @_;
chomp($line);
if (
!$line || $line =~ qr{\A\s*\z}xms # blank line
|| $line =~ qr{\A\s*\#}xms # comment line
) {
return;
}
my ($name, $passwd) = split(qr{\s*:\s*}xms, $line);
if (exists($new_names{$name})) {
delete($new_names{$name});
}
else {
$old_names{$name} = 1;
}
},
) || return;
}
else {
write_file($trac_passwd_file) || return;
}
if (%old_names || %new_names) {
for my $name (keys(%old_names)) {
$RUNNER->run(
"removing $name from $trac_passwd_file",
sub {
return !system(
qw{htpasswd -D}, $trac_passwd_file, $name,
);
},
);
}
for my $name (keys(%new_names)) {
$RUNNER->run(
"adding $name to $trac_passwd_file",
sub {
return !system(
qw{htpasswd -b}, $trac_passwd_file, $name, q{},
);
},
);
sleep(1); # ensure the random seed for htpasswd is changed
}
}
return 1;
},
# Note: can use HTTPD::UserAdmin, if it is installed
);
return 1;
}
# ------------------------------------------------------------------------------
# Manages the session* tables in the DB of a Trac environment.
sub manage_users_in_trac_db_of {
my ($project, $user_ref) = @_;
return $RUNNER->run_with_retries(
sprintf(
qq{checking/updating %s},
$project->get_trac_live_db_path(),
),
sub {return _manage_users_in_trac_db_of($project, $user_ref)},
);
}
# ------------------------------------------------------------------------------
# Recovers a SVN repository from its backup.
sub recover_svn_repository {
my ($project, $recover_dumps_option, $recover_hooks_option) = @_;
if (-e $project->get_svn_live_path()) {
die(sprintf(
"%s: live repository exists.\n",
$project->get_svn_live_path(),
));
}
run_mkpath($CONFIG->get_svn_live_dir());
my $base_name = $project->get_svn_base_name();
my $work_dir = tempdir(
qq{$base_name.XXXXXX},
DIR => $CONFIG->get_svn_live_dir(),
CLEANUP => 1,
);
my $work_path = catfile($work_dir, $base_name);
_extract_backup_archive($project->get_svn_backup_path(), $work_path);
if ($recover_dumps_option) {
my $youngest = _svnlook_youngest($work_path);
my %dump_path_of;
_get_files_from(
$CONFIG->get_svn_dump_dir(),
sub {
my ($dump_base_name, $path) = @_;
my ($name, $rev) = $dump_base_name =~ qr{\A(.*)-(\d+)\.gz\z}msx;
if ( !$name
|| !$rev
|| $name ne $base_name
|| $rev <= $youngest
) {
return;
}
$dump_path_of{$rev} = $path;
},
);
for my $rev (sort {$a <=> $b} keys(%dump_path_of)) {
my $dump_path = $dump_path_of{$rev};
$RUNNER->run(
"loading $dump_path into $work_path",
sub {
my $pipe = IO::Pipe->new();
$pipe->writer(qw{svnadmin load}, $work_path);
my $handle = IO::Zlib->new($dump_path, 'rb');
if (!$handle) {
die("$dump_path: $!\n");
}
while ($handle->read(my $buffer, $BUFFER_SIZE)) {
$pipe->print($buffer);
}
$handle->close();
return ($pipe->close());
},
);
}
}
run_rename($work_path, $project->get_svn_live_path());
my $group = $CONFIG->get_svn_group();
if ($group) {
_chgrp_and_chmod($project->get_svn_live_path(), $group);
}
if ($recover_hooks_option) {
install_svn_hook($project);
housekeep_svn_hook_logs($project);
}
return 1;
}
# ------------------------------------------------------------------------------
# Recovers a Trac environment from its backup.
sub recover_trac_environment {
my ($project) = @_;
if (-e $project->get_trac_live_path()) {
die(sprintf(
"%s: live environment exists.\n",
$project->get_trac_live_path(),
));
}
run_mkpath($CONFIG->get_trac_live_dir());
my $base_name = $project->get_name();
my $work_dir = tempdir(
qq{$base_name.XXXXXX},
DIR => $CONFIG->get_trac_live_dir(),
CLEANUP => 1,
);
my $work_path = catfile($work_dir, $base_name);
_extract_backup_archive($project->get_trac_backup_path(), $work_path);
run_rename($work_path, $project->get_trac_live_path());
my $group = $CONFIG->get_trac_group();
if ($group) {
_chgrp_and_chmod($project->get_trac_live_path(), $group);
}
}
# ------------------------------------------------------------------------------
# Recover a file from the Trac backup directory to the Trac live directory.
sub recover_trac_files {
# (no argument)
_copy_files(
$CONFIG->get_trac_backup_dir(),
$CONFIG->get_trac_live_dir(),
$NO_OVERWRITE,
qr{\.tgz\z}msx,
);
}
# ------------------------------------------------------------------------------
# Vacuum the database of a Trac environment.
sub vacuum_trac_env_db {
my ($project) = @_;
$RUNNER->run(
"performing vacuum on database of Trac environment for $project",
sub {
my $db_handle = _get_trac_db_handle_for($project);
if (!$db_handle) {
return;
}
$db_handle->do(q{vacuum;}) && $db_handle->disconnect();
},
);
}
# ------------------------------------------------------------------------------
# Verify users. Return a list of bad users from @users.
sub verify_users {
my @users = @_;
if (!defined($USER_INFO_TOOL)) {
my $name = $CONFIG->get_user_info_tool();
my $class = $UTIL->class_load($USER_INFO_TOOL_OF{$name});
$USER_INFO_TOOL = $class->new({util => $UTIL});
}
return $USER_INFO_TOOL->verify_users(@users);
}
# ------------------------------------------------------------------------------
# Changes/restores ownership and permission of a given $path to a given $group.
sub _chgrp_and_chmod {
my ($path, $group) = @_;
my $gid = $group ? scalar(getgrnam($group)) : -1;
find(
sub {
my $file = $File::Find::name;
my $old_gid = (stat($file))[5];
if ($old_gid != $gid) {
$RUNNER->run(
"changing group ownership for $file",
sub {return chown(-1, $gid, $file)},
);
}
my $old_mode = (stat($file))[2];
my $mode = (stat($file))[2] | S_IRGRP | S_IWGRP;
if ($old_mode != $mode) {
$RUNNER->run(
"adding group write permission for $file",
sub {return chmod($mode, $file)},
);
}
},
$path,
);
return 1;
}
# ------------------------------------------------------------------------------
# Copies files immediately under $source to $target.
sub _copy_files {
my ($source, $target, $no_overwrite, $re_skip) = @_;
my @bases;
opendir(my $handle, $source) || die("$source: $!\n");
while (my $base = readdir($handle)) {
if (-f catfile($source, $base)) {
if ($no_overwrite && -f catfile($target, $base)) {
warn("[SKIP] $base: already exists in $target.\n");
}
elsif (!$re_skip || ($base !~ $re_skip)) {
push(@bases, $base);
}
}
}
closedir($handle);
run_mkpath($target);
for my $base (@bases) {
run_copy(map {catfile($_, $base)} ($source, $target));
}
return 1;
}
# ------------------------------------------------------------------------------
# Creates backup archive from a path.
sub _create_backup_archive {
my ($source_path, $backup_dir, $archive_base_name) = @_;
my $source_dir = dirname($source_path);
my $source_base_name = basename($source_path);
run_mkpath($backup_dir);
my ($fh, $work_backup_path)
= tempfile(qq{$archive_base_name.XXXXXX}, DIR => $backup_dir);
close($fh);
run_create_archive($work_backup_path, $source_dir, $source_base_name);
my $backup_path = catfile($backup_dir, $archive_base_name);
run_rename($work_backup_path, $backup_path);
my $mode = (stat($backup_path))[2] | S_IRGRP | S_IROTH;
return chmod($mode, $backup_path);
}
# ------------------------------------------------------------------------------
# Extracts from a backup archive to a work path.
sub _extract_backup_archive {
my ($archive_path, $work_path) = @_;
run_extract_archive($archive_path, dirname($work_path));
if (! -e $work_path) {
my ($base_name) = basename($work_path);
die("$base_name: does not exist in archive $archive_path.\n");
}
return 1;
}
# ------------------------------------------------------------------------------
# Searches a directory for files and invokes a callback on each file.
sub _get_files_from {
my ($dir_path, $callback_ref) = @_;
my $dir_handle = IO::Dir->new($dir_path);
if (!defined($dir_handle)) {
return;
}
BASE_NAME:
while (my $base_name = $dir_handle->read()) {
my $path = catfile($dir_path, $base_name);
if (index($base_name, q{.}) == 0) {
next BASE_NAME;
}
$callback_ref->($base_name, $path);
}
return $dir_handle->close();
}
# ------------------------------------------------------------------------------
# Returns a database handle for the database of a Trac environment.
sub _get_trac_db_handle_for {
my ($project) = @_;
my $db_path = $project->get_trac_live_db_path();
return DBI->connect(qq{dbi:SQLite:dbname=$db_path}, q{}, q{});
}
# ------------------------------------------------------------------------------
# Manages the session* tables in the DB of a Trac environment.
sub _manage_users_in_trac_db_of {
my ($project, $user_ref) = @_;
my $db_handle = _get_trac_db_handle_for($project);
if (!$db_handle) {
return;
}
SESSION: {
my $session_select_statement = $db_handle->prepare(
"SELECT sid FROM session WHERE authenticated == 1",
);
my $session_insert_statement = $db_handle->prepare(
"INSERT INTO session VALUES (?, 1, 0)",
);
my $session_delete_statement = $db_handle->prepare(
"DELETE FROM session WHERE sid == ?",
);
$session_select_statement->execute();
my $is_changed = 0;
my %session_old_users;
while (my ($sid) = $session_select_statement->fetchrow_array()) {
if (exists($user_ref->{$sid})) {
$session_old_users{$sid} = 1;
}
else {
$RUNNER->run(
"session: removing $sid",
sub{return $session_delete_statement->execute($sid)},
);
$is_changed = 1;
}
}
for my $sid (keys(%{$user_ref})) {
if (!exists($session_old_users{$sid})) {
$RUNNER->run(
"session: adding $sid",
sub {return $session_insert_statement->execute($sid)},
);
$is_changed = 1;
}
}
$session_select_statement->finish();
$session_insert_statement->finish();
$session_delete_statement->finish();
}
SESSION_ATTRIBUTE: {
my $attribute_select_statement = $db_handle->prepare(
"SELECT sid,name,value FROM session_attribute "
. "WHERE authenticated == 1",
);
my $attribute_insert_statement = $db_handle->prepare(
"INSERT INTO session_attribute VALUES (?, 1, ?, ?)",
);
my $attribute_update_statement = $db_handle->prepare(
"UPDATE session_attribute SET value = ? "
. "WHERE sid = ? AND authenticated == 1 AND name == ?",
);
my $attribute_delete_statement = $db_handle->prepare(
"DELETE FROM session_attribute WHERE sid == ?",
);
my $attribute_delete_name_statement = $db_handle->prepare(
"DELETE FROM session_attribute WHERE sid == ? AND name == ?",
);
$attribute_select_statement->execute();
my %attribute_old_users;
my %deleted_users;
ROW:
while (my @row = $attribute_select_statement->fetchrow_array()) {
my ($sid, $name, $value) = @row;
my $user = exists($user_ref->{$sid})? $user_ref->{$sid} : undef;
if (defined($user)) {
my $getter
= $name eq 'name' ? 'get_display_name'
: $name eq 'email' ? 'get_email'
: undef;
if (!defined($getter)) {
next ROW;
}
$attribute_old_users{"$sid|$name"} = 1;
my $new_value = $user->$getter();
if ($new_value && $new_value ne $value) {
$RUNNER->run(
"session_attribute: updating $name: $sid: $new_value",
sub {return $attribute_update_statement->execute(
$new_value, $sid, $name,
)},
);
}
elsif (!$new_value && $value) {
$RUNNER->run(
"session_attribute: removing $name: $sid",
sub {return $attribute_delete_name_statement->execute(
$sid, $name,
)},
);
}
}
elsif (!exists($deleted_users{$sid})) {
$deleted_users{$sid} = 1;
$RUNNER->run(
"session_attribute: removing $sid",
sub {return $attribute_delete_statement->execute($sid)},
);
}
}
for my $sid (keys(%{$user_ref})) {
my $user = $user_ref->{$sid};
ATTRIB:
for (
['name' , $user->get_display_name()],
['email', $user->get_email() ],
) {
my ($name, $value) = @{$_};
if (exists($attribute_old_users{"$sid|$name"})) {
next ATTRIB;
}
if ($value) {
$RUNNER->run(
"session_attribute: adding $name: $sid: $value",
sub {$attribute_insert_statement->execute(
$sid, $name, $value,
)},
);
}
}
}
$attribute_select_statement->finish();
$attribute_insert_statement->finish();
$attribute_update_statement->finish();
$attribute_delete_statement->finish();
}
return $db_handle->disconnect();
}
# ------------------------------------------------------------------------------
# Returns the youngest revision of a SVN repository.
sub _svnlook_youngest {
my ($svn_repos_path) = @_;
my ($youngest) = qx{svnlook youngest $svn_repos_path};
chomp($youngest);
return $youngest;
}
1;
__END__
=head1 NAME
FCM::Admin::System
=head1 SYNOPSIS
use FCM::Admin::System qw{ ... };
# ... see descriptions of individual functions for detail
=head1 DESCRIPTION
This module contains utility functions for the administration of Subversion
repositories and Trac environments hosted by the FCM team.
=head1 FUNCTIONS
=over 4
=item add_svn_repository($project_name)
Creates a new Subversion repository.
=item add_trac_environment($project_name)
Creates a new Trac environment.
=item backup_svn_repository(\%option,$project)
Creates an archived hotcopy of $project's live SVN repository, and put it in the
SVN backup directory. If $option{'no-verify-integrity'} does not exist, it
verifies the integrity of the live repository before creating the hotcopy. If
$option{'no-pack'} does not exist, it packs the live repository before creating
the hotcopy. If $option{'no-housekeep-dumps'} does not exist, it housekeeps the
revision dumps of $project following a successful backup.
$project should be a L object.
=item backup_trac_environment(\%option,$project)
Creates an archived hotcopy of $project's live Trac environment, and put it in
the Trac backup directory. If $option{'no-verify-integrity'} does not exist, it
verifies the integrity of the database of the live environment before creating
the hotcopy.
$project should be a L object.
=item backup_trac_files()
Copies regular files immediately under the live Trac directory to the Trac
backup directory.
=item distribute_wc()
Distributes the central FCM working copy to standard locations.
=item filter_projects($project_list_ref,$filter_list_ref)
Filters the project list in $project_list_ref using a list of names in
$filter_list_ref. Returns a list of projects with names matching those in
$filter_list_ref. Returns the full list if $filter_list_ref points to an empty
list.
=item get_projects_from_svn_backup()
Returns a list of L objects by
searching the SVN backup directory. By default, all valid projects are returned.
=item get_projects_from_svn_live()
Similar to get_projects_from_svn_backup(), but it searches the SVN live
directory.
=item get_projects_from_trac_backup()
Similar to get_projects_from_svn_backup(), but it searches the Trac backup
directory.
=item get_projects_from_trac_live()
Similar to get_projects_from_svn_backup(), but it searches the Trac live
directory.
=item get_users(@only_users)
Retrieves a list of users. Store results in a HASH, {user ID => user info, ...}
where each user info is stored in an instance of
L.
If no argument, return all valid users. If @only_users, return only those users
with matching user ID in @only_users.
=item housekeep_svn_hook_logs($project)
Housekeep logs generated by the hook scripts of the $project's SVN live
repository.
$project should be a L object.
=item install_svn_hook($project, $clean_mode)
Searches for hook scripts in the standard location and install them (as symbolic
links) in the I directory of the $project's SVN live repository.
$project should be a L object.
If $clean_mode is specified and is true, remove any items in the I
directory that are not known to this install.
=item manage_users_in_svn_passwd($user_ref)
Using entries in the hash reference $user_ref, sets up or updates the SVN and
Trac password files. The $user_ref argument should be a reference to a hash, as
returned by get_users().
=item manage_users_in_trac_passwd($user_ref)
Using entries in the hash reference $user_ref, sets up or updates the Trac
password files. The $user_ref argument should be a reference to a hash, as
returned by get_users().
=item manage_users_in_trac_db_of($project, $user_ref)
Using entries in $user_ref, sets up or updates the session/session_attribute
tables in the databases of the live Trac environments. The $project argument
should be a L object
and $user_ref should be a reference to a hash, as returned by get_users().
=item recover_svn_repository($project,$recover_dumps_option,$recover_hooks_option)
Recovers a project's SVN repository using its backup. If $recover_dumps_option
is set to true, it will also attempt to load the latest revision dumps following
a successful recovery. If $recover_hooks_option is set to true, it will also
attempt to re-install the hook scripts following a successful recovery.
$project should be a L object.
=item recover_trac_environment($project)
Recovers a project's Trac environment using its backup.
$project should be a L object.
=item recover_trac_files()
Copies files immediately under the backup Trac directory to the Trac live
directory (if the files do not already exist).
=item vacuum_trac_env_db($project)
Connects to the database of a project's Trac environment, and issues the
"VACUUM" SQL command.
$project should be a L object.
=back
=head1 SEE ALSO
L,
L,
L,
L
=head1 COPYRIGHT
E<169> Crown copyright Met Office. All rights reserved.
=cut