App-LXC-Container
view release on metacpan or search on metacpan
lib/App/LXC/Container/Update.pm view on Meta::CPAN
local $_ = $self->{containers}[0];
if (m/^(?:no-|local-)?network$/)
{
1 == @{$self->{containers}} or fatal 'special_container__1_alone', $_;
m/^local-network$/ and $self->{network} = 1;
m/^network$/ and $self->{network} = 2;
$self->{audio_from} = $_;
$self->{network_from} = $_;
$self->{x11_from} = $_;
$self->{containers} = [];
}
else
{
$self->_parse_master();
@{$self->{user_ids}} and $self->_parse_users();
}
$self->_parse_packages();
$self->_parse_mounts();
$self->_parse_filter();
$self->_parse_specials();
m/^(no-|local-)?network$/ and $self->{containers} = [ $_ ];
$self->_write_lxc_configuration();
}
#########################################################################
=head2 B<network_number> - return current container's network number
$network_number = $self->network_number();
=head3 description:
This method determines the network number (the last number of the IP v4
network address) of the current container. If the number is not yet defined
the next free number is used and stored in the global network configuration
file.
=head3 returns:
current container's network number
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub network_number($)
{
my $self = shift;
debug(1, __PACKAGE__, '::network_number($self)');
my $container = $self->{name};
unless (defined $self->{networks}{$container})
{
local $_ = _ROOT_DIR_ . '/.networks.lst';
open my $out, '>>', $_ or fatal 'can_t_open__1__2', $_, $!;
$self->{networks}{$container} = $self->{next_network}++;
say $out $self->{networks}{$container}, ':', $container;
close $out;
}
return $self->{networks}{$container};
}
#########################################################################
#########################################################################
=head1 HELPER METHODS
The following methods should not be used outside of this module itself:
=cut
#########################################################################
=head2 B<_create_mount_points> - create all mount points for path
$self->_create_mount_points($mounts, '/');
=head3 parameters:
$path root path
$mounts App::LXC::Container::Mounts object
=head3 description:
This method (recursively) creates all (real) mount-points below (including)
the given path.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _create_mount_points($$$)
{
my $self = shift;
my ($mounts, $path, $out) = @_;
debug(3, __PACKAGE__,
'::_create_mount_points::($self, "', join('", "', @_), '")');
local $_ = $mounts->mount_point($path);
if ($_ == EMPTY or $_ == EXPLICIT or $_ == IMPLICIT)
{ $self->_make_lxc_path($path); }
elsif ($_ == COPY or $_ == IMPLICIT_LINK)
{
(my $parent = $path) =~ s|/[^/]+$||;
$self->_make_lxc_path($parent);
-d $path and not -l $path
and fatal('internal_error__1', $path.' is directory in COPY');
my $target = $self->{root_fs} . '/' . $self->{name} . $path;
unless (-e $target or -l $target)
{
system('cp', '--archive', $path, $target) == 0
or error('can_t_copy__1__2', $path, $?);
}
}
$self->_create_mount_points($mounts, $_)
foreach $mounts->sub_directories($path);
}
lib/App/LXC/Container/Update.pm view on Meta::CPAN
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _parse_users($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_parse_users($self)');
use constant PWD => '/etc/passwd';
my $key = 'container users';
push @{$self->{mount_sources}}, $key;
$self->{mounts_of_source}{$key} = [];
my $re_users =
'^(?:' . join('|', values %{$self->{users}}) . '):.*:(/[^:]+):[^:]+$';
# Normally this could never fail:
# uncoverable branch true
open my $pwd, '<', PWD or fatal 'can_t_open__1__2', PWD, $!;
my @users = ();
local $_;
while (<$pwd>)
{
next unless m/$re_users/o;
$self->{mount_entry}{$1} =
$1 . ' ' . substr($1, 1) . ' none create=dir,rw,bind';
$self->{mount_source}{$1} = $key;
push @{$self->{mounts_of_source}{$key}}, $1;
}
close $pwd;
}
#########################################################################
=head2 B<_write_lxc_configuration> - write LXC configuration file
$self->_write_lxc_configuration();
=head3 description:
This method writes the parsed meta-configuration into the real concrete
LXC configuration file for the selected (command-line) application
container.
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _write_lxc_configuration($)
{
my $self = shift;
debug(2, __PACKAGE__, '::_write_lxc_configuration($self)');
use constant HEADER_1 => "\n#################### ";
use constant HEADER_1s => '#################### ';
use constant HEADER_2 => ' ####################';
local $_;
my $container = $self->{name};
my $path = _ROOT_DIR_ . '/' . $container . '.conf';
open my $out, '>', $path or fatal 'can_t_open__1__2', $path, $!;
################################
# part 1 - global definitions:
say $out '# container description created by ', __PACKAGE__;
say($out
'# MASTER: ',
($self->{network} == 2 ? 'G' . $self->network_number() :
$self->{network} == 1 ? 'L' . $self->network_number() : 'N'),
',', ($self->{x11} ? 'X' : '-'),
',', ($self->{audio} ? 'A' : '-'));
say $out 'lxc.uts.name = ' . $container;
say $out 'lxc.rootfs.path = ' . $self->{root_fs} . '/' . $container;
say $out 'lxc.rootfs.options = idmap=container';
if ($self->{network})
{
say $out
HEADER_1, $self->{network_from}, ', 10-NET-default.conf', HEADER_2;
$_ = _ROOT_DIR_ . '/conf/10-NET-default.conf';
open my $in, '<', $_ or fatal 'can_t_open__1__2', $_, $!;
my $network_number = $self->network_number();
while (<$in>)
{
next if m/^\s*(?:#|$)/;
s|\.\$N/|.$network_number/|;
print $out $_;
}
close $in;
}
else
{
say $out HEADER_1, 'no network', HEADER_2;
say $out 'lxc.net.0.type = empty';
}
say $out HEADER_1, '20-DEV-default.conf', HEADER_2;
$_ = _ROOT_DIR_ . '/conf/20-DEV-default.conf';
open my $in, '<', $_ or fatal 'can_t_open__1__2', $_, $!;
while (<$in>)
{ print $out $_ unless m/^\s*(?:#|$)/; }
close $in;
my @users_from = @{$self->{users_from}};
my %groups = ();
if (@users_from)
{
# TODO: This is a workaround while su does not work with a mapped root:
# uncoverable branch false
unless (defined $self->{users}{root})
{
push @{$self->{user_ids}}, 0;
$self->{users}{0} = 'root';
}
say $out HEADER_1, join(', ', @users_from), HEADER_2;
my $uid = 0;
foreach (sort {$a <=> $b} keys %{$self->{users}})
{
say $out 'lxc.idmap = u ', $uid, ' ', 100000 + $uid, ' ', $_ - $uid
if $_ - $uid > 1;
my $user = $self->{users}{$_};
say $out '# ', $user, ':';
say $out 'lxc.idmap = u ', $_, ' ', $_, ' 1';
$uid = $_;
foreach (groups_of($uid))
{
# There are no standard users with multiple groups:
# uncoverable branch false
defined $groups{$_} or $groups{$_} = '';
$groups{$_} .= ' ' . $user;
}
$uid++;
}
say $out 'lxc.idmap = u ', $uid, ' ', 100000 + $uid, ' ', 65536 - $uid;
}
else
{
say $out HEADER_1, '-no privileged users-', HEADER_2;
say $out 'lxc.idmap = u 0 100000 65536';
}
if (0 < keys(%groups))
{
my $gid = 0;
foreach (sort {$a <=> $b} keys %groups)
{
say $out 'lxc.idmap = g ', $gid, ' ', 100000 + $gid, ' ', $_ - $gid
if $_ - $gid > 1;
say $out '#', $groups{$_}, ':';
say $out 'lxc.idmap = g ', $_, ' ', $_, ' 1';
$gid = $_ + 1;
}
say $out 'lxc.idmap = g ', $gid, ' ', 100000 + $gid, ' ', 65536 - $gid;
}
else
{ say $out 'lxc.idmap = g 0 100000 65536'; }
################################
# part 2 - special configuration:
if (@{$self->{specials}})
{
say $out HEADER_1, 'special configuration', HEADER_2;
say $out $_ foreach @{$self->{specials}};
}
################################
# part 3 - explicit mounts:
my $mounts = App::LXC::Container::Mounts->new();
foreach my $source (@{$self->{mount_sources}})
{
say $out HEADER_1, $source, HEADER_2;
foreach (@{$self->{mounts_of_source}{$source}})
{
next unless $self->{mount_source}{$_} eq $source;
say $out 'lxc.mount.entry = ', $self->{mount_entry}{$_};
$mounts->mount_point($_, EXPLICIT);
}
}
################################
# part 4a - implicit mounts (from packages) - determine prerequisites:
print $out "\n";
foreach my $source (@{$self->{package_sources}})
{
say $out HEADER_1s, $source, HEADER_2;
foreach (sort keys %{$self->{package_source}})
{
say $out '# ', $_
if $self->{package_source}{$_} eq $source;
}
}
# We sort packages according to their reference count and put the user
# selections at or near the end (by initialising them with a negative
# reference count):
my @packages = @{$self->{packages}};
my %referenced_packages =
map { ($_, ($self->{package_source}{$_} =~ m/^\d/) ? 0 : -2) }
@packages;
my $include = 0; # TODO: Get initial value via interface!
while (@packages)
{
my @add = ();
foreach (@packages)
{ push @add, depends_on($_, $include); }
@packages = ();
$include = -1;
foreach (@add)
{
unless (defined $referenced_packages{$_})
{
$referenced_packages{$_} = 0;
push @packages, $_;
}
$referenced_packages{$_}++;
}
}
@packages =
sort { $referenced_packages{$b} <=> $referenced_packages{$a} }
keys %referenced_packages;
################################
# part 4b - implicit mounts (from packages) - prepare filters:
my $header = 0;
foreach my $key (sort keys %{$self->{filter}})
{
$_ = $self->{filter}{$key};
if ($_ eq 'copy')
{ $mounts->mount_point($key, COPY); }
elsif ($_ eq 'empty')
{
if (-d $key)
{
unless ($header)
{
say $out HEADER_1, 'empty filters', HEADER_2;
$header = 1;
}
say($out
'lxc.mount.entry = tmpfs ', substr($key, 1),
' tmpfs create=dir,rw 0 0');
$mounts->mount_point($key, EMPTY);
}
else
{ push @{$self->{empty_files}}, $key; }
}
elsif ($_ eq 'ignore')
{ $mounts->mount_point($key, IGNORE); }
elsif ($_ eq 'nomerge')
{ $mounts->mount_point($key, NO_MERGE); }
else
{ fatal 'internal_error__1', 'bad filter value: ' . $_; }
}
################################
# part 4c - implicit mounts (from packages) - gather and merge paths of
# packages (while respecting the filters!):
foreach my $package (@packages)
{
# gather paths of next package:
foreach (paths_of($package))
{
unless (-e)
{
error('_1_does_not_exist', $_);
next;
}
my $state = undef;
if (-l)
{
$state = $mounts->mount_point($_);
$mounts->mount_point($_, IMPLICIT_LINK) if $state == UNDEFINED;
next;
}
next if -d;
$_ = abs_path($_); # resolve links in path!
$state = $mounts->mount_point($_);
if ($state == UNDEFINED)
{ $mounts->mount_point($_, IMPLICIT); }
}
# TODO: tune heuristic, put into constant or make configurable:
$mounts->merge_mount_points(100, 30, 4, 3);
}
################################
# part 4d - implicit mounts (from packages) - write configuration:
say $out HEADER_1, 'mounts derived from above packages', HEADER_2;
say $out $_ foreach $mounts->implicit_mount_lines('/');
################################
# part 5 - create all mount points:
my $errors = [];
$_ = $self->{root_fs} . '/' . $container;
-d $_ and remove_tree($_, {error => \$errors, safe => 1});
$errors = join(' ', map { (values(%$_)) } @$errors);
$errors eq '' or error('can_t_remove__1__2', $_, $errors);
$self->_create_mount_points($mounts, '/');
################################
# part 6 - create all empty files:
foreach (@{$self->{empty_files}})
{
$_ = $self->{root_fs} . '/' . $container . $_;
# As we just deleted the whole tree we can't create a test for a
# failed empty file here:
# uncoverable branch true
open my $empty, '>', $_ or fatal 'can_t_open__1__2', $_, $!;
close $empty;
chmod 0600, $_;
}
close $out;
}
#########################################################################
1;
#########################################################################
#########################################################################
=head1 SEE ALSO
man pages C<lxc.container.conf>, C<lxc> and C<lxcfs>
LXC documentation on L<https://linuxcontainers.org>
=head1 LICENSE
Copyright (C) Thomas Dorner.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See LICENSE file for more details.
=head1 AUTHOR
Thomas Dorner E<lt>dorner (at) cpan (dot) orgE<gt>
=head2 Contributors
none so far
=cut
( run in 0.695 second using v1.01-cache-2.11-cpan-d7a12ab2c7f )