From: Dietmar Maurer Date: Fri, 27 Feb 2015 15:57:20 +0000 (+0100) Subject: rename data to src X-Git-Url: https://git.proxmox.com/?p=pve-common.git;a=commitdiff_plain;h=b51b16e6f58de4cb385bd461d97866b3d94c93ec rename data to src --- diff --git a/Makefile b/Makefile index 9f25911..ff3ae9f 100644 --- a/Makefile +++ b/Makefile @@ -27,7 +27,7 @@ dinstall: deb .PHONY: deb deb ${DEB}: rm -rf build - rsync -a data/ build + rsync -a src/ build rsync -a debian/ build/debian echo "git clone git://git.proxmox.com/git/pve-common.git\\ngit checkout ${GITVERSION}" > build/debian/SOURCE cd build; dpkg-buildpackage -rfakeroot -b -us -uc diff --git a/README.dev b/README.dev index 0c4abdb..bc6cfbe 100644 --- a/README.dev +++ b/README.dev @@ -12,7 +12,15 @@ lintian libdevel-cycle-perl libjson-perl libcommon-sense-perl \ liblinux-inotify2-perl libio-stringy-perl libstring-shellquote-perl \ dh-systemd rpm2cpio libsqlite3-dev sqlite3 libglib2.0-dev librrd-dev \ librrds-perl rrdcached libdigest-hmac-perl libxml-parser-perl \ -gdb +gdb libcrypt-openssl-random-perl libcrypt-openssl-rsa-perl \ +libnet-ldap-perl libauthen-pam-perl libjson-xs-perl libterm-readline-gnu-perl oathtool libmime-base32-perl liboath0 libpci-dev texi2html libsdl1.2-dev \ +libgnutls28-dev libspice-protocol-dev xfslibs-dev libnuma-dev libaio-dev \ +libspice-server-dev libusbredirparser-dev glusterfs-common libusb-1.0-0-dev \ +librbd-dev libpopt-dev iproute bridge-utils numactl glusterfs-common \ +ceph-common python-ceph libgoogle-perftools4 libfile-chdir-perl lvm2 \ +glusterfs-client liblockfile-simple-perl libsystemd-daemon-dev \ +libreadline-gplv2-dev libio-multiplex-perl libnetfilter-log-dev \ +libipset3 ipset socat libsasl2-dev # old wheezy depends apt-get -y install build-essential git-core debhelper autotools-dev \ diff --git a/data/Makefile b/data/Makefile deleted file mode 100644 index 5e50005..0000000 --- a/data/Makefile +++ /dev/null @@ -1,39 +0,0 @@ - -PREFIX=/usr -BINDIR=${PREFIX}/bin -MANDIR=${PREFIX}/share/man -DOCDIR=${PREFIX}/share/doc -MAN1DIR=${MANDIR}/man1/ -PERLDIR=${PREFIX}/share/perl5 - -LIB_SOURCES= \ - Daemon.pm \ - SectionConfig.pm \ - Network.pm \ - ProcFSTools.pm \ - PodParser.pm \ - CLIHandler.pm \ - RESTHandler.pm \ - JSONSchema.pm \ - SafeSyslog.pm \ - AtomicFile.pm \ - INotify.pm \ - Tools.pm \ - AbstractMigrate.pm \ - Exception.pm - -all: - -.PHONY: install -install: - install -d -m 0755 ${DESTDIR}${PERLDIR}/PVE - for i in ${LIB_SOURCES}; do install -D -m 0644 PVE/$$i ${DESTDIR}${PERLDIR}/PVE/$$i; done - - -.PHONY: clean -clean: - rm -rf *~ - -.PHONY: distclean -distclean: clean - diff --git a/data/PVE/AbstractMigrate.pm b/data/PVE/AbstractMigrate.pm deleted file mode 100644 index 01d0a50..0000000 --- a/data/PVE/AbstractMigrate.pm +++ /dev/null @@ -1,277 +0,0 @@ -package PVE::AbstractMigrate; - -use strict; -use warnings; -use POSIX qw(strftime); -use PVE::Tools; - -my $msg2text = sub { - my ($level, $msg) = @_; - - chomp $msg; - - return '' if !$msg; - - my $res = ''; - - my $tstr = strftime("%b %d %H:%M:%S", localtime); - - foreach my $line (split (/\n/, $msg)) { - if ($level eq 'err') { - $res .= "$tstr ERROR: $line\n"; - } else { - $res .= "$tstr $line\n"; - } - } - - return $res; -}; - -sub log { - my ($self, $level, $msg) = @_; - - chomp $msg; - - return if !$msg; - - print &$msg2text($level, $msg); -} - -sub cmd { - my ($self, $cmd, %param) = @_; - - my $logfunc = sub { - my $line = shift; - $self->log('info', $line); - }; - - $self->log('info', "# " . PVE::Tools::cmd2string($cmd)); - - PVE::Tools::run_command($cmd, %param, outfunc => $logfunc, errfunc => $logfunc); -} - -my $run_command_quiet_full = sub { - my ($self, $cmd, $logerr, %param) = @_; - - my $log = ''; - my $logfunc = sub { - my $line = shift; - $log .= &$msg2text('info', $line);; - }; - - eval { PVE::Tools::run_command($cmd, %param, outfunc => $logfunc, errfunc => $logfunc); }; - if (my $err = $@) { - $self->log('info', "# " . PVE::Tools::cmd2string($cmd)); - print $log; - if ($logerr) { - $self->{errors} = 1; - $self->log('err', $err); - } else { - die $err; - } - } -}; - -sub cmd_quiet { - my ($self, $cmd, %param) = @_; - return &$run_command_quiet_full($self, $cmd, 0, %param); -} - -sub cmd_logerr { - my ($self, $cmd, %param) = @_; - return &$run_command_quiet_full($self, $cmd, 1, %param); -} - -my $eval_int = sub { - my ($self, $func, @param) = @_; - - eval { - local $SIG{INT} = $SIG{TERM} = $SIG{QUIT} = $SIG{HUP} = sub { - $self->{delayed_interrupt} = 0; - die "interrupted by signal\n"; - }; - local $SIG{PIPE} = sub { - $self->{delayed_interrupt} = 0; - die "interrupted by signal\n"; - }; - - my $di = $self->{delayed_interrupt}; - $self->{delayed_interrupt} = 0; - - die "interrupted by signal\n" if $di; - - &$func($self, @param); - }; -}; - -my @ssh_opts = ('-o', 'BatchMode=yes'); -my @ssh_cmd = ('/usr/bin/ssh', @ssh_opts); -my @scp_cmd = ('/usr/bin/scp', @ssh_opts); -my @rsync_opts = ('-aHAX', '--delete', '--numeric-ids'); -my @rsync_cmd = ('/usr/bin/rsync', @rsync_opts); - -sub migrate { - my ($class, $node, $nodeip, $vmid, $opts) = @_; - - $class = ref($class) || $class; - - my $self = { - delayed_interrupt => 0, - opts => $opts, - vmid => $vmid, - node => $node, - nodeip => $nodeip, - rsync_cmd => [ @rsync_cmd ], - rem_ssh => [ @ssh_cmd, "root\@$nodeip" ], - scp_cmd => [ @scp_cmd ], - }; - - $self = bless $self, $class; - - my $starttime = time(); - - local $ENV{RSYNC_RSH} = join(' ', @ssh_cmd); - - local $SIG{INT} = $SIG{TERM} = $SIG{QUIT} = $SIG{HUP} = $SIG{PIPE} = sub { - $self->log('err', "received interrupt - delayed"); - $self->{delayed_interrupt} = 1; - }; - - local $ENV{RSYNC_RSH} = join(' ', @ssh_cmd); - - # lock container during migration - eval { $self->lock_vm($self->{vmid}, sub { - - $self->{running} = 0; - &$eval_int($self, sub { $self->{running} = $self->prepare($self->{vmid}); }); - die $@ if $@; - - &$eval_int($self, sub { $self->phase1($self->{vmid}); }); - my $err = $@; - if ($err) { - $self->log('err', $err); - eval { $self->phase1_cleanup($self->{vmid}, $err); }; - if (my $tmperr = $@) { - $self->log('err', $tmperr); - } - eval { $self->final_cleanup($self->{vmid}); }; - if (my $tmperr = $@) { - $self->log('err', $tmperr); - } - die $err; - } - - # vm is now owned by other node - # Note: there is no VM config file on the local node anymore - - if ($self->{running}) { - - &$eval_int($self, sub { $self->phase2($self->{vmid}); }); - my $phase2err = $@; - if ($phase2err) { - $self->{errors} = 1; - $self->log('err', "online migrate failure - $phase2err"); - } - eval { $self->phase2_cleanup($self->{vmid}, $phase2err); }; - if (my $err = $@) { - $self->log('err', $err); - $self->{errors} = 1; - } - } - - # phase3 (finalize) - &$eval_int($self, sub { $self->phase3($self->{vmid}); }); - my $phase3err = $@; - if ($phase3err) { - $self->log('err', $phase3err); - $self->{errors} = 1; - } - eval { $self->phase3_cleanup($self->{vmid}, $phase3err); }; - if (my $err = $@) { - $self->log('err', $err); - $self->{errors} = 1; - } - eval { $self->final_cleanup($self->{vmid}); }; - if (my $err = $@) { - $self->log('err', $err); - $self->{errors} = 1; - } - })}; - - my $err = $@; - - my $delay = time() - $starttime; - my $mins = int($delay/60); - my $secs = $delay - $mins*60; - my $hours = int($mins/60); - $mins = $mins - $hours*60; - - my $duration = sprintf "%02d:%02d:%02d", $hours, $mins, $secs; - - if ($err) { - $self->log('err', "migration aborted (duration $duration): $err"); - die "migration aborted\n"; - } - - if ($self->{errors}) { - $self->log('err', "migration finished with problems (duration $duration)"); - die "migration problems\n" - } - - $self->log('info', "migration finished successfuly (duration $duration)"); -} - -sub lock_vm { - my ($self, $vmid, $code, @param) = @_; - - die "abstract method - implement me"; -} - -sub prepare { - my ($self, $vmid) = @_; - - die "abstract method - implement me"; - - # return $running; -} - -# transfer all data and move VM config files -sub phase1 { - my ($self, $vmid) = @_; - die "abstract method - implement me"; -} - -# only called if there are errors in phase1 -sub phase1_cleanup { - my ($self, $vmid, $err) = @_; - die "abstract method - implement me"; -} - -# only called when VM is running and phase1 was successful -sub phase2 { - my ($self, $vmid) = @_; - die "abstract method - implement me"; -} - -# only called when VM is running and phase1 was successful -sub phase2_cleanup { - my ($self, $vmid, $err) = @_; -}; - -# only called when phase1 was successful -sub phase3 { - my ($self, $vmid) = @_; -} - -# only called when phase1 was successful -sub phase3_cleanup { - my ($self, $vmid, $err) = @_; -} - -# final cleanup - always called -sub final_cleanup { - my ($self, $vmid) = @_; - die "abstract method - implement me"; -} - -1; diff --git a/data/PVE/AtomicFile.pm b/data/PVE/AtomicFile.pm deleted file mode 100644 index 110a8ae..0000000 --- a/data/PVE/AtomicFile.pm +++ /dev/null @@ -1,19 +0,0 @@ -package PVE::AtomicFile; - -use strict; -use warnings; -use IO::AtomicFile; -use vars qw(@ISA); - -@ISA = qw(IO::AtomicFile); - -sub new { - my $class = shift; - my $self = $class->SUPER::new(@_); - $self; -} - - -sub DESTROY { - # dont close atomatically (explicit close required to commit changes) -} diff --git a/data/PVE/CLIHandler.pm b/data/PVE/CLIHandler.pm deleted file mode 100644 index 33011c6..0000000 --- a/data/PVE/CLIHandler.pm +++ /dev/null @@ -1,228 +0,0 @@ -package PVE::CLIHandler; - -use strict; -use warnings; - -use PVE::Exception qw(raise raise_param_exc); -use PVE::RESTHandler; -use PVE::PodParser; - -use base qw(PVE::RESTHandler); - -my $cmddef; -my $exename; - -my $expand_command_name = sub { - my ($def, $cmd) = @_; - - if (!$def->{$cmd}) { - my $expanded; - for my $k (keys(%$def)) { - if ($k =~ m/^$cmd/) { - if ($expanded) { - $expanded = undef; # more than one match - last; - } else { - $expanded = $k; - } - } - } - $cmd = $expanded if $expanded; - } - return $cmd; -}; - -__PACKAGE__->register_method ({ - name => 'help', - path => 'help', - method => 'GET', - description => "Get help about specified command.", - parameters => { - additionalProperties => 0, - properties => { - cmd => { - description => "Command name", - type => 'string', - optional => 1, - }, - verbose => { - description => "Verbose output format.", - type => 'boolean', - optional => 1, - }, - }, - }, - returns => { type => 'null' }, - - code => sub { - my ($param) = @_; - - die "not initialized" if !($cmddef && $exename); - - my $cmd = $param->{cmd}; - - my $verbose = defined($cmd) && $cmd; - $verbose = $param->{verbose} if defined($param->{verbose}); - - if (!$cmd) { - if ($verbose) { - print_usage_verbose(); - } else { - print_usage_short(\*STDOUT); - } - return undef; - } - - $cmd = &$expand_command_name($cmddef, $cmd); - - my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd} || []}; - - raise_param_exc({ cmd => "no such command '$cmd'"}) if !$class; - - - my $str = $class->usage_str($name, "$exename $cmd", $arg_param, $uri_param, $verbose ? 'full' : 'short'); - if ($verbose) { - print "$str\n"; - } else { - print "USAGE: $str\n"; - } - - return undef; - - }}); - -sub print_pod_manpage { - my ($podfn) = @_; - - die "not initialized" if !($cmddef && $exename); - die "no pod file specified" if !$podfn; - - my $synopsis = ""; - - $synopsis .= " $exename [ARGS] [OPTIONS]\n\n"; - - my $style = 'full'; # or should we use 'short'? - my $oldclass; - foreach my $cmd (sorted_commands()) { - my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd}}; - my $str = $class->usage_str($name, "$exename $cmd", $arg_param, - $uri_param, $style); - $str =~ s/^USAGE: //; - - $synopsis .= "\n" if $oldclass && $oldclass ne $class; - $str =~ s/\n/\n /g; - $synopsis .= " $str\n\n"; - $oldclass = $class; - } - - $synopsis .= "\n"; - - my $parser = PVE::PodParser->new(); - $parser->{include}->{synopsis} = $synopsis; - $parser->parse_from_file($podfn); -} - -sub print_usage_verbose { - - die "not initialized" if !($cmddef && $exename); - - print "USAGE: $exename [ARGS] [OPTIONS]\n\n"; - - foreach my $cmd (sort keys %$cmddef) { - my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd}}; - my $str = $class->usage_str($name, "$exename $cmd", $arg_param, $uri_param, 'full'); - print "$str\n\n"; - } -} - -sub sorted_commands { - return sort { ($cmddef->{$a}->[0] cmp $cmddef->{$b}->[0]) || ($a cmp $b)} keys %$cmddef; -} - -sub print_usage_short { - my ($fd, $msg) = @_; - - die "not initialized" if !($cmddef && $exename); - - print $fd "ERROR: $msg\n" if $msg; - print $fd "USAGE: $exename [ARGS] [OPTIONS]\n"; - - my $oldclass; - foreach my $cmd (sorted_commands()) { - my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd}}; - my $str = $class->usage_str($name, "$exename $cmd", $arg_param, $uri_param, 'short'); - print $fd "\n" if $oldclass && $oldclass ne $class; - print $fd " $str"; - $oldclass = $class; - } -} - -sub handle_cmd { - my ($def, $cmdname, $cmd, $args, $pwcallback, $podfn) = @_; - - $cmddef = $def; - $exename = $cmdname; - - $cmddef->{help} = [ __PACKAGE__, 'help', ['cmd'] ]; - - if (!$cmd) { - print_usage_short (\*STDERR, "no command specified"); - exit (-1); - } elsif ($cmd eq 'verifyapi') { - PVE::RESTHandler::validate_method_schemas(); - return; - } elsif ($cmd eq 'printmanpod') { - print_pod_manpage($podfn); - return; - } - - $cmd = &$expand_command_name($cmddef, $cmd); - - my ($class, $name, $arg_param, $uri_param, $outsub) = @{$cmddef->{$cmd} || []}; - - if (!$class) { - print_usage_short (\*STDERR, "unknown command '$cmd'"); - exit (-1); - } - - my $prefix = "$exename $cmd"; - my $res = $class->cli_handler($prefix, $name, \@ARGV, $arg_param, $uri_param, $pwcallback); - - &$outsub($res) if $outsub; -} - -sub handle_simple_cmd { - my ($def, $args, $pwcallback, $podfn) = @_; - - my ($class, $name, $arg_param, $uri_param, $outsub) = @{$def}; - die "no class specified" if !$class; - - if (scalar(@$args) == 1) { - if ($args->[0] eq 'help') { - my $str = "USAGE: $name help\n"; - $str .= $class->usage_str($name, $name, $arg_param, $uri_param, 'long'); - print STDERR "$str\n\n"; - return; - } elsif ($args->[0] eq 'verifyapi') { - PVE::RESTHandler::validate_method_schemas(); - return; - } elsif ($args->[0] eq 'printmanpod') { - my $synopsis = " $name help\n\n"; - my $str = $class->usage_str($name, $name, $arg_param, $uri_param, 'long'); - $str =~ s/^USAGE://; - $str =~ s/\n/\n /g; - $synopsis .= $str; - - my $parser = PVE::PodParser->new(); - $parser->{include}->{synopsis} = $synopsis; - $parser->parse_from_file($podfn); - return; - } - } - - my $res = $class->cli_handler($name, $name, \@ARGV, $arg_param, $uri_param, $pwcallback); - - &$outsub($res) if $outsub; -} - -1; diff --git a/data/PVE/Daemon.pm b/data/PVE/Daemon.pm deleted file mode 100644 index 264f8be..0000000 --- a/data/PVE/Daemon.pm +++ /dev/null @@ -1,827 +0,0 @@ -package PVE::Daemon; - -# Abstract class to implement Daemons -# -# Features: -# * lock and write PID file /var/run/$name.pid to make sure onyl -# one instance is running. -# * keep lock open during restart -# * correctly daemonize (redirect STDIN/STDOUT) -# * restart by stop/start, exec, or signal HUP -# * daemon restart on error (option 'restart_on_error') -# * handle worker processes (option 'max_workers') -# * allow to restart while workers are still runningl -# (option 'leave_children_open_on_reload') -# * run as different user using setuid/setgid - -use strict; -use warnings; -use English; - -use PVE::SafeSyslog; -use PVE::INotify; - -use POSIX ":sys_wait_h"; -use Fcntl ':flock'; -use Socket qw(IPPROTO_TCP TCP_NODELAY SOMAXCONN); -use IO::Socket::INET; - -use Getopt::Long; -use Time::HiRes qw (gettimeofday); - -use base qw(PVE::CLIHandler); - -$ENV{'PATH'} = '/sbin:/bin:/usr/sbin:/usr/bin'; - -my $daemon_initialized = 0; # we only allow one instance - -my $close_daemon_lock = sub { - my ($self) = @_; - - return if !$self->{daemon_lock_fh}; - - close $self->{daemon_lock_fh}; - delete $self->{daemon_lock_fh}; -}; - -my $log_err = sub { - my ($msg) = @_; - chomp $msg; - print STDERR "$msg\n"; - syslog('err', "%s", $msg); -}; - -# call this if you fork() from child -# Note: we already call this for workers, so it is only required -# if you fork inside a simple daemon (max_workers == 0). -sub after_fork_cleanup { - my ($self) = @_; - - &$close_daemon_lock($self); - - PVE::INotify::inotify_close(); - - for my $sig (qw(CHLD HUP INT TERM QUIT)) { - $SIG{$sig} = 'DEFAULT'; # restore default handler - # AnyEvent signals only works if $SIG{XX} is - # undefined (perl event loop) - delete $SIG{$sig}; # so that we can handle events with AnyEvent - } -} - -my $lockpidfile = sub { - my ($self) = @_; - - my $lkfn = $self->{pidfile} . ".lock"; - - my $waittime = 0; - - if (my $fd = $self->{env_pve_lock_fd}) { - - $self->{daemon_lock_fh} = IO::Handle->new_from_fd($fd, "a"); - - } else { - - $waittime = 5; - $self->{daemon_lock_fh} = IO::File->new(">>$lkfn"); - } - - if (!$self->{daemon_lock_fh}) { - die "can't open lock '$lkfn' - $!\n"; - } - - for (my $i = 0; $i < $waittime; $i ++) { - return if flock ($self->{daemon_lock_fh}, LOCK_EX|LOCK_NB); - sleep(1); - } - - if (!flock ($self->{daemon_lock_fh}, LOCK_EX|LOCK_NB)) { - &$close_daemon_lock($self); - my $err = $!; - - my ($running, $pid) = $self->running(); - if ($running) { - die "can't aquire lock '$lkfn' - daemon already started (pid = $pid)\n"; - } else { - die "can't aquire lock '$lkfn' - $err\n"; - } - } -}; - -my $writepidfile = sub { - my ($self) = @_; - - my $pidfile = $self->{pidfile}; - - die "can't open pid file '$pidfile' - $!\n" if !open (PIDFH, ">$pidfile"); - - print PIDFH "$$\n"; - close (PIDFH); -}; - -my $server_cleanup = sub { - my ($self) = @_; - - unlink $self->{pidfile} . ".lock"; - unlink $self->{pidfile}; -}; - -my $finish_workers = sub { - my ($self) = @_; - - foreach my $id (qw(workers old_workers)) { - foreach my $cpid (keys %{$self->{$id}}) { - my $waitpid = waitpid($cpid, WNOHANG); - if (defined($waitpid) && ($waitpid == $cpid)) { - delete ($self->{$id}->{$cpid}); - syslog('info', "worker $cpid finished"); - } - } - } -}; - -my $start_workers = sub { - my ($self) = @_; - - return if $self->{terminate}; - - my $count = 0; - foreach my $cpid (keys %{$self->{workers}}) { - $count++; - } - - my $need = $self->{max_workers} - $count; - - return if $need <= 0; - - syslog('info', "starting $need worker(s)"); - - while ($need > 0) { - my $pid = fork; - - if (!defined ($pid)) { - syslog('err', "can't fork worker"); - sleep (1); - } elsif ($pid) { # parent - $self->{workers}->{$pid} = 1; - syslog('info', "worker $pid started"); - $need--; - } else { - $0 = "$self->{name} worker"; - - $self->after_fork_cleanup(); - - eval { $self->run(); }; - if (my $err = $@) { - syslog('err', $err); - sleep(5); # avoid fast restarts - } - - syslog('info', "worker exit"); - exit (0); - } - } -}; - -my $terminate_server = sub { - my ($self, $allow_open_children) = @_; - - $self->{terminate} = 1; # set flag to avoid worker restart - - if (!$self->{max_workers}) { - eval { $self->shutdown(); }; - warn $@ if $@; - return; - } - - eval { $self->shutdown(); }; - warn $@ if $@; - - # we have workers - send TERM signal - - foreach my $cpid (keys %{$self->{workers}}) { - kill(15, $cpid); # TERM childs - } - - # if configured, leave children running on HUP - return if $allow_open_children && - $self->{leave_children_open_on_reload}; - - # else, send TERM to old workers - foreach my $cpid (keys %{$self->{old_workers}}) { - kill(15, $cpid); # TERM childs - } - - # nicely shutdown childs (give them max 10 seconds to shut down) - my $previous_alarm = alarm(10); - eval { - local $SIG{ALRM} = sub { die "timeout\n" }; - - while ((my $pid = waitpid (-1, 0)) > 0) { - foreach my $id (qw(workers old_workers)) { - if (defined($self->{$id}->{$pid})) { - delete($self->{$id}->{$pid}); - syslog('info', "worker $pid finished"); - } - } - } - alarm(0); # avoid race condition - }; - my $err = $@; - - alarm ($previous_alarm); - - if ($err) { - syslog('err', "error stopping workers (will kill them now) - $err"); - foreach my $id (qw(workers old_workers)) { - foreach my $cpid (keys %{$self->{$id}}) { - # KILL childs still alive! - if (kill (0, $cpid)) { - delete($self->{$id}->{$cpid}); - syslog("err", "kill worker $cpid"); - kill(9, $cpid); - # fixme: waitpid? - } - } - } - } -}; - -my $server_run = sub { - my ($self, $debug) = @_; - - # fixme: handle restart lockfd - &$lockpidfile($self); - - # remove FD_CLOEXEC bit to reuse on exec - $self->{daemon_lock_fh}->fcntl(Fcntl::F_SETFD(), 0); - - $ENV{PVE_DAEMON_LOCK_FD} = $self->{daemon_lock_fh}->fileno; - - # run in background - my $spid; - - $self->{debug} = 1 if $debug; - - $self->init(); - - if (!$debug) { - open STDIN, '/dev/null' || die "can't write /dev/null"; - } - - if (!$self->{env_restart_pve_daemon} && !$debug) { - PVE::INotify::inotify_close(); - $spid = fork(); - if (!defined ($spid)) { - die "can't put server into background - fork failed"; - } elsif ($spid) { # parent - exit (0); - } - PVE::INotify::inotify_init(); - } - - if ($self->{env_restart_pve_daemon}) { - syslog('info' , "restarting server"); - } else { - &$writepidfile($self); - syslog('info' , "starting server"); - } - - POSIX::setsid(); - - open STDERR, '>&STDOUT' || die "can't close STDERR\n"; - - my $old_sig_term = $SIG{TERM}; - local $SIG{TERM} = sub { - local ($@, $!, $?); # do not overwrite error vars - syslog('info', "received signal TERM"); - &$terminate_server($self, 0); - &$server_cleanup($self); - &$old_sig_term(@_) if $old_sig_term; - }; - - my $old_sig_quit = $SIG{QUIT}; - local $SIG{QUIT} = sub { - local ($@, $!, $?); # do not overwrite error vars - syslog('info', "received signal QUIT"); - &$terminate_server($self, 0); - &$server_cleanup($self); - &$old_sig_quit(@_) if $old_sig_quit; - }; - - my $old_sig_int = $SIG{INT}; - local $SIG{INT} = sub { - local ($@, $!, $?); # do not overwrite error vars - syslog('info', "received signal INT"); - $SIG{INT} = 'DEFAULT'; # allow to terminate now - &$terminate_server($self, 0); - &$server_cleanup($self); - &$old_sig_int(@_) if $old_sig_int; - }; - - $SIG{HUP} = sub { - local ($@, $!, $?); # do not overwrite error vars - syslog('info', "received signal HUP"); - $self->{got_hup_signal} = 1; - if ($self->{max_workers}) { - &$terminate_server($self, 1); - } elsif ($self->can('hup')) { - eval { $self->hup() }; - warn $@ if $@; - } - }; - - eval { - if ($self->{max_workers}) { - my $old_sig_chld = $SIG{CHLD}; - local $SIG{CHLD} = sub { - local ($@, $!, $?); # do not overwrite error vars - &$finish_workers($self); - &$old_sig_chld(@_) if $old_sig_chld; - }; - - # catch worker finished during restart phase - &$finish_workers($self); - - # now loop forever (until we receive terminate signal) - for (;;) { - &$start_workers($self); - sleep(5); - &$finish_workers($self); - last if $self->{terminate}; - } - - } else { - $self->run(); - } - }; - my $err = $@; - - if ($err) { - syslog ('err', "ERROR: $err"); - - &$terminate_server($self, 1); - - if (my $wait_time = $self->{restart_on_error}) { - $self->restart_daemon($wait_time); - } else { - $self->exit_daemon(-1); - } - } - - if ($self->{got_hup_signal}) { - $self->restart_daemon(); - } else { - $self->exit_daemon(0); - } -}; - -sub new { - my ($this, $name, $cmdline, %params) = @_; - - $name = 'daemon' if !$name; # should not happen - - initlog($name); - - my $self; - - eval { - - my $restart = $ENV{RESTART_PVE_DAEMON}; - delete $ENV{RESTART_PVE_DAEMON}; - - my $lockfd = $ENV{PVE_DAEMON_LOCK_FD}; - delete $ENV{PVE_DAEMON_LOCK_FD}; - - if (defined($lockfd)) { - die "unable to parse lock fd '$lockfd'\n" - if $lockfd !~ m/^(\d+)$/; - $lockfd = $1; # untaint - } - - die "please run as root\n" if !$restart && ($> != 0); - - die "can't create more that one PVE::Daemon" if $daemon_initialized; - $daemon_initialized = 1; - - PVE::INotify::inotify_init(); - - my $class = ref($this) || $this; - - $self = bless { - name => $name, - pidfile => "/var/run/${name}.pid", - env_restart_pve_daemon => $restart, - env_pve_lock_fd => $lockfd, - workers => {}, - old_workers => {}, - }, $class; - - - foreach my $opt (keys %params) { - my $value = $params{$opt}; - if ($opt eq 'restart_on_error') { - $self->{$opt} = $value; - } elsif ($opt eq 'stop_wait_time') { - $self->{$opt} = $value; - } elsif ($opt eq 'pidfile') { - $self->{$opt} = $value; - } elsif ($opt eq 'max_workers') { - $self->{$opt} = $value; - } elsif ($opt eq 'leave_children_open_on_reload') { - $self->{$opt} = $value; - } elsif ($opt eq 'setgid') { - $self->{$opt} = $value; - } elsif ($opt eq 'setuid') { - $self->{$opt} = $value; - } else { - die "unknown daemon option '$opt'\n"; - } - } - - if (my $gidstr = $self->{setgid}) { - my $gid = getgrnam($gidstr) || die "getgrnam failed - $!\n"; - POSIX::setgid($gid) || die "setgid $gid failed - $!\n"; - $EGID = "$gid $gid"; # this calls setgroups - # just to be sure - die "detected strange gid\n" if !($GID eq "$gid $gid" && $EGID eq "$gid $gid"); - } - - if (my $uidstr = $self->{setuid}) { - my $uid = getpwnam($uidstr) || die "getpwnam failed - $!\n"; - POSIX::setuid($uid) || die "setuid $uid failed - $!\n"; - # just to be sure - die "detected strange uid\n" if !($UID == $uid && $EUID == $uid); - } - - if ($restart && $self->{max_workers}) { - if (my $wpids = $ENV{PVE_DAEMON_WORKER_PIDS}) { - foreach my $pid (split(':', $wpids)) { - if ($pid =~ m/^(\d+)$/) { - $self->{old_workers}->{$1} = 1; - } - } - } - } - - $self->{nodename} = PVE::INotify::nodename(); - - $self->{cmdline} = []; - - foreach my $el (@$cmdline) { - $el =~ m/^(.*)$/; # untaint - push @{$self->{cmdline}}, $1; - } - - $0 = $name; - }; - if (my $err = $@) { - &$log_err($err); - exit(-1); - } - - return $self; -} - -sub exit_daemon { - my ($self, $status) = @_; - - syslog("info", "server stopped"); - - &$server_cleanup($self); - - exit($status); -} - -sub restart_daemon { - my ($self, $waittime) = @_; - - syslog('info', "server shutdown (restart)"); - - $ENV{RESTART_PVE_DAEMON} = 1; - - if ($self->{max_workers}) { - my @workers = keys %{$self->{workers}}; - push @workers, keys %{$self->{old_workers}}; - $ENV{PVE_DAEMON_WORKER_PIDS} = join(':', @workers); - } - - sleep($waittime) if $waittime; # avoid high server load due to restarts - - PVE::INotify::inotify_close(); - - exec (@{$self->{cmdline}}); - - exit (-1); # never reached? -} - -# please overwrite in subclass -# this is called at startup - before forking -sub init { - my ($self) = @_; - -} - -# please overwrite in subclass -sub shutdown { - my ($self) = @_; - - syslog('info' , "server closing"); - - if (!$self->{max_workers}) { - # wait for children - 1 while (waitpid(-1, POSIX::WNOHANG()) > 0); - } -} - -# please define in subclass -#sub hup { -# my ($self) = @_; -# -# syslog('info' , "received signal HUP (restart)"); -#} - -# please overwrite in subclass -sub run { - my ($self) = @_; - - for (;;) { # forever - syslog('info' , "server is running"); - sleep(5); - } -} - -sub start { - my ($self, $debug) = @_; - - eval { &$server_run($self, $debug); }; - if (my $err = $@) { - &$log_err("start failed - $err"); - exit(-1); - } -} - -my $read_pid = sub { - my ($self) = @_; - - my $pid_str = PVE::Tools::file_read_firstline($self->{pidfile}); - - return 0 if !$pid_str; - - return 0 if $pid_str !~ m/^(\d+)$/; # untaint - - my $pid = int($1); - - return $pid; -}; - -sub running { - my ($self) = @_; - - my $pid = &$read_pid($self); - - if ($pid) { - my $res = PVE::ProcFSTools::check_process_running($pid) ? 1 : 0; - return wantarray ? ($res, $pid) : $res; - } - - return wantarray ? (0, 0) : 0; -} - -sub stop { - my ($self) = @_; - - my $pid = &$read_pid($self); - - return if !$pid; - - if (PVE::ProcFSTools::check_process_running($pid)) { - kill(15, $pid); # send TERM signal - # give some time - my $wait_time = $self->{stop_wait_time} || 5; - my $running = 1; - for (my $i = 0; $i < $wait_time; $i++) { - $running = PVE::ProcFSTools::check_process_running($pid); - last if !$running; - sleep (1); - } - - syslog('err', "server still running - send KILL") if $running; - - # to be sure - kill(9, $pid); - waitpid($pid, 0); - } - - if (-f $self->{pidfile}) { - eval { - # try to get the lock - &$lockpidfile($self); - &$server_cleanup($self); - }; - if (my $err = $@) { - &$log_err("cleanup failed - $err"); - } - } -} - -sub register_start_command { - my ($self, $description) = @_; - - my $class = ref($self); - - $class->register_method({ - name => 'start', - path => 'start', - method => 'POST', - description => $description || "Start the daemon.", - parameters => { - additionalProperties => 0, - properties => { - debug => { - description => "Debug mode - stay in foreground", - type => "boolean", - optional => 1, - default => 0, - }, - }, - }, - returns => { type => 'null' }, - - code => sub { - my ($param) = @_; - - $self->start($param->{debug}); - - return undef; - }}); -} - -my $reload_daemon = sub { - my ($self, $use_hup) = @_; - - if ($self->{env_restart_pve_daemon}) { - $self->start(); - } else { - my ($running, $pid) = $self->running(); - if (!$running) { - $self->start(); - } else { - if ($use_hup) { - syslog('info', "send HUP to $pid"); - kill 1, $pid; - } else { - $self->stop(); - $self->start(); - } - } - } -}; - -sub register_restart_command { - my ($self, $use_hup, $description) = @_; - - my $class = ref($self); - - $class->register_method({ - name => 'restart', - path => 'restart', - method => 'POST', - description => $description || "Restart the daemon (or start if not running).", - parameters => { - additionalProperties => 0, - properties => {}, - }, - returns => { type => 'null' }, - - code => sub { - my ($param) = @_; - - &$reload_daemon($self, $use_hup); - - return undef; - }}); -} - -sub register_reload_command { - my ($self, $description) = @_; - - my $class = ref($self); - - $class->register_method({ - name => 'reload', - path => 'reload', - method => 'POST', - description => $description || "Reload daemon configuration (or start if not running).", - parameters => { - additionalProperties => 0, - properties => {}, - }, - returns => { type => 'null' }, - - code => sub { - my ($param) = @_; - - &$reload_daemon($self, 1); - - return undef; - }}); -} - -sub register_stop_command { - my ($self, $description) = @_; - - my $class = ref($self); - - $class->register_method({ - name => 'stop', - path => 'stop', - method => 'POST', - description => $description || "Stop the daemon.", - parameters => { - additionalProperties => 0, - properties => {}, - }, - returns => { type => 'null' }, - - code => sub { - my ($param) = @_; - - $self->stop(); - - return undef; - }}); -} - -sub register_status_command { - my ($self, $description) = @_; - - my $class = ref($self); - - $class->register_method({ - name => 'status', - path => 'status', - method => 'GET', - description => "Get daemon status.", - parameters => { - additionalProperties => 0, - properties => {}, - }, - returns => { - type => 'string', - enum => ['stopped', 'running'], - }, - code => sub { - my ($param) = @_; - - return $self->running() ? 'running' : 'stopped'; - }}); -} - -# some useful helper - -sub create_reusable_socket { - my ($self, $port, $host) = @_; - - die "no port specifed" if !$port; - - my ($socket, $sockfd); - - if (defined($sockfd = $ENV{"PVE_DAEMON_SOCKET_$port"}) && - $self->{env_restart_pve_daemon}) { - - die "unable to parse socket fd '$sockfd'\n" - if $sockfd !~ m/^(\d+)$/; - $sockfd = $1; # untaint - - $socket = IO::Socket::INET->new; - $socket->fdopen($sockfd, 'w') || - die "cannot fdopen file descriptor '$sockfd' - $!\n"; - - } else { - - $socket = IO::Socket::INET->new( - LocalAddr => $host, - LocalPort => $port, - Listen => SOMAXCONN, - Proto => 'tcp', - ReuseAddr => 1) || - die "unable to create socket - $@\n"; - - # we often observe delays when using Nagle algorithm, - # so we disable that to maximize performance - setsockopt($socket, IPPROTO_TCP, TCP_NODELAY, 1); - - $ENV{"PVE_DAEMON_SOCKET_$port"} = $socket->fileno; - } - - # remove FD_CLOEXEC bit to reuse on exec - $socket->fcntl(Fcntl::F_SETFD(), 0); - - return $socket; -} - - -1; - diff --git a/data/PVE/Exception.pm b/data/PVE/Exception.pm deleted file mode 100644 index fa6b73a..0000000 --- a/data/PVE/Exception.pm +++ /dev/null @@ -1,142 +0,0 @@ -package PVE::Exception; - -# a way to add more information to exceptions (see man perlfunc (die)) -# use PVE::Exception qw(raise); -# raise ("my error message", code => 400, errors => { param1 => "err1", ...} ); - -use strict; -use warnings; -use vars qw(@ISA @EXPORT_OK); -require Exporter; -use Storable qw(dclone); -use HTTP::Status qw(:constants); - -@ISA = qw(Exporter); - -use overload '""' => sub {local $@; shift->stringify}; -use overload 'cmp' => sub { - my ($a, $b) = @_; - local $@; - return "$a" cmp "$b"; # compare as string -}; - -@EXPORT_OK = qw(raise raise_param_exc raise_perm_exc); - -sub new { - my ($class, $msg, %param) = @_; - - $class = ref($class) || $class; - - my $self = { - msg => $msg, - }; - - foreach my $p (keys %param) { - next if defined($self->{$p}); - my $v = $param{$p}; - $self->{$p} = ref($v) ? dclone($v) : $v; - } - - return bless $self; -} - -sub raise { - - my $exc = PVE::Exception->new(@_); - - my ($pkg, $filename, $line) = caller; - - $exc->{filename} = $filename; - $exc->{line} = $line; - - die $exc; -} - -sub raise_perm_exc { - my ($what) = @_; - - my $param = { code => HTTP_FORBIDDEN }; - - my $msg = "Permission check failed"; - - $msg .= " ($what)" if $what; - - my $exc = PVE::Exception->new("$msg\n", %$param); - - my ($pkg, $filename, $line) = caller; - - $exc->{filename} = $filename; - $exc->{line} = $line; - - die $exc; -} - -sub is_param_exc { - my ($self) = @_; - - return $self->{code} && $self->{code} eq HTTP_BAD_REQUEST; -} - -sub raise_param_exc { - my ($errors, $usage) = @_; - - my $param = { - code => HTTP_BAD_REQUEST, - errors => $errors, - }; - - $param->{usage} = $usage if $usage; - - my $exc = PVE::Exception->new("Parameter verification failed.\n", %$param); - - my ($pkg, $filename, $line) = caller; - - $exc->{filename} = $filename; - $exc->{line} = $line; - - die $exc; -} - -sub stringify { - my $self = shift; - - my $msg = $self->{code} ? "$self->{code} $self->{msg}" : $self->{msg}; - - if ($msg !~ m/\n$/) { - - if ($self->{filename} && $self->{line}) { - $msg .= " at $self->{filename} line $self->{line}"; - } - - $msg .= "\n"; - } - - if ($self->{errors}) { - foreach my $e (keys %{$self->{errors}}) { - $msg .= "$e: $self->{errors}->{$e}\n"; - } - } - - if ($self->{propagate}) { - foreach my $pi (@{$self->{propagate}}) { - $msg .= "\t...propagated at $pi->[0] line $pi->[1]\n"; - } - } - - if ($self->{usage}) { - $msg .= $self->{usage}; - $msg .= "\n" if $msg !~ m/\n$/; - } - - return $msg; -} - -sub PROPAGATE { - my ($self, $file, $line) = @_; - - push @{$self->{propagate}}, [$file, $line]; - - return $self; -} - -1; diff --git a/data/PVE/INotify.pm b/data/PVE/INotify.pm deleted file mode 100644 index fbedc50..0000000 --- a/data/PVE/INotify.pm +++ /dev/null @@ -1,1293 +0,0 @@ -package PVE::INotify; - -# todo: maybe we do not need update_file() ? - -use strict; -use warnings; - -use POSIX; -use IO::File; -use IO::Dir; -use File::stat; -use File::Basename; -use Fcntl qw(:DEFAULT :flock); -use PVE::SafeSyslog; -use PVE::Exception qw(raise_param_exc); -use PVE::Tools; -use Storable qw(dclone); -use Linux::Inotify2; -use base 'Exporter'; -use JSON; - -our @EXPORT_OK = qw(read_file write_file register_file); - -my $ccache; -my $ccachemap; -my $ccacheregex; -my $inotify; -my $inotify_pid = 0; -my $versions; -my $shadowfiles = { - '/etc/network/interfaces' => '/etc/network/interfaces.new', -}; - -# to enable cached operation, you need to call 'inotify_init' -# inotify handles are a limited resource, so use with care (only -# enable the cache if you really need it) - -# Note: please close the inotify handle after you fork - -sub ccache_default_writer { - my ($filename, $data) = @_; - - die "undefined config writer for '$filename' :ERROR"; -} - -sub ccache_default_parser { - my ($filename, $srcfd) = @_; - - die "undefined config reader for '$filename' :ERROR"; -} - -sub ccache_compute_diff { - my ($filename, $shadow) = @_; - - my $diff = ''; - - open (TMP, "diff -b -N -u '$filename' '$shadow'|"); - - while (my $line = ) { - $diff .= $line; - } - - close (TMP); - - $diff = undef if !$diff; - - return $diff; -} - -sub ccache_info { - my ($filename) = @_; - - foreach my $uid (keys %$ccacheregex) { - my $ccinfo = $ccacheregex->{$uid}; - my $dir = $ccinfo->{dir}; - my $regex = $ccinfo->{regex}; - if ($filename =~ m|^$dir/+$regex$|) { - if (!$ccache->{$filename}) { - my $cp = {}; - while (my ($k, $v) = each %$ccinfo) { - $cp->{$k} = $v; - } - $ccache->{$filename} = $cp; - } - return ($ccache->{$filename}, $filename); - } - } - - $filename = $ccachemap->{$filename} if defined ($ccachemap->{$filename}); - - die "file '$filename' not added :ERROR" if !defined ($ccache->{$filename}); - - return ($ccache->{$filename}, $filename); -} - -sub write_file { - my ($fileid, $data, $full) = @_; - - my ($ccinfo, $filename) = ccache_info($fileid); - - my $writer = $ccinfo->{writer}; - - my $realname = $filename; - - my $shadow; - if ($shadow = $shadowfiles->{$filename}) { - $realname = $shadow; - } - - my $perm = $ccinfo->{perm} || 0644; - - my $tmpname = "$realname.tmp.$$"; - - my $res; - eval { - my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm); - die "unable to open file '$tmpname' - $!\n" if !$fh; - - $res = &$writer($filename, $fh, $data); - - die "closing file '$tmpname' failed - $!\n" unless close $fh; - }; - my $err = $@; - - $ccinfo->{version} = undef; - - if ($err) { - unlink $tmpname; - die $err; - } - - if (!rename($tmpname, $realname)) { - my $msg = "close (rename) atomic file '$filename' failed: $!\n"; - unlink $tmpname; - die $msg; - } - - my $diff; - if ($shadow && $full) { - $diff = ccache_compute_diff ($filename, $shadow); - } - - if ($full) { - return { data => $res, changes => $diff }; - } - - return $res; -} - -sub update_file { - my ($fileid, $data, @args) = @_; - - my ($ccinfo, $filename) = ccache_info($fileid); - - my $update = $ccinfo->{update}; - - die "unable to update/merge data" if !$update; - - my $lkfn = "$filename.lock"; - - my $timeout = 10; - - my $fd; - - my $code = sub { - - $fd = IO::File->new ($filename, "r"); - - my $new = &$update($filename, $fd, $data, @args); - - if (defined($new)) { - PVE::Tools::file_set_contents($filename, $new, $ccinfo->{perm}); - } else { - unlink $filename; - } - }; - - PVE::Tools::lock_file($lkfn, $timeout, $code); - my $err = $@; - - close($fd) if defined($fd); - - die $err if $err; - - return undef; -} - -sub discard_changes { - my ($fileid, $full) = @_; - - my ($ccinfo, $filename) = ccache_info($fileid); - - if (my $copy = $shadowfiles->{$filename}) { - unlink $copy; - } - - return read_file ($filename, $full); -} - -sub read_file { - my ($fileid, $full) = @_; - - my $parser; - - my ($ccinfo, $filename) = ccache_info($fileid); - - $parser = $ccinfo->{parser}; - - my $fd; - my $shadow; - - poll() if $inotify; # read new inotify events - - $versions->{$filename} = 0 if !defined ($versions->{$filename}); - - my $cver = $versions->{$filename}; - - if (my $copy = $shadowfiles->{$filename}) { - if ($fd = IO::File->new ($copy, "r")) { - $shadow = $copy; - } else { - $fd = IO::File->new ($filename, "r"); - } - } else { - $fd = IO::File->new ($filename, "r"); - } - - my $acp = $ccinfo->{always_call_parser}; - - if (!$fd) { - $ccinfo->{version} = undef; - $ccinfo->{data} = undef; - $ccinfo->{diff} = undef; - return undef if !$acp; - } - - my $noclone = $ccinfo->{noclone}; - - # file unchanged? - if (!$ccinfo->{nocache} && - $inotify && $versions->{$filename} && - defined ($ccinfo->{data}) && - defined ($ccinfo->{version}) && - ($ccinfo->{readonce} || - ($ccinfo->{version} == $versions->{$filename}))) { - - my $ret; - if (!$noclone && ref ($ccinfo->{data})) { - $ret->{data} = dclone ($ccinfo->{data}); - } else { - $ret->{data} = $ccinfo->{data}; - } - $ret->{changes} = $ccinfo->{diff}; - - return $full ? $ret : $ret->{data}; - } - - my $diff; - - if ($shadow) { - $diff = ccache_compute_diff ($filename, $shadow); - } - - my $res = &$parser($filename, $fd); - - if (!$ccinfo->{nocache}) { - $ccinfo->{version} = $cver; - } - - # we cache data with references, so we always need to - # dclone this data. Else the original data may get - # modified. - $ccinfo->{data} = $res; - - # also store diff - $ccinfo->{diff} = $diff; - - my $ret; - if (!$noclone && ref ($ccinfo->{data})) { - $ret->{data} = dclone ($ccinfo->{data}); - } else { - $ret->{data} = $ccinfo->{data}; - } - $ret->{changes} = $ccinfo->{diff}; - - return $full ? $ret : $ret->{data}; -} - -sub parse_ccache_options { - my ($ccinfo, %options) = @_; - - foreach my $opt (keys %options) { - my $v = $options{$opt}; - if ($opt eq 'readonce') { - $ccinfo->{$opt} = $v; - } elsif ($opt eq 'nocache') { - $ccinfo->{$opt} = $v; - } elsif ($opt eq 'shadow') { - $ccinfo->{$opt} = $v; - } elsif ($opt eq 'perm') { - $ccinfo->{$opt} = $v; - } elsif ($opt eq 'noclone') { - # noclone flag for large read-only data chunks like aplinfo - $ccinfo->{$opt} = $v; - } elsif ($opt eq 'always_call_parser') { - # when set, we call parser even when the file does not exists. - # this allows the parser to return some default - $ccinfo->{$opt} = $v; - } else { - die "internal error - unsupported option '$opt'"; - } - } -} - -sub register_file { - my ($id, $filename, $parser, $writer, $update, %options) = @_; - - die "can't register file '$filename' after inotify_init" if $inotify; - - die "file '$filename' already added :ERROR" if defined ($ccache->{$filename}); - die "ID '$id' already used :ERROR" if defined ($ccachemap->{$id}); - - my $ccinfo = {}; - - $ccinfo->{id} = $id; - $ccinfo->{parser} = $parser || \&ccache_default_parser; - $ccinfo->{writer} = $writer || \&ccache_default_writer; - $ccinfo->{update} = $update; - - parse_ccache_options($ccinfo, %options); - - if ($options{shadow}) { - $shadowfiles->{$filename} = $options{shadow}; - } - - $ccachemap->{$id} = $filename; - $ccache->{$filename} = $ccinfo; -} - -sub register_regex { - my ($dir, $regex, $parser, $writer, $update, %options) = @_; - - die "can't register regex after initify_init" if $inotify; - - my $uid = "$dir/$regex"; - die "regular expression '$uid' already added :ERROR" if defined ($ccacheregex->{$uid}); - - my $ccinfo = {}; - - $ccinfo->{dir} = $dir; - $ccinfo->{regex} = $regex; - $ccinfo->{parser} = $parser || \&ccache_default_parser; - $ccinfo->{writer} = $writer || \&ccache_default_writer; - $ccinfo->{update} = $update; - - parse_ccache_options($ccinfo, %options); - - $ccacheregex->{$uid} = $ccinfo; -} - -sub poll { - return if !$inotify; - - if ($inotify_pid != $$) { - syslog ('err', "got inotify poll request in wrong process - disabling inotify"); - $inotify = undef; - } else { - 1 while $inotify && $inotify->poll; - } -} - -sub flushcache { - foreach my $filename (keys %$ccache) { - $ccache->{$filename}->{version} = undef; - $ccache->{$filename}->{data} = undef; - $ccache->{$filename}->{diff} = undef; - } -} - -sub inotify_close { - $inotify = undef; -} - -sub inotify_init { - - die "only one inotify instance allowed" if $inotify; - - $inotify = Linux::Inotify2->new() - || die "Unable to create new inotify object: $!"; - - $inotify->blocking (0); - - $versions = {}; - - my $dirhash = {}; - foreach my $fn (keys %$ccache) { - my $dir = dirname ($fn); - my $base = basename ($fn); - - $dirhash->{$dir}->{$base} = $fn; - - if (my $sf = $shadowfiles->{$fn}) { - $base = basename ($sf); - $dir = dirname ($sf); - $dirhash->{$dir}->{$base} = $fn; # change version of original file! - } - } - - foreach my $uid (keys %$ccacheregex) { - my $ccinfo = $ccacheregex->{$uid}; - $dirhash->{$ccinfo->{dir}}->{_regex} = 1; - } - - $inotify_pid = $$; - - foreach my $dir (keys %$dirhash) { - - my $evlist = IN_MODIFY|IN_ATTRIB|IN_MOVED_FROM|IN_MOVED_TO|IN_DELETE|IN_CREATE; - $inotify->watch ($dir, $evlist, sub { - my $e = shift; - my $name = $e->name; - - if ($inotify_pid != $$) { - syslog ('err', "got inotify event in wrong process"); - } - - if ($e->IN_ISDIR || !$name) { - return; - } - - if ($e->IN_Q_OVERFLOW) { - syslog ('info', "got inotify overflow - flushing cache"); - flushcache(); - return; - } - - if ($e->IN_UNMOUNT) { - syslog ('err', "got 'unmount' event on '$name' - disabling inotify"); - $inotify = undef; - } - if ($e->IN_IGNORED) { - syslog ('err', "got 'ignored' event on '$name' - disabling inotify"); - $inotify = undef; - } - - if ($dirhash->{$dir}->{_regex}) { - foreach my $uid (keys %$ccacheregex) { - my $ccinfo = $ccacheregex->{$uid}; - next if $dir ne $ccinfo->{dir}; - my $regex = $ccinfo->{regex}; - if ($regex && ($name =~ m|^$regex$|)) { - - my $fn = "$dir/$name"; - $versions->{$fn}++; - #print "VERSION:$fn:$versions->{$fn}\n"; - } - } - } elsif (my $fn = $dirhash->{$dir}->{$name}) { - - $versions->{$fn}++; - #print "VERSION:$fn:$versions->{$fn}\n"; - } - }); - } - - foreach my $dir (keys %$dirhash) { - foreach my $name (keys %{$dirhash->{$dir}}) { - if ($name eq '_regex') { - foreach my $uid (keys %$ccacheregex) { - my $ccinfo = $ccacheregex->{$uid}; - next if $dir ne $ccinfo->{dir}; - my $re = $ccinfo->{regex}; - if (my $fd = IO::Dir->new ($dir)) { - while (defined(my $de = $fd->read)) { - if ($de =~ m/^$re$/) { - my $fn = "$dir/$de"; - $versions->{$fn}++; # init with version - #print "init:$fn:$versions->{$fn}\n"; - } - } - } - } - } else { - my $fn = $dirhash->{$dir}->{$name}; - $versions->{$fn}++; # init with version - #print "init:$fn:$versions->{$fn}\n"; - } - } - } -} - -my $cached_nodename; - -sub nodename { - - return $cached_nodename if $cached_nodename; - - my ($sysname, $nodename) = POSIX::uname(); - - $nodename =~ s/\..*$//; # strip domain part, if any - - die "unable to read node name\n" if !$nodename; - - $cached_nodename = $nodename; - - return $cached_nodename; -} - -sub read_etc_hostname { - my ($filename, $fd) = @_; - - my $hostname = <$fd>; - - chomp $hostname; - - $hostname =~ s/\..*$//; # strip domain part, if any - - return $hostname; -} - -sub write_etc_hostname { - my ($filename, $fh, $hostname) = @_; - - die "write failed: $!" unless print $fh "$hostname\n"; - - return $hostname; -} - -register_file('hostname', "/etc/hostname", - \&read_etc_hostname, - \&write_etc_hostname); - -sub read_etc_resolv_conf { - my ($filename, $fh) = @_; - - my $res = {}; - - my $nscount = 0; - while (my $line = <$fh>) { - chomp $line; - if ($line =~ m/^(search|domain)\s+(\S+)\s*/) { - $res->{search} = $2; - } elsif ($line =~ m/^nameserver\s+(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\s*/) { - $nscount++; - if ($nscount <= 3) { - $res->{"dns$nscount"} = $1; - } - } - } - - return $res; -} - -sub update_etc_resolv_conf { - my ($filename, $fh, $resolv, @args) = @_; - - my $data = ""; - - $data = "search $resolv->{search}\n" - if $resolv->{search}; - - my $written = {}; - foreach my $k ("dns1", "dns2", "dns3") { - my $ns = $resolv->{$k}; - if ($ns && $ns ne '0.0.0.0' && !$written->{$ns}) { - $written->{$ns} = 1; - $data .= "nameserver $ns\n"; - } - } - - while (my $line = <$fh>) { - next if $line =~ m/^(search|domain|nameserver)\s+/; - $data .= $line - } - - return $data; -} - -register_file('resolvconf', "/etc/resolv.conf", - \&read_etc_resolv_conf, undef, - \&update_etc_resolv_conf); - -sub read_etc_timezone { - my ($filename, $fd) = @_; - - my $timezone = <$fd>; - - chomp $timezone; - - return $timezone; -} - -sub write_etc_timezone { - my ($filename, $fh, $timezone) = @_; - - my $tzinfo = "/usr/share/zoneinfo/$timezone"; - - raise_param_exc({ 'timezone' => "No such timezone" }) - if (! -f $tzinfo); - - ($timezone) = $timezone =~ m/^(.*)$/; # untaint - - print $fh "$timezone\n"; - - unlink ("/etc/localtime"); - symlink ("/usr/share/zoneinfo/$timezone", "/etc/localtime"); - -} - -register_file('timezone', "/etc/timezone", - \&read_etc_timezone, - \&write_etc_timezone); - -sub read_active_workers { - my ($filename, $fh) = @_; - - return [] if !$fh; - - my $res = []; - while (defined (my $line = <$fh>)) { - if ($line =~ m/^(\S+)\s(0|1)(\s([0-9A-Za-z]{8})(\s(\s*\S.*))?)?$/) { - my $upid = $1; - my $saved = $2; - my $endtime = $4; - my $status = $6; - if ((my $task = PVE::Tools::upid_decode($upid, 1))) { - $task->{upid} = $upid; - $task->{saved} = $saved; - $task->{endtime} = hex($endtime) if $endtime; - $task->{status} = $status if $status; - push @$res, $task; - } - } else { - warn "unable to parse line: $line"; - } - } - - return $res; - -} - -sub write_active_workers { - my ($filename, $fh, $tasklist) = @_; - - my $raw = ''; - foreach my $task (@$tasklist) { - my $upid = $task->{upid}; - my $saved = $task->{saved} ? 1 : 0; - if ($task->{endtime}) { - if ($task->{status}) { - $raw .= sprintf("$upid $saved %08X $task->{status}\n", $task->{endtime}); - } else { - $raw .= sprintf("$upid $saved %08X\n", $task->{endtime}); - } - } else { - $raw .= "$upid $saved\n"; - } - } - - PVE::Tools::safe_print($filename, $fh, $raw) if $raw; -} - -register_file('active', "/var/log/pve/tasks/active", - \&read_active_workers, - \&write_active_workers); - - -my $bond_modes = { 'balance-rr' => 0, - 'active-backup' => 1, - 'balance-xor' => 2, - 'broadcast' => 3, - '802.3ad' => 4, - 'balance-tlb' => 5, - 'balance-alb' => 6, - }; - -my $ovs_bond_modes = { - 'active-backup' => 1, - 'balance-slb' => 1, - 'lacp-balance-slb' => 1, - 'lacp-balance-tcp' => 1, -}; - -#sub get_bond_modes { -# return $bond_modes; -#} - -my $parse_ovs_option = sub { - my ($data) = @_; - - my $opts = {}; - foreach my $kv (split (/\s+/, $data || '')) { - my ($k, $v) = split('=', $kv, 2); - $opts->{$k} = $v if $k && $v; - } - return $opts; -}; - -my $set_ovs_option = sub { - my ($d, %params) = @_; - - my $opts = &$parse_ovs_option($d->{ovs_options}); - - foreach my $k (keys %params) { - my $v = $params{$k}; - if ($v) { - $opts->{$k} = $v; - } else { - delete $opts->{$k}; - } - } - - my $res = []; - foreach my $k (keys %$opts) { - push @$res, "$k=$opts->{$k}"; - } - - if (my $new = join(' ', @$res)) { - $d->{ovs_options} = $new; - return $d->{ovs_options}; - } else { - delete $d->{ovs_options}; - return undef; - } -}; - -my $extract_ovs_option = sub { - my ($d, $name) = @_; - - my $opts = &$parse_ovs_option($d->{ovs_options}); - - my $v = delete $opts->{$name}; - - my $res = []; - foreach my $k (keys %$opts) { - push @$res, "$k=$opts->{$k}"; - } - - if (my $new = join(' ', @$res)) { - $d->{ovs_options} = $new; - } else { - delete $d->{ovs_options}; - } - - return $v; -}; - -sub read_etc_network_interfaces { - my ($filename, $fh) = @_; - - my $ifaces = {}; - - my $line; - - if (my $fd2 = IO::File->new("/proc/net/dev", "r")) { - while (defined ($line = <$fd2>)) { - if ($line =~ m/^\s*(eth\d+):.*/) { - $ifaces->{$1}->{exists} = 1; - } - } - close($fd2); - } - - # we try to keep order inside the file - my $priority = 2; # 1 is reserved for lo - - my $gateway = 0; - - while (defined ($line = <$fh>)) { - chomp ($line); - next if $line =~ m/^#/; - - if ($line =~ m/^auto\s+(.*)$/) { - my @aa = split (/\s+/, $1); - - foreach my $a (@aa) { - $ifaces->{$a}->{autostart} = 1; - } - - } elsif ($line =~ m/^iface\s+(\S+)\s+inet\s+(\S+)\s*$/) { - my $i = $1; - $ifaces->{$i}->{method} = $2; - $ifaces->{$i}->{priority} = $priority++; - - my $d = $ifaces->{$i}; - while (defined ($line = <$fh>)) { - if ($line =~ m/^\s*#(.*)\s*$/) { - # NOTE: we use 'comments' instead of 'comment' to - # avoid automatic utf8 conversion - $d->{comments} = '' if !$d->{comments}; - $d->{comments} .= "$1\n"; - } elsif ($line =~ m/^\s+((\S+)\s+(.+))$/) { - my $option = $1; - my ($id, $value) = ($2, $3); - if (($id eq 'address') || ($id eq 'netmask') || ($id eq 'broadcast')) { - $d->{$id} = $value; - } elsif ($id eq 'gateway') { - $d->{$id} = $value; - $gateway = 1; - } elsif ($id eq 'ovs_type' || $id eq 'ovs_options'|| $id eq 'ovs_bridge' || - $id eq 'ovs_bonds' || $id eq 'ovs_ports') { - $d->{$id} = $value; - } elsif ($id eq 'slaves' || $id eq 'bridge_ports') { - my $devs = {}; - foreach my $p (split (/\s+/, $value)) { - next if $p eq 'none'; - $devs->{$p} = 1; - } - my $str = join (' ', sort keys %{$devs}); - $d->{$id} = $str || ''; - } elsif ($id eq 'bridge_stp') { - if ($value =~ m/^\s*(on|yes)\s*$/i) { - $d->{$id} = 'on'; - } else { - $d->{$id} = 'off'; - } - } elsif ($id eq 'bridge_fd') { - $d->{$id} = $value; - } elsif ($id eq 'bond_miimon') { - $d->{$id} = $value; - } elsif ($id eq 'bond_xmit_hash_policy') { - $d->{$id} = $value; - } elsif ($id eq 'bond_mode') { - # always use names - foreach my $bm (keys %$bond_modes) { - my $id = $bond_modes->{$bm}; - if ($id eq $value) { - $value = $bm; - last; - } - } - $d->{$id} = $value; - } else { - push @{$d->{options}}, $option; - } - } else { - last; - } - } - } - } - - - - if (!$ifaces->{lo}) { - $ifaces->{lo}->{priority} = 1; - $ifaces->{lo}->{method} = 'loopback'; - $ifaces->{lo}->{type} = 'loopback'; - $ifaces->{lo}->{autostart} = 1; - } - - foreach my $iface (keys %$ifaces) { - my $d = $ifaces->{$iface}; - if ($iface =~ m/^bond\d+$/) { - if (!$d->{ovs_type}) { - $d->{type} = 'bond'; - } elsif ($d->{ovs_type} eq 'OVSBond') { - $d->{type} = $d->{ovs_type}; - # translate: ovs_options => bond_mode - $d->{'bond_mode'} = &$extract_ovs_option($d, 'bond_mode'); - my $lacp = &$extract_ovs_option($d, 'lacp'); - if ($lacp && $lacp eq 'active') { - if ($d->{'bond_mode'} eq 'balance-slb') { - $d->{'bond_mode'} = 'lacp-balance-slb'; - } - } - # Note: balance-tcp needs lacp - if ($d->{'bond_mode'} eq 'balance-tcp') { - $d->{'bond_mode'} = 'lacp-balance-tcp'; - } - my $tag = &$extract_ovs_option($d, 'tag'); - $d->{ovs_tag} = $tag if defined($tag); - } else { - $d->{type} = 'unknown'; - } - } elsif ($iface =~ m/^vmbr\d+$/) { - if (!$d->{ovs_type}) { - $d->{type} = 'bridge'; - - if (!defined ($d->{bridge_fd})) { - $d->{bridge_fd} = 0; - } - if (!defined ($d->{bridge_stp})) { - $d->{bridge_stp} = 'off'; - } - } elsif ($d->{ovs_type} eq 'OVSBridge') { - $d->{type} = $d->{ovs_type}; - } else { - $d->{type} = 'unknown'; - } - } elsif ($iface =~ m/^(\S+):\d+$/) { - $d->{type} = 'alias'; - if (defined ($ifaces->{$1})) { - $d->{exists} = $ifaces->{$1}->{exists}; - } else { - $ifaces->{$1}->{exists} = 0; - $d->{exists} = 0; - } - } elsif ($iface =~ m/^eth\d+$/) { - if (!$d->{ovs_type}) { - $d->{type} = 'eth'; - } elsif ($d->{ovs_type} eq 'OVSPort') { - $d->{type} = $d->{ovs_type}; - my $tag = &$extract_ovs_option($d, 'tag'); - $d->{ovs_tag} = $tag if defined($tag); - } else { - $d->{type} = 'unknown'; - } - } elsif ($iface =~ m/^lo$/) { - $d->{type} = 'loopback'; - } else { - if (!$d->{ovs_type}) { - $d->{type} = 'unknown'; - } elsif ($d->{ovs_type} eq 'OVSIntPort') { - $d->{type} = $d->{ovs_type}; - my $tag = &$extract_ovs_option($d, 'tag'); - $d->{ovs_tag} = $tag if defined($tag); - } - } - - $d->{method} = 'manual' if !$d->{method}; - } - - if (my $fd2 = IO::File->new("/proc/net/if_inet6", "r")) { - while (defined ($line = <$fd2>)) { - if ($line =~ m/^[a-f0-9]{32}\s+[a-f0-9]{2}\s+[a-f0-9]{2}\s+[a-f0-9]{2}\s+[a-f0-9]{2}\s+(\S+)$/) { - $ifaces->{$1}->{active} = 1 if defined($ifaces->{$1}); - } - } - close ($fd2); - } - - return $ifaces; -} - -sub __interface_to_string { - my ($iface, $d) = @_; - - return '' if !($d && $d->{method}); - - my $raw = ''; - - $raw .= "iface $iface inet $d->{method}\n"; - $raw .= "\taddress $d->{address}\n" if $d->{address}; - $raw .= "\tnetmask $d->{netmask}\n" if $d->{netmask}; - $raw .= "\tgateway $d->{gateway}\n" if $d->{gateway}; - $raw .= "\tbroadcast $d->{broadcast}\n" if $d->{broadcast}; - - my $done = { type => 1, priority => 1, method => 1, active => 1, exists => 1, - comments => 1, autostart => 1, options => 1, - address => 1, netmask => 1, gateway => 1, broadcast => 1 }; - - if ($d->{type} eq 'bridge') { - - my $ports = $d->{bridge_ports} || 'none'; - $raw .= "\tbridge_ports $ports\n"; - $done->{bridge_ports} = 1; - - my $v = defined($d->{bridge_stp}) ? $d->{bridge_stp} : 'off'; - $raw .= "\tbridge_stp $v\n"; - $done->{bridge_stp} = 1; - - $v = defined($d->{bridge_fd}) ? $d->{bridge_fd} : 0; - $raw .= "\tbridge_fd $v\n"; - $done->{bridge_fd} = 1; - - } elsif ($d->{type} eq 'bond') { - - my $slaves = $d->{slaves} || 'none'; - $raw .= "\tslaves $slaves\n"; - $done->{slaves} = 1; - - my $v = defined ($d->{'bond_miimon'}) ? $d->{'bond_miimon'} : 100; - $raw .= "\tbond_miimon $v\n"; - $done->{'bond_miimon'} = 1; - - $v = defined ($d->{'bond_mode'}) ? $d->{'bond_mode'} : 'balance-rr'; - $raw .= "\tbond_mode $v\n"; - $done->{'bond_mode'} = 1; - - if ($d->{'bond_mode'} && $d->{'bond_xmit_hash_policy'} && - ($d->{'bond_mode'} eq 'balance-xor' || $d->{'bond_mode'} eq '802.3ad')) { - $raw .= "\tbond_xmit_hash_policy $d->{'bond_xmit_hash_policy'}\n"; - } - $done->{'bond_xmit_hash_policy'} = 1; - - } elsif ($d->{type} eq 'OVSBridge') { - - $raw .= "\tovs_type $d->{type}\n"; - $done->{ovs_type} = 1; - - $raw .= "\tovs_ports $d->{ovs_ports}\n" if $d->{ovs_ports}; - $done->{ovs_ports} = 1; - - } elsif ($d->{type} eq 'OVSPort' || $d->{type} eq 'OVSIntPort' || - $d->{type} eq 'OVSBond') { - - $d->{autostart} = 0; # started by the bridge - - if (defined($d->{ovs_tag})) { - &$set_ovs_option($d, tag => $d->{ovs_tag}); - } - $done->{ovs_tag} = 1; - - if ($d->{type} eq 'OVSBond') { - - $d->{bond_mode} = 'active-backup' if !$d->{bond_mode}; - - $ovs_bond_modes->{$d->{bond_mode}} || - die "OVS does not support bond mode '$d->{bond_mode}\n"; - - if ($d->{bond_mode} eq 'lacp-balance-slb') { - &$set_ovs_option($d, lacp => 'active'); - &$set_ovs_option($d, bond_mode => 'balance-slb'); - } elsif ($d->{bond_mode} eq 'lacp-balance-tcp') { - &$set_ovs_option($d, lacp => 'active'); - &$set_ovs_option($d, bond_mode => 'balance-tcp'); - } else { - &$set_ovs_option($d, lacp => undef); - &$set_ovs_option($d, bond_mode => $d->{bond_mode}); - } - $done->{bond_mode} = 1; - - $raw .= "\tovs_bonds $d->{ovs_bonds}\n" if $d->{ovs_bonds}; - $done->{ovs_bonds} = 1; - } - - if ($d->{ovs_bridge}) { - $raw = "allow-$d->{ovs_bridge} $iface\n$raw"; - } - - $raw .= "\tovs_type $d->{type}\n"; - $done->{ovs_type} = 1; - - if ($d->{ovs_bridge}) { - $raw .= "\tovs_bridge $d->{ovs_bridge}\n"; - $done->{ovs_bridge} = 1; - } - # fixme: use Data::Dumper; print Dumper($d); - } - - # print other settings - foreach my $k (keys %$d) { - next if $done->{$k}; - next if !$d->{$k}; - $raw .= "\t$k $d->{$k}\n"; - } - - foreach my $option (@{$d->{options}}) { - $raw .= "\t$option\n"; - } - - # add comments - my $comments = $d->{comments} || ''; - foreach my $cl (split(/\n/, $comments)) { - $raw .= "#$cl\n"; - } - - if ($d->{autostart}) { - $raw = "auto $iface\n$raw"; - } - - $raw .= "\n"; - - return $raw; -} - -sub write_etc_network_interfaces { - my ($filename, $fh, $ifaces) = @_; - - my $used_ports = {}; - - foreach my $iface (keys %$ifaces) { - my $d = $ifaces->{$iface}; - - my $ports = ''; - foreach my $k (qw(bridge_ports ovs_ports slaves ovs_bonds)) { - $ports .= " $d->{$k}" if $d->{$k}; - } - - foreach my $p (PVE::Tools::split_list($ports)) { - die "port '$p' is already used on interface '$used_ports->{$p}'\n" - if $used_ports->{$p} && $used_ports->{$p} ne $iface; - $used_ports->{$p} = $iface; - } - } - - # delete unused OVS ports - foreach my $iface (keys %$ifaces) { - my $d = $ifaces->{$iface}; - if ($d->{type} eq 'OVSPort' || $d->{type} eq 'OVSIntPort' || - $d->{type} eq 'OVSBond') { - my $brname = $used_ports->{$iface}; - if (!$brname || !$ifaces->{$brname}) { - delete $ifaces->{$iface}; - next; - } - my $bd = $ifaces->{$brname}; - if ($bd->{type} ne 'OVSBridge') { - delete $ifaces->{$iface}; - next; - } - } - } - - # create OVS bridge ports - foreach my $iface (keys %$ifaces) { - my $d = $ifaces->{$iface}; - if ($d->{type} eq 'OVSBridge' && $d->{ovs_ports}) { - foreach my $p (split (/\s+/, $d->{ovs_ports})) { - my $n = $ifaces->{$p}; - die "OVS bridge '$iface' - unable to find port '$p'\n" - if !$n; - if ($n->{type} eq 'eth') { - $n->{type} = 'OVSPort'; - $n->{ovs_bridge} = $iface; - } elsif ($n->{type} eq 'OVSBond' || $n->{type} eq 'OVSPort' || - $n->{type} eq 'OVSIntPort') { - $n->{ovs_bridge} = $iface; - } else { - die "interface '$p' is not defined as OVS port/bond\n"; - } - } - } - } - - # check OVS bond ports - foreach my $iface (keys %$ifaces) { - my $d = $ifaces->{$iface}; - if ($d->{type} eq 'OVSBond' && $d->{ovs_bonds}) { - foreach my $p (split (/\s+/, $d->{ovs_bonds})) { - my $n = $ifaces->{$p}; - die "OVS bond '$iface' - unable to find slave '$p'\n" - if !$n; - die "OVS bond '$iface' - wrong interface type on slave '$p' " . - "('$n->{type}' != 'eth')\n" if $n->{type} ne 'eth'; - } - } - } - - my $raw = "# network interface settings\n"; - - my $printed = {}; - - my $if_type_hash = { - unknown => 0, - loopback => 10, - eth => 20, - bond => 30, - bridge => 40, - }; - - my $lookup_type_prio = sub { - my $iface = shift; - - my $alias = 0; - if ($iface =~ m/^(\S+):\d+$/) { - $iface = $1; - $alias = 1; - } - - my $pri; - if ($iface eq 'lo') { - $pri = $if_type_hash->{loopback}; - } elsif ($iface =~ m/^eth\d+$/) { - $pri = $if_type_hash->{eth} + $alias; - } elsif ($iface =~ m/^bond\d+$/) { - $pri = $if_type_hash->{bond} + $alias; - } elsif ($iface =~ m/^vmbr\d+$/) { - $pri = $if_type_hash->{bridge} + $alias; - } - - return $pri || ($if_type_hash->{unknown} + $alias); - }; - - foreach my $iface (sort { - my $ref1 = $ifaces->{$a}; - my $ref2 = $ifaces->{$b}; - my $p1 = &$lookup_type_prio($a); - my $p2 = &$lookup_type_prio($b); - - return $p1 <=> $p2 if $p1 != $p2; - - $p1 = $ref1->{priority} || 100000; - $p2 = $ref2->{priority} || 100000; - - return $p1 <=> $p2 if $p1 != $p2; - - return $a cmp $b; - } keys %$ifaces) { - - my $d = $ifaces->{$iface}; - - next if $printed->{$iface}; - - $printed->{$iface} = 1; - $raw .= __interface_to_string($iface, $d); - } - - PVE::Tools::safe_print($filename, $fh, $raw); -} - -register_file('interfaces', "/etc/network/interfaces", - \&read_etc_network_interfaces, - \&write_etc_network_interfaces); - - -sub read_iscsi_initiatorname { - my ($filename, $fd) = @_; - - while (defined(my $line = <$fd>)) { - if ($line =~ m/^InitiatorName=(\S+)$/) { - return $1; - } - } - - return 'undefined'; -} - -register_file('initiatorname', "/etc/iscsi/initiatorname.iscsi", - \&read_iscsi_initiatorname); - -sub read_apt_auth { - my ($filename, $fd) = @_; - - local $/; - - my $raw = defined($fd) ? <$fd> : ''; - - $raw =~ s/^\s+//; - - - my @tokens = split(/\s+/, $raw); - - my $data = {}; - - my $machine; - while (defined(my $tok = shift @tokens)) { - - $machine = shift @tokens if $tok eq 'machine'; - next if !$machine; - $data->{$machine} = {} if !$data->{$machine}; - - $data->{$machine}->{login} = shift @tokens if $tok eq 'login'; - $data->{$machine}->{password} = shift @tokens if $tok eq 'password'; - }; - - return $data; -} - -my $format_apt_auth_data = sub { - my $data = shift; - - my $raw = ''; - - foreach my $machine (sort keys %$data) { - my $d = $data->{$machine}; - $raw .= "machine $machine\n"; - $raw .= " login $d->{login}\n" if $d->{login}; - $raw .= " password $d->{password}\n" if $d->{password}; - $raw .= "\n"; - } - - return $raw; -}; - -sub write_apt_auth { - my ($filename, $fh, $data) = @_; - - my $raw = &$format_apt_auth_data($data); - - die "write failed: $!" unless print $fh "$raw\n"; - - return $data; -} - -sub update_apt_auth { - my ($filename, $fh, $data) = @_; - - my $orig = read_apt_auth($filename, $fh); - - foreach my $machine (keys %$data) { - $orig->{$machine} = $data->{$machine}; - } - - return &$format_apt_auth_data($orig); -} - -register_file('apt-auth', "/etc/apt/auth.conf", - \&read_apt_auth, \&write_apt_auth, - \&update_apt_auth, perm => 0640); - -1; diff --git a/data/PVE/JSONSchema.pm b/data/PVE/JSONSchema.pm deleted file mode 100644 index 3e0fd52..0000000 --- a/data/PVE/JSONSchema.pm +++ /dev/null @@ -1,1126 +0,0 @@ -package PVE::JSONSchema; - -use strict; -use warnings; -use Storable; # for dclone -use Getopt::Long; -use Devel::Cycle -quiet; # todo: remove? -use PVE::Tools qw(split_list $IPV6RE $IPV4RE); -use PVE::Exception qw(raise); -use HTTP::Status qw(:constants); -use Net::IP qw(:PROC); - -use base 'Exporter'; - -our @EXPORT_OK = qw( -register_standard_option -get_standard_option -); - -# Note: This class implements something similar to JSON schema, but it is not 100% complete. -# see: http://tools.ietf.org/html/draft-zyp-json-schema-02 -# see: http://json-schema.org/ - -# the code is similar to the javascript parser from http://code.google.com/p/jsonschema/ - -my $standard_options = {}; -sub register_standard_option { - my ($name, $schema) = @_; - - die "standard option '$name' already registered\n" - if $standard_options->{$name}; - - $standard_options->{$name} = $schema; -} - -sub get_standard_option { - my ($name, $base) = @_; - - my $std = $standard_options->{$name}; - die "no such standard option\n" if !$std; - - my $res = $base || {}; - - foreach my $opt (keys %$std) { - next if $res->{$opt}; - $res->{$opt} = $std->{$opt}; - } - - return $res; -}; - -register_standard_option('pve-vmid', { - description => "The (unique) ID of the VM.", - type => 'integer', format => 'pve-vmid', - minimum => 1 -}); - -register_standard_option('pve-node', { - description => "The cluster node name.", - type => 'string', format => 'pve-node', -}); - -register_standard_option('pve-node-list', { - description => "List of cluster node names.", - type => 'string', format => 'pve-node-list', -}); - -register_standard_option('pve-iface', { - description => "Network interface name.", - type => 'string', format => 'pve-iface', - minLength => 2, maxLength => 20, -}); - -PVE::JSONSchema::register_standard_option('pve-storage-id', { - description => "The storage identifier.", - type => 'string', format => 'pve-storage-id', -}); - -PVE::JSONSchema::register_standard_option('pve-config-digest', { - description => 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.', - type => 'string', - optional => 1, - maxLength => 40, # sha1 hex digest lenght is 40 -}); - -my $format_list = {}; - -sub register_format { - my ($format, $code) = @_; - - die "JSON schema format '$format' already registered\n" - if $format_list->{$format}; - - $format_list->{$format} = $code; -} - -# register some common type for pve - -register_format('string', sub {}); # allow format => 'string-list' - -register_format('pve-configid', \&pve_verify_configid); -sub pve_verify_configid { - my ($id, $noerr) = @_; - - if ($id !~ m/^[a-z][a-z0-9_]+$/i) { - return undef if $noerr; - die "invalid configuration ID '$id'\n"; - } - return $id; -} - -PVE::JSONSchema::register_format('pve-storage-id', \&parse_storage_id); -sub parse_storage_id { - my ($storeid, $noerr) = @_; - - if ($storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) { - return undef if $noerr; - die "storage ID '$storeid' contains illegal characters\n"; - } - return $storeid; -} - - -register_format('pve-vmid', \&pve_verify_vmid); -sub pve_verify_vmid { - my ($vmid, $noerr) = @_; - - if ($vmid !~ m/^[1-9][0-9]+$/) { - return undef if $noerr; - die "value does not look like a valid VM ID\n"; - } - return $vmid; -} - -register_format('pve-node', \&pve_verify_node_name); -sub pve_verify_node_name { - my ($node, $noerr) = @_; - - if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) { - return undef if $noerr; - die "value does not look like a valid node name\n"; - } - return $node; -} - -register_format('ipv4', \&pve_verify_ipv4); -sub pve_verify_ipv4 { - my ($ipv4, $noerr) = @_; - - if (!Net::IP::ip_is_ipv4($ipv4)) { - return undef if $noerr; - die "value does not look like a valid IP address\n"; - } - return $ipv4; -} - -my $ipv4_mask_hash = { - '128.0.0.0' => 1, - '192.0.0.0' => 2, - '224.0.0.0' => 3, - '240.0.0.0' => 4, - '248.0.0.0' => 5, - '252.0.0.0' => 6, - '254.0.0.0' => 7, - '255.0.0.0' => 8, - '255.128.0.0' => 9, - '255.192.0.0' => 10, - '255.224.0.0' => 11, - '255.240.0.0' => 12, - '255.248.0.0' => 13, - '255.252.0.0' => 14, - '255.254.0.0' => 15, - '255.255.0.0' => 16, - '255.255.128.0' => 17, - '255.255.192.0' => 18, - '255.255.224.0' => 19, - '255.255.240.0' => 20, - '255.255.248.0' => 21, - '255.255.252.0' => 22, - '255.255.254.0' => 23, - '255.255.255.0' => 24, - '255.255.255.128' => 25, - '255.255.255.192' => 26, - '255.255.255.224' => 27, - '255.255.255.240' => 28, - '255.255.255.248' => 29, - '255.255.255.252' => 30 -}; - -register_format('ipv4mask', \&pve_verify_ipv4mask); -sub pve_verify_ipv4mask { - my ($mask, $noerr) = @_; - - if (!defined($ipv4_mask_hash->{$mask})) { - return undef if $noerr; - die "value does not look like a valid IP netmask\n"; - } - return $mask; -} - -register_format('CIDR', \&pve_verify_cidr); -sub pve_verify_cidr { - my ($cidr, $noerr) = @_; - - if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 < 32)) { - return $cidr; - } elsif ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 120)) { - return $cidr; - } - - return undef if $noerr; - die "value does not look like a valid CIDR network\n"; -} - -register_format('email', \&pve_verify_email); -sub pve_verify_email { - my ($email, $noerr) = @_; - - # we use same regex as extjs Ext.form.VTypes.email - if ($email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,6}$/) { - return undef if $noerr; - die "value does not look like a valid email address\n"; - } - return $email; -} - -register_format('dns-name', \&pve_verify_dns_name); -sub pve_verify_dns_name { - my ($name, $noerr) = @_; - - my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)"; - - if ($name !~ /^(${namere}\.)*${namere}$/) { - return undef if $noerr; - die "value does not look like a valid DNS name\n"; - } - return $name; -} - -# network interface name -register_format('pve-iface', \&pve_verify_iface); -sub pve_verify_iface { - my ($id, $noerr) = @_; - - if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) { - return undef if $noerr; - die "invalid network interface name '$id'\n"; - } - return $id; -} - -register_standard_option('spice-proxy', { - description => "SPICE proxy server. This can be used by the client to specify the proxy server. All nodes in a cluster runs 'spiceproxy', so it is up to the client to choose one. By default, we return the node where the VM is currently running. As resonable setting is to use same node you use to connect to the API (This is window.location.hostname for the JS GUI).", - type => 'string', format => 'dns-name', -}); - -register_standard_option('remote-viewer-config', { - description => "Returned values can be directly passed to the 'remote-viewer' application.", - additionalProperties => 1, - properties => { - type => { type => 'string' }, - password => { type => 'string' }, - proxy => { type => 'string' }, - host => { type => 'string' }, - 'tls-port' => { type => 'integer' }, - }, -}); - -sub check_format { - my ($format, $value) = @_; - - return if $format eq 'regex'; - - if ($format =~ m/^(.*)-a?list$/) { - - my $code = $format_list->{$1}; - - die "undefined format '$format'\n" if !$code; - - # Note: we allow empty lists - foreach my $v (split_list($value)) { - &$code($v); - } - - } elsif ($format =~ m/^(.*)-opt$/) { - - my $code = $format_list->{$1}; - - die "undefined format '$format'\n" if !$code; - - return if !$value; # allow empty string - - &$code($value); - - } else { - - my $code = $format_list->{$format}; - - die "undefined format '$format'\n" if !$code; - - &$code($value); - } -} - -sub add_error { - my ($errors, $path, $msg) = @_; - - $path = '_root' if !$path; - - if ($errors->{$path}) { - $errors->{$path} = join ('\n', $errors->{$path}, $msg); - } else { - $errors->{$path} = $msg; - } -} - -sub is_number { - my $value = shift; - - # see 'man perlretut' - return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/; -} - -sub is_integer { - my $value = shift; - - return $value =~ m/^[+-]?\d+$/; -} - -sub check_type { - my ($path, $type, $value, $errors) = @_; - - return 1 if !$type; - - if (!defined($value)) { - return 1 if $type eq 'null'; - die "internal error" - } - - if (my $tt = ref($type)) { - if ($tt eq 'ARRAY') { - foreach my $t (@$type) { - my $tmperr = {}; - check_type($path, $t, $value, $tmperr); - return 1 if !scalar(%$tmperr); - } - my $ttext = join ('|', @$type); - add_error($errors, $path, "type check ('$ttext') failed"); - return undef; - } elsif ($tt eq 'HASH') { - my $tmperr = {}; - check_prop($value, $type, $path, $tmperr); - return 1 if !scalar(%$tmperr); - add_error($errors, $path, "type check failed"); - return undef; - } else { - die "internal error - got reference type '$tt'"; - } - - } else { - - return 1 if $type eq 'any'; - - if ($type eq 'null') { - if (defined($value)) { - add_error($errors, $path, "type check ('$type') failed - value is not null"); - return undef; - } - return 1; - } - - my $vt = ref($value); - - if ($type eq 'array') { - if (!$vt || $vt ne 'ARRAY') { - add_error($errors, $path, "type check ('$type') failed"); - return undef; - } - return 1; - } elsif ($type eq 'object') { - if (!$vt || $vt ne 'HASH') { - add_error($errors, $path, "type check ('$type') failed"); - return undef; - } - return 1; - } elsif ($type eq 'coderef') { - if (!$vt || $vt ne 'CODE') { - add_error($errors, $path, "type check ('$type') failed"); - return undef; - } - return 1; - } else { - if ($vt) { - add_error($errors, $path, "type check ('$type') failed - got $vt"); - return undef; - } else { - if ($type eq 'string') { - return 1; # nothing to check ? - } elsif ($type eq 'boolean') { - #if ($value =~ m/^(1|true|yes|on)$/i) { - if ($value eq '1') { - return 1; - #} elsif ($value =~ m/^(0|false|no|off)$/i) { - } elsif ($value eq '0') { - return 0; - } else { - add_error($errors, $path, "type check ('$type') failed - got '$value'"); - return undef; - } - } elsif ($type eq 'integer') { - if (!is_integer($value)) { - add_error($errors, $path, "type check ('$type') failed - got '$value'"); - return undef; - } - return 1; - } elsif ($type eq 'number') { - if (!is_number($value)) { - add_error($errors, $path, "type check ('$type') failed - got '$value'"); - return undef; - } - return 1; - } else { - return 1; # no need to verify unknown types - } - } - } - } - - return undef; -} - -sub check_object { - my ($path, $schema, $value, $additional_properties, $errors) = @_; - - # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema); - - my $st = ref($schema); - if (!$st || $st ne 'HASH') { - add_error($errors, $path, "Invalid schema definition."); - return; - } - - my $vt = ref($value); - if (!$vt || $vt ne 'HASH') { - add_error($errors, $path, "an object is required"); - return; - } - - foreach my $k (keys %$schema) { - check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors); - } - - foreach my $k (keys %$value) { - - my $newpath = $path ? "$path.$k" : $k; - - if (my $subschema = $schema->{$k}) { - if (my $requires = $subschema->{requires}) { - if (ref($requires)) { - #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ; - check_prop($value, $requires, $path, $errors); - } elsif (!defined($value->{$requires})) { - add_error($errors, $path ? "$path.$requires" : $requires, - "missing property - '$newpath' requiers this property"); - } - } - - next; # value is already checked above - } - - if (defined ($additional_properties) && !$additional_properties) { - add_error($errors, $newpath, "property is not defined in schema " . - "and the schema does not allow additional properties"); - next; - } - check_prop($value->{$k}, $additional_properties, $newpath, $errors) - if ref($additional_properties); - } -} - -sub check_prop { - my ($value, $schema, $path, $errors) = @_; - - die "internal error - no schema" if !$schema; - die "internal error" if !$errors; - - #print "check_prop $path\n" if $value; - - my $st = ref($schema); - if (!$st || $st ne 'HASH') { - add_error($errors, $path, "Invalid schema definition."); - return; - } - - # if it extends another schema, it must pass that schema as well - if($schema->{extends}) { - check_prop($value, $schema->{extends}, $path, $errors); - } - - if (!defined ($value)) { - return if $schema->{type} && $schema->{type} eq 'null'; - if (!$schema->{optional}) { - add_error($errors, $path, "property is missing and it is not optional"); - } - return; - } - - return if !check_type($path, $schema->{type}, $value, $errors); - - if ($schema->{disallow}) { - my $tmperr = {}; - if (check_type($path, $schema->{disallow}, $value, $tmperr)) { - add_error($errors, $path, "disallowed value was matched"); - return; - } - } - - if (my $vt = ref($value)) { - - if ($vt eq 'ARRAY') { - if ($schema->{items}) { - my $it = ref($schema->{items}); - if ($it && $it eq 'ARRAY') { - #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value); - die "not implemented"; - } else { - my $ind = 0; - foreach my $el (@$value) { - check_prop($el, $schema->{items}, "${path}[$ind]", $errors); - $ind++; - } - } - } - return; - } elsif ($schema->{properties} || $schema->{additionalProperties}) { - check_object($path, defined($schema->{properties}) ? $schema->{properties} : {}, - $value, $schema->{additionalProperties}, $errors); - return; - } - - } else { - - if (my $format = $schema->{format}) { - eval { check_format($format, $value); }; - if ($@) { - add_error($errors, $path, "invalid format - $@"); - return; - } - } - - if (my $pattern = $schema->{pattern}) { - if ($value !~ m/^$pattern$/) { - add_error($errors, $path, "value does not match the regex pattern"); - return; - } - } - - if (defined (my $max = $schema->{maxLength})) { - if (length($value) > $max) { - add_error($errors, $path, "value may only be $max characters long"); - return; - } - } - - if (defined (my $min = $schema->{minLength})) { - if (length($value) < $min) { - add_error($errors, $path, "value must be at least $min characters long"); - return; - } - } - - if (is_number($value)) { - if (defined (my $max = $schema->{maximum})) { - if ($value > $max) { - add_error($errors, $path, "value must have a maximum value of $max"); - return; - } - } - - if (defined (my $min = $schema->{minimum})) { - if ($value < $min) { - add_error($errors, $path, "value must have a minimum value of $min"); - return; - } - } - } - - if (my $ea = $schema->{enum}) { - - my $found; - foreach my $ev (@$ea) { - if ($ev eq $value) { - $found = 1; - last; - } - } - if (!$found) { - add_error($errors, $path, "value '$value' does not have a value in the enumeration '" . - join(", ", @$ea) . "'"); - } - } - } -} - -sub validate { - my ($instance, $schema, $errmsg) = @_; - - my $errors = {}; - $errmsg = "Parameter verification failed.\n" if !$errmsg; - - # todo: cycle detection is only needed for debugging, I guess - # we can disable that in the final release - # todo: is there a better/faster way to detect cycles? - my $cycles = 0; - find_cycle($instance, sub { $cycles = 1 }); - if ($cycles) { - add_error($errors, undef, "data structure contains recursive cycles"); - } elsif ($schema) { - check_prop($instance, $schema, '', $errors); - } - - if (scalar(%$errors)) { - raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors; - } - - return 1; -} - -my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"]; -my $default_schema_noref = { - description => "This is the JSON Schema for JSON Schemas.", - type => [ "object" ], - additionalProperties => 0, - properties => { - type => { - type => ["string", "array"], - description => "This is a type definition value. This can be a simple type, or a union type", - optional => 1, - default => "any", - items => { - type => "string", - enum => $schema_valid_types, - }, - enum => $schema_valid_types, - }, - optional => { - type => "boolean", - description => "This indicates that the instance property in the instance object is not required.", - optional => 1, - default => 0 - }, - properties => { - type => "object", - description => "This is a definition for the properties of an object value", - optional => 1, - default => {}, - }, - items => { - type => "object", - description => "When the value is an array, this indicates the schema to use to validate each item in an array", - optional => 1, - default => {}, - }, - additionalProperties => { - type => [ "boolean", "object"], - description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.", - optional => 1, - default => {}, - }, - minimum => { - type => "number", - optional => 1, - description => "This indicates the minimum value for the instance property when the type of the instance value is a number.", - }, - maximum => { - type => "number", - optional => 1, - description => "This indicates the maximum value for the instance property when the type of the instance value is a number.", - }, - minLength => { - type => "integer", - description => "When the instance value is a string, this indicates minimum length of the string", - optional => 1, - minimum => 0, - default => 0, - }, - maxLength => { - type => "integer", - description => "When the instance value is a string, this indicates maximum length of the string.", - optional => 1, - }, - typetext => { - type => "string", - optional => 1, - description => "A text representation of the type (used to generate documentation).", - }, - pattern => { - type => "string", - format => "regex", - description => "When the instance value is a string, this provides a regular expression that a instance string value should match in order to be valid.", - optional => 1, - default => ".*", - }, - - enum => { - type => "array", - optional => 1, - description => "This provides an enumeration of possible values that are valid for the instance property.", - }, - description => { - type => "string", - optional => 1, - description => "This provides a description of the purpose the instance property. The value can be a string or it can be an object with properties corresponding to various different instance languages (with an optional default property indicating the default description).", - }, - title => { - type => "string", - optional => 1, - description => "This provides the title of the property", - }, - requires => { - type => [ "string", "object" ], - optional => 1, - description => "indicates a required property or a schema that must be validated if this property is present", - }, - format => { - type => "string", - optional => 1, - description => "This indicates what format the data is among some predefined formats which may include:\n\ndate - a string following the ISO format \naddress \nschema - a schema definition object \nperson \npage \nhtml - a string representing HTML", - }, - default => { - type => "any", - optional => 1, - description => "This indicates the default for the instance property." - }, - disallow => { - type => "object", - optional => 1, - description => "This attribute may take the same values as the \"type\" attribute, however if the instance matches the type or if this value is an array and the instance matches any type or schema in the array, than this instance is not valid.", - }, - extends => { - type => "object", - optional => 1, - description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.", - default => {}, - }, - # this is from hyper schema - links => { - type => "array", - description => "This defines the link relations of the instance objects", - optional => 1, - items => { - type => "object", - properties => { - href => { - type => "string", - description => "This defines the target URL for the relation and can be parameterized using {propertyName} notation. It should be resolved as a URI-reference relative to the URI that was used to retrieve the instance document", - }, - rel => { - type => "string", - description => "This is the name of the link relation", - optional => 1, - default => "full", - }, - method => { - type => "string", - description => "For submission links, this defines the method that should be used to access the target resource", - optional => 1, - default => "GET", - }, - }, - }, - }, - } -}; - -my $default_schema = Storable::dclone($default_schema_noref); - -$default_schema->{properties}->{properties}->{additionalProperties} = $default_schema; -$default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties}; - -$default_schema->{properties}->{items}->{properties} = $default_schema->{properties}; -$default_schema->{properties}->{items}->{additionalProperties} = 0; - -$default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties}; -$default_schema->{properties}->{disallow}->{additionalProperties} = 0; - -$default_schema->{properties}->{requires}->{properties} = $default_schema->{properties}; -$default_schema->{properties}->{requires}->{additionalProperties} = 0; - -$default_schema->{properties}->{extends}->{properties} = $default_schema->{properties}; -$default_schema->{properties}->{extends}->{additionalProperties} = 0; - -my $method_schema = { - type => "object", - additionalProperties => 0, - properties => { - description => { - description => "This a description of the method", - optional => 1, - }, - name => { - type => 'string', - description => "This indicates the name of the function to call.", - optional => 1, - requires => { - additionalProperties => 1, - properties => { - name => {}, - description => {}, - code => {}, - method => {}, - parameters => {}, - path => {}, - parameters => {}, - returns => {}, - } - }, - }, - method => { - type => 'string', - description => "The HTTP method name.", - enum => [ 'GET', 'POST', 'PUT', 'DELETE' ], - optional => 1, - }, - protected => { - type => 'boolean', - description => "Method needs special privileges - only pvedaemon can execute it", - optional => 1, - }, - proxyto => { - type => 'string', - description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.", - optional => 1, - }, - permissions => { - type => 'object', - description => "Required access permissions. By default only 'root' is allowed to access this method.", - optional => 1, - additionalProperties => 0, - properties => { - description => { - description => "Describe access permissions.", - optional => 1, - }, - user => { - description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.", - type => 'string', - enum => ['all', 'world'], - optional => 1, - }, - check => { - description => "Array of permission checks (prefix notation).", - type => 'array', - optional => 1 - }, - }, - }, - match_name => { - description => "Used internally", - optional => 1, - }, - match_re => { - description => "Used internally", - optional => 1, - }, - path => { - type => 'string', - description => "path for URL matching (uri template)", - }, - fragmentDelimiter => { - type => 'string', - description => "A ways to override the default fragment delimiter '/'. This onyl works on a whole sub-class. You can set this to the empty string to match the whole rest of the URI.", - optional => 1, - }, - parameters => { - type => 'object', - description => "JSON Schema for parameters.", - optional => 1, - }, - returns => { - type => 'object', - description => "JSON Schema for return value.", - optional => 1, - }, - code => { - type => 'coderef', - description => "method implementaion (code reference)", - optional => 1, - }, - subclass => { - type => 'string', - description => "Delegate call to this class (perl class string).", - optional => 1, - requires => { - additionalProperties => 0, - properties => { - subclass => {}, - path => {}, - match_name => {}, - match_re => {}, - fragmentDelimiter => { optional => 1 } - } - }, - }, - }, - -}; - -sub validate_schema { - my ($schema) = @_; - - my $errmsg = "internal error - unable to verify schema\n"; - validate($schema, $default_schema, $errmsg); -} - -sub validate_method_info { - my $info = shift; - - my $errmsg = "internal error - unable to verify method info\n"; - validate($info, $method_schema, $errmsg); - - validate_schema($info->{parameters}) if $info->{parameters}; - validate_schema($info->{returns}) if $info->{returns}; -} - -# run a self test on load -# make sure we can verify the default schema -validate_schema($default_schema_noref); -validate_schema($method_schema); - -# and now some utility methods (used by pve api) -sub method_get_child_link { - my ($info) = @_; - - return undef if !$info; - - my $schema = $info->{returns}; - return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array'; - - my $links = $schema->{links}; - return undef if !$links; - - my $found; - foreach my $lnk (@$links) { - if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) { - $found = $lnk; - last; - } - } - - return $found; -} - -# a way to parse command line parameters, using a -# schema to configure Getopt::Long -sub get_options { - my ($schema, $args, $arg_param, $fixed_param, $pwcallback) = @_; - - if (!$schema || !$schema->{properties}) { - raise("too many arguments\n", code => HTTP_BAD_REQUEST) - if scalar(@$args) != 0; - return {}; - } - - my $list_param; - if ($arg_param && !ref($arg_param)) { - my $pd = $schema->{properties}->{$arg_param}; - die "expected list format $pd->{format}" - if !($pd && $pd->{format} && $pd->{format} =~ m/-list/); - $list_param = $arg_param; - } - - my @getopt = (); - foreach my $prop (keys %{$schema->{properties}}) { - my $pd = $schema->{properties}->{$prop}; - next if $list_param && $prop eq $list_param; - next if defined($fixed_param->{$prop}); - - if ($prop eq 'password' && $pwcallback) { - # we do not accept plain password on input line, instead - # we turn this into a boolean option and ask for password below - # using $pwcallback() (for security reasons). - push @getopt, "$prop"; - } elsif ($pd->{type} eq 'boolean') { - push @getopt, "$prop:s"; - } else { - if ($pd->{format} && $pd->{format} =~ m/-a?list/) { - push @getopt, "$prop=s@"; - } else { - push @getopt, "$prop=s"; - } - } - } - - my $opts = {}; - raise("unable to parse option\n", code => HTTP_BAD_REQUEST) - if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt); - - if (my $acount = scalar(@$args)) { - if ($list_param) { - $opts->{$list_param} = $args; - $args = []; - } elsif (ref($arg_param)) { - raise("wrong number of arguments\n", code => HTTP_BAD_REQUEST) - if scalar(@$arg_param) != $acount; - foreach my $p (@$arg_param) { - $opts->{$p} = shift @$args; - } - } else { - raise("too many arguments\n", code => HTTP_BAD_REQUEST) - if scalar(@$args) != 0; - } - } - - if (my $pd = $schema->{properties}->{password}) { - if ($pd->{type} ne 'boolean' && $pwcallback) { - if ($opts->{password} || !$pd->{optional}) { - $opts->{password} = &$pwcallback(); - } - } - } - - $opts = PVE::Tools::decode_utf8_parameters($opts); - - foreach my $p (keys %$opts) { - if (my $pd = $schema->{properties}->{$p}) { - if ($pd->{type} eq 'boolean') { - if ($opts->{$p} eq '') { - $opts->{$p} = 1; - } elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) { - $opts->{$p} = 1; - } elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) { - $opts->{$p} = 0; - } else { - raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST); - } - } elsif ($pd->{format}) { - - if ($pd->{format} =~ m/-list/) { - # allow --vmid 100 --vmid 101 and --vmid 100,101 - # allow --dow mon --dow fri and --dow mon,fri - $opts->{$p} = join(",", @{$opts->{$p}}); - } elsif ($pd->{format} =~ m/-alist/) { - # we encode array as \0 separated strings - # Note: CGI.pm also use this encoding - if (scalar(@{$opts->{$p}}) != 1) { - $opts->{$p} = join("\0", @{$opts->{$p}}); - } else { - # st that split_list knows it is \0 terminated - my $v = $opts->{$p}->[0]; - $opts->{$p} = "$v\0"; - } - } - } - } - } - - foreach my $p (keys %$fixed_param) { - $opts->{$p} = $fixed_param->{$p}; - } - - return $opts; -} - -# A way to parse configuration data by giving a json schema -sub parse_config { - my ($schema, $filename, $raw) = @_; - - # do fast check (avoid validate_schema($schema)) - die "got strange schema" if !$schema->{type} || - !$schema->{properties} || $schema->{type} ne 'object'; - - my $cfg = {}; - - while ($raw && $raw =~ s/^(.*?)(\n|$)//) { - my $line = $1; - - next if $line =~ m/^\#/; # skip comment lines - next if $line =~ m/^\s*$/; # skip empty lines - - if ($line =~ m/^(\S+):\s*(\S+)\s*$/) { - my $key = $1; - my $value = $2; - if ($schema->{properties}->{$key} && - $schema->{properties}->{$key}->{type} eq 'boolean') { - - $value = 1 if $value =~ m/^(1|on|yes|true)$/i; - $value = 0 if $value =~ m/^(0|off|no|false)$/i; - } - $cfg->{$key} = $value; - } else { - warn "ignore config line: $line\n" - } - } - - my $errors = {}; - check_prop($cfg, $schema, '', $errors); - - foreach my $k (keys %$errors) { - warn "parse error in '$filename' - '$k': $errors->{$k}\n"; - delete $cfg->{$k}; - } - - return $cfg; -} - -# generate simple key/value file -sub dump_config { - my ($schema, $filename, $cfg) = @_; - - # do fast check (avoid validate_schema($schema)) - die "got strange schema" if !$schema->{type} || - !$schema->{properties} || $schema->{type} ne 'object'; - - validate($cfg, $schema, "validation error in '$filename'\n"); - - my $data = ''; - - foreach my $k (keys %$cfg) { - $data .= "$k: $cfg->{$k}\n"; - } - - return $data; -} - -1; diff --git a/data/PVE/Network.pm b/data/PVE/Network.pm deleted file mode 100644 index 00639f6..0000000 --- a/data/PVE/Network.pm +++ /dev/null @@ -1,352 +0,0 @@ -package PVE::Network; - -use strict; -use warnings; -use PVE::Tools qw(run_command); -use PVE::ProcFSTools; -use PVE::INotify; -use File::Basename; - -# host network related utility functions - -sub setup_tc_rate_limit { - my ($iface, $rate, $burst, $debug) = @_; - - system("/sbin/tc class del dev $iface parent 1: classid 1:1 >/dev/null 2>&1"); - system("/sbin/tc filter del dev $iface parent ffff: protocol ip prio 50 estimator 1sec 8sec >/dev/null 2>&1"); - system("/sbin/tc qdisc del dev $iface ingress >/dev/null 2>&1"); - system("/sbin/tc qdisc del dev $iface root >/dev/null 2>&1"); - - return if !$rate; - - run_command("/sbin/tc qdisc add dev $iface handle ffff: ingress"); - - # this does not work wit virtio - don't know why (setting "mtu 64kb" does not help) - #run_command("/sbin/tc filter add dev $iface parent ffff: protocol ip prio 50 u32 match ip src 0.0.0.0/0 police rate ${rate}bps burst ${burst}b drop flowid :1"); - # so we use avrate instead - run_command("/sbin/tc filter add dev $iface parent ffff: " . - "protocol ip prio 50 estimator 1sec 8sec " . - "u32 match ip src 0.0.0.0/0 police avrate ${rate}bps drop flowid :1"); - - # tbf does not work for unknown reason - #$TC qdisc add dev $DEV root tbf rate $RATE latency 100ms burst $BURST - # so we use htb instead - run_command("/sbin/tc qdisc add dev $iface root handle 1: htb default 1"); - run_command("/sbin/tc class add dev $iface parent 1: classid 1:1 " . - "htb rate ${rate}bps burst ${burst}b"); - - if ($debug) { - print "DEBUG tc settings\n"; - system("/sbin/tc qdisc ls dev $iface"); - system("/sbin/tc class ls dev $iface"); - system("/sbin/tc filter ls dev $iface parent ffff:"); - } -} - -sub tap_rate_limit { - my ($iface, $rate) = @_; - - my $debug = 0; - $rate = int($rate*1024*1024); - my $burst = 1024*1024; - - setup_tc_rate_limit($iface, $rate, $burst, $debug); -} - -my $read_bridge_mtu = sub { - my ($bridge) = @_; - - my $mtu = PVE::Tools::file_read_firstline("/sys/class/net/$bridge/mtu"); - die "bridge '$bridge' does not exist\n" if !$mtu; - # avoid insecure dependency; - die "unable to parse mtu value" if $mtu !~ /^(\d+)$/; - $mtu = int($1); - - return $mtu; -}; - -my $parse_tap_devive_name = sub { - my ($iface, $noerr) = @_; - - my ($vmid, $devid); - - if ($iface =~ m/^tap(\d+)i(\d+)$/) { - $vmid = $1; - $devid = $2; - } elsif ($iface =~ m/^veth(\d+)\.(\d+)$/) { - $vmid = $1; - $devid = $2; - } else { - return undef if $noerr; - die "can't create firewall bridge for random interface name '$iface'\n"; - } - - return ($vmid, $devid); -}; - -my $compute_fwbr_names = sub { - my ($vmid, $devid) = @_; - - my $fwbr = "fwbr${vmid}i${devid}"; - # Note: the firewall use 'fwln+' to filter traffic to VMs - my $vethfw = "fwln${vmid}i${devid}"; - my $vethfwpeer = "fwpr${vmid}p${devid}"; - my $ovsintport = "fwln${vmid}o${devid}"; - - return ($fwbr, $vethfw, $vethfwpeer, $ovsintport); -}; - -my $cond_create_bridge = sub { - my ($bridge) = @_; - - if (! -d "/sys/class/net/$bridge") { - system("/sbin/brctl addbr $bridge") == 0 || - die "can't add bridge '$bridge'\n"; - } -}; - -my $bridge_add_interface = sub { - my ($bridge, $iface) = @_; - - system("/sbin/brctl addif $bridge $iface") == 0 || - die "can't add interface 'iface' to bridge '$bridge'\n"; -}; - -my $ovs_bridge_add_port = sub { - my ($bridge, $iface, $tag, $internal) = @_; - - my $cmd = "/usr/bin/ovs-vsctl add-port $bridge $iface"; - $cmd .= " tag=$tag" if $tag; - $cmd .= " -- set Interface $iface type=internal" if $internal; - system($cmd) == 0 || - die "can't add ovs port '$iface'\n"; -}; - -my $activate_interface = sub { - my ($iface) = @_; - - system("/sbin/ip link set $iface up") == 0 || - die "can't activate interface '$iface'\n"; -}; - -sub tap_create { - my ($iface, $bridge) = @_; - - die "unable to get bridge setting\n" if !$bridge; - - my $bridgemtu = &$read_bridge_mtu($bridge); - - eval { - PVE::Tools::run_command("/sbin/ifconfig $iface 0.0.0.0 promisc up mtu $bridgemtu"); - }; - die "interface activation failed\n" if $@; -} - -my $create_firewall_bridge_linux = sub { - my ($iface, $bridge) = @_; - - my ($vmid, $devid) = &$parse_tap_devive_name($iface); - my ($fwbr, $vethfw, $vethfwpeer) = &$compute_fwbr_names($vmid, $devid); - - my $bridgemtu = &$read_bridge_mtu($bridge); - - &$cond_create_bridge($fwbr); - &$activate_interface($fwbr); - - copy_bridge_config($bridge, $fwbr); - # create veth pair - if (! -d "/sys/class/net/$vethfw") { - system("/sbin/ip link add name $vethfw type veth peer name $vethfwpeer mtu $bridgemtu") == 0 || - die "can't create interface $vethfw\n"; - } - - # up vethpair - &$activate_interface($vethfw); - &$activate_interface($vethfwpeer); - - &$bridge_add_interface($fwbr, $vethfw); - &$bridge_add_interface($bridge, $vethfwpeer); - - return $fwbr; -}; - -my $create_firewall_bridge_ovs = sub { - my ($iface, $bridge, $tag) = @_; - - my ($vmid, $devid) = &$parse_tap_devive_name($iface); - my ($fwbr, undef, undef, $ovsintport) = &$compute_fwbr_names($vmid, $devid); - - my $bridgemtu = &$read_bridge_mtu($bridge); - - &$cond_create_bridge($fwbr); - &$activate_interface($fwbr); - - &$bridge_add_interface($fwbr, $iface); - - &$ovs_bridge_add_port($bridge, $ovsintport, $tag, 1); - &$activate_interface($ovsintport); - - # set the same mtu for ovs int port - PVE::Tools::run_command("/sbin/ifconfig $ovsintport mtu $bridgemtu"); - - &$bridge_add_interface($fwbr, $ovsintport); -}; - -my $cleanup_firewall_bridge = sub { - my ($iface) = @_; - - my ($vmid, $devid) = &$parse_tap_devive_name($iface, 1); - return if !defined($vmid); - my ($fwbr, $vethfw, $vethfwpeer, $ovsintport) = &$compute_fwbr_names($vmid, $devid); - - # cleanup old port config from any openvswitch bridge - if (-d "/sys/class/net/$ovsintport") { - run_command("/usr/bin/ovs-vsctl del-port $ovsintport", outfunc => sub {}, errfunc => sub {}); - } - - # delete old vethfw interface - if (-d "/sys/class/net/$vethfw") { - run_command("/sbin/ip link delete dev $vethfw", outfunc => sub {}, errfunc => sub {}); - } - - # cleanup fwbr bridge - if (-d "/sys/class/net/$fwbr") { - run_command("/sbin/ip link set dev $fwbr down", outfunc => sub {}, errfunc => sub {}); - run_command("/sbin/brctl delbr $fwbr", outfunc => sub {}, errfunc => sub {}); - } -}; - -sub tap_plug { - my ($iface, $bridge, $tag, $firewall) = @_; - - #cleanup old port config from any openvswitch bridge - eval {run_command("/usr/bin/ovs-vsctl del-port $iface", outfunc => sub {}, errfunc => sub {}) }; - - if (-d "/sys/class/net/$bridge/bridge") { - &$cleanup_firewall_bridge($iface); # remove stale devices - - my $newbridge = activate_bridge_vlan($bridge, $tag); - copy_bridge_config($bridge, $newbridge) if $bridge ne $newbridge; - - $newbridge = &$create_firewall_bridge_linux($iface, $newbridge) if $firewall; - - &$bridge_add_interface($newbridge, $iface); - } else { - &$cleanup_firewall_bridge($iface); # remove stale devices - - if ($firewall) { - &$create_firewall_bridge_ovs($iface, $bridge, $tag); - } else { - &$ovs_bridge_add_port($bridge, $iface, $tag); - } - } -} - -sub tap_unplug { - my ($iface) = @_; - - my $path= "/sys/class/net/$iface/brport/bridge"; - if (-l $path) { - my $bridge = basename(readlink($path)); - #avoid insecure dependency; - ($bridge) = $bridge =~ /(\S+)/; - - system("/sbin/brctl delif $bridge $iface") == 0 || - die "can't del interface '$iface' from bridge '$bridge'\n"; - - } - - &$cleanup_firewall_bridge($iface); -} - -sub copy_bridge_config { - my ($br0, $br1) = @_; - - return if $br0 eq $br1; - - my $br_configs = [ 'ageing_time', 'stp_state', 'priority', 'forward_delay', - 'hello_time', 'max_age', 'multicast_snooping', 'multicast_querier']; - - foreach my $sysname (@$br_configs) { - eval { - my $v0 = PVE::Tools::file_read_firstline("/sys/class/net/$br0/bridge/$sysname"); - my $v1 = PVE::Tools::file_read_firstline("/sys/class/net/$br1/bridge/$sysname"); - if ($v0 ne $v1) { - PVE::ProcFSTools::write_proc_entry("/sys/class/net/$br1/bridge/$sysname", $v0); - } - }; - warn $@ if $@; - } -} - -sub activate_bridge_vlan_slave { - my ($bridgevlan, $iface, $tag) = @_; - my $ifacevlan = "${iface}.$tag"; - - # create vlan on $iface is not already exist - if (! -d "/sys/class/net/$ifacevlan") { - system("/sbin/vconfig add $iface $tag") == 0 || - die "can't add vlan tag $tag to interface $iface\n"; - } - - # be sure to have the $ifacevlan up - &$activate_interface($ifacevlan); - - # test if $vlaniface is already enslaved in another bridge - my $path= "/sys/class/net/$ifacevlan/brport/bridge"; - if (-l $path) { - my $tbridge = basename(readlink($path)); - if ($tbridge ne $bridgevlan) { - die "interface $ifacevlan already exist in bridge $tbridge\n"; - } else { - # Port already attached to bridge: do nothing. - return; - } - } - - # add $ifacevlan to the bridge - &$bridge_add_interface($bridgevlan, $ifacevlan); -} - -sub activate_bridge_vlan { - my ($bridge, $tag_param) = @_; - - die "bridge '$bridge' is not active\n" if ! -d "/sys/class/net/$bridge"; - - return $bridge if !defined($tag_param); # no vlan, simply return - - my $tag = int($tag_param); - - die "got strange vlan tag '$tag_param'\n" if $tag < 1 || $tag > 4094; - - my $bridgevlan = "${bridge}v$tag"; - - my @ifaces = (); - my $dir = "/sys/class/net/$bridge/brif"; - PVE::Tools::dir_glob_foreach($dir, '((eth|bond)\d+)', sub { - push @ifaces, $_[0]; - }); - - die "no physical interface on bridge '$bridge'\n" if scalar(@ifaces) == 0; - - # add bridgevlan if it doesn't already exist - if (! -d "/sys/class/net/$bridgevlan") { - system("/sbin/brctl addbr $bridgevlan") == 0 || - die "can't add bridge $bridgevlan\n"; - } - - # for each physical interface (eth or bridge) bind them to bridge vlan - foreach my $iface (@ifaces) { - activate_bridge_vlan_slave($bridgevlan, $iface, $tag); - } - - #fixme: set other bridge flags - - # be sure to have the bridge up - system("/sbin/ip link set $bridgevlan up") == 0 || - die "can't up bridge $bridgevlan\n"; - - return $bridgevlan; -} - -1; diff --git a/data/PVE/PodParser.pm b/data/PVE/PodParser.pm deleted file mode 100644 index 7e31e19..0000000 --- a/data/PVE/PodParser.pm +++ /dev/null @@ -1,108 +0,0 @@ -package PVE::PodParser; - -use strict; -use warnings; -use Pod::Parser; -use base qw(Pod::Parser); - -my $currentYear = (localtime(time))[5] + 1900; - -my $stdinclude = { - pve_copyright => <. -EODATA -}; - -sub command { - my ($self, $cmd, $text, $line_num, $pod_para) = @_; - - if (($cmd eq 'include' && $text =~ m/^\s*(\S+)\s/)) { - my $incl = $1; - my $data = $stdinclude->{$incl} ? $stdinclude->{$incl} : - $self->{include}->{$incl}; - chomp $data; - $self->textblock("$data\n\n", $line_num, $pod_para); - } else { - $self->textblock($pod_para->raw_text(), $line_num, $pod_para); - } -} - -# helpers used to generate our manual pages - -sub schema_get_type_text { - my ($phash) = @_; - - if ($phash->{typetext}) { - return $phash->{typetext}; - } elsif ($phash->{enum}) { - return "(" . join(' | ', sort @{$phash->{enum}}) . ")"; - } elsif ($phash->{pattern}) { - return $phash->{pattern}; - } elsif ($phash->{type} eq 'integer' || $phash->{type} eq 'number') { - if (defined($phash->{minimum}) && defined($phash->{maximum})) { - return "$phash->{type} ($phash->{minimum} - $phash->{maximum})"; - } elsif (defined($phash->{minimum})) { - return "$phash->{type} ($phash->{minimum} - N)"; - } elsif (defined($phash->{maximum})) { - return "$phash->{type} (-N - $phash->{maximum})"; - } - } - - my $type = $phash->{type} || 'string'; - - return $type; -} - -# generta epop from JSON schema properties -sub dump_properties { - my ($properties) = @_; - - my $data = "=over 1\n\n"; - - my $idx_param = {}; # -vlan\d+ -scsi\d+ - - foreach my $key (sort keys %$properties) { - my $d = $properties->{$key}; - my $base = $key; - if ($key =~ m/^([a-z]+)(\d+)$/) { - my $name = $1; - next if $idx_param->{$name}; - $idx_param->{$name} = 1; - $base = "${name}[n]"; - } - - my $descr = $d->{description} || 'No description avalable.'; - chomp $descr; - - if (defined(my $dv = $d->{default})) { - my $multi = $descr =~ m/\n\n/; # multi paragraph ? - $descr .= $multi ? "\n\n" : " "; - $descr .= "Default value is '$dv'."; - } - - my $typetext = schema_get_type_text($d); - $data .= "=item $base: $typetext\n\n"; - $data .= "$descr\n\n"; - } - - $data .= "=back"; - - return $data; -} - -1; diff --git a/data/PVE/ProcFSTools.pm b/data/PVE/ProcFSTools.pm deleted file mode 100644 index 8bb0d72..0000000 --- a/data/PVE/ProcFSTools.pm +++ /dev/null @@ -1,287 +0,0 @@ -package PVE::ProcFSTools; - -use strict; -use warnings; -use POSIX; -use Time::HiRes qw (gettimeofday); -use IO::File; -use PVE::Tools; - -my $clock_ticks = POSIX::sysconf(&POSIX::_SC_CLK_TCK); - -my $cpuinfo; - -sub read_cpuinfo { - my $fn = '/proc/cpuinfo'; - - return $cpuinfo if $cpuinfo; - - my $res = { - user_hz => $clock_ticks, - model => 'unknown', - mhz => 0, - cpus => 1, - sockets => 1, - }; - - my $fh = IO::File->new ($fn, "r"); - return $res if !$fh; - - my $idhash = {}; - my $count = 0; - while (defined(my $line = <$fh>)) { - if ($line =~ m/^processor\s*:\s*\d+\s*$/i) { - $count++; - } elsif ($line =~ m/^model\s+name\s*:\s*(.*)\s*$/i) { - $res->{model} = $1 if $res->{model} eq 'unknown'; - } elsif ($line =~ m/^cpu\s+MHz\s*:\s*(\d+\.\d+)\s*$/i) { - $res->{mhz} = $1 if !$res->{mhz}; - } elsif ($line =~ m/^flags\s*:.*(vmx|svm)/) { - $res->{hvm} = 1; # Hardware Virtual Machine (Intel VT / AMD-V) - } elsif ($line =~ m/^physical id\s*:\s*(\d+)\s*$/i) { - $idhash->{$1} = 1; - } - } - - $res->{sockets} = scalar(keys %$idhash) || 1; - - $res->{cpus} = $count; - - $fh->close; - - $cpuinfo = $res; - - return $res; -} - -sub read_proc_uptime { - my $ticks = shift; - - my $line = PVE::Tools::file_read_firstline("/proc/uptime"); - if ($line && $line =~ m|^(\d+\.\d+)\s+(\d+\.\d+)\s*$|) { - if ($ticks) { - return (int($1*$clock_ticks), int($2*$clock_ticks)); - } else { - return (int($1), int($2)); - } - } - - return (0, 0); -} - -sub read_loadavg { - - my $line = PVE::Tools::file_read_firstline('/proc/loadavg'); - - if ($line =~ m|^(\d+\.\d+)\s+(\d+\.\d+)\s+(\d+\.\d+)\s+\d+/\d+\s+\d+\s*$|) { - return wantarray ? ($1, $2, $3) : $1; - } - - return wantarray ? (0, 0, 0) : 0; -} - -my $last_proc_stat; - -sub read_proc_stat { - my $res = { user => 0, nice => 0, system => 0, idle => 0 , sum => 0}; - - my $cpucount = 0; - - if (my $fh = IO::File->new ("/proc/stat", "r")) { - while (defined (my $line = <$fh>)) { - if ($line =~ m|^cpu\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s|) { - $res->{user} = $1; - $res->{nice} = $2; - $res->{system} = $3; - $res->{idle} = $4; - $res->{used} = $1+$2+$3; - $res->{iowait} = $5; - } elsif ($line =~ m|^cpu\d+\s|) { - $cpucount++; - } - } - $fh->close; - } - - $cpucount = 1 if !$cpucount; - - my $ctime = gettimeofday; # floating point time in seconds - - $res->{ctime} = $ctime; - $res->{cpu} = 0; - $res->{wait} = 0; - - $last_proc_stat = $res if !$last_proc_stat; - - my $diff = ($ctime - $last_proc_stat->{ctime}) * $clock_ticks * $cpucount; - - if ($diff > 1000) { # don't update too often - my $useddiff = $res->{used} - $last_proc_stat->{used}; - $useddiff = $diff if $useddiff > $diff; - $res->{cpu} = $useddiff/$diff; - my $waitdiff = $res->{iowait} - $last_proc_stat->{iowait}; - $waitdiff = $diff if $waitdiff > $diff; - $res->{wait} = $waitdiff/$diff; - $last_proc_stat = $res; - } else { - $res->{cpu} = $last_proc_stat->{cpu}; - $res->{wait} = $last_proc_stat->{wait}; - } - - return $res; -} - -sub read_proc_pid_stat { - my $pid = shift; - - my $statstr = PVE::Tools::file_read_firstline("/proc/$pid/stat"); - - if ($statstr && $statstr =~ m/^$pid \(.*\) (\S) (-?\d+) -?\d+ -?\d+ -?\d+ -?\d+ \d+ \d+ \d+ \d+ \d+ (\d+) (\d+) (-?\d+) (-?\d+) -?\d+ -?\d+ -?\d+ 0 (\d+) (\d+) (-?\d+) \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ -?\d+ -?\d+ \d+ \d+ \d+/) { - return { - status => $1, - utime => $3, - stime => $4, - starttime => $7, - vsize => $8, - rss => $9 * 4096, - }; - } - - return undef; -} - -sub check_process_running { - my ($pid, $pstart) = @_; - - # note: waitpid only work for child processes, but not - # for processes spanned by other processes. - # kill(0, pid) return succes for zombies. - # So we read the status form /proc/$pid/stat instead - - my $info = read_proc_pid_stat($pid); - - return $info && (!$pstart || ($info->{starttime} eq $pstart)) && ($info->{status} ne 'Z') ? $info : undef; -} - -sub read_proc_starttime { - my $pid = shift; - - my $info = read_proc_pid_stat($pid); - return $info ? $info->{starttime} : 0; -} - -sub read_meminfo { - - my $res = { - memtotal => 0, - memfree => 0, - memused => 0, - memshared => 0, - swaptotal => 0, - swapfree => 0, - swapused => 0, - }; - - my $fh = IO::File->new ("/proc/meminfo", "r"); - return $res if !$fh; - - my $d = {}; - while (my $line = <$fh>) { - if ($line =~ m/^(\S+):\s+(\d+)\s*kB/i) { - $d->{lc ($1)} = $2 * 1024; - } - } - close($fh); - - $res->{memtotal} = $d->{memtotal}; - $res->{memfree} = $d->{memfree} + $d->{buffers} + $d->{cached}; - $res->{memused} = $res->{memtotal} - $res->{memfree}; - - $res->{swaptotal} = $d->{swaptotal}; - $res->{swapfree} = $d->{swapfree}; - $res->{swapused} = $res->{swaptotal} - $res->{swapfree}; - - my $spages = PVE::Tools::file_read_firstline("/sys/kernel/mm/ksm/pages_sharing"); - $res->{memshared} = int($spages) * 4096; - - return $res; -} - -# memory usage of current process -sub read_memory_usage { - - my $res = { size => 0, resident => 0, shared => 0 }; - - my $ps = 4096; - - my $line = PVE::Tools::file_read_firstline("/proc/$$/statm"); - - if ($line =~ m/^(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s*/) { - $res->{size} = $1*$ps; - $res->{resident} = $2*$ps; - $res->{shared} = $3*$ps; - } - - return $res; -} - -sub read_proc_net_dev { - - my $res = {}; - - my $fh = IO::File->new ("/proc/net/dev", "r"); - return $res if !$fh; - - while (defined (my $line = <$fh>)) { - if ($line =~ m/^\s*(.*):\s*(\d+)\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+(\d+)\s+/) { - $res->{$1} = { - receive => $2, - transmit => $3, - }; - } - } - - close($fh); - - return $res; -} - -sub write_proc_entry { - my ($filename, $data) = @_;# - - my $fh = IO::File->new($filename, O_WRONLY); - die "unable to open file '$filename' - $!\n" if !$fh; - die "unable to write '$filename' - $!\n" unless print $fh $data; - die "closing file '$filename' failed - $!\n" unless close $fh; - $fh->close(); -} - -sub read_proc_net_route { - my $filename = "/proc/net/route"; - - my $res = []; - - my $fh = IO::File->new ($filename, "r"); - return $res if !$fh; - - my $int_to_quad = sub { - return join '.' => map { ($_[0] >> 8*(3-$_)) % 256 } (3, 2, 1, 0); - }; - - while (defined(my $line = <$fh>)) { - next if $line =~/^Iface\s+Destination/; # skip head - my ($iface, $dest, $gateway, $metric, $mask, $mtu) = (split(/\s+/, $line))[0,1,2,6,7,8]; - push @$res, { - dest => &$int_to_quad(hex($dest)), - gateway => &$int_to_quad(hex($gateway)), - mask => &$int_to_quad(hex($mask)), - metric => $metric, - mtu => $mtu, - iface => $iface, - }; - } - - return $res; -} - -1; diff --git a/data/PVE/RESTHandler.pm b/data/PVE/RESTHandler.pm deleted file mode 100644 index 4153192..0000000 --- a/data/PVE/RESTHandler.pm +++ /dev/null @@ -1,577 +0,0 @@ -package PVE::RESTHandler; - -use strict; -no strict 'refs'; # our autoload requires this -use warnings; -use PVE::SafeSyslog; -use PVE::Exception qw(raise raise_param_exc); -use PVE::JSONSchema; -use PVE::PodParser; -use HTTP::Status qw(:constants :is status_message); -use Text::Wrap; -use Storable qw(dclone); - -my $method_registry = {}; -my $method_by_name = {}; -my $method_path_lookup = {}; - -our $AUTOLOAD; # it's a package global - -sub api_clone_schema { - my ($schema) = @_; - - my $res = {}; - my $ref = ref($schema); - die "not a HASH reference" if !($ref && $ref eq 'HASH'); - - foreach my $k (keys %$schema) { - my $d = $schema->{$k}; - if ($k ne 'properties') { - $res->{$k} = ref($d) ? dclone($d) : $d; - next; - } - # convert indexed parameters like -net\d+ to -net[n] - foreach my $p (keys %$d) { - my $pd = $d->{$p}; - if ($p =~ m/^([a-z]+)(\d+)$/) { - if ($2 == 0) { - $p = "$1\[n\]"; - } else { - next; - } - } - $res->{$k}->{$p} = ref($pd) ? dclone($pd) : $pd; - } - } - - return $res; -} - -sub api_dump_full { - my ($tree, $index, $class, $prefix) = @_; - - $prefix = '' if !$prefix; - - my $ma = $method_registry->{$class}; - - foreach my $info (@$ma) { - - my $path = "$prefix/$info->{path}"; - $path =~ s/\/+$//; - - if ($info->{subclass}) { - api_dump_full($tree, $index, $info->{subclass}, $path); - } else { - next if !$path; - - # check if method is unique - my $realpath = $path; - $realpath =~ s/\{[^\}]+\}/\{\}/g; - my $fullpath = "$info->{method} $realpath"; - die "duplicate path '$realpath'" if $index->{$fullpath}; - $index->{$fullpath} = $info; - - # insert into tree - my $treedir = $tree; - my $res; - my $sp = ''; - foreach my $dir (split('/', $path)) { - next if !$dir; - $sp .= "/$dir"; - $res = (grep { $_->{text} eq $dir } @$treedir)[0]; - if ($res) { - $res->{children} = [] if !$res->{children}; - $treedir = $res->{children}; - } else { - $res = { - path => $sp, - text => $dir, - children => [], - }; - push @$treedir, $res; - $treedir = $res->{children}; - } - } - - if ($res) { - my $data = {}; - foreach my $k (keys %$info) { - next if $k eq 'code' || $k eq "match_name" || $k eq "match_re" || - $k eq "path"; - - my $d = $info->{$k}; - - if ($k eq 'parameters') { - $data->{$k} = api_clone_schema($d); - } else { - - $data->{$k} = ref($d) ? dclone($d) : $d; - } - } - $res->{info}->{$info->{method}} = $data; - }; - } - } -}; - -sub api_dump_cleanup_tree { - my ($tree) = @_; - - foreach my $rec (@$tree) { - delete $rec->{children} if $rec->{children} && !scalar(@{$rec->{children}}); - if ($rec->{children}) { - $rec->{leaf} = 0; - api_dump_cleanup_tree($rec->{children}); - } else { - $rec->{leaf} = 1; - } - } - -} - -sub api_dump { - my ($class, $prefix) = @_; - - my $tree = []; - - my $index = {}; - api_dump_full($tree, $index, $class); - api_dump_cleanup_tree($tree); - return $tree; -}; - -sub validate_method_schemas { - - foreach my $class (keys %$method_registry) { - my $ma = $method_registry->{$class}; - - foreach my $info (@$ma) { - PVE::JSONSchema::validate_method_info($info); - } - } -} - -sub register_method { - my ($self, $info) = @_; - - my $match_re = []; - my $match_name = []; - - my $errprefix; - - my $method; - if ($info->{subclass}) { - $errprefix = "register subclass $info->{subclass} at ${self}/$info->{path} -"; - $method = 'SUBCLASS'; - } else { - $errprefix = "register method ${self}/$info->{path} -"; - $info->{method} = 'GET' if !$info->{method}; - $method = $info->{method}; - } - - $method_path_lookup->{$self} = {} if !defined($method_path_lookup->{$self}); - my $path_lookup = $method_path_lookup->{$self}; - - die "$errprefix no path" if !defined($info->{path}); - - foreach my $comp (split(/\/+/, $info->{path})) { - die "$errprefix path compoment has zero length\n" if $comp eq ''; - my ($name, $regex); - if ($comp =~ m/^\{(\w+)(:(.*))?\}$/) { - $name = $1; - $regex = $3 ? $3 : '\S+'; - push @$match_re, $regex; - push @$match_name, $name; - } else { - $name = $comp; - push @$match_re, $name; - push @$match_name, undef; - } - - if ($regex) { - $path_lookup->{regex} = {} if !defined($path_lookup->{regex}); - - my $old_name = $path_lookup->{regex}->{match_name}; - die "$errprefix found changed regex match name\n" - if defined($old_name) && ($old_name ne $name); - my $old_re = $path_lookup->{regex}->{match_re}; - die "$errprefix found changed regex\n" - if defined($old_re) && ($old_re ne $regex); - $path_lookup->{regex}->{match_name} = $name; - $path_lookup->{regex}->{match_re} = $regex; - - die "$errprefix path match error - regex and fixed items\n" - if defined($path_lookup->{folders}); - - $path_lookup = $path_lookup->{regex}; - - } else { - $path_lookup->{folders}->{$name} = {} if !defined($path_lookup->{folders}->{$name}); - - die "$errprefix path match error - regex and fixed items\n" - if defined($path_lookup->{regex}); - - $path_lookup = $path_lookup->{folders}->{$name}; - } - } - - die "$errprefix duplicate method definition\n" - if defined($path_lookup->{$method}); - - if ($method eq 'SUBCLASS') { - foreach my $m (qw(GET PUT POST DELETE)) { - die "$errprefix duplicate method definition SUBCLASS and $m\n" if $path_lookup->{$m}; - } - } - $path_lookup->{$method} = $info; - - $info->{match_re} = $match_re; - $info->{match_name} = $match_name; - - $method_by_name->{$self} = {} if !defined($method_by_name->{$self}); - - if ($info->{name}) { - die "$errprefix method name already defined\n" - if defined($method_by_name->{$self}->{$info->{name}}); - - $method_by_name->{$self}->{$info->{name}} = $info; - } - - push @{$method_registry->{$self}}, $info; -} - -sub register_page_formatter { - my ($self, %config) = @_; - - my $format = $config{format} || - die "missing format"; - - my $path = $config{path} || - die "missing path"; - - my $method = $config{method} || - die "missing method"; - - my $code = $config{code} || - die "missing formatter code"; - - my $uri_param = {}; - my ($handler, $info) = $self->find_handler($method, $path, $uri_param); - die "unabe to find handler for '$method: $path'" if !($handler && $info); - - die "duplicate formatter for '$method: $path'" - if $info->{formatter} && $info->{formatter}->{$format}; - - $info->{formatter}->{$format} = $code; -} - -sub DESTROY {}; # avoid problems with autoload - -sub AUTOLOAD { - my ($this) = @_; - - # also see "man perldiag" - - my $sub = $AUTOLOAD; - (my $method = $sub) =~ s/.*:://; - - $method =~ s/.*:://; - - my $info = $this->map_method_by_name($method); - - *{$sub} = sub { - my $self = shift; - return $self->handle($info, @_); - }; - goto &$AUTOLOAD; -} - -sub method_attributes { - my ($self) = @_; - - return $method_registry->{$self}; -} - -sub map_method_by_name { - my ($self, $name) = @_; - - my $info = $method_by_name->{$self}->{$name}; - die "no such method '${self}::$name'\n" if !$info; - - return $info; -} - -sub map_path_to_methods { - my ($class, $stack, $uri_param, $pathmatchref) = @_; - - my $path_lookup = $method_path_lookup->{$class}; - - # Note: $pathmatchref can be used to obtain path including - # uri patterns like '/cluster/firewall/groups/{group}'. - # Used by pvesh to display help - if (defined($pathmatchref)) { - $$pathmatchref = '' if !$$pathmatchref; - } - - while (defined(my $comp = shift @$stack)) { - return undef if !$path_lookup; # not registerd? - if ($path_lookup->{regex}) { - my $name = $path_lookup->{regex}->{match_name}; - my $regex = $path_lookup->{regex}->{match_re}; - - return undef if $comp !~ m/^($regex)$/; - $uri_param->{$name} = $1; - $path_lookup = $path_lookup->{regex}; - $$pathmatchref .= '/{' . $name . '}' if defined($pathmatchref); - } elsif ($path_lookup->{folders}) { - $path_lookup = $path_lookup->{folders}->{$comp}; - $$pathmatchref .= '/' . $comp if defined($pathmatchref); - } else { - die "internal error"; - } - - return undef if !$path_lookup; - - if (my $info = $path_lookup->{SUBCLASS}) { - $class = $info->{subclass}; - - my $fd = $info->{fragmentDelimiter}; - - if (defined($fd)) { - # we only support the empty string '' (match whole URI) - die "unsupported fragmentDelimiter '$fd'" - if $fd ne ''; - - $stack = [ join ('/', @$stack) ] if scalar(@$stack) > 1; - } - $path_lookup = $method_path_lookup->{$class}; - } - } - - return undef if !$path_lookup; - - return ($class, $path_lookup); -} - -sub find_handler { - my ($class, $method, $path, $uri_param, $pathmatchref) = @_; - - my $stack = [ grep { length($_) > 0 } split('\/+' , $path)]; # skip empty fragments - - my ($handler_class, $path_info); - eval { - ($handler_class, $path_info) = $class->map_path_to_methods($stack, $uri_param, $pathmatchref); - }; - my $err = $@; - syslog('err', $err) if $err; - - return undef if !($handler_class && $path_info); - - my $method_info = $path_info->{$method}; - - return undef if !$method_info; - - return ($handler_class, $method_info); -} - -sub handle { - my ($self, $info, $param) = @_; - - my $func = $info->{code}; - - if (!($info->{name} && $func)) { - raise("Method lookup failed ('$info->{name}')\n", - code => HTTP_INTERNAL_SERVER_ERROR); - } - - if (my $schema = $info->{parameters}) { - # warn "validate ". Dumper($param}) . "\n" . Dumper($schema); - PVE::JSONSchema::validate($param, $schema); - # untaint data (already validated) - while (my ($key, $val) = each %$param) { - ($param->{$key}) = $val =~ /^(.*)$/s; - } - } - - my $result = &$func($param); - - # todo: this is only to be safe - disable? - if (my $schema = $info->{returns}) { - PVE::JSONSchema::validate($result, $schema, "Result verification vailed\n"); - } - - return $result; -} - -# generate usage information for command line tools -# -# $name ... the name of the method -# $prefix ... usually something like "$exename $cmd" ('pvesm add') -# $arg_param ... list of parameters we want to get as ordered arguments -# on the command line (or single parameter name for lists) -# $fixed_param ... do not generate and info about those parameters -# $format: -# 'long' ... default (list all options) -# 'short' ... command line only (one line) -# 'full' ... also include description -# $hidepw ... hide password option (use this if you provide a read passwork callback) -sub usage_str { - my ($self, $name, $prefix, $arg_param, $fixed_param, $format, $hidepw) = @_; - - $format = 'long' if !$format; - - my $info = $self->map_method_by_name($name); - my $schema = $info->{parameters}; - my $prop = $schema->{properties}; - - my $out = ''; - - my $arg_hash = {}; - - my $args = ''; - - $arg_param = [ $arg_param ] if $arg_param && !ref($arg_param); - - foreach my $p (@$arg_param) { - next if !$prop->{$p}; # just to be sure - my $pd = $prop->{$p}; - - $arg_hash->{$p} = 1; - $args .= " " if $args; - if ($pd->{format} && $pd->{format} =~ m/-list/) { - $args .= "{<$p>}"; - } else { - $args .= $pd->{optional} ? "[<$p>]" : "<$p>"; - } - } - - my $get_prop_descr = sub { - my ($k, $display_name) = @_; - - my $phash = $prop->{$k}; - - my $res = ''; - - my $descr = $phash->{description} || "no description available"; - chomp $descr; - - my $type = PVE::PodParser::schema_get_type_text($phash); - - if ($hidepw && $k eq 'password') { - $type = ''; - } - - my $defaulttxt = ''; - if (defined(my $dv = $phash->{default})) { - $defaulttxt = " (default=$dv)"; - } - my $tmp = sprintf " %-10s %s$defaulttxt\n", $display_name, "$type"; - my $indend = " "; - - $res .= Text::Wrap::wrap('', $indend, ($tmp)); - $res .= "\n", - $res .= Text::Wrap::wrap($indend, $indend, ($descr)) . "\n\n"; - - if (my $req = $phash->{requires}) { - my $tmp = "Requires option(s): "; - $tmp .= ref($req) ? join(', ', @$req) : $req; - $res .= Text::Wrap::wrap($indend, $indend, ($tmp)). "\n\n"; - } - - return $res; - }; - - my $argdescr = ''; - foreach my $k (@$arg_param) { - next if defined($fixed_param->{$k}); # just to be sure - next if !$prop->{$k}; # just to be sure - $argdescr .= &$get_prop_descr($k, "<$k>"); - } - - my $idx_param = {}; # -vlan\d+ -scsi\d+ - - my $opts = ''; - foreach my $k (sort keys %$prop) { - next if $arg_hash->{$k}; - next if defined($fixed_param->{$k}); - - my $type = $prop->{$k}->{type} || 'string'; - - next if $hidepw && ($k eq 'password') && !$prop->{$k}->{optional}; - - my $base = $k; - if ($k =~ m/^([a-z]+)(\d+)$/) { - my $name = $1; - next if $idx_param->{$name}; - $idx_param->{$name} = 1; - $base = "${name}[n]"; - } - - $opts .= &$get_prop_descr($k, "-$base"); - - if (!$prop->{$k}->{optional}) { - $args .= " " if $args; - $args .= "-$base <$type>" - } - } - - $out .= "USAGE: " if $format ne 'short'; - - $out .= "$prefix $args"; - - $out .= $opts ? " [OPTIONS]\n" : "\n"; - - return $out if $format eq 'short'; - - if ($info->{description} && $format eq 'full') { - my $desc = Text::Wrap::wrap(' ', ' ', ($info->{description})); - $out .= "\n$desc\n\n"; - } - - $out .= $argdescr if $argdescr; - - $out .= $opts if $opts; - - return $out; -} - -sub cli_handler { - my ($self, $prefix, $name, $args, $arg_param, $fixed_param, $pwcallback) = @_; - - my $info = $self->map_method_by_name($name); - - my $res; - eval { - my $param = PVE::JSONSchema::get_options($info->{parameters}, $args, $arg_param, $fixed_param, $pwcallback); - $res = $self->handle($info, $param); - }; - if (my $err = $@) { - my $ec = ref($err); - - die $err if !$ec || $ec ne "PVE::Exception" || !$err->is_param_exc(); - - $err->{usage} = $self->usage_str($name, $prefix, $arg_param, $fixed_param, 'short', $pwcallback); - - die $err; - } - - return $res; -} - -# utility methods -# note: this modifies the original hash by adding the id property -sub hash_to_array { - my ($hash, $idprop) = @_; - - my $res = []; - return $res if !$hash; - - foreach my $k (keys %$hash) { - $hash->{$k}->{$idprop} = $k; - push @$res, $hash->{$k}; - } - - return $res; -} - -1; diff --git a/data/PVE/SafeSyslog.pm b/data/PVE/SafeSyslog.pm deleted file mode 100644 index 63b37f8..0000000 --- a/data/PVE/SafeSyslog.pm +++ /dev/null @@ -1,51 +0,0 @@ -package PVE::SafeSyslog; - -use strict; -use warnings; -use File::Basename; -use Sys::Syslog (); -use Encode; - -use vars qw($VERSION @ISA @EXPORT); - -$VERSION = '1.00'; - -require Exporter; - -@ISA = qw(Exporter); - -@EXPORT = qw(syslog initlog); - -my $log_tag = "unknown"; - -# never log to console - thats too slow, and -# it corrupts the DBD database connection! - -sub syslog { - eval { Sys::Syslog::syslog (@_); }; # ignore errors -} - -sub initlog { - my ($tag, $facility) = @_; - - if ($tag) { - $tag = basename($tag); - - $tag = encode("ascii", decode_utf8($tag)); - - $log_tag = $tag; - } - - $facility = "daemon" if !$facility; - - # never log to console - thats too slow - Sys::Syslog::setlogsock ('unix'); - - Sys::Syslog::openlog ($log_tag, 'pid', $facility); -} - -sub tag { - return $log_tag; -} - -1; diff --git a/data/PVE/SectionConfig.pm b/data/PVE/SectionConfig.pm deleted file mode 100644 index 06ebbe7..0000000 --- a/data/PVE/SectionConfig.pm +++ /dev/null @@ -1,429 +0,0 @@ -package PVE::SectionConfig; - -use strict; -use warnings; -use Digest::SHA; -use PVE::Exception qw(raise_param_exc); -use PVE::JSONSchema qw(get_standard_option); - -use Data::Dumper; - -my $defaultData = { - options => {}, - plugins => {}, - plugindata => {}, - propertyList => {}, -}; - -sub private { - die "overwrite me"; - return $defaultData; -} - -sub register { - my ($class) = @_; - - my $type = $class->type(); - my $pdata = $class->private(); - - my $plugindata = $class->plugindata(); - $pdata->{plugindata}->{$type} = $plugindata; - $pdata->{plugins}->{$type} = $class; -} - -sub type { - die "overwrite me"; -} - -sub properties { - return {}; -} - -sub options { - return {}; -} - -sub plugindata { - return {}; -} - -sub createSchema { - my ($class) = @_; - - my $pdata = $class->private(); - my $propertyList = $pdata->{propertyList}; - - return { - type => "object", - additionalProperties => 0, - properties => $propertyList, - }; -} - -sub updateSchema { - my ($class) = @_; - - my $pdata = $class->private(); - my $propertyList = $pdata->{propertyList}; - my $plugins = $pdata->{plugins}; - - my $props = {}; - - foreach my $p (keys %$propertyList) { - next if $p eq 'type'; - if (!$propertyList->{$p}->{optional}) { - $props->{$p} = $propertyList->{$p}; - next; - } - foreach my $t (keys %$plugins) { - my $opts = $pdata->{options}->{$t}; - next if !defined($opts->{$p}); - if (!$opts->{$p}->{fixed}) { - $props->{$p} = $propertyList->{$p}; - } - } - } - - $props->{digest} = get_standard_option('pve-config-digest'); - - $props->{delete} = { - type => 'string', format => 'pve-configid-list', - description => "A list of settings you want to delete.", - maxLength => 4096, - optional => 1, - }; - - return { - type => "object", - additionalProperties => 0, - properties => $props, - }; -} - -sub init { - my ($class) = @_; - - my $pdata = $class->private(); - - foreach my $k (qw(options plugins plugindata propertyList)) { - $pdata->{$k} = {} if !$pdata->{$k}; - } - - my $plugins = $pdata->{plugins}; - my $propertyList = $pdata->{propertyList}; - - foreach my $type (keys %$plugins) { - my $props = $plugins->{$type}->properties(); - foreach my $p (keys %$props) { - die "duplicate property '$p'" if defined($propertyList->{$p}); - my $res = $propertyList->{$p} = {}; - my $data = $props->{$p}; - for my $a (keys %$data) { - $res->{$a} = $data->{$a}; - } - $res->{optional} = 1; - } - } - - foreach my $type (keys %$plugins) { - my $opts = $plugins->{$type}->options(); - foreach my $p (keys %$opts) { - die "undefined property '$p'" if !$propertyList->{$p}; - } - $pdata->{options}->{$type} = $opts; - } - - $propertyList->{type}->{type} = 'string'; - $propertyList->{type}->{enum} = [keys %$plugins]; -} - -sub lookup { - my ($class, $type) = @_; - - my $pdata = $class->private(); - my $plugin = $pdata->{plugins}->{$type}; - - die "unknown section type '$type'\n" if !$plugin; - - return $plugin; -} - -sub lookup_types { - my ($class) = @_; - - my $pdata = $class->private(); - - return [ keys %{$pdata->{plugins}} ]; -} - -sub decode_value { - my ($class, $type, $key, $value) = @_; - - return $value; -} - -sub encode_value { - my ($class, $type, $key, $value) = @_; - - return $value; -} - -sub check_value { - my ($class, $type, $key, $value, $storeid, $skipSchemaCheck) = @_; - - my $pdata = $class->private(); - - return $value if $key eq 'type' && $type eq $value; - - my $opts = $pdata->{options}->{$type}; - die "unknown section type '$type'\n" if !$opts; - - die "unexpected property '$key'\n" if !defined($opts->{$key}); - - my $schema = $pdata->{propertyList}->{$key}; - die "unknown property type\n" if !$schema; - - my $ct = $schema->{type}; - - $value = 1 if $ct eq 'boolean' && !defined($value); - - die "got undefined value\n" if !defined($value); - - die "property contains a line feed\n" if $value =~ m/[\n\r]/; - - if (!$skipSchemaCheck) { - my $errors = {}; - PVE::JSONSchema::check_prop($value, $schema, '', $errors); - if (scalar(keys %$errors)) { - die "$errors->{$key}\n" if $errors->{$key}; - die "$errors->{_root}\n" if $errors->{_root}; - die "unknown error\n"; - } - } - - return $value; -} - -sub parse_section_header { - my ($class, $line) = @_; - - if ($line =~ m/^(\S+):\s*(\S+)\s*$/) { - my ($type, $sectionId) = ($1, $2); - my $errmsg = undef; # set if you want to skip whole section - my $config = {}; # to return additional attributes - return ($type, $sectionId, $errmsg, $config); - } - return undef; -} - -sub format_section_header { - my ($class, $type, $sectionId) = @_; - - return "$type: $sectionId\n"; -} - - -sub parse_config { - my ($class, $filename, $raw) = @_; - - my $pdata = $class->private(); - - my $ids = {}; - my $order = {}; - - my $digest = Digest::SHA::sha1_hex(defined($raw) ? $raw : ''); - - my $pri = 1; - - my $lineno = 0; - - while ($raw && $raw =~ s/^(.*?)(\n|$)//) { - my $line = $1; - $lineno++; - - next if $line =~ m/^\#/; - next if $line =~ m/^\s*$/; - - my $errprefix = "file $filename line $lineno"; - - my ($type, $sectionId, $errmsg, $config) = $class->parse_section_header($line); - if ($config) { - my $ignore = 0; - - my $plugin; - - if ($errmsg) { - $ignore = 1; - chomp $errmsg; - warn "$errprefix (skip section '$sectionId'): $errmsg\n"; - } elsif (!$type) { - $ignore = 1; - warn "$errprefix (skip section '$sectionId'): missing type - internal error\n"; - } else { - if (!($plugin = $pdata->{plugins}->{$type})) { - $ignore = 1; - warn "$errprefix (skip section '$sectionId'): unsupported type '$type'\n"; - } - } - - while ($raw && $raw =~ s/^(.*?)(\n|$)//) { - $line = $1; - $lineno++; - - next if $line =~ m/^\#/; - last if $line =~ m/^\s*$/; - - next if $ignore; # skip - - $errprefix = "file $filename line $lineno"; - - if ($line =~ m/^\s+(\S+)(\s+(.*\S))?\s*$/) { - my ($k, $v) = ($1, $3); - - eval { - die "duplicate attribute\n" if defined($config->{$k}); - $config->{$k} = $plugin->check_value($type, $k, $v, $sectionId); - }; - warn "$errprefix (section '$sectionId') - unable to parse value of '$k': $@" if $@; - - } else { - warn "$errprefix (section '$sectionId') - ignore config line: $line\n"; - } - } - - if (!$ignore && $type && $plugin && $config) { - $config->{type} = $type; - eval { $ids->{$sectionId} = $plugin->check_config($sectionId, $config, 1, 1); }; - warn "$errprefix (skip section '$sectionId'): $@" if $@; - $order->{$sectionId} = $pri++; - } - - } else { - warn "$errprefix - ignore config line: $line\n"; - } - } - - - my $cfg = { ids => $ids, order => $order, digest => $digest}; - - return $cfg; -} - -sub check_config { - my ($class, $sectionId, $config, $create, $skipSchemaCheck) = @_; - - my $type = $class->type(); - my $pdata = $class->private(); - my $opts = $pdata->{options}->{$type}; - - my $settings = { type => $type }; - - foreach my $k (keys %$config) { - my $value = $config->{$k}; - - die "can't change value of fixed parameter '$k'\n" - if !$create && $opts->{$k}->{fixed}; - - if (defined($value)) { - my $tmp = $class->check_value($type, $k, $value, $sectionId, $skipSchemaCheck); - $settings->{$k} = $class->decode_value($type, $k, $tmp); - } else { - die "got undefined value for option '$k'\n"; - } - } - - if ($create) { - # check if we have a value for all required options - foreach my $k (keys %$opts) { - next if $opts->{$k}->{optional}; - die "missing value for required option '$k'\n" - if !defined($config->{$k}); - } - } - - return $settings; -} - -my $format_config_line = sub { - my ($schema, $key, $value) = @_; - - my $ct = $schema->{type}; - - if ($ct eq 'boolean') { - return $value ? "\t$key\n" : ''; - } else { - return "\t$key $value\n" if "$value" ne ''; - } -}; - -sub write_config { - my ($class, $filename, $cfg) = @_; - - my $pdata = $class->private(); - my $propertyList = $pdata->{propertyList}; - - my $out = ''; - - my $ids = $cfg->{ids}; - my $order = $cfg->{order}; - - my $maxpri = 0; - foreach my $sectionId (keys %$ids) { - my $pri = $order->{$sectionId}; - $maxpri = $pri if $pri && $pri > $maxpri; - } - foreach my $sectionId (keys %$ids) { - if (!defined ($order->{$sectionId})) { - $order->{$sectionId} = ++$maxpri; - } - } - - foreach my $sectionId (sort {$order->{$a} <=> $order->{$b}} keys %$ids) { - my $scfg = $ids->{$sectionId}; - my $type = $scfg->{type}; - my $opts = $pdata->{options}->{$type}; - - die "unknown section type '$type'\n" if !$opts; - - my $data = $class->format_section_header($type, $sectionId); - if ($scfg->{comment}) { - my $k = 'comment'; - my $v = $class->encode_value($type, $k, $scfg->{$k}); - $data .= &$format_config_line($propertyList->{$k}, $k, $v); - } - - $data .= "\tdisable\n" if $scfg->{disable}; - - my $done_hash = { comment => 1, disable => 1}; - - foreach my $k (keys %$opts) { - next if $opts->{$k}->{optional}; - $done_hash->{$k} = 1; - my $v = $scfg->{$k}; - die "section '$sectionId' - missing value for required option '$k'\n" - if !defined ($v); - $v = $class->encode_value($type, $k, $v); - $data .= &$format_config_line($propertyList->{$k}, $k, $v); - } - - foreach my $k (keys %$opts) { - next if defined($done_hash->{$k}); - my $v = $scfg->{$k}; - next if !defined($v); - $v = $class->encode_value($type, $k, $v); - $data .= &$format_config_line($propertyList->{$k}, $k, $v); - } - - $out .= "$data\n"; - } - - return $out; -} - -sub assert_if_modified { - my ($cfg, $digest) = @_; - - PVE::Tools::assert_if_modified($cfg->{digest}, $digest); -} - -1; diff --git a/data/PVE/Tools.pm b/data/PVE/Tools.pm deleted file mode 100644 index 827ca58..0000000 --- a/data/PVE/Tools.pm +++ /dev/null @@ -1,1046 +0,0 @@ -package PVE::Tools; - -use strict; -use warnings; -use POSIX qw(EINTR); -use IO::Socket::INET; -use IO::Select; -use File::Basename; -use File::Path qw(make_path); -use IO::File; -use IO::Dir; -use IPC::Open3; -use Fcntl qw(:DEFAULT :flock); -use base 'Exporter'; -use URI::Escape; -use Encode; -use Digest::SHA; -use Text::ParseWords; -use String::ShellQuote; -use Time::HiRes qw(usleep gettimeofday tv_interval); - -# avoid warning when parsing long hex values with hex() -no warnings 'portable'; # Support for 64-bit ints required - -our @EXPORT_OK = qw( -$IPV6RE -$IPV4RE -lock_file -lock_file_full -run_command -file_set_contents -file_get_contents -file_read_firstline -dir_glob_regex -dir_glob_foreach -split_list -template_replace -safe_print -trim -extract_param -); - -my $pvelogdir = "/var/log/pve"; -my $pvetaskdir = "$pvelogdir/tasks"; - -mkdir $pvelogdir; -mkdir $pvetaskdir; - -my $IPV4OCTET = "(?:25[0-5]|(?:[1-9]|1[0-9]|2[0-4])?[0-9])"; -our $IPV4RE = "(?:(?:$IPV4OCTET\\.){3}$IPV4OCTET)"; -my $IPV6H16 = "(?:[0-9a-fA-F]{1,4})"; -my $IPV6LS32 = "(?:(?:$IPV4RE|$IPV6H16:$IPV6H16))"; - -our $IPV6RE = "(?:" . - "(?:(?:" . "(?:$IPV6H16:){6})$IPV6LS32)|" . - "(?:(?:" . "::(?:$IPV6H16:){5})$IPV6LS32)|" . - "(?:(?:(?:" . "$IPV6H16)?::(?:$IPV6H16:){4})$IPV6LS32)|" . - "(?:(?:(?:(?:$IPV6H16:){0,1}$IPV6H16)?::(?:$IPV6H16:){3})$IPV6LS32)|" . - "(?:(?:(?:(?:$IPV6H16:){0,2}$IPV6H16)?::(?:$IPV6H16:){2})$IPV6LS32)|" . - "(?:(?:(?:(?:$IPV6H16:){0,3}$IPV6H16)?::(?:$IPV6H16:){1})$IPV6LS32)|" . - "(?:(?:(?:(?:$IPV6H16:){0,4}$IPV6H16)?::" . ")$IPV6LS32)|" . - "(?:(?:(?:(?:$IPV6H16:){0,5}$IPV6H16)?::" . ")$IPV6H16)|" . - "(?:(?:(?:(?:$IPV6H16:){0,6}$IPV6H16)?::" . ")))"; - -sub run_with_timeout { - my ($timeout, $code, @param) = @_; - - die "got timeout\n" if $timeout <= 0; - - my $prev_alarm; - - my $sigcount = 0; - - my $res; - - local $SIG{ALRM} = sub { $sigcount++; }; # catch alarm outside eval - - eval { - local $SIG{ALRM} = sub { $sigcount++; die "got timeout\n"; }; - local $SIG{PIPE} = sub { $sigcount++; die "broken pipe\n" }; - local $SIG{__DIE__}; # see SA bug 4631 - - $prev_alarm = alarm($timeout); - - $res = &$code(@param); - - alarm(0); # avoid race conditions - }; - - my $err = $@; - - alarm($prev_alarm) if defined($prev_alarm); - - die "unknown error" if $sigcount && !$err; # seems to happen sometimes - - die $err if $err; - - return $res; -} - -# flock: we use one file handle per process, so lock file -# can be called multiple times and succeeds for the same process. - -my $lock_handles = {}; - -sub lock_file_full { - my ($filename, $timeout, $shared, $code, @param) = @_; - - $timeout = 10 if !$timeout; - - my $mode = $shared ? LOCK_SH : LOCK_EX; - - my $lock_func = sub { - if (!$lock_handles->{$$}->{$filename}) { - $lock_handles->{$$}->{$filename} = new IO::File (">>$filename") || - die "can't open file - $!\n"; - } - - if (!flock ($lock_handles->{$$}->{$filename}, $mode|LOCK_NB)) { - print STDERR "trying to aquire lock..."; - my $success; - while(1) { - $success = flock($lock_handles->{$$}->{$filename}, $mode); - # try again on EINTR (see bug #273) - if ($success || ($! != EINTR)) { - last; - } - } - if (!$success) { - print STDERR " failed\n"; - die "can't aquire lock - $!\n"; - } - print STDERR " OK\n"; - } - }; - - my $res; - - eval { run_with_timeout($timeout, $lock_func); }; - my $err = $@; - if ($err) { - $err = "can't lock file '$filename' - $err"; - } else { - eval { $res = &$code(@param) }; - $err = $@; - } - - if (my $fh = $lock_handles->{$$}->{$filename}) { - $lock_handles->{$$}->{$filename} = undef; - close ($fh); - } - - if ($err) { - $@ = $err; - return undef; - } - - $@ = undef; - - return $res; -} - - -sub lock_file { - my ($filename, $timeout, $code, @param) = @_; - - return lock_file_full($filename, $timeout, 0, $code, @param); -} - -sub file_set_contents { - my ($filename, $data, $perm) = @_; - - $perm = 0644 if !defined($perm); - - my $tmpname = "$filename.tmp.$$"; - - eval { - my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm); - die "unable to open file '$tmpname' - $!\n" if !$fh; - die "unable to write '$tmpname' - $!\n" unless print $fh $data; - die "closing file '$tmpname' failed - $!\n" unless close $fh; - }; - my $err = $@; - - if ($err) { - unlink $tmpname; - die $err; - } - - if (!rename($tmpname, $filename)) { - my $msg = "close (rename) atomic file '$filename' failed: $!\n"; - unlink $tmpname; - die $msg; - } -} - -sub file_get_contents { - my ($filename, $max) = @_; - - my $fh = IO::File->new($filename, "r") || - die "can't open '$filename' - $!\n"; - - my $content = safe_read_from($fh, $max); - - close $fh; - - return $content; -} - -sub file_read_firstline { - my ($filename) = @_; - - my $fh = IO::File->new ($filename, "r"); - return undef if !$fh; - my $res = <$fh>; - chomp $res if $res; - $fh->close; - return $res; -} - -sub safe_read_from { - my ($fh, $max, $oneline) = @_; - - $max = 32768 if !$max; - - my $br = 0; - my $input = ''; - my $count; - while ($count = sysread($fh, $input, 8192, $br)) { - $br += $count; - die "input too long - aborting\n" if $br > $max; - if ($oneline && $input =~ m/^(.*)\n/) { - $input = $1; - last; - } - } - die "unable to read input - $!\n" if !defined($count); - - return $input; -} - -sub run_command { - my ($cmd, %param) = @_; - - my $old_umask; - my $cmdstr; - - if (!ref($cmd)) { - $cmdstr = $cmd; - if ($cmd =~ m/|/) { - # see 'man bash' for option pipefail - $cmd = [ '/bin/bash', '-c', "set -o pipefail && $cmd" ]; - } else { - $cmd = [ $cmd ]; - } - } else { - $cmdstr = cmd2string($cmd); - } - - my $errmsg; - my $laststderr; - my $timeout; - my $oldtimeout; - my $pid; - - my $outfunc; - my $errfunc; - my $logfunc; - my $input; - my $output; - my $afterfork; - - eval { - - foreach my $p (keys %param) { - if ($p eq 'timeout') { - $timeout = $param{$p}; - } elsif ($p eq 'umask') { - $old_umask = umask($param{$p}); - } elsif ($p eq 'errmsg') { - $errmsg = $param{$p}; - } elsif ($p eq 'input') { - $input = $param{$p}; - } elsif ($p eq 'output') { - $output = $param{$p}; - } elsif ($p eq 'outfunc') { - $outfunc = $param{$p}; - } elsif ($p eq 'errfunc') { - $errfunc = $param{$p}; - } elsif ($p eq 'logfunc') { - $logfunc = $param{$p}; - } elsif ($p eq 'afterfork') { - $afterfork = $param{$p}; - } else { - die "got unknown parameter '$p' for run_command\n"; - } - } - - if ($errmsg) { - my $origerrfunc = $errfunc; - $errfunc = sub { - if ($laststderr) { - if ($origerrfunc) { - &$origerrfunc("$laststderr\n"); - } else { - print STDERR "$laststderr\n" if $laststderr; - } - } - $laststderr = shift; - }; - } - - my $reader = $output && $output =~ m/^>&/ ? $output : IO::File->new(); - my $writer = $input && $input =~ m/^<&/ ? $input : IO::File->new(); - my $error = IO::File->new(); - - # try to avoid locale related issues/warnings - my $lang = $param{lang} || 'C'; - - my $orig_pid = $$; - - eval { - local $ENV{LC_ALL} = $lang; - - # suppress LVM warnings like: "File descriptor 3 left open"; - local $ENV{LVM_SUPPRESS_FD_WARNINGS} = "1"; - - $pid = open3($writer, $reader, $error, @$cmd) || die $!; - - # if we pipe fron STDIN, open3 closes STDIN, so we we - # a perl warning "Filehandle STDIN reopened as GENXYZ .. " - # as soon as we open a new file. - # to avoid that we open /dev/null - if (!ref($writer) && !defined(fileno(STDIN))) { - POSIX::close(0); - open(STDIN, "add($reader) if ref($reader); - $select->add($error); - - my $outlog = ''; - my $errlog = ''; - - my $starttime = time(); - - while ($select->count) { - my @handles = $select->can_read(1); - - foreach my $h (@handles) { - my $buf = ''; - my $count = sysread ($h, $buf, 4096); - if (!defined ($count)) { - my $err = $!; - kill (9, $pid); - waitpid ($pid, 0); - die $err; - } - $select->remove ($h) if !$count; - if ($h eq $reader) { - if ($outfunc || $logfunc) { - eval { - $outlog .= $buf; - while ($outlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) { - my $line = $1; - &$outfunc($line) if $outfunc; - &$logfunc($line) if $logfunc; - } - }; - my $err = $@; - if ($err) { - kill (9, $pid); - waitpid ($pid, 0); - die $err; - } - } else { - print $buf; - *STDOUT->flush(); - } - } elsif ($h eq $error) { - if ($errfunc || $logfunc) { - eval { - $errlog .= $buf; - while ($errlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) { - my $line = $1; - &$errfunc($line) if $errfunc; - &$logfunc($line) if $logfunc; - } - }; - my $err = $@; - if ($err) { - kill (9, $pid); - waitpid ($pid, 0); - die $err; - } - } else { - print STDERR $buf; - *STDERR->flush(); - } - } - } - } - - &$outfunc($outlog) if $outfunc && $outlog; - &$logfunc($outlog) if $logfunc && $outlog; - - &$errfunc($errlog) if $errfunc && $errlog; - &$logfunc($errlog) if $logfunc && $errlog; - - waitpid ($pid, 0); - - if ($? == -1) { - die "failed to execute\n"; - } elsif (my $sig = ($? & 127)) { - die "got signal $sig\n"; - } elsif (my $ec = ($? >> 8)) { - if (!($ec == 24 && ($cmdstr =~ m|^(\S+/)?rsync\s|))) { - if ($errmsg && $laststderr) { - my $lerr = $laststderr; - $laststderr = undef; - die "$lerr\n"; - } - die "exit code $ec\n"; - } - } - - alarm(0); - }; - - my $err = $@; - - alarm(0); - - if ($errmsg && $laststderr) { - &$errfunc(undef); # flush laststderr - } - - umask ($old_umask) if defined($old_umask); - - alarm($oldtimeout) if $oldtimeout; - - if ($err) { - if ($pid && ($err eq "got timeout\n")) { - kill (9, $pid); - waitpid ($pid, 0); - die "command '$cmdstr' failed: $err"; - } - - if ($errmsg) { - $err =~ s/^usermod:\s*// if $cmdstr =~ m|^(\S+/)?usermod\s|; - die "$errmsg: $err"; - } else { - die "command '$cmdstr' failed: $err"; - } - } - - return undef; -} - -sub split_list { - my $listtxt = shift || ''; - - return split (/\0/, $listtxt) if $listtxt =~ m/\0/; - - $listtxt =~ s/[,;]/ /g; - $listtxt =~ s/^\s+//; - - my @data = split (/\s+/, $listtxt); - - return @data; -} - -sub trim { - my $txt = shift; - - return $txt if !defined($txt); - - $txt =~ s/^\s+//; - $txt =~ s/\s+$//; - - return $txt; -} - -# simple uri templates like "/vms/{vmid}" -sub template_replace { - my ($tmpl, $data) = @_; - - return $tmpl if !$tmpl; - - my $res = ''; - while ($tmpl =~ m/([^{]+)?({([^}]+)})?/g) { - $res .= $1 if $1; - $res .= ($data->{$3} || '-') if $2; - } - return $res; -} - -sub safe_print { - my ($filename, $fh, $data) = @_; - - return if !$data; - - my $res = print $fh $data; - - die "write to '$filename' failed\n" if !$res; -} - -sub debmirrors { - - return { - 'at' => 'ftp.at.debian.org', - 'au' => 'ftp.au.debian.org', - 'be' => 'ftp.be.debian.org', - 'bg' => 'ftp.bg.debian.org', - 'br' => 'ftp.br.debian.org', - 'ca' => 'ftp.ca.debian.org', - 'ch' => 'ftp.ch.debian.org', - 'cl' => 'ftp.cl.debian.org', - 'cz' => 'ftp.cz.debian.org', - 'de' => 'ftp.de.debian.org', - 'dk' => 'ftp.dk.debian.org', - 'ee' => 'ftp.ee.debian.org', - 'es' => 'ftp.es.debian.org', - 'fi' => 'ftp.fi.debian.org', - 'fr' => 'ftp.fr.debian.org', - 'gr' => 'ftp.gr.debian.org', - 'hk' => 'ftp.hk.debian.org', - 'hr' => 'ftp.hr.debian.org', - 'hu' => 'ftp.hu.debian.org', - 'ie' => 'ftp.ie.debian.org', - 'is' => 'ftp.is.debian.org', - 'it' => 'ftp.it.debian.org', - 'jp' => 'ftp.jp.debian.org', - 'kr' => 'ftp.kr.debian.org', - 'mx' => 'ftp.mx.debian.org', - 'nl' => 'ftp.nl.debian.org', - 'no' => 'ftp.no.debian.org', - 'nz' => 'ftp.nz.debian.org', - 'pl' => 'ftp.pl.debian.org', - 'pt' => 'ftp.pt.debian.org', - 'ro' => 'ftp.ro.debian.org', - 'ru' => 'ftp.ru.debian.org', - 'se' => 'ftp.se.debian.org', - 'si' => 'ftp.si.debian.org', - 'sk' => 'ftp.sk.debian.org', - 'tr' => 'ftp.tr.debian.org', - 'tw' => 'ftp.tw.debian.org', - 'gb' => 'ftp.uk.debian.org', - 'us' => 'ftp.us.debian.org', - }; -} - -my $keymaphash = { - 'dk' => ['Danish', 'da', 'qwerty/dk-latin1.kmap.gz', 'dk', 'nodeadkeys'], - 'de' => ['German', 'de', 'qwertz/de-latin1-nodeadkeys.kmap.gz', 'de', 'nodeadkeys' ], - 'de-ch' => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz', 'ch', 'de_nodeadkeys' ], - 'en-gb' => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', undef], - 'en-us' => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz', 'us', undef ], - 'es' => ['Spanish', 'es', 'qwerty/es.kmap.gz', 'es', 'nodeadkeys'], - #'et' => [], # Ethopia or Estonia ?? - 'fi' => ['Finnish', 'fi', 'qwerty/fi-latin1.kmap.gz', 'fi', 'nodeadkeys'], - #'fo' => ['Faroe Islands', 'fo', ???, 'fo', 'nodeadkeys'], - 'fr' => ['French', 'fr', 'azerty/fr-latin1.kmap.gz', 'fr', 'nodeadkeys'], - 'fr-be' => ['Belgium-French', 'fr-be', 'azerty/be2-latin1.kmap.gz', 'be', 'nodeadkeys'], - 'fr-ca' => ['Canada-French', 'fr-ca', 'qwerty/cf.kmap.gz', 'ca', 'fr-legacy'], - 'fr-ch' => ['Swiss-French', 'fr-ch', 'qwertz/fr_CH-latin1.kmap.gz', 'ch', 'fr_nodeadkeys'], - #'hr' => ['Croatia', 'hr', 'qwertz/croat.kmap.gz', 'hr', ??], # latin2? - 'hu' => ['Hungarian', 'hu', 'qwertz/hu.kmap.gz', 'hu', undef], - 'is' => ['Icelandic', 'is', 'qwerty/is-latin1.kmap.gz', 'is', 'nodeadkeys'], - 'it' => ['Italian', 'it', 'qwerty/it2.kmap.gz', 'it', 'nodeadkeys'], - 'jp' => ['Japanese', 'ja', 'qwerty/jp106.kmap.gz', 'jp', undef], - 'lt' => ['Lithuanian', 'lt', 'qwerty/lt.kmap.gz', 'lt', 'std'], - #'lv' => ['Latvian', 'lv', 'qwerty/lv-latin4.kmap.gz', 'lv', ??], # latin4 or latin7? - 'mk' => ['Macedonian', 'mk', 'qwerty/mk.kmap.gz', 'mk', 'nodeadkeys'], - 'nl' => ['Dutch', 'nl', 'qwerty/nl.kmap.gz', 'nl', undef], - #'nl-be' => ['Belgium-Dutch', 'nl-be', ?, ?, ?], - 'no' => ['Norwegian', 'no', 'qwerty/no-latin1.kmap.gz', 'no', 'nodeadkeys'], - 'pl' => ['Polish', 'pl', 'qwerty/pl.kmap.gz', 'pl', undef], - 'pt' => ['Portuguese', 'pt', 'qwerty/pt-latin1.kmap.gz', 'pt', 'nodeadkeys'], - 'pt-br' => ['Brazil-Portuguese', 'pt-br', 'qwerty/br-latin1.kmap.gz', 'br', 'nodeadkeys'], - #'ru' => ['Russian', 'ru', 'qwerty/ru.kmap.gz', 'ru', undef], # dont know? - 'si' => ['Slovenian', 'sl', 'qwertz/slovene.kmap.gz', 'si', undef], - 'se' => ['Swedish', 'sv', 'qwerty/se-latin1.kmap.gz', 'se', 'nodeadkeys'], - #'th' => [], - 'tr' => ['Turkish', 'tr', 'qwerty/trq.kmap.gz', 'tr', undef], -}; - -my $kvmkeymaparray = []; -foreach my $lc (keys %$keymaphash) { - push @$kvmkeymaparray, $keymaphash->{$lc}->[1]; -} - -sub kvmkeymaps { - return $keymaphash; -} - -sub kvmkeymaplist { - return $kvmkeymaparray; -} - -sub extract_param { - my ($param, $key) = @_; - - my $res = $param->{$key}; - delete $param->{$key}; - - return $res; -} - -# Note: we use this to wait until vncterm/spiceterm is ready -sub wait_for_vnc_port { - my ($port, $timeout) = @_; - - $timeout = 5 if !$timeout; - my $sleeptime = 0; - my $starttime = [gettimeofday]; - my $elapsed; - - while (($elapsed = tv_interval($starttime)) < $timeout) { - if (my $fh = IO::File->new ("/proc/net/tcp", "r")) { - while (defined (my $line = <$fh>)) { - if ($line =~ m/^\s*\d+:\s+([0-9A-Fa-f]{8}):([0-9A-Fa-f]{4})\s/) { - if ($port == hex($2)) { - close($fh); - return 1; - } - } - } - close($fh); - } - $sleeptime += 100000 if $sleeptime < 1000000; - usleep($sleeptime); - } - - return undef; -} - -sub next_unused_port { - my ($range_start, $range_end) = @_; - - # We use a file to register allocated ports. - # Those registrations expires after $expiretime. - # We use this to avoid race conditions between - # allocation and use of ports. - - my $filename = "/var/tmp/pve-reserved-ports"; - - my $code = sub { - - my $expiretime = 5; - my $ctime = time(); - - my $ports = {}; - - if (my $fh = IO::File->new ($filename, "r")) { - while (my $line = <$fh>) { - if ($line =~ m/^(\d+)\s(\d+)$/) { - my ($port, $timestamp) = ($1, $2); - if (($timestamp + $expiretime) > $ctime) { - $ports->{$port} = $timestamp; # not expired - } - } - } - } - - my $newport; - - for (my $p = $range_start; $p < $range_end; $p++) { - next if $ports->{$p}; # reserved - - my $sock = IO::Socket::INET->new(Listen => 5, - LocalAddr => '0.0.0.0', - LocalPort => $p, - ReuseAddr => 1, - Proto => 0); - - if ($sock) { - close($sock); - $newport = $p; - $ports->{$p} = $ctime; - last; - } - } - - my $data = ""; - foreach my $p (keys %$ports) { - $data .= "$p $ports->{$p}\n"; - } - - file_set_contents($filename, $data); - - return $newport; - }; - - my $p = lock_file($filename, 10, $code); - die $@ if $@; - - die "unable to find free port (${range_start}-${range_end})\n" if !$p; - - return $p; -} - -sub next_migrate_port { - return next_unused_port(60000, 60050); -} - -sub next_vnc_port { - return next_unused_port(5900, 6000); -} - -sub next_spice_port { - return next_unused_port(61000, 61099); -} - -# NOTE: NFS syscall can't be interrupted, so alarm does -# not work to provide timeouts. -# from 'man nfs': "Only SIGKILL can interrupt a pending NFS operation" -# So the spawn external 'df' process instead of using -# Filesys::Df (which uses statfs syscall) -sub df { - my ($path, $timeout) = @_; - - my $cmd = [ 'df', '-P', '-B', '1', $path]; - - my $res = { - total => 0, - used => 0, - avail => 0, - }; - - my $parser = sub { - my $line = shift; - if (my ($fsid, $total, $used, $avail) = $line =~ - m/^(\S+.*)\s+(\d+)\s+(\d+)\s+(\d+)\s+\d+%\s.*$/) { - $res = { - total => $total, - used => $used, - avail => $avail, - }; - } - }; - eval { run_command($cmd, timeout => $timeout, outfunc => $parser); }; - warn $@ if $@; - - return $res; -} - -# UPID helper -# We use this to uniquely identify a process. -# An 'Unique Process ID' has the following format: -# "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user" - -sub upid_encode { - my $d = shift; - - # Note: pstart can be > 32bit if uptime > 497 days, so this can result in - # more that 8 characters for pstart - return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid}, - $d->{pstart}, $d->{starttime}, $d->{type}, $d->{id}, - $d->{user}); -} - -sub upid_decode { - my ($upid, $noerr) = @_; - - my $res; - my $filename; - - # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user" - # Note: allow up to 9 characters for pstart (work until 20 years uptime) - if ($upid =~ m/^UPID:([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8,9}):([0-9A-Fa-f]{8}):([^:\s]+):([^:\s]*):([^:\s]+):$/) { - $res->{node} = $1; - $res->{pid} = hex($3); - $res->{pstart} = hex($4); - $res->{starttime} = hex($5); - $res->{type} = $6; - $res->{id} = $7; - $res->{user} = $8; - - my $subdir = substr($5, 7, 8); - $filename = "$pvetaskdir/$subdir/$upid"; - - } else { - return undef if $noerr; - die "unable to parse worker upid '$upid'\n"; - } - - return wantarray ? ($res, $filename) : $res; -} - -sub upid_open { - my ($upid) = @_; - - my ($task, $filename) = upid_decode($upid); - - my $dirname = dirname($filename); - make_path($dirname); - - my $wwwid = getpwnam('www-data') || - die "getpwnam failed"; - - my $perm = 0640; - - my $outfh = IO::File->new ($filename, O_WRONLY|O_CREAT|O_EXCL, $perm) || - die "unable to create output file '$filename' - $!\n"; - chown $wwwid, -1, $outfh; - - return $outfh; -}; - -sub upid_read_status { - my ($upid) = @_; - - my ($task, $filename) = upid_decode($upid); - my $fh = IO::File->new($filename, "r"); - return "unable to open file - $!" if !$fh; - my $maxlen = 4096; - sysseek($fh, -$maxlen, 2); - my $readbuf = ''; - my $br = sysread($fh, $readbuf, $maxlen); - close($fh); - if ($br) { - return "unable to extract last line" - if $readbuf !~ m/\n?(.+)$/; - my $line = $1; - if ($line =~ m/^TASK OK$/) { - return 'OK'; - } elsif ($line =~ m/^TASK ERROR: (.+)$/) { - return $1; - } else { - return "unexpected status"; - } - } - return "unable to read tail (got $br bytes)"; -} - -# useful functions to store comments in config files -sub encode_text { - my ($text) = @_; - - # all control and hi-bit characters, and ':' - my $unsafe = "^\x20-\x39\x3b-\x7e"; - return uri_escape(Encode::encode("utf8", $text), $unsafe); -} - -sub decode_text { - my ($data) = @_; - - return Encode::decode("utf8", uri_unescape($data)); -} - -sub decode_utf8_parameters { - my ($param) = @_; - - foreach my $p (qw(comment description firstname lastname)) { - $param->{$p} = decode('utf8', $param->{$p}) if $param->{$p}; - } - - return $param; -} - -sub random_ether_addr { - - my ($seconds, $microseconds) = gettimeofday; - - my $rand = Digest::SHA::sha1_hex($$, rand(), $seconds, $microseconds); - - my $mac = ''; - for (my $i = 0; $i < 6; $i++) { - my $ss = hex(substr($rand, $i*2, 2)); - if (!$i) { - $ss &= 0xfe; # clear multicast - $ss |= 2; # set local id - } - $ss = sprintf("%02X", $ss); - - if (!$i) { - $mac .= "$ss"; - } else { - $mac .= ":$ss"; - } - } - - return $mac; -} - -sub shellquote { - my $str = shift; - - return String::ShellQuote::shell_quote($str); -} - -sub cmd2string { - my ($cmd) = @_; - - die "no arguments" if !$cmd; - - return $cmd if !ref($cmd); - - my @qa = (); - foreach my $arg (@$cmd) { push @qa, shellquote($arg); } - - return join (' ', @qa); -} - -# split an shell argument string into an array, -sub split_args { - my ($str) = @_; - - return $str ? [ Text::ParseWords::shellwords($str) ] : []; -} - -sub dump_logfile { - my ($filename, $start, $limit, $filter) = @_; - - my $lines = []; - my $count = 0; - - my $fh = IO::File->new($filename, "r"); - if (!$fh) { - $count++; - push @$lines, { n => $count, t => "unable to open file - $!"}; - return ($count, $lines); - } - - $start = 0 if !$start; - $limit = 50 if !$limit; - - my $line; - - if ($filter) { - # duplicate code, so that we do not slow down normal path - while (defined($line = <$fh>)) { - next if $line !~ m/$filter/; - next if $count++ < $start; - next if $limit <= 0; - chomp $line; - push @$lines, { n => $count, t => $line}; - $limit--; - } - } else { - while (defined($line = <$fh>)) { - next if $count++ < $start; - next if $limit <= 0; - chomp $line; - push @$lines, { n => $count, t => $line}; - $limit--; - } - } - - close($fh); - - # HACK: ExtJS store.guaranteeRange() does not like empty array - # so we add a line - if (!$count) { - $count++; - push @$lines, { n => $count, t => "no content"}; - } - - return ($count, $lines); -} - -sub dir_glob_regex { - my ($dir, $regex) = @_; - - my $dh = IO::Dir->new ($dir); - return wantarray ? () : undef if !$dh; - - while (defined(my $tmp = $dh->read)) { - if (my @res = $tmp =~ m/^($regex)$/) { - $dh->close; - return wantarray ? @res : $tmp; - } - } - $dh->close; - - return wantarray ? () : undef; -} - -sub dir_glob_foreach { - my ($dir, $regex, $func) = @_; - - my $dh = IO::Dir->new ($dir); - if (defined $dh) { - while (defined(my $tmp = $dh->read)) { - if (my @res = $tmp =~ m/^($regex)$/) { - &$func (@res); - } - } - } -} - -sub assert_if_modified { - my ($digest1, $digest2) = @_; - - if ($digest1 && $digest2 && ($digest1 ne $digest2)) { - die "detected modified configuration - file changed by other user? Try again.\n"; - } -} - -# Digest for short strings -# like FNV32a, but we only return 31 bits (positive numbers) -sub fnv31a { - my ($string) = @_; - - my $hval = 0x811c9dc5; - - foreach my $c (unpack('C*', $string)) { - $hval ^= $c; - $hval += ( - (($hval << 1) ) + - (($hval << 4) ) + - (($hval << 7) ) + - (($hval << 8) ) + - (($hval << 24) ) ); - $hval = $hval & 0xffffffff; - } - return $hval & 0x7fffffff; -} - -sub fnv31a_hex { return sprintf("%X", fnv31a(@_)); } - -1; diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..5e50005 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,39 @@ + +PREFIX=/usr +BINDIR=${PREFIX}/bin +MANDIR=${PREFIX}/share/man +DOCDIR=${PREFIX}/share/doc +MAN1DIR=${MANDIR}/man1/ +PERLDIR=${PREFIX}/share/perl5 + +LIB_SOURCES= \ + Daemon.pm \ + SectionConfig.pm \ + Network.pm \ + ProcFSTools.pm \ + PodParser.pm \ + CLIHandler.pm \ + RESTHandler.pm \ + JSONSchema.pm \ + SafeSyslog.pm \ + AtomicFile.pm \ + INotify.pm \ + Tools.pm \ + AbstractMigrate.pm \ + Exception.pm + +all: + +.PHONY: install +install: + install -d -m 0755 ${DESTDIR}${PERLDIR}/PVE + for i in ${LIB_SOURCES}; do install -D -m 0644 PVE/$$i ${DESTDIR}${PERLDIR}/PVE/$$i; done + + +.PHONY: clean +clean: + rm -rf *~ + +.PHONY: distclean +distclean: clean + diff --git a/src/PVE/AbstractMigrate.pm b/src/PVE/AbstractMigrate.pm new file mode 100644 index 0000000..01d0a50 --- /dev/null +++ b/src/PVE/AbstractMigrate.pm @@ -0,0 +1,277 @@ +package PVE::AbstractMigrate; + +use strict; +use warnings; +use POSIX qw(strftime); +use PVE::Tools; + +my $msg2text = sub { + my ($level, $msg) = @_; + + chomp $msg; + + return '' if !$msg; + + my $res = ''; + + my $tstr = strftime("%b %d %H:%M:%S", localtime); + + foreach my $line (split (/\n/, $msg)) { + if ($level eq 'err') { + $res .= "$tstr ERROR: $line\n"; + } else { + $res .= "$tstr $line\n"; + } + } + + return $res; +}; + +sub log { + my ($self, $level, $msg) = @_; + + chomp $msg; + + return if !$msg; + + print &$msg2text($level, $msg); +} + +sub cmd { + my ($self, $cmd, %param) = @_; + + my $logfunc = sub { + my $line = shift; + $self->log('info', $line); + }; + + $self->log('info', "# " . PVE::Tools::cmd2string($cmd)); + + PVE::Tools::run_command($cmd, %param, outfunc => $logfunc, errfunc => $logfunc); +} + +my $run_command_quiet_full = sub { + my ($self, $cmd, $logerr, %param) = @_; + + my $log = ''; + my $logfunc = sub { + my $line = shift; + $log .= &$msg2text('info', $line);; + }; + + eval { PVE::Tools::run_command($cmd, %param, outfunc => $logfunc, errfunc => $logfunc); }; + if (my $err = $@) { + $self->log('info', "# " . PVE::Tools::cmd2string($cmd)); + print $log; + if ($logerr) { + $self->{errors} = 1; + $self->log('err', $err); + } else { + die $err; + } + } +}; + +sub cmd_quiet { + my ($self, $cmd, %param) = @_; + return &$run_command_quiet_full($self, $cmd, 0, %param); +} + +sub cmd_logerr { + my ($self, $cmd, %param) = @_; + return &$run_command_quiet_full($self, $cmd, 1, %param); +} + +my $eval_int = sub { + my ($self, $func, @param) = @_; + + eval { + local $SIG{INT} = $SIG{TERM} = $SIG{QUIT} = $SIG{HUP} = sub { + $self->{delayed_interrupt} = 0; + die "interrupted by signal\n"; + }; + local $SIG{PIPE} = sub { + $self->{delayed_interrupt} = 0; + die "interrupted by signal\n"; + }; + + my $di = $self->{delayed_interrupt}; + $self->{delayed_interrupt} = 0; + + die "interrupted by signal\n" if $di; + + &$func($self, @param); + }; +}; + +my @ssh_opts = ('-o', 'BatchMode=yes'); +my @ssh_cmd = ('/usr/bin/ssh', @ssh_opts); +my @scp_cmd = ('/usr/bin/scp', @ssh_opts); +my @rsync_opts = ('-aHAX', '--delete', '--numeric-ids'); +my @rsync_cmd = ('/usr/bin/rsync', @rsync_opts); + +sub migrate { + my ($class, $node, $nodeip, $vmid, $opts) = @_; + + $class = ref($class) || $class; + + my $self = { + delayed_interrupt => 0, + opts => $opts, + vmid => $vmid, + node => $node, + nodeip => $nodeip, + rsync_cmd => [ @rsync_cmd ], + rem_ssh => [ @ssh_cmd, "root\@$nodeip" ], + scp_cmd => [ @scp_cmd ], + }; + + $self = bless $self, $class; + + my $starttime = time(); + + local $ENV{RSYNC_RSH} = join(' ', @ssh_cmd); + + local $SIG{INT} = $SIG{TERM} = $SIG{QUIT} = $SIG{HUP} = $SIG{PIPE} = sub { + $self->log('err', "received interrupt - delayed"); + $self->{delayed_interrupt} = 1; + }; + + local $ENV{RSYNC_RSH} = join(' ', @ssh_cmd); + + # lock container during migration + eval { $self->lock_vm($self->{vmid}, sub { + + $self->{running} = 0; + &$eval_int($self, sub { $self->{running} = $self->prepare($self->{vmid}); }); + die $@ if $@; + + &$eval_int($self, sub { $self->phase1($self->{vmid}); }); + my $err = $@; + if ($err) { + $self->log('err', $err); + eval { $self->phase1_cleanup($self->{vmid}, $err); }; + if (my $tmperr = $@) { + $self->log('err', $tmperr); + } + eval { $self->final_cleanup($self->{vmid}); }; + if (my $tmperr = $@) { + $self->log('err', $tmperr); + } + die $err; + } + + # vm is now owned by other node + # Note: there is no VM config file on the local node anymore + + if ($self->{running}) { + + &$eval_int($self, sub { $self->phase2($self->{vmid}); }); + my $phase2err = $@; + if ($phase2err) { + $self->{errors} = 1; + $self->log('err', "online migrate failure - $phase2err"); + } + eval { $self->phase2_cleanup($self->{vmid}, $phase2err); }; + if (my $err = $@) { + $self->log('err', $err); + $self->{errors} = 1; + } + } + + # phase3 (finalize) + &$eval_int($self, sub { $self->phase3($self->{vmid}); }); + my $phase3err = $@; + if ($phase3err) { + $self->log('err', $phase3err); + $self->{errors} = 1; + } + eval { $self->phase3_cleanup($self->{vmid}, $phase3err); }; + if (my $err = $@) { + $self->log('err', $err); + $self->{errors} = 1; + } + eval { $self->final_cleanup($self->{vmid}); }; + if (my $err = $@) { + $self->log('err', $err); + $self->{errors} = 1; + } + })}; + + my $err = $@; + + my $delay = time() - $starttime; + my $mins = int($delay/60); + my $secs = $delay - $mins*60; + my $hours = int($mins/60); + $mins = $mins - $hours*60; + + my $duration = sprintf "%02d:%02d:%02d", $hours, $mins, $secs; + + if ($err) { + $self->log('err', "migration aborted (duration $duration): $err"); + die "migration aborted\n"; + } + + if ($self->{errors}) { + $self->log('err', "migration finished with problems (duration $duration)"); + die "migration problems\n" + } + + $self->log('info', "migration finished successfuly (duration $duration)"); +} + +sub lock_vm { + my ($self, $vmid, $code, @param) = @_; + + die "abstract method - implement me"; +} + +sub prepare { + my ($self, $vmid) = @_; + + die "abstract method - implement me"; + + # return $running; +} + +# transfer all data and move VM config files +sub phase1 { + my ($self, $vmid) = @_; + die "abstract method - implement me"; +} + +# only called if there are errors in phase1 +sub phase1_cleanup { + my ($self, $vmid, $err) = @_; + die "abstract method - implement me"; +} + +# only called when VM is running and phase1 was successful +sub phase2 { + my ($self, $vmid) = @_; + die "abstract method - implement me"; +} + +# only called when VM is running and phase1 was successful +sub phase2_cleanup { + my ($self, $vmid, $err) = @_; +}; + +# only called when phase1 was successful +sub phase3 { + my ($self, $vmid) = @_; +} + +# only called when phase1 was successful +sub phase3_cleanup { + my ($self, $vmid, $err) = @_; +} + +# final cleanup - always called +sub final_cleanup { + my ($self, $vmid) = @_; + die "abstract method - implement me"; +} + +1; diff --git a/src/PVE/AtomicFile.pm b/src/PVE/AtomicFile.pm new file mode 100644 index 0000000..110a8ae --- /dev/null +++ b/src/PVE/AtomicFile.pm @@ -0,0 +1,19 @@ +package PVE::AtomicFile; + +use strict; +use warnings; +use IO::AtomicFile; +use vars qw(@ISA); + +@ISA = qw(IO::AtomicFile); + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + $self; +} + + +sub DESTROY { + # dont close atomatically (explicit close required to commit changes) +} diff --git a/src/PVE/CLIHandler.pm b/src/PVE/CLIHandler.pm new file mode 100644 index 0000000..33011c6 --- /dev/null +++ b/src/PVE/CLIHandler.pm @@ -0,0 +1,228 @@ +package PVE::CLIHandler; + +use strict; +use warnings; + +use PVE::Exception qw(raise raise_param_exc); +use PVE::RESTHandler; +use PVE::PodParser; + +use base qw(PVE::RESTHandler); + +my $cmddef; +my $exename; + +my $expand_command_name = sub { + my ($def, $cmd) = @_; + + if (!$def->{$cmd}) { + my $expanded; + for my $k (keys(%$def)) { + if ($k =~ m/^$cmd/) { + if ($expanded) { + $expanded = undef; # more than one match + last; + } else { + $expanded = $k; + } + } + } + $cmd = $expanded if $expanded; + } + return $cmd; +}; + +__PACKAGE__->register_method ({ + name => 'help', + path => 'help', + method => 'GET', + description => "Get help about specified command.", + parameters => { + additionalProperties => 0, + properties => { + cmd => { + description => "Command name", + type => 'string', + optional => 1, + }, + verbose => { + description => "Verbose output format.", + type => 'boolean', + optional => 1, + }, + }, + }, + returns => { type => 'null' }, + + code => sub { + my ($param) = @_; + + die "not initialized" if !($cmddef && $exename); + + my $cmd = $param->{cmd}; + + my $verbose = defined($cmd) && $cmd; + $verbose = $param->{verbose} if defined($param->{verbose}); + + if (!$cmd) { + if ($verbose) { + print_usage_verbose(); + } else { + print_usage_short(\*STDOUT); + } + return undef; + } + + $cmd = &$expand_command_name($cmddef, $cmd); + + my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd} || []}; + + raise_param_exc({ cmd => "no such command '$cmd'"}) if !$class; + + + my $str = $class->usage_str($name, "$exename $cmd", $arg_param, $uri_param, $verbose ? 'full' : 'short'); + if ($verbose) { + print "$str\n"; + } else { + print "USAGE: $str\n"; + } + + return undef; + + }}); + +sub print_pod_manpage { + my ($podfn) = @_; + + die "not initialized" if !($cmddef && $exename); + die "no pod file specified" if !$podfn; + + my $synopsis = ""; + + $synopsis .= " $exename [ARGS] [OPTIONS]\n\n"; + + my $style = 'full'; # or should we use 'short'? + my $oldclass; + foreach my $cmd (sorted_commands()) { + my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd}}; + my $str = $class->usage_str($name, "$exename $cmd", $arg_param, + $uri_param, $style); + $str =~ s/^USAGE: //; + + $synopsis .= "\n" if $oldclass && $oldclass ne $class; + $str =~ s/\n/\n /g; + $synopsis .= " $str\n\n"; + $oldclass = $class; + } + + $synopsis .= "\n"; + + my $parser = PVE::PodParser->new(); + $parser->{include}->{synopsis} = $synopsis; + $parser->parse_from_file($podfn); +} + +sub print_usage_verbose { + + die "not initialized" if !($cmddef && $exename); + + print "USAGE: $exename [ARGS] [OPTIONS]\n\n"; + + foreach my $cmd (sort keys %$cmddef) { + my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd}}; + my $str = $class->usage_str($name, "$exename $cmd", $arg_param, $uri_param, 'full'); + print "$str\n\n"; + } +} + +sub sorted_commands { + return sort { ($cmddef->{$a}->[0] cmp $cmddef->{$b}->[0]) || ($a cmp $b)} keys %$cmddef; +} + +sub print_usage_short { + my ($fd, $msg) = @_; + + die "not initialized" if !($cmddef && $exename); + + print $fd "ERROR: $msg\n" if $msg; + print $fd "USAGE: $exename [ARGS] [OPTIONS]\n"; + + my $oldclass; + foreach my $cmd (sorted_commands()) { + my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd}}; + my $str = $class->usage_str($name, "$exename $cmd", $arg_param, $uri_param, 'short'); + print $fd "\n" if $oldclass && $oldclass ne $class; + print $fd " $str"; + $oldclass = $class; + } +} + +sub handle_cmd { + my ($def, $cmdname, $cmd, $args, $pwcallback, $podfn) = @_; + + $cmddef = $def; + $exename = $cmdname; + + $cmddef->{help} = [ __PACKAGE__, 'help', ['cmd'] ]; + + if (!$cmd) { + print_usage_short (\*STDERR, "no command specified"); + exit (-1); + } elsif ($cmd eq 'verifyapi') { + PVE::RESTHandler::validate_method_schemas(); + return; + } elsif ($cmd eq 'printmanpod') { + print_pod_manpage($podfn); + return; + } + + $cmd = &$expand_command_name($cmddef, $cmd); + + my ($class, $name, $arg_param, $uri_param, $outsub) = @{$cmddef->{$cmd} || []}; + + if (!$class) { + print_usage_short (\*STDERR, "unknown command '$cmd'"); + exit (-1); + } + + my $prefix = "$exename $cmd"; + my $res = $class->cli_handler($prefix, $name, \@ARGV, $arg_param, $uri_param, $pwcallback); + + &$outsub($res) if $outsub; +} + +sub handle_simple_cmd { + my ($def, $args, $pwcallback, $podfn) = @_; + + my ($class, $name, $arg_param, $uri_param, $outsub) = @{$def}; + die "no class specified" if !$class; + + if (scalar(@$args) == 1) { + if ($args->[0] eq 'help') { + my $str = "USAGE: $name help\n"; + $str .= $class->usage_str($name, $name, $arg_param, $uri_param, 'long'); + print STDERR "$str\n\n"; + return; + } elsif ($args->[0] eq 'verifyapi') { + PVE::RESTHandler::validate_method_schemas(); + return; + } elsif ($args->[0] eq 'printmanpod') { + my $synopsis = " $name help\n\n"; + my $str = $class->usage_str($name, $name, $arg_param, $uri_param, 'long'); + $str =~ s/^USAGE://; + $str =~ s/\n/\n /g; + $synopsis .= $str; + + my $parser = PVE::PodParser->new(); + $parser->{include}->{synopsis} = $synopsis; + $parser->parse_from_file($podfn); + return; + } + } + + my $res = $class->cli_handler($name, $name, \@ARGV, $arg_param, $uri_param, $pwcallback); + + &$outsub($res) if $outsub; +} + +1; diff --git a/src/PVE/Daemon.pm b/src/PVE/Daemon.pm new file mode 100644 index 0000000..264f8be --- /dev/null +++ b/src/PVE/Daemon.pm @@ -0,0 +1,827 @@ +package PVE::Daemon; + +# Abstract class to implement Daemons +# +# Features: +# * lock and write PID file /var/run/$name.pid to make sure onyl +# one instance is running. +# * keep lock open during restart +# * correctly daemonize (redirect STDIN/STDOUT) +# * restart by stop/start, exec, or signal HUP +# * daemon restart on error (option 'restart_on_error') +# * handle worker processes (option 'max_workers') +# * allow to restart while workers are still runningl +# (option 'leave_children_open_on_reload') +# * run as different user using setuid/setgid + +use strict; +use warnings; +use English; + +use PVE::SafeSyslog; +use PVE::INotify; + +use POSIX ":sys_wait_h"; +use Fcntl ':flock'; +use Socket qw(IPPROTO_TCP TCP_NODELAY SOMAXCONN); +use IO::Socket::INET; + +use Getopt::Long; +use Time::HiRes qw (gettimeofday); + +use base qw(PVE::CLIHandler); + +$ENV{'PATH'} = '/sbin:/bin:/usr/sbin:/usr/bin'; + +my $daemon_initialized = 0; # we only allow one instance + +my $close_daemon_lock = sub { + my ($self) = @_; + + return if !$self->{daemon_lock_fh}; + + close $self->{daemon_lock_fh}; + delete $self->{daemon_lock_fh}; +}; + +my $log_err = sub { + my ($msg) = @_; + chomp $msg; + print STDERR "$msg\n"; + syslog('err', "%s", $msg); +}; + +# call this if you fork() from child +# Note: we already call this for workers, so it is only required +# if you fork inside a simple daemon (max_workers == 0). +sub after_fork_cleanup { + my ($self) = @_; + + &$close_daemon_lock($self); + + PVE::INotify::inotify_close(); + + for my $sig (qw(CHLD HUP INT TERM QUIT)) { + $SIG{$sig} = 'DEFAULT'; # restore default handler + # AnyEvent signals only works if $SIG{XX} is + # undefined (perl event loop) + delete $SIG{$sig}; # so that we can handle events with AnyEvent + } +} + +my $lockpidfile = sub { + my ($self) = @_; + + my $lkfn = $self->{pidfile} . ".lock"; + + my $waittime = 0; + + if (my $fd = $self->{env_pve_lock_fd}) { + + $self->{daemon_lock_fh} = IO::Handle->new_from_fd($fd, "a"); + + } else { + + $waittime = 5; + $self->{daemon_lock_fh} = IO::File->new(">>$lkfn"); + } + + if (!$self->{daemon_lock_fh}) { + die "can't open lock '$lkfn' - $!\n"; + } + + for (my $i = 0; $i < $waittime; $i ++) { + return if flock ($self->{daemon_lock_fh}, LOCK_EX|LOCK_NB); + sleep(1); + } + + if (!flock ($self->{daemon_lock_fh}, LOCK_EX|LOCK_NB)) { + &$close_daemon_lock($self); + my $err = $!; + + my ($running, $pid) = $self->running(); + if ($running) { + die "can't aquire lock '$lkfn' - daemon already started (pid = $pid)\n"; + } else { + die "can't aquire lock '$lkfn' - $err\n"; + } + } +}; + +my $writepidfile = sub { + my ($self) = @_; + + my $pidfile = $self->{pidfile}; + + die "can't open pid file '$pidfile' - $!\n" if !open (PIDFH, ">$pidfile"); + + print PIDFH "$$\n"; + close (PIDFH); +}; + +my $server_cleanup = sub { + my ($self) = @_; + + unlink $self->{pidfile} . ".lock"; + unlink $self->{pidfile}; +}; + +my $finish_workers = sub { + my ($self) = @_; + + foreach my $id (qw(workers old_workers)) { + foreach my $cpid (keys %{$self->{$id}}) { + my $waitpid = waitpid($cpid, WNOHANG); + if (defined($waitpid) && ($waitpid == $cpid)) { + delete ($self->{$id}->{$cpid}); + syslog('info', "worker $cpid finished"); + } + } + } +}; + +my $start_workers = sub { + my ($self) = @_; + + return if $self->{terminate}; + + my $count = 0; + foreach my $cpid (keys %{$self->{workers}}) { + $count++; + } + + my $need = $self->{max_workers} - $count; + + return if $need <= 0; + + syslog('info', "starting $need worker(s)"); + + while ($need > 0) { + my $pid = fork; + + if (!defined ($pid)) { + syslog('err', "can't fork worker"); + sleep (1); + } elsif ($pid) { # parent + $self->{workers}->{$pid} = 1; + syslog('info', "worker $pid started"); + $need--; + } else { + $0 = "$self->{name} worker"; + + $self->after_fork_cleanup(); + + eval { $self->run(); }; + if (my $err = $@) { + syslog('err', $err); + sleep(5); # avoid fast restarts + } + + syslog('info', "worker exit"); + exit (0); + } + } +}; + +my $terminate_server = sub { + my ($self, $allow_open_children) = @_; + + $self->{terminate} = 1; # set flag to avoid worker restart + + if (!$self->{max_workers}) { + eval { $self->shutdown(); }; + warn $@ if $@; + return; + } + + eval { $self->shutdown(); }; + warn $@ if $@; + + # we have workers - send TERM signal + + foreach my $cpid (keys %{$self->{workers}}) { + kill(15, $cpid); # TERM childs + } + + # if configured, leave children running on HUP + return if $allow_open_children && + $self->{leave_children_open_on_reload}; + + # else, send TERM to old workers + foreach my $cpid (keys %{$self->{old_workers}}) { + kill(15, $cpid); # TERM childs + } + + # nicely shutdown childs (give them max 10 seconds to shut down) + my $previous_alarm = alarm(10); + eval { + local $SIG{ALRM} = sub { die "timeout\n" }; + + while ((my $pid = waitpid (-1, 0)) > 0) { + foreach my $id (qw(workers old_workers)) { + if (defined($self->{$id}->{$pid})) { + delete($self->{$id}->{$pid}); + syslog('info', "worker $pid finished"); + } + } + } + alarm(0); # avoid race condition + }; + my $err = $@; + + alarm ($previous_alarm); + + if ($err) { + syslog('err', "error stopping workers (will kill them now) - $err"); + foreach my $id (qw(workers old_workers)) { + foreach my $cpid (keys %{$self->{$id}}) { + # KILL childs still alive! + if (kill (0, $cpid)) { + delete($self->{$id}->{$cpid}); + syslog("err", "kill worker $cpid"); + kill(9, $cpid); + # fixme: waitpid? + } + } + } + } +}; + +my $server_run = sub { + my ($self, $debug) = @_; + + # fixme: handle restart lockfd + &$lockpidfile($self); + + # remove FD_CLOEXEC bit to reuse on exec + $self->{daemon_lock_fh}->fcntl(Fcntl::F_SETFD(), 0); + + $ENV{PVE_DAEMON_LOCK_FD} = $self->{daemon_lock_fh}->fileno; + + # run in background + my $spid; + + $self->{debug} = 1 if $debug; + + $self->init(); + + if (!$debug) { + open STDIN, '/dev/null' || die "can't write /dev/null"; + } + + if (!$self->{env_restart_pve_daemon} && !$debug) { + PVE::INotify::inotify_close(); + $spid = fork(); + if (!defined ($spid)) { + die "can't put server into background - fork failed"; + } elsif ($spid) { # parent + exit (0); + } + PVE::INotify::inotify_init(); + } + + if ($self->{env_restart_pve_daemon}) { + syslog('info' , "restarting server"); + } else { + &$writepidfile($self); + syslog('info' , "starting server"); + } + + POSIX::setsid(); + + open STDERR, '>&STDOUT' || die "can't close STDERR\n"; + + my $old_sig_term = $SIG{TERM}; + local $SIG{TERM} = sub { + local ($@, $!, $?); # do not overwrite error vars + syslog('info', "received signal TERM"); + &$terminate_server($self, 0); + &$server_cleanup($self); + &$old_sig_term(@_) if $old_sig_term; + }; + + my $old_sig_quit = $SIG{QUIT}; + local $SIG{QUIT} = sub { + local ($@, $!, $?); # do not overwrite error vars + syslog('info', "received signal QUIT"); + &$terminate_server($self, 0); + &$server_cleanup($self); + &$old_sig_quit(@_) if $old_sig_quit; + }; + + my $old_sig_int = $SIG{INT}; + local $SIG{INT} = sub { + local ($@, $!, $?); # do not overwrite error vars + syslog('info', "received signal INT"); + $SIG{INT} = 'DEFAULT'; # allow to terminate now + &$terminate_server($self, 0); + &$server_cleanup($self); + &$old_sig_int(@_) if $old_sig_int; + }; + + $SIG{HUP} = sub { + local ($@, $!, $?); # do not overwrite error vars + syslog('info', "received signal HUP"); + $self->{got_hup_signal} = 1; + if ($self->{max_workers}) { + &$terminate_server($self, 1); + } elsif ($self->can('hup')) { + eval { $self->hup() }; + warn $@ if $@; + } + }; + + eval { + if ($self->{max_workers}) { + my $old_sig_chld = $SIG{CHLD}; + local $SIG{CHLD} = sub { + local ($@, $!, $?); # do not overwrite error vars + &$finish_workers($self); + &$old_sig_chld(@_) if $old_sig_chld; + }; + + # catch worker finished during restart phase + &$finish_workers($self); + + # now loop forever (until we receive terminate signal) + for (;;) { + &$start_workers($self); + sleep(5); + &$finish_workers($self); + last if $self->{terminate}; + } + + } else { + $self->run(); + } + }; + my $err = $@; + + if ($err) { + syslog ('err', "ERROR: $err"); + + &$terminate_server($self, 1); + + if (my $wait_time = $self->{restart_on_error}) { + $self->restart_daemon($wait_time); + } else { + $self->exit_daemon(-1); + } + } + + if ($self->{got_hup_signal}) { + $self->restart_daemon(); + } else { + $self->exit_daemon(0); + } +}; + +sub new { + my ($this, $name, $cmdline, %params) = @_; + + $name = 'daemon' if !$name; # should not happen + + initlog($name); + + my $self; + + eval { + + my $restart = $ENV{RESTART_PVE_DAEMON}; + delete $ENV{RESTART_PVE_DAEMON}; + + my $lockfd = $ENV{PVE_DAEMON_LOCK_FD}; + delete $ENV{PVE_DAEMON_LOCK_FD}; + + if (defined($lockfd)) { + die "unable to parse lock fd '$lockfd'\n" + if $lockfd !~ m/^(\d+)$/; + $lockfd = $1; # untaint + } + + die "please run as root\n" if !$restart && ($> != 0); + + die "can't create more that one PVE::Daemon" if $daemon_initialized; + $daemon_initialized = 1; + + PVE::INotify::inotify_init(); + + my $class = ref($this) || $this; + + $self = bless { + name => $name, + pidfile => "/var/run/${name}.pid", + env_restart_pve_daemon => $restart, + env_pve_lock_fd => $lockfd, + workers => {}, + old_workers => {}, + }, $class; + + + foreach my $opt (keys %params) { + my $value = $params{$opt}; + if ($opt eq 'restart_on_error') { + $self->{$opt} = $value; + } elsif ($opt eq 'stop_wait_time') { + $self->{$opt} = $value; + } elsif ($opt eq 'pidfile') { + $self->{$opt} = $value; + } elsif ($opt eq 'max_workers') { + $self->{$opt} = $value; + } elsif ($opt eq 'leave_children_open_on_reload') { + $self->{$opt} = $value; + } elsif ($opt eq 'setgid') { + $self->{$opt} = $value; + } elsif ($opt eq 'setuid') { + $self->{$opt} = $value; + } else { + die "unknown daemon option '$opt'\n"; + } + } + + if (my $gidstr = $self->{setgid}) { + my $gid = getgrnam($gidstr) || die "getgrnam failed - $!\n"; + POSIX::setgid($gid) || die "setgid $gid failed - $!\n"; + $EGID = "$gid $gid"; # this calls setgroups + # just to be sure + die "detected strange gid\n" if !($GID eq "$gid $gid" && $EGID eq "$gid $gid"); + } + + if (my $uidstr = $self->{setuid}) { + my $uid = getpwnam($uidstr) || die "getpwnam failed - $!\n"; + POSIX::setuid($uid) || die "setuid $uid failed - $!\n"; + # just to be sure + die "detected strange uid\n" if !($UID == $uid && $EUID == $uid); + } + + if ($restart && $self->{max_workers}) { + if (my $wpids = $ENV{PVE_DAEMON_WORKER_PIDS}) { + foreach my $pid (split(':', $wpids)) { + if ($pid =~ m/^(\d+)$/) { + $self->{old_workers}->{$1} = 1; + } + } + } + } + + $self->{nodename} = PVE::INotify::nodename(); + + $self->{cmdline} = []; + + foreach my $el (@$cmdline) { + $el =~ m/^(.*)$/; # untaint + push @{$self->{cmdline}}, $1; + } + + $0 = $name; + }; + if (my $err = $@) { + &$log_err($err); + exit(-1); + } + + return $self; +} + +sub exit_daemon { + my ($self, $status) = @_; + + syslog("info", "server stopped"); + + &$server_cleanup($self); + + exit($status); +} + +sub restart_daemon { + my ($self, $waittime) = @_; + + syslog('info', "server shutdown (restart)"); + + $ENV{RESTART_PVE_DAEMON} = 1; + + if ($self->{max_workers}) { + my @workers = keys %{$self->{workers}}; + push @workers, keys %{$self->{old_workers}}; + $ENV{PVE_DAEMON_WORKER_PIDS} = join(':', @workers); + } + + sleep($waittime) if $waittime; # avoid high server load due to restarts + + PVE::INotify::inotify_close(); + + exec (@{$self->{cmdline}}); + + exit (-1); # never reached? +} + +# please overwrite in subclass +# this is called at startup - before forking +sub init { + my ($self) = @_; + +} + +# please overwrite in subclass +sub shutdown { + my ($self) = @_; + + syslog('info' , "server closing"); + + if (!$self->{max_workers}) { + # wait for children + 1 while (waitpid(-1, POSIX::WNOHANG()) > 0); + } +} + +# please define in subclass +#sub hup { +# my ($self) = @_; +# +# syslog('info' , "received signal HUP (restart)"); +#} + +# please overwrite in subclass +sub run { + my ($self) = @_; + + for (;;) { # forever + syslog('info' , "server is running"); + sleep(5); + } +} + +sub start { + my ($self, $debug) = @_; + + eval { &$server_run($self, $debug); }; + if (my $err = $@) { + &$log_err("start failed - $err"); + exit(-1); + } +} + +my $read_pid = sub { + my ($self) = @_; + + my $pid_str = PVE::Tools::file_read_firstline($self->{pidfile}); + + return 0 if !$pid_str; + + return 0 if $pid_str !~ m/^(\d+)$/; # untaint + + my $pid = int($1); + + return $pid; +}; + +sub running { + my ($self) = @_; + + my $pid = &$read_pid($self); + + if ($pid) { + my $res = PVE::ProcFSTools::check_process_running($pid) ? 1 : 0; + return wantarray ? ($res, $pid) : $res; + } + + return wantarray ? (0, 0) : 0; +} + +sub stop { + my ($self) = @_; + + my $pid = &$read_pid($self); + + return if !$pid; + + if (PVE::ProcFSTools::check_process_running($pid)) { + kill(15, $pid); # send TERM signal + # give some time + my $wait_time = $self->{stop_wait_time} || 5; + my $running = 1; + for (my $i = 0; $i < $wait_time; $i++) { + $running = PVE::ProcFSTools::check_process_running($pid); + last if !$running; + sleep (1); + } + + syslog('err', "server still running - send KILL") if $running; + + # to be sure + kill(9, $pid); + waitpid($pid, 0); + } + + if (-f $self->{pidfile}) { + eval { + # try to get the lock + &$lockpidfile($self); + &$server_cleanup($self); + }; + if (my $err = $@) { + &$log_err("cleanup failed - $err"); + } + } +} + +sub register_start_command { + my ($self, $description) = @_; + + my $class = ref($self); + + $class->register_method({ + name => 'start', + path => 'start', + method => 'POST', + description => $description || "Start the daemon.", + parameters => { + additionalProperties => 0, + properties => { + debug => { + description => "Debug mode - stay in foreground", + type => "boolean", + optional => 1, + default => 0, + }, + }, + }, + returns => { type => 'null' }, + + code => sub { + my ($param) = @_; + + $self->start($param->{debug}); + + return undef; + }}); +} + +my $reload_daemon = sub { + my ($self, $use_hup) = @_; + + if ($self->{env_restart_pve_daemon}) { + $self->start(); + } else { + my ($running, $pid) = $self->running(); + if (!$running) { + $self->start(); + } else { + if ($use_hup) { + syslog('info', "send HUP to $pid"); + kill 1, $pid; + } else { + $self->stop(); + $self->start(); + } + } + } +}; + +sub register_restart_command { + my ($self, $use_hup, $description) = @_; + + my $class = ref($self); + + $class->register_method({ + name => 'restart', + path => 'restart', + method => 'POST', + description => $description || "Restart the daemon (or start if not running).", + parameters => { + additionalProperties => 0, + properties => {}, + }, + returns => { type => 'null' }, + + code => sub { + my ($param) = @_; + + &$reload_daemon($self, $use_hup); + + return undef; + }}); +} + +sub register_reload_command { + my ($self, $description) = @_; + + my $class = ref($self); + + $class->register_method({ + name => 'reload', + path => 'reload', + method => 'POST', + description => $description || "Reload daemon configuration (or start if not running).", + parameters => { + additionalProperties => 0, + properties => {}, + }, + returns => { type => 'null' }, + + code => sub { + my ($param) = @_; + + &$reload_daemon($self, 1); + + return undef; + }}); +} + +sub register_stop_command { + my ($self, $description) = @_; + + my $class = ref($self); + + $class->register_method({ + name => 'stop', + path => 'stop', + method => 'POST', + description => $description || "Stop the daemon.", + parameters => { + additionalProperties => 0, + properties => {}, + }, + returns => { type => 'null' }, + + code => sub { + my ($param) = @_; + + $self->stop(); + + return undef; + }}); +} + +sub register_status_command { + my ($self, $description) = @_; + + my $class = ref($self); + + $class->register_method({ + name => 'status', + path => 'status', + method => 'GET', + description => "Get daemon status.", + parameters => { + additionalProperties => 0, + properties => {}, + }, + returns => { + type => 'string', + enum => ['stopped', 'running'], + }, + code => sub { + my ($param) = @_; + + return $self->running() ? 'running' : 'stopped'; + }}); +} + +# some useful helper + +sub create_reusable_socket { + my ($self, $port, $host) = @_; + + die "no port specifed" if !$port; + + my ($socket, $sockfd); + + if (defined($sockfd = $ENV{"PVE_DAEMON_SOCKET_$port"}) && + $self->{env_restart_pve_daemon}) { + + die "unable to parse socket fd '$sockfd'\n" + if $sockfd !~ m/^(\d+)$/; + $sockfd = $1; # untaint + + $socket = IO::Socket::INET->new; + $socket->fdopen($sockfd, 'w') || + die "cannot fdopen file descriptor '$sockfd' - $!\n"; + + } else { + + $socket = IO::Socket::INET->new( + LocalAddr => $host, + LocalPort => $port, + Listen => SOMAXCONN, + Proto => 'tcp', + ReuseAddr => 1) || + die "unable to create socket - $@\n"; + + # we often observe delays when using Nagle algorithm, + # so we disable that to maximize performance + setsockopt($socket, IPPROTO_TCP, TCP_NODELAY, 1); + + $ENV{"PVE_DAEMON_SOCKET_$port"} = $socket->fileno; + } + + # remove FD_CLOEXEC bit to reuse on exec + $socket->fcntl(Fcntl::F_SETFD(), 0); + + return $socket; +} + + +1; + diff --git a/src/PVE/Exception.pm b/src/PVE/Exception.pm new file mode 100644 index 0000000..fa6b73a --- /dev/null +++ b/src/PVE/Exception.pm @@ -0,0 +1,142 @@ +package PVE::Exception; + +# a way to add more information to exceptions (see man perlfunc (die)) +# use PVE::Exception qw(raise); +# raise ("my error message", code => 400, errors => { param1 => "err1", ...} ); + +use strict; +use warnings; +use vars qw(@ISA @EXPORT_OK); +require Exporter; +use Storable qw(dclone); +use HTTP::Status qw(:constants); + +@ISA = qw(Exporter); + +use overload '""' => sub {local $@; shift->stringify}; +use overload 'cmp' => sub { + my ($a, $b) = @_; + local $@; + return "$a" cmp "$b"; # compare as string +}; + +@EXPORT_OK = qw(raise raise_param_exc raise_perm_exc); + +sub new { + my ($class, $msg, %param) = @_; + + $class = ref($class) || $class; + + my $self = { + msg => $msg, + }; + + foreach my $p (keys %param) { + next if defined($self->{$p}); + my $v = $param{$p}; + $self->{$p} = ref($v) ? dclone($v) : $v; + } + + return bless $self; +} + +sub raise { + + my $exc = PVE::Exception->new(@_); + + my ($pkg, $filename, $line) = caller; + + $exc->{filename} = $filename; + $exc->{line} = $line; + + die $exc; +} + +sub raise_perm_exc { + my ($what) = @_; + + my $param = { code => HTTP_FORBIDDEN }; + + my $msg = "Permission check failed"; + + $msg .= " ($what)" if $what; + + my $exc = PVE::Exception->new("$msg\n", %$param); + + my ($pkg, $filename, $line) = caller; + + $exc->{filename} = $filename; + $exc->{line} = $line; + + die $exc; +} + +sub is_param_exc { + my ($self) = @_; + + return $self->{code} && $self->{code} eq HTTP_BAD_REQUEST; +} + +sub raise_param_exc { + my ($errors, $usage) = @_; + + my $param = { + code => HTTP_BAD_REQUEST, + errors => $errors, + }; + + $param->{usage} = $usage if $usage; + + my $exc = PVE::Exception->new("Parameter verification failed.\n", %$param); + + my ($pkg, $filename, $line) = caller; + + $exc->{filename} = $filename; + $exc->{line} = $line; + + die $exc; +} + +sub stringify { + my $self = shift; + + my $msg = $self->{code} ? "$self->{code} $self->{msg}" : $self->{msg}; + + if ($msg !~ m/\n$/) { + + if ($self->{filename} && $self->{line}) { + $msg .= " at $self->{filename} line $self->{line}"; + } + + $msg .= "\n"; + } + + if ($self->{errors}) { + foreach my $e (keys %{$self->{errors}}) { + $msg .= "$e: $self->{errors}->{$e}\n"; + } + } + + if ($self->{propagate}) { + foreach my $pi (@{$self->{propagate}}) { + $msg .= "\t...propagated at $pi->[0] line $pi->[1]\n"; + } + } + + if ($self->{usage}) { + $msg .= $self->{usage}; + $msg .= "\n" if $msg !~ m/\n$/; + } + + return $msg; +} + +sub PROPAGATE { + my ($self, $file, $line) = @_; + + push @{$self->{propagate}}, [$file, $line]; + + return $self; +} + +1; diff --git a/src/PVE/INotify.pm b/src/PVE/INotify.pm new file mode 100644 index 0000000..fbedc50 --- /dev/null +++ b/src/PVE/INotify.pm @@ -0,0 +1,1293 @@ +package PVE::INotify; + +# todo: maybe we do not need update_file() ? + +use strict; +use warnings; + +use POSIX; +use IO::File; +use IO::Dir; +use File::stat; +use File::Basename; +use Fcntl qw(:DEFAULT :flock); +use PVE::SafeSyslog; +use PVE::Exception qw(raise_param_exc); +use PVE::Tools; +use Storable qw(dclone); +use Linux::Inotify2; +use base 'Exporter'; +use JSON; + +our @EXPORT_OK = qw(read_file write_file register_file); + +my $ccache; +my $ccachemap; +my $ccacheregex; +my $inotify; +my $inotify_pid = 0; +my $versions; +my $shadowfiles = { + '/etc/network/interfaces' => '/etc/network/interfaces.new', +}; + +# to enable cached operation, you need to call 'inotify_init' +# inotify handles are a limited resource, so use with care (only +# enable the cache if you really need it) + +# Note: please close the inotify handle after you fork + +sub ccache_default_writer { + my ($filename, $data) = @_; + + die "undefined config writer for '$filename' :ERROR"; +} + +sub ccache_default_parser { + my ($filename, $srcfd) = @_; + + die "undefined config reader for '$filename' :ERROR"; +} + +sub ccache_compute_diff { + my ($filename, $shadow) = @_; + + my $diff = ''; + + open (TMP, "diff -b -N -u '$filename' '$shadow'|"); + + while (my $line = ) { + $diff .= $line; + } + + close (TMP); + + $diff = undef if !$diff; + + return $diff; +} + +sub ccache_info { + my ($filename) = @_; + + foreach my $uid (keys %$ccacheregex) { + my $ccinfo = $ccacheregex->{$uid}; + my $dir = $ccinfo->{dir}; + my $regex = $ccinfo->{regex}; + if ($filename =~ m|^$dir/+$regex$|) { + if (!$ccache->{$filename}) { + my $cp = {}; + while (my ($k, $v) = each %$ccinfo) { + $cp->{$k} = $v; + } + $ccache->{$filename} = $cp; + } + return ($ccache->{$filename}, $filename); + } + } + + $filename = $ccachemap->{$filename} if defined ($ccachemap->{$filename}); + + die "file '$filename' not added :ERROR" if !defined ($ccache->{$filename}); + + return ($ccache->{$filename}, $filename); +} + +sub write_file { + my ($fileid, $data, $full) = @_; + + my ($ccinfo, $filename) = ccache_info($fileid); + + my $writer = $ccinfo->{writer}; + + my $realname = $filename; + + my $shadow; + if ($shadow = $shadowfiles->{$filename}) { + $realname = $shadow; + } + + my $perm = $ccinfo->{perm} || 0644; + + my $tmpname = "$realname.tmp.$$"; + + my $res; + eval { + my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm); + die "unable to open file '$tmpname' - $!\n" if !$fh; + + $res = &$writer($filename, $fh, $data); + + die "closing file '$tmpname' failed - $!\n" unless close $fh; + }; + my $err = $@; + + $ccinfo->{version} = undef; + + if ($err) { + unlink $tmpname; + die $err; + } + + if (!rename($tmpname, $realname)) { + my $msg = "close (rename) atomic file '$filename' failed: $!\n"; + unlink $tmpname; + die $msg; + } + + my $diff; + if ($shadow && $full) { + $diff = ccache_compute_diff ($filename, $shadow); + } + + if ($full) { + return { data => $res, changes => $diff }; + } + + return $res; +} + +sub update_file { + my ($fileid, $data, @args) = @_; + + my ($ccinfo, $filename) = ccache_info($fileid); + + my $update = $ccinfo->{update}; + + die "unable to update/merge data" if !$update; + + my $lkfn = "$filename.lock"; + + my $timeout = 10; + + my $fd; + + my $code = sub { + + $fd = IO::File->new ($filename, "r"); + + my $new = &$update($filename, $fd, $data, @args); + + if (defined($new)) { + PVE::Tools::file_set_contents($filename, $new, $ccinfo->{perm}); + } else { + unlink $filename; + } + }; + + PVE::Tools::lock_file($lkfn, $timeout, $code); + my $err = $@; + + close($fd) if defined($fd); + + die $err if $err; + + return undef; +} + +sub discard_changes { + my ($fileid, $full) = @_; + + my ($ccinfo, $filename) = ccache_info($fileid); + + if (my $copy = $shadowfiles->{$filename}) { + unlink $copy; + } + + return read_file ($filename, $full); +} + +sub read_file { + my ($fileid, $full) = @_; + + my $parser; + + my ($ccinfo, $filename) = ccache_info($fileid); + + $parser = $ccinfo->{parser}; + + my $fd; + my $shadow; + + poll() if $inotify; # read new inotify events + + $versions->{$filename} = 0 if !defined ($versions->{$filename}); + + my $cver = $versions->{$filename}; + + if (my $copy = $shadowfiles->{$filename}) { + if ($fd = IO::File->new ($copy, "r")) { + $shadow = $copy; + } else { + $fd = IO::File->new ($filename, "r"); + } + } else { + $fd = IO::File->new ($filename, "r"); + } + + my $acp = $ccinfo->{always_call_parser}; + + if (!$fd) { + $ccinfo->{version} = undef; + $ccinfo->{data} = undef; + $ccinfo->{diff} = undef; + return undef if !$acp; + } + + my $noclone = $ccinfo->{noclone}; + + # file unchanged? + if (!$ccinfo->{nocache} && + $inotify && $versions->{$filename} && + defined ($ccinfo->{data}) && + defined ($ccinfo->{version}) && + ($ccinfo->{readonce} || + ($ccinfo->{version} == $versions->{$filename}))) { + + my $ret; + if (!$noclone && ref ($ccinfo->{data})) { + $ret->{data} = dclone ($ccinfo->{data}); + } else { + $ret->{data} = $ccinfo->{data}; + } + $ret->{changes} = $ccinfo->{diff}; + + return $full ? $ret : $ret->{data}; + } + + my $diff; + + if ($shadow) { + $diff = ccache_compute_diff ($filename, $shadow); + } + + my $res = &$parser($filename, $fd); + + if (!$ccinfo->{nocache}) { + $ccinfo->{version} = $cver; + } + + # we cache data with references, so we always need to + # dclone this data. Else the original data may get + # modified. + $ccinfo->{data} = $res; + + # also store diff + $ccinfo->{diff} = $diff; + + my $ret; + if (!$noclone && ref ($ccinfo->{data})) { + $ret->{data} = dclone ($ccinfo->{data}); + } else { + $ret->{data} = $ccinfo->{data}; + } + $ret->{changes} = $ccinfo->{diff}; + + return $full ? $ret : $ret->{data}; +} + +sub parse_ccache_options { + my ($ccinfo, %options) = @_; + + foreach my $opt (keys %options) { + my $v = $options{$opt}; + if ($opt eq 'readonce') { + $ccinfo->{$opt} = $v; + } elsif ($opt eq 'nocache') { + $ccinfo->{$opt} = $v; + } elsif ($opt eq 'shadow') { + $ccinfo->{$opt} = $v; + } elsif ($opt eq 'perm') { + $ccinfo->{$opt} = $v; + } elsif ($opt eq 'noclone') { + # noclone flag for large read-only data chunks like aplinfo + $ccinfo->{$opt} = $v; + } elsif ($opt eq 'always_call_parser') { + # when set, we call parser even when the file does not exists. + # this allows the parser to return some default + $ccinfo->{$opt} = $v; + } else { + die "internal error - unsupported option '$opt'"; + } + } +} + +sub register_file { + my ($id, $filename, $parser, $writer, $update, %options) = @_; + + die "can't register file '$filename' after inotify_init" if $inotify; + + die "file '$filename' already added :ERROR" if defined ($ccache->{$filename}); + die "ID '$id' already used :ERROR" if defined ($ccachemap->{$id}); + + my $ccinfo = {}; + + $ccinfo->{id} = $id; + $ccinfo->{parser} = $parser || \&ccache_default_parser; + $ccinfo->{writer} = $writer || \&ccache_default_writer; + $ccinfo->{update} = $update; + + parse_ccache_options($ccinfo, %options); + + if ($options{shadow}) { + $shadowfiles->{$filename} = $options{shadow}; + } + + $ccachemap->{$id} = $filename; + $ccache->{$filename} = $ccinfo; +} + +sub register_regex { + my ($dir, $regex, $parser, $writer, $update, %options) = @_; + + die "can't register regex after initify_init" if $inotify; + + my $uid = "$dir/$regex"; + die "regular expression '$uid' already added :ERROR" if defined ($ccacheregex->{$uid}); + + my $ccinfo = {}; + + $ccinfo->{dir} = $dir; + $ccinfo->{regex} = $regex; + $ccinfo->{parser} = $parser || \&ccache_default_parser; + $ccinfo->{writer} = $writer || \&ccache_default_writer; + $ccinfo->{update} = $update; + + parse_ccache_options($ccinfo, %options); + + $ccacheregex->{$uid} = $ccinfo; +} + +sub poll { + return if !$inotify; + + if ($inotify_pid != $$) { + syslog ('err', "got inotify poll request in wrong process - disabling inotify"); + $inotify = undef; + } else { + 1 while $inotify && $inotify->poll; + } +} + +sub flushcache { + foreach my $filename (keys %$ccache) { + $ccache->{$filename}->{version} = undef; + $ccache->{$filename}->{data} = undef; + $ccache->{$filename}->{diff} = undef; + } +} + +sub inotify_close { + $inotify = undef; +} + +sub inotify_init { + + die "only one inotify instance allowed" if $inotify; + + $inotify = Linux::Inotify2->new() + || die "Unable to create new inotify object: $!"; + + $inotify->blocking (0); + + $versions = {}; + + my $dirhash = {}; + foreach my $fn (keys %$ccache) { + my $dir = dirname ($fn); + my $base = basename ($fn); + + $dirhash->{$dir}->{$base} = $fn; + + if (my $sf = $shadowfiles->{$fn}) { + $base = basename ($sf); + $dir = dirname ($sf); + $dirhash->{$dir}->{$base} = $fn; # change version of original file! + } + } + + foreach my $uid (keys %$ccacheregex) { + my $ccinfo = $ccacheregex->{$uid}; + $dirhash->{$ccinfo->{dir}}->{_regex} = 1; + } + + $inotify_pid = $$; + + foreach my $dir (keys %$dirhash) { + + my $evlist = IN_MODIFY|IN_ATTRIB|IN_MOVED_FROM|IN_MOVED_TO|IN_DELETE|IN_CREATE; + $inotify->watch ($dir, $evlist, sub { + my $e = shift; + my $name = $e->name; + + if ($inotify_pid != $$) { + syslog ('err', "got inotify event in wrong process"); + } + + if ($e->IN_ISDIR || !$name) { + return; + } + + if ($e->IN_Q_OVERFLOW) { + syslog ('info', "got inotify overflow - flushing cache"); + flushcache(); + return; + } + + if ($e->IN_UNMOUNT) { + syslog ('err', "got 'unmount' event on '$name' - disabling inotify"); + $inotify = undef; + } + if ($e->IN_IGNORED) { + syslog ('err', "got 'ignored' event on '$name' - disabling inotify"); + $inotify = undef; + } + + if ($dirhash->{$dir}->{_regex}) { + foreach my $uid (keys %$ccacheregex) { + my $ccinfo = $ccacheregex->{$uid}; + next if $dir ne $ccinfo->{dir}; + my $regex = $ccinfo->{regex}; + if ($regex && ($name =~ m|^$regex$|)) { + + my $fn = "$dir/$name"; + $versions->{$fn}++; + #print "VERSION:$fn:$versions->{$fn}\n"; + } + } + } elsif (my $fn = $dirhash->{$dir}->{$name}) { + + $versions->{$fn}++; + #print "VERSION:$fn:$versions->{$fn}\n"; + } + }); + } + + foreach my $dir (keys %$dirhash) { + foreach my $name (keys %{$dirhash->{$dir}}) { + if ($name eq '_regex') { + foreach my $uid (keys %$ccacheregex) { + my $ccinfo = $ccacheregex->{$uid}; + next if $dir ne $ccinfo->{dir}; + my $re = $ccinfo->{regex}; + if (my $fd = IO::Dir->new ($dir)) { + while (defined(my $de = $fd->read)) { + if ($de =~ m/^$re$/) { + my $fn = "$dir/$de"; + $versions->{$fn}++; # init with version + #print "init:$fn:$versions->{$fn}\n"; + } + } + } + } + } else { + my $fn = $dirhash->{$dir}->{$name}; + $versions->{$fn}++; # init with version + #print "init:$fn:$versions->{$fn}\n"; + } + } + } +} + +my $cached_nodename; + +sub nodename { + + return $cached_nodename if $cached_nodename; + + my ($sysname, $nodename) = POSIX::uname(); + + $nodename =~ s/\..*$//; # strip domain part, if any + + die "unable to read node name\n" if !$nodename; + + $cached_nodename = $nodename; + + return $cached_nodename; +} + +sub read_etc_hostname { + my ($filename, $fd) = @_; + + my $hostname = <$fd>; + + chomp $hostname; + + $hostname =~ s/\..*$//; # strip domain part, if any + + return $hostname; +} + +sub write_etc_hostname { + my ($filename, $fh, $hostname) = @_; + + die "write failed: $!" unless print $fh "$hostname\n"; + + return $hostname; +} + +register_file('hostname', "/etc/hostname", + \&read_etc_hostname, + \&write_etc_hostname); + +sub read_etc_resolv_conf { + my ($filename, $fh) = @_; + + my $res = {}; + + my $nscount = 0; + while (my $line = <$fh>) { + chomp $line; + if ($line =~ m/^(search|domain)\s+(\S+)\s*/) { + $res->{search} = $2; + } elsif ($line =~ m/^nameserver\s+(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\s*/) { + $nscount++; + if ($nscount <= 3) { + $res->{"dns$nscount"} = $1; + } + } + } + + return $res; +} + +sub update_etc_resolv_conf { + my ($filename, $fh, $resolv, @args) = @_; + + my $data = ""; + + $data = "search $resolv->{search}\n" + if $resolv->{search}; + + my $written = {}; + foreach my $k ("dns1", "dns2", "dns3") { + my $ns = $resolv->{$k}; + if ($ns && $ns ne '0.0.0.0' && !$written->{$ns}) { + $written->{$ns} = 1; + $data .= "nameserver $ns\n"; + } + } + + while (my $line = <$fh>) { + next if $line =~ m/^(search|domain|nameserver)\s+/; + $data .= $line + } + + return $data; +} + +register_file('resolvconf', "/etc/resolv.conf", + \&read_etc_resolv_conf, undef, + \&update_etc_resolv_conf); + +sub read_etc_timezone { + my ($filename, $fd) = @_; + + my $timezone = <$fd>; + + chomp $timezone; + + return $timezone; +} + +sub write_etc_timezone { + my ($filename, $fh, $timezone) = @_; + + my $tzinfo = "/usr/share/zoneinfo/$timezone"; + + raise_param_exc({ 'timezone' => "No such timezone" }) + if (! -f $tzinfo); + + ($timezone) = $timezone =~ m/^(.*)$/; # untaint + + print $fh "$timezone\n"; + + unlink ("/etc/localtime"); + symlink ("/usr/share/zoneinfo/$timezone", "/etc/localtime"); + +} + +register_file('timezone', "/etc/timezone", + \&read_etc_timezone, + \&write_etc_timezone); + +sub read_active_workers { + my ($filename, $fh) = @_; + + return [] if !$fh; + + my $res = []; + while (defined (my $line = <$fh>)) { + if ($line =~ m/^(\S+)\s(0|1)(\s([0-9A-Za-z]{8})(\s(\s*\S.*))?)?$/) { + my $upid = $1; + my $saved = $2; + my $endtime = $4; + my $status = $6; + if ((my $task = PVE::Tools::upid_decode($upid, 1))) { + $task->{upid} = $upid; + $task->{saved} = $saved; + $task->{endtime} = hex($endtime) if $endtime; + $task->{status} = $status if $status; + push @$res, $task; + } + } else { + warn "unable to parse line: $line"; + } + } + + return $res; + +} + +sub write_active_workers { + my ($filename, $fh, $tasklist) = @_; + + my $raw = ''; + foreach my $task (@$tasklist) { + my $upid = $task->{upid}; + my $saved = $task->{saved} ? 1 : 0; + if ($task->{endtime}) { + if ($task->{status}) { + $raw .= sprintf("$upid $saved %08X $task->{status}\n", $task->{endtime}); + } else { + $raw .= sprintf("$upid $saved %08X\n", $task->{endtime}); + } + } else { + $raw .= "$upid $saved\n"; + } + } + + PVE::Tools::safe_print($filename, $fh, $raw) if $raw; +} + +register_file('active', "/var/log/pve/tasks/active", + \&read_active_workers, + \&write_active_workers); + + +my $bond_modes = { 'balance-rr' => 0, + 'active-backup' => 1, + 'balance-xor' => 2, + 'broadcast' => 3, + '802.3ad' => 4, + 'balance-tlb' => 5, + 'balance-alb' => 6, + }; + +my $ovs_bond_modes = { + 'active-backup' => 1, + 'balance-slb' => 1, + 'lacp-balance-slb' => 1, + 'lacp-balance-tcp' => 1, +}; + +#sub get_bond_modes { +# return $bond_modes; +#} + +my $parse_ovs_option = sub { + my ($data) = @_; + + my $opts = {}; + foreach my $kv (split (/\s+/, $data || '')) { + my ($k, $v) = split('=', $kv, 2); + $opts->{$k} = $v if $k && $v; + } + return $opts; +}; + +my $set_ovs_option = sub { + my ($d, %params) = @_; + + my $opts = &$parse_ovs_option($d->{ovs_options}); + + foreach my $k (keys %params) { + my $v = $params{$k}; + if ($v) { + $opts->{$k} = $v; + } else { + delete $opts->{$k}; + } + } + + my $res = []; + foreach my $k (keys %$opts) { + push @$res, "$k=$opts->{$k}"; + } + + if (my $new = join(' ', @$res)) { + $d->{ovs_options} = $new; + return $d->{ovs_options}; + } else { + delete $d->{ovs_options}; + return undef; + } +}; + +my $extract_ovs_option = sub { + my ($d, $name) = @_; + + my $opts = &$parse_ovs_option($d->{ovs_options}); + + my $v = delete $opts->{$name}; + + my $res = []; + foreach my $k (keys %$opts) { + push @$res, "$k=$opts->{$k}"; + } + + if (my $new = join(' ', @$res)) { + $d->{ovs_options} = $new; + } else { + delete $d->{ovs_options}; + } + + return $v; +}; + +sub read_etc_network_interfaces { + my ($filename, $fh) = @_; + + my $ifaces = {}; + + my $line; + + if (my $fd2 = IO::File->new("/proc/net/dev", "r")) { + while (defined ($line = <$fd2>)) { + if ($line =~ m/^\s*(eth\d+):.*/) { + $ifaces->{$1}->{exists} = 1; + } + } + close($fd2); + } + + # we try to keep order inside the file + my $priority = 2; # 1 is reserved for lo + + my $gateway = 0; + + while (defined ($line = <$fh>)) { + chomp ($line); + next if $line =~ m/^#/; + + if ($line =~ m/^auto\s+(.*)$/) { + my @aa = split (/\s+/, $1); + + foreach my $a (@aa) { + $ifaces->{$a}->{autostart} = 1; + } + + } elsif ($line =~ m/^iface\s+(\S+)\s+inet\s+(\S+)\s*$/) { + my $i = $1; + $ifaces->{$i}->{method} = $2; + $ifaces->{$i}->{priority} = $priority++; + + my $d = $ifaces->{$i}; + while (defined ($line = <$fh>)) { + if ($line =~ m/^\s*#(.*)\s*$/) { + # NOTE: we use 'comments' instead of 'comment' to + # avoid automatic utf8 conversion + $d->{comments} = '' if !$d->{comments}; + $d->{comments} .= "$1\n"; + } elsif ($line =~ m/^\s+((\S+)\s+(.+))$/) { + my $option = $1; + my ($id, $value) = ($2, $3); + if (($id eq 'address') || ($id eq 'netmask') || ($id eq 'broadcast')) { + $d->{$id} = $value; + } elsif ($id eq 'gateway') { + $d->{$id} = $value; + $gateway = 1; + } elsif ($id eq 'ovs_type' || $id eq 'ovs_options'|| $id eq 'ovs_bridge' || + $id eq 'ovs_bonds' || $id eq 'ovs_ports') { + $d->{$id} = $value; + } elsif ($id eq 'slaves' || $id eq 'bridge_ports') { + my $devs = {}; + foreach my $p (split (/\s+/, $value)) { + next if $p eq 'none'; + $devs->{$p} = 1; + } + my $str = join (' ', sort keys %{$devs}); + $d->{$id} = $str || ''; + } elsif ($id eq 'bridge_stp') { + if ($value =~ m/^\s*(on|yes)\s*$/i) { + $d->{$id} = 'on'; + } else { + $d->{$id} = 'off'; + } + } elsif ($id eq 'bridge_fd') { + $d->{$id} = $value; + } elsif ($id eq 'bond_miimon') { + $d->{$id} = $value; + } elsif ($id eq 'bond_xmit_hash_policy') { + $d->{$id} = $value; + } elsif ($id eq 'bond_mode') { + # always use names + foreach my $bm (keys %$bond_modes) { + my $id = $bond_modes->{$bm}; + if ($id eq $value) { + $value = $bm; + last; + } + } + $d->{$id} = $value; + } else { + push @{$d->{options}}, $option; + } + } else { + last; + } + } + } + } + + + + if (!$ifaces->{lo}) { + $ifaces->{lo}->{priority} = 1; + $ifaces->{lo}->{method} = 'loopback'; + $ifaces->{lo}->{type} = 'loopback'; + $ifaces->{lo}->{autostart} = 1; + } + + foreach my $iface (keys %$ifaces) { + my $d = $ifaces->{$iface}; + if ($iface =~ m/^bond\d+$/) { + if (!$d->{ovs_type}) { + $d->{type} = 'bond'; + } elsif ($d->{ovs_type} eq 'OVSBond') { + $d->{type} = $d->{ovs_type}; + # translate: ovs_options => bond_mode + $d->{'bond_mode'} = &$extract_ovs_option($d, 'bond_mode'); + my $lacp = &$extract_ovs_option($d, 'lacp'); + if ($lacp && $lacp eq 'active') { + if ($d->{'bond_mode'} eq 'balance-slb') { + $d->{'bond_mode'} = 'lacp-balance-slb'; + } + } + # Note: balance-tcp needs lacp + if ($d->{'bond_mode'} eq 'balance-tcp') { + $d->{'bond_mode'} = 'lacp-balance-tcp'; + } + my $tag = &$extract_ovs_option($d, 'tag'); + $d->{ovs_tag} = $tag if defined($tag); + } else { + $d->{type} = 'unknown'; + } + } elsif ($iface =~ m/^vmbr\d+$/) { + if (!$d->{ovs_type}) { + $d->{type} = 'bridge'; + + if (!defined ($d->{bridge_fd})) { + $d->{bridge_fd} = 0; + } + if (!defined ($d->{bridge_stp})) { + $d->{bridge_stp} = 'off'; + } + } elsif ($d->{ovs_type} eq 'OVSBridge') { + $d->{type} = $d->{ovs_type}; + } else { + $d->{type} = 'unknown'; + } + } elsif ($iface =~ m/^(\S+):\d+$/) { + $d->{type} = 'alias'; + if (defined ($ifaces->{$1})) { + $d->{exists} = $ifaces->{$1}->{exists}; + } else { + $ifaces->{$1}->{exists} = 0; + $d->{exists} = 0; + } + } elsif ($iface =~ m/^eth\d+$/) { + if (!$d->{ovs_type}) { + $d->{type} = 'eth'; + } elsif ($d->{ovs_type} eq 'OVSPort') { + $d->{type} = $d->{ovs_type}; + my $tag = &$extract_ovs_option($d, 'tag'); + $d->{ovs_tag} = $tag if defined($tag); + } else { + $d->{type} = 'unknown'; + } + } elsif ($iface =~ m/^lo$/) { + $d->{type} = 'loopback'; + } else { + if (!$d->{ovs_type}) { + $d->{type} = 'unknown'; + } elsif ($d->{ovs_type} eq 'OVSIntPort') { + $d->{type} = $d->{ovs_type}; + my $tag = &$extract_ovs_option($d, 'tag'); + $d->{ovs_tag} = $tag if defined($tag); + } + } + + $d->{method} = 'manual' if !$d->{method}; + } + + if (my $fd2 = IO::File->new("/proc/net/if_inet6", "r")) { + while (defined ($line = <$fd2>)) { + if ($line =~ m/^[a-f0-9]{32}\s+[a-f0-9]{2}\s+[a-f0-9]{2}\s+[a-f0-9]{2}\s+[a-f0-9]{2}\s+(\S+)$/) { + $ifaces->{$1}->{active} = 1 if defined($ifaces->{$1}); + } + } + close ($fd2); + } + + return $ifaces; +} + +sub __interface_to_string { + my ($iface, $d) = @_; + + return '' if !($d && $d->{method}); + + my $raw = ''; + + $raw .= "iface $iface inet $d->{method}\n"; + $raw .= "\taddress $d->{address}\n" if $d->{address}; + $raw .= "\tnetmask $d->{netmask}\n" if $d->{netmask}; + $raw .= "\tgateway $d->{gateway}\n" if $d->{gateway}; + $raw .= "\tbroadcast $d->{broadcast}\n" if $d->{broadcast}; + + my $done = { type => 1, priority => 1, method => 1, active => 1, exists => 1, + comments => 1, autostart => 1, options => 1, + address => 1, netmask => 1, gateway => 1, broadcast => 1 }; + + if ($d->{type} eq 'bridge') { + + my $ports = $d->{bridge_ports} || 'none'; + $raw .= "\tbridge_ports $ports\n"; + $done->{bridge_ports} = 1; + + my $v = defined($d->{bridge_stp}) ? $d->{bridge_stp} : 'off'; + $raw .= "\tbridge_stp $v\n"; + $done->{bridge_stp} = 1; + + $v = defined($d->{bridge_fd}) ? $d->{bridge_fd} : 0; + $raw .= "\tbridge_fd $v\n"; + $done->{bridge_fd} = 1; + + } elsif ($d->{type} eq 'bond') { + + my $slaves = $d->{slaves} || 'none'; + $raw .= "\tslaves $slaves\n"; + $done->{slaves} = 1; + + my $v = defined ($d->{'bond_miimon'}) ? $d->{'bond_miimon'} : 100; + $raw .= "\tbond_miimon $v\n"; + $done->{'bond_miimon'} = 1; + + $v = defined ($d->{'bond_mode'}) ? $d->{'bond_mode'} : 'balance-rr'; + $raw .= "\tbond_mode $v\n"; + $done->{'bond_mode'} = 1; + + if ($d->{'bond_mode'} && $d->{'bond_xmit_hash_policy'} && + ($d->{'bond_mode'} eq 'balance-xor' || $d->{'bond_mode'} eq '802.3ad')) { + $raw .= "\tbond_xmit_hash_policy $d->{'bond_xmit_hash_policy'}\n"; + } + $done->{'bond_xmit_hash_policy'} = 1; + + } elsif ($d->{type} eq 'OVSBridge') { + + $raw .= "\tovs_type $d->{type}\n"; + $done->{ovs_type} = 1; + + $raw .= "\tovs_ports $d->{ovs_ports}\n" if $d->{ovs_ports}; + $done->{ovs_ports} = 1; + + } elsif ($d->{type} eq 'OVSPort' || $d->{type} eq 'OVSIntPort' || + $d->{type} eq 'OVSBond') { + + $d->{autostart} = 0; # started by the bridge + + if (defined($d->{ovs_tag})) { + &$set_ovs_option($d, tag => $d->{ovs_tag}); + } + $done->{ovs_tag} = 1; + + if ($d->{type} eq 'OVSBond') { + + $d->{bond_mode} = 'active-backup' if !$d->{bond_mode}; + + $ovs_bond_modes->{$d->{bond_mode}} || + die "OVS does not support bond mode '$d->{bond_mode}\n"; + + if ($d->{bond_mode} eq 'lacp-balance-slb') { + &$set_ovs_option($d, lacp => 'active'); + &$set_ovs_option($d, bond_mode => 'balance-slb'); + } elsif ($d->{bond_mode} eq 'lacp-balance-tcp') { + &$set_ovs_option($d, lacp => 'active'); + &$set_ovs_option($d, bond_mode => 'balance-tcp'); + } else { + &$set_ovs_option($d, lacp => undef); + &$set_ovs_option($d, bond_mode => $d->{bond_mode}); + } + $done->{bond_mode} = 1; + + $raw .= "\tovs_bonds $d->{ovs_bonds}\n" if $d->{ovs_bonds}; + $done->{ovs_bonds} = 1; + } + + if ($d->{ovs_bridge}) { + $raw = "allow-$d->{ovs_bridge} $iface\n$raw"; + } + + $raw .= "\tovs_type $d->{type}\n"; + $done->{ovs_type} = 1; + + if ($d->{ovs_bridge}) { + $raw .= "\tovs_bridge $d->{ovs_bridge}\n"; + $done->{ovs_bridge} = 1; + } + # fixme: use Data::Dumper; print Dumper($d); + } + + # print other settings + foreach my $k (keys %$d) { + next if $done->{$k}; + next if !$d->{$k}; + $raw .= "\t$k $d->{$k}\n"; + } + + foreach my $option (@{$d->{options}}) { + $raw .= "\t$option\n"; + } + + # add comments + my $comments = $d->{comments} || ''; + foreach my $cl (split(/\n/, $comments)) { + $raw .= "#$cl\n"; + } + + if ($d->{autostart}) { + $raw = "auto $iface\n$raw"; + } + + $raw .= "\n"; + + return $raw; +} + +sub write_etc_network_interfaces { + my ($filename, $fh, $ifaces) = @_; + + my $used_ports = {}; + + foreach my $iface (keys %$ifaces) { + my $d = $ifaces->{$iface}; + + my $ports = ''; + foreach my $k (qw(bridge_ports ovs_ports slaves ovs_bonds)) { + $ports .= " $d->{$k}" if $d->{$k}; + } + + foreach my $p (PVE::Tools::split_list($ports)) { + die "port '$p' is already used on interface '$used_ports->{$p}'\n" + if $used_ports->{$p} && $used_ports->{$p} ne $iface; + $used_ports->{$p} = $iface; + } + } + + # delete unused OVS ports + foreach my $iface (keys %$ifaces) { + my $d = $ifaces->{$iface}; + if ($d->{type} eq 'OVSPort' || $d->{type} eq 'OVSIntPort' || + $d->{type} eq 'OVSBond') { + my $brname = $used_ports->{$iface}; + if (!$brname || !$ifaces->{$brname}) { + delete $ifaces->{$iface}; + next; + } + my $bd = $ifaces->{$brname}; + if ($bd->{type} ne 'OVSBridge') { + delete $ifaces->{$iface}; + next; + } + } + } + + # create OVS bridge ports + foreach my $iface (keys %$ifaces) { + my $d = $ifaces->{$iface}; + if ($d->{type} eq 'OVSBridge' && $d->{ovs_ports}) { + foreach my $p (split (/\s+/, $d->{ovs_ports})) { + my $n = $ifaces->{$p}; + die "OVS bridge '$iface' - unable to find port '$p'\n" + if !$n; + if ($n->{type} eq 'eth') { + $n->{type} = 'OVSPort'; + $n->{ovs_bridge} = $iface; + } elsif ($n->{type} eq 'OVSBond' || $n->{type} eq 'OVSPort' || + $n->{type} eq 'OVSIntPort') { + $n->{ovs_bridge} = $iface; + } else { + die "interface '$p' is not defined as OVS port/bond\n"; + } + } + } + } + + # check OVS bond ports + foreach my $iface (keys %$ifaces) { + my $d = $ifaces->{$iface}; + if ($d->{type} eq 'OVSBond' && $d->{ovs_bonds}) { + foreach my $p (split (/\s+/, $d->{ovs_bonds})) { + my $n = $ifaces->{$p}; + die "OVS bond '$iface' - unable to find slave '$p'\n" + if !$n; + die "OVS bond '$iface' - wrong interface type on slave '$p' " . + "('$n->{type}' != 'eth')\n" if $n->{type} ne 'eth'; + } + } + } + + my $raw = "# network interface settings\n"; + + my $printed = {}; + + my $if_type_hash = { + unknown => 0, + loopback => 10, + eth => 20, + bond => 30, + bridge => 40, + }; + + my $lookup_type_prio = sub { + my $iface = shift; + + my $alias = 0; + if ($iface =~ m/^(\S+):\d+$/) { + $iface = $1; + $alias = 1; + } + + my $pri; + if ($iface eq 'lo') { + $pri = $if_type_hash->{loopback}; + } elsif ($iface =~ m/^eth\d+$/) { + $pri = $if_type_hash->{eth} + $alias; + } elsif ($iface =~ m/^bond\d+$/) { + $pri = $if_type_hash->{bond} + $alias; + } elsif ($iface =~ m/^vmbr\d+$/) { + $pri = $if_type_hash->{bridge} + $alias; + } + + return $pri || ($if_type_hash->{unknown} + $alias); + }; + + foreach my $iface (sort { + my $ref1 = $ifaces->{$a}; + my $ref2 = $ifaces->{$b}; + my $p1 = &$lookup_type_prio($a); + my $p2 = &$lookup_type_prio($b); + + return $p1 <=> $p2 if $p1 != $p2; + + $p1 = $ref1->{priority} || 100000; + $p2 = $ref2->{priority} || 100000; + + return $p1 <=> $p2 if $p1 != $p2; + + return $a cmp $b; + } keys %$ifaces) { + + my $d = $ifaces->{$iface}; + + next if $printed->{$iface}; + + $printed->{$iface} = 1; + $raw .= __interface_to_string($iface, $d); + } + + PVE::Tools::safe_print($filename, $fh, $raw); +} + +register_file('interfaces', "/etc/network/interfaces", + \&read_etc_network_interfaces, + \&write_etc_network_interfaces); + + +sub read_iscsi_initiatorname { + my ($filename, $fd) = @_; + + while (defined(my $line = <$fd>)) { + if ($line =~ m/^InitiatorName=(\S+)$/) { + return $1; + } + } + + return 'undefined'; +} + +register_file('initiatorname', "/etc/iscsi/initiatorname.iscsi", + \&read_iscsi_initiatorname); + +sub read_apt_auth { + my ($filename, $fd) = @_; + + local $/; + + my $raw = defined($fd) ? <$fd> : ''; + + $raw =~ s/^\s+//; + + + my @tokens = split(/\s+/, $raw); + + my $data = {}; + + my $machine; + while (defined(my $tok = shift @tokens)) { + + $machine = shift @tokens if $tok eq 'machine'; + next if !$machine; + $data->{$machine} = {} if !$data->{$machine}; + + $data->{$machine}->{login} = shift @tokens if $tok eq 'login'; + $data->{$machine}->{password} = shift @tokens if $tok eq 'password'; + }; + + return $data; +} + +my $format_apt_auth_data = sub { + my $data = shift; + + my $raw = ''; + + foreach my $machine (sort keys %$data) { + my $d = $data->{$machine}; + $raw .= "machine $machine\n"; + $raw .= " login $d->{login}\n" if $d->{login}; + $raw .= " password $d->{password}\n" if $d->{password}; + $raw .= "\n"; + } + + return $raw; +}; + +sub write_apt_auth { + my ($filename, $fh, $data) = @_; + + my $raw = &$format_apt_auth_data($data); + + die "write failed: $!" unless print $fh "$raw\n"; + + return $data; +} + +sub update_apt_auth { + my ($filename, $fh, $data) = @_; + + my $orig = read_apt_auth($filename, $fh); + + foreach my $machine (keys %$data) { + $orig->{$machine} = $data->{$machine}; + } + + return &$format_apt_auth_data($orig); +} + +register_file('apt-auth', "/etc/apt/auth.conf", + \&read_apt_auth, \&write_apt_auth, + \&update_apt_auth, perm => 0640); + +1; diff --git a/src/PVE/JSONSchema.pm b/src/PVE/JSONSchema.pm new file mode 100644 index 0000000..3e0fd52 --- /dev/null +++ b/src/PVE/JSONSchema.pm @@ -0,0 +1,1126 @@ +package PVE::JSONSchema; + +use strict; +use warnings; +use Storable; # for dclone +use Getopt::Long; +use Devel::Cycle -quiet; # todo: remove? +use PVE::Tools qw(split_list $IPV6RE $IPV4RE); +use PVE::Exception qw(raise); +use HTTP::Status qw(:constants); +use Net::IP qw(:PROC); + +use base 'Exporter'; + +our @EXPORT_OK = qw( +register_standard_option +get_standard_option +); + +# Note: This class implements something similar to JSON schema, but it is not 100% complete. +# see: http://tools.ietf.org/html/draft-zyp-json-schema-02 +# see: http://json-schema.org/ + +# the code is similar to the javascript parser from http://code.google.com/p/jsonschema/ + +my $standard_options = {}; +sub register_standard_option { + my ($name, $schema) = @_; + + die "standard option '$name' already registered\n" + if $standard_options->{$name}; + + $standard_options->{$name} = $schema; +} + +sub get_standard_option { + my ($name, $base) = @_; + + my $std = $standard_options->{$name}; + die "no such standard option\n" if !$std; + + my $res = $base || {}; + + foreach my $opt (keys %$std) { + next if $res->{$opt}; + $res->{$opt} = $std->{$opt}; + } + + return $res; +}; + +register_standard_option('pve-vmid', { + description => "The (unique) ID of the VM.", + type => 'integer', format => 'pve-vmid', + minimum => 1 +}); + +register_standard_option('pve-node', { + description => "The cluster node name.", + type => 'string', format => 'pve-node', +}); + +register_standard_option('pve-node-list', { + description => "List of cluster node names.", + type => 'string', format => 'pve-node-list', +}); + +register_standard_option('pve-iface', { + description => "Network interface name.", + type => 'string', format => 'pve-iface', + minLength => 2, maxLength => 20, +}); + +PVE::JSONSchema::register_standard_option('pve-storage-id', { + description => "The storage identifier.", + type => 'string', format => 'pve-storage-id', +}); + +PVE::JSONSchema::register_standard_option('pve-config-digest', { + description => 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.', + type => 'string', + optional => 1, + maxLength => 40, # sha1 hex digest lenght is 40 +}); + +my $format_list = {}; + +sub register_format { + my ($format, $code) = @_; + + die "JSON schema format '$format' already registered\n" + if $format_list->{$format}; + + $format_list->{$format} = $code; +} + +# register some common type for pve + +register_format('string', sub {}); # allow format => 'string-list' + +register_format('pve-configid', \&pve_verify_configid); +sub pve_verify_configid { + my ($id, $noerr) = @_; + + if ($id !~ m/^[a-z][a-z0-9_]+$/i) { + return undef if $noerr; + die "invalid configuration ID '$id'\n"; + } + return $id; +} + +PVE::JSONSchema::register_format('pve-storage-id', \&parse_storage_id); +sub parse_storage_id { + my ($storeid, $noerr) = @_; + + if ($storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) { + return undef if $noerr; + die "storage ID '$storeid' contains illegal characters\n"; + } + return $storeid; +} + + +register_format('pve-vmid', \&pve_verify_vmid); +sub pve_verify_vmid { + my ($vmid, $noerr) = @_; + + if ($vmid !~ m/^[1-9][0-9]+$/) { + return undef if $noerr; + die "value does not look like a valid VM ID\n"; + } + return $vmid; +} + +register_format('pve-node', \&pve_verify_node_name); +sub pve_verify_node_name { + my ($node, $noerr) = @_; + + if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) { + return undef if $noerr; + die "value does not look like a valid node name\n"; + } + return $node; +} + +register_format('ipv4', \&pve_verify_ipv4); +sub pve_verify_ipv4 { + my ($ipv4, $noerr) = @_; + + if (!Net::IP::ip_is_ipv4($ipv4)) { + return undef if $noerr; + die "value does not look like a valid IP address\n"; + } + return $ipv4; +} + +my $ipv4_mask_hash = { + '128.0.0.0' => 1, + '192.0.0.0' => 2, + '224.0.0.0' => 3, + '240.0.0.0' => 4, + '248.0.0.0' => 5, + '252.0.0.0' => 6, + '254.0.0.0' => 7, + '255.0.0.0' => 8, + '255.128.0.0' => 9, + '255.192.0.0' => 10, + '255.224.0.0' => 11, + '255.240.0.0' => 12, + '255.248.0.0' => 13, + '255.252.0.0' => 14, + '255.254.0.0' => 15, + '255.255.0.0' => 16, + '255.255.128.0' => 17, + '255.255.192.0' => 18, + '255.255.224.0' => 19, + '255.255.240.0' => 20, + '255.255.248.0' => 21, + '255.255.252.0' => 22, + '255.255.254.0' => 23, + '255.255.255.0' => 24, + '255.255.255.128' => 25, + '255.255.255.192' => 26, + '255.255.255.224' => 27, + '255.255.255.240' => 28, + '255.255.255.248' => 29, + '255.255.255.252' => 30 +}; + +register_format('ipv4mask', \&pve_verify_ipv4mask); +sub pve_verify_ipv4mask { + my ($mask, $noerr) = @_; + + if (!defined($ipv4_mask_hash->{$mask})) { + return undef if $noerr; + die "value does not look like a valid IP netmask\n"; + } + return $mask; +} + +register_format('CIDR', \&pve_verify_cidr); +sub pve_verify_cidr { + my ($cidr, $noerr) = @_; + + if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 < 32)) { + return $cidr; + } elsif ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 120)) { + return $cidr; + } + + return undef if $noerr; + die "value does not look like a valid CIDR network\n"; +} + +register_format('email', \&pve_verify_email); +sub pve_verify_email { + my ($email, $noerr) = @_; + + # we use same regex as extjs Ext.form.VTypes.email + if ($email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,6}$/) { + return undef if $noerr; + die "value does not look like a valid email address\n"; + } + return $email; +} + +register_format('dns-name', \&pve_verify_dns_name); +sub pve_verify_dns_name { + my ($name, $noerr) = @_; + + my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)"; + + if ($name !~ /^(${namere}\.)*${namere}$/) { + return undef if $noerr; + die "value does not look like a valid DNS name\n"; + } + return $name; +} + +# network interface name +register_format('pve-iface', \&pve_verify_iface); +sub pve_verify_iface { + my ($id, $noerr) = @_; + + if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) { + return undef if $noerr; + die "invalid network interface name '$id'\n"; + } + return $id; +} + +register_standard_option('spice-proxy', { + description => "SPICE proxy server. This can be used by the client to specify the proxy server. All nodes in a cluster runs 'spiceproxy', so it is up to the client to choose one. By default, we return the node where the VM is currently running. As resonable setting is to use same node you use to connect to the API (This is window.location.hostname for the JS GUI).", + type => 'string', format => 'dns-name', +}); + +register_standard_option('remote-viewer-config', { + description => "Returned values can be directly passed to the 'remote-viewer' application.", + additionalProperties => 1, + properties => { + type => { type => 'string' }, + password => { type => 'string' }, + proxy => { type => 'string' }, + host => { type => 'string' }, + 'tls-port' => { type => 'integer' }, + }, +}); + +sub check_format { + my ($format, $value) = @_; + + return if $format eq 'regex'; + + if ($format =~ m/^(.*)-a?list$/) { + + my $code = $format_list->{$1}; + + die "undefined format '$format'\n" if !$code; + + # Note: we allow empty lists + foreach my $v (split_list($value)) { + &$code($v); + } + + } elsif ($format =~ m/^(.*)-opt$/) { + + my $code = $format_list->{$1}; + + die "undefined format '$format'\n" if !$code; + + return if !$value; # allow empty string + + &$code($value); + + } else { + + my $code = $format_list->{$format}; + + die "undefined format '$format'\n" if !$code; + + &$code($value); + } +} + +sub add_error { + my ($errors, $path, $msg) = @_; + + $path = '_root' if !$path; + + if ($errors->{$path}) { + $errors->{$path} = join ('\n', $errors->{$path}, $msg); + } else { + $errors->{$path} = $msg; + } +} + +sub is_number { + my $value = shift; + + # see 'man perlretut' + return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/; +} + +sub is_integer { + my $value = shift; + + return $value =~ m/^[+-]?\d+$/; +} + +sub check_type { + my ($path, $type, $value, $errors) = @_; + + return 1 if !$type; + + if (!defined($value)) { + return 1 if $type eq 'null'; + die "internal error" + } + + if (my $tt = ref($type)) { + if ($tt eq 'ARRAY') { + foreach my $t (@$type) { + my $tmperr = {}; + check_type($path, $t, $value, $tmperr); + return 1 if !scalar(%$tmperr); + } + my $ttext = join ('|', @$type); + add_error($errors, $path, "type check ('$ttext') failed"); + return undef; + } elsif ($tt eq 'HASH') { + my $tmperr = {}; + check_prop($value, $type, $path, $tmperr); + return 1 if !scalar(%$tmperr); + add_error($errors, $path, "type check failed"); + return undef; + } else { + die "internal error - got reference type '$tt'"; + } + + } else { + + return 1 if $type eq 'any'; + + if ($type eq 'null') { + if (defined($value)) { + add_error($errors, $path, "type check ('$type') failed - value is not null"); + return undef; + } + return 1; + } + + my $vt = ref($value); + + if ($type eq 'array') { + if (!$vt || $vt ne 'ARRAY') { + add_error($errors, $path, "type check ('$type') failed"); + return undef; + } + return 1; + } elsif ($type eq 'object') { + if (!$vt || $vt ne 'HASH') { + add_error($errors, $path, "type check ('$type') failed"); + return undef; + } + return 1; + } elsif ($type eq 'coderef') { + if (!$vt || $vt ne 'CODE') { + add_error($errors, $path, "type check ('$type') failed"); + return undef; + } + return 1; + } else { + if ($vt) { + add_error($errors, $path, "type check ('$type') failed - got $vt"); + return undef; + } else { + if ($type eq 'string') { + return 1; # nothing to check ? + } elsif ($type eq 'boolean') { + #if ($value =~ m/^(1|true|yes|on)$/i) { + if ($value eq '1') { + return 1; + #} elsif ($value =~ m/^(0|false|no|off)$/i) { + } elsif ($value eq '0') { + return 0; + } else { + add_error($errors, $path, "type check ('$type') failed - got '$value'"); + return undef; + } + } elsif ($type eq 'integer') { + if (!is_integer($value)) { + add_error($errors, $path, "type check ('$type') failed - got '$value'"); + return undef; + } + return 1; + } elsif ($type eq 'number') { + if (!is_number($value)) { + add_error($errors, $path, "type check ('$type') failed - got '$value'"); + return undef; + } + return 1; + } else { + return 1; # no need to verify unknown types + } + } + } + } + + return undef; +} + +sub check_object { + my ($path, $schema, $value, $additional_properties, $errors) = @_; + + # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema); + + my $st = ref($schema); + if (!$st || $st ne 'HASH') { + add_error($errors, $path, "Invalid schema definition."); + return; + } + + my $vt = ref($value); + if (!$vt || $vt ne 'HASH') { + add_error($errors, $path, "an object is required"); + return; + } + + foreach my $k (keys %$schema) { + check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors); + } + + foreach my $k (keys %$value) { + + my $newpath = $path ? "$path.$k" : $k; + + if (my $subschema = $schema->{$k}) { + if (my $requires = $subschema->{requires}) { + if (ref($requires)) { + #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ; + check_prop($value, $requires, $path, $errors); + } elsif (!defined($value->{$requires})) { + add_error($errors, $path ? "$path.$requires" : $requires, + "missing property - '$newpath' requiers this property"); + } + } + + next; # value is already checked above + } + + if (defined ($additional_properties) && !$additional_properties) { + add_error($errors, $newpath, "property is not defined in schema " . + "and the schema does not allow additional properties"); + next; + } + check_prop($value->{$k}, $additional_properties, $newpath, $errors) + if ref($additional_properties); + } +} + +sub check_prop { + my ($value, $schema, $path, $errors) = @_; + + die "internal error - no schema" if !$schema; + die "internal error" if !$errors; + + #print "check_prop $path\n" if $value; + + my $st = ref($schema); + if (!$st || $st ne 'HASH') { + add_error($errors, $path, "Invalid schema definition."); + return; + } + + # if it extends another schema, it must pass that schema as well + if($schema->{extends}) { + check_prop($value, $schema->{extends}, $path, $errors); + } + + if (!defined ($value)) { + return if $schema->{type} && $schema->{type} eq 'null'; + if (!$schema->{optional}) { + add_error($errors, $path, "property is missing and it is not optional"); + } + return; + } + + return if !check_type($path, $schema->{type}, $value, $errors); + + if ($schema->{disallow}) { + my $tmperr = {}; + if (check_type($path, $schema->{disallow}, $value, $tmperr)) { + add_error($errors, $path, "disallowed value was matched"); + return; + } + } + + if (my $vt = ref($value)) { + + if ($vt eq 'ARRAY') { + if ($schema->{items}) { + my $it = ref($schema->{items}); + if ($it && $it eq 'ARRAY') { + #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value); + die "not implemented"; + } else { + my $ind = 0; + foreach my $el (@$value) { + check_prop($el, $schema->{items}, "${path}[$ind]", $errors); + $ind++; + } + } + } + return; + } elsif ($schema->{properties} || $schema->{additionalProperties}) { + check_object($path, defined($schema->{properties}) ? $schema->{properties} : {}, + $value, $schema->{additionalProperties}, $errors); + return; + } + + } else { + + if (my $format = $schema->{format}) { + eval { check_format($format, $value); }; + if ($@) { + add_error($errors, $path, "invalid format - $@"); + return; + } + } + + if (my $pattern = $schema->{pattern}) { + if ($value !~ m/^$pattern$/) { + add_error($errors, $path, "value does not match the regex pattern"); + return; + } + } + + if (defined (my $max = $schema->{maxLength})) { + if (length($value) > $max) { + add_error($errors, $path, "value may only be $max characters long"); + return; + } + } + + if (defined (my $min = $schema->{minLength})) { + if (length($value) < $min) { + add_error($errors, $path, "value must be at least $min characters long"); + return; + } + } + + if (is_number($value)) { + if (defined (my $max = $schema->{maximum})) { + if ($value > $max) { + add_error($errors, $path, "value must have a maximum value of $max"); + return; + } + } + + if (defined (my $min = $schema->{minimum})) { + if ($value < $min) { + add_error($errors, $path, "value must have a minimum value of $min"); + return; + } + } + } + + if (my $ea = $schema->{enum}) { + + my $found; + foreach my $ev (@$ea) { + if ($ev eq $value) { + $found = 1; + last; + } + } + if (!$found) { + add_error($errors, $path, "value '$value' does not have a value in the enumeration '" . + join(", ", @$ea) . "'"); + } + } + } +} + +sub validate { + my ($instance, $schema, $errmsg) = @_; + + my $errors = {}; + $errmsg = "Parameter verification failed.\n" if !$errmsg; + + # todo: cycle detection is only needed for debugging, I guess + # we can disable that in the final release + # todo: is there a better/faster way to detect cycles? + my $cycles = 0; + find_cycle($instance, sub { $cycles = 1 }); + if ($cycles) { + add_error($errors, undef, "data structure contains recursive cycles"); + } elsif ($schema) { + check_prop($instance, $schema, '', $errors); + } + + if (scalar(%$errors)) { + raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors; + } + + return 1; +} + +my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"]; +my $default_schema_noref = { + description => "This is the JSON Schema for JSON Schemas.", + type => [ "object" ], + additionalProperties => 0, + properties => { + type => { + type => ["string", "array"], + description => "This is a type definition value. This can be a simple type, or a union type", + optional => 1, + default => "any", + items => { + type => "string", + enum => $schema_valid_types, + }, + enum => $schema_valid_types, + }, + optional => { + type => "boolean", + description => "This indicates that the instance property in the instance object is not required.", + optional => 1, + default => 0 + }, + properties => { + type => "object", + description => "This is a definition for the properties of an object value", + optional => 1, + default => {}, + }, + items => { + type => "object", + description => "When the value is an array, this indicates the schema to use to validate each item in an array", + optional => 1, + default => {}, + }, + additionalProperties => { + type => [ "boolean", "object"], + description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.", + optional => 1, + default => {}, + }, + minimum => { + type => "number", + optional => 1, + description => "This indicates the minimum value for the instance property when the type of the instance value is a number.", + }, + maximum => { + type => "number", + optional => 1, + description => "This indicates the maximum value for the instance property when the type of the instance value is a number.", + }, + minLength => { + type => "integer", + description => "When the instance value is a string, this indicates minimum length of the string", + optional => 1, + minimum => 0, + default => 0, + }, + maxLength => { + type => "integer", + description => "When the instance value is a string, this indicates maximum length of the string.", + optional => 1, + }, + typetext => { + type => "string", + optional => 1, + description => "A text representation of the type (used to generate documentation).", + }, + pattern => { + type => "string", + format => "regex", + description => "When the instance value is a string, this provides a regular expression that a instance string value should match in order to be valid.", + optional => 1, + default => ".*", + }, + + enum => { + type => "array", + optional => 1, + description => "This provides an enumeration of possible values that are valid for the instance property.", + }, + description => { + type => "string", + optional => 1, + description => "This provides a description of the purpose the instance property. The value can be a string or it can be an object with properties corresponding to various different instance languages (with an optional default property indicating the default description).", + }, + title => { + type => "string", + optional => 1, + description => "This provides the title of the property", + }, + requires => { + type => [ "string", "object" ], + optional => 1, + description => "indicates a required property or a schema that must be validated if this property is present", + }, + format => { + type => "string", + optional => 1, + description => "This indicates what format the data is among some predefined formats which may include:\n\ndate - a string following the ISO format \naddress \nschema - a schema definition object \nperson \npage \nhtml - a string representing HTML", + }, + default => { + type => "any", + optional => 1, + description => "This indicates the default for the instance property." + }, + disallow => { + type => "object", + optional => 1, + description => "This attribute may take the same values as the \"type\" attribute, however if the instance matches the type or if this value is an array and the instance matches any type or schema in the array, than this instance is not valid.", + }, + extends => { + type => "object", + optional => 1, + description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.", + default => {}, + }, + # this is from hyper schema + links => { + type => "array", + description => "This defines the link relations of the instance objects", + optional => 1, + items => { + type => "object", + properties => { + href => { + type => "string", + description => "This defines the target URL for the relation and can be parameterized using {propertyName} notation. It should be resolved as a URI-reference relative to the URI that was used to retrieve the instance document", + }, + rel => { + type => "string", + description => "This is the name of the link relation", + optional => 1, + default => "full", + }, + method => { + type => "string", + description => "For submission links, this defines the method that should be used to access the target resource", + optional => 1, + default => "GET", + }, + }, + }, + }, + } +}; + +my $default_schema = Storable::dclone($default_schema_noref); + +$default_schema->{properties}->{properties}->{additionalProperties} = $default_schema; +$default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties}; + +$default_schema->{properties}->{items}->{properties} = $default_schema->{properties}; +$default_schema->{properties}->{items}->{additionalProperties} = 0; + +$default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties}; +$default_schema->{properties}->{disallow}->{additionalProperties} = 0; + +$default_schema->{properties}->{requires}->{properties} = $default_schema->{properties}; +$default_schema->{properties}->{requires}->{additionalProperties} = 0; + +$default_schema->{properties}->{extends}->{properties} = $default_schema->{properties}; +$default_schema->{properties}->{extends}->{additionalProperties} = 0; + +my $method_schema = { + type => "object", + additionalProperties => 0, + properties => { + description => { + description => "This a description of the method", + optional => 1, + }, + name => { + type => 'string', + description => "This indicates the name of the function to call.", + optional => 1, + requires => { + additionalProperties => 1, + properties => { + name => {}, + description => {}, + code => {}, + method => {}, + parameters => {}, + path => {}, + parameters => {}, + returns => {}, + } + }, + }, + method => { + type => 'string', + description => "The HTTP method name.", + enum => [ 'GET', 'POST', 'PUT', 'DELETE' ], + optional => 1, + }, + protected => { + type => 'boolean', + description => "Method needs special privileges - only pvedaemon can execute it", + optional => 1, + }, + proxyto => { + type => 'string', + description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.", + optional => 1, + }, + permissions => { + type => 'object', + description => "Required access permissions. By default only 'root' is allowed to access this method.", + optional => 1, + additionalProperties => 0, + properties => { + description => { + description => "Describe access permissions.", + optional => 1, + }, + user => { + description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.", + type => 'string', + enum => ['all', 'world'], + optional => 1, + }, + check => { + description => "Array of permission checks (prefix notation).", + type => 'array', + optional => 1 + }, + }, + }, + match_name => { + description => "Used internally", + optional => 1, + }, + match_re => { + description => "Used internally", + optional => 1, + }, + path => { + type => 'string', + description => "path for URL matching (uri template)", + }, + fragmentDelimiter => { + type => 'string', + description => "A ways to override the default fragment delimiter '/'. This onyl works on a whole sub-class. You can set this to the empty string to match the whole rest of the URI.", + optional => 1, + }, + parameters => { + type => 'object', + description => "JSON Schema for parameters.", + optional => 1, + }, + returns => { + type => 'object', + description => "JSON Schema for return value.", + optional => 1, + }, + code => { + type => 'coderef', + description => "method implementaion (code reference)", + optional => 1, + }, + subclass => { + type => 'string', + description => "Delegate call to this class (perl class string).", + optional => 1, + requires => { + additionalProperties => 0, + properties => { + subclass => {}, + path => {}, + match_name => {}, + match_re => {}, + fragmentDelimiter => { optional => 1 } + } + }, + }, + }, + +}; + +sub validate_schema { + my ($schema) = @_; + + my $errmsg = "internal error - unable to verify schema\n"; + validate($schema, $default_schema, $errmsg); +} + +sub validate_method_info { + my $info = shift; + + my $errmsg = "internal error - unable to verify method info\n"; + validate($info, $method_schema, $errmsg); + + validate_schema($info->{parameters}) if $info->{parameters}; + validate_schema($info->{returns}) if $info->{returns}; +} + +# run a self test on load +# make sure we can verify the default schema +validate_schema($default_schema_noref); +validate_schema($method_schema); + +# and now some utility methods (used by pve api) +sub method_get_child_link { + my ($info) = @_; + + return undef if !$info; + + my $schema = $info->{returns}; + return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array'; + + my $links = $schema->{links}; + return undef if !$links; + + my $found; + foreach my $lnk (@$links) { + if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) { + $found = $lnk; + last; + } + } + + return $found; +} + +# a way to parse command line parameters, using a +# schema to configure Getopt::Long +sub get_options { + my ($schema, $args, $arg_param, $fixed_param, $pwcallback) = @_; + + if (!$schema || !$schema->{properties}) { + raise("too many arguments\n", code => HTTP_BAD_REQUEST) + if scalar(@$args) != 0; + return {}; + } + + my $list_param; + if ($arg_param && !ref($arg_param)) { + my $pd = $schema->{properties}->{$arg_param}; + die "expected list format $pd->{format}" + if !($pd && $pd->{format} && $pd->{format} =~ m/-list/); + $list_param = $arg_param; + } + + my @getopt = (); + foreach my $prop (keys %{$schema->{properties}}) { + my $pd = $schema->{properties}->{$prop}; + next if $list_param && $prop eq $list_param; + next if defined($fixed_param->{$prop}); + + if ($prop eq 'password' && $pwcallback) { + # we do not accept plain password on input line, instead + # we turn this into a boolean option and ask for password below + # using $pwcallback() (for security reasons). + push @getopt, "$prop"; + } elsif ($pd->{type} eq 'boolean') { + push @getopt, "$prop:s"; + } else { + if ($pd->{format} && $pd->{format} =~ m/-a?list/) { + push @getopt, "$prop=s@"; + } else { + push @getopt, "$prop=s"; + } + } + } + + my $opts = {}; + raise("unable to parse option\n", code => HTTP_BAD_REQUEST) + if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt); + + if (my $acount = scalar(@$args)) { + if ($list_param) { + $opts->{$list_param} = $args; + $args = []; + } elsif (ref($arg_param)) { + raise("wrong number of arguments\n", code => HTTP_BAD_REQUEST) + if scalar(@$arg_param) != $acount; + foreach my $p (@$arg_param) { + $opts->{$p} = shift @$args; + } + } else { + raise("too many arguments\n", code => HTTP_BAD_REQUEST) + if scalar(@$args) != 0; + } + } + + if (my $pd = $schema->{properties}->{password}) { + if ($pd->{type} ne 'boolean' && $pwcallback) { + if ($opts->{password} || !$pd->{optional}) { + $opts->{password} = &$pwcallback(); + } + } + } + + $opts = PVE::Tools::decode_utf8_parameters($opts); + + foreach my $p (keys %$opts) { + if (my $pd = $schema->{properties}->{$p}) { + if ($pd->{type} eq 'boolean') { + if ($opts->{$p} eq '') { + $opts->{$p} = 1; + } elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) { + $opts->{$p} = 1; + } elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) { + $opts->{$p} = 0; + } else { + raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST); + } + } elsif ($pd->{format}) { + + if ($pd->{format} =~ m/-list/) { + # allow --vmid 100 --vmid 101 and --vmid 100,101 + # allow --dow mon --dow fri and --dow mon,fri + $opts->{$p} = join(",", @{$opts->{$p}}); + } elsif ($pd->{format} =~ m/-alist/) { + # we encode array as \0 separated strings + # Note: CGI.pm also use this encoding + if (scalar(@{$opts->{$p}}) != 1) { + $opts->{$p} = join("\0", @{$opts->{$p}}); + } else { + # st that split_list knows it is \0 terminated + my $v = $opts->{$p}->[0]; + $opts->{$p} = "$v\0"; + } + } + } + } + } + + foreach my $p (keys %$fixed_param) { + $opts->{$p} = $fixed_param->{$p}; + } + + return $opts; +} + +# A way to parse configuration data by giving a json schema +sub parse_config { + my ($schema, $filename, $raw) = @_; + + # do fast check (avoid validate_schema($schema)) + die "got strange schema" if !$schema->{type} || + !$schema->{properties} || $schema->{type} ne 'object'; + + my $cfg = {}; + + while ($raw && $raw =~ s/^(.*?)(\n|$)//) { + my $line = $1; + + next if $line =~ m/^\#/; # skip comment lines + next if $line =~ m/^\s*$/; # skip empty lines + + if ($line =~ m/^(\S+):\s*(\S+)\s*$/) { + my $key = $1; + my $value = $2; + if ($schema->{properties}->{$key} && + $schema->{properties}->{$key}->{type} eq 'boolean') { + + $value = 1 if $value =~ m/^(1|on|yes|true)$/i; + $value = 0 if $value =~ m/^(0|off|no|false)$/i; + } + $cfg->{$key} = $value; + } else { + warn "ignore config line: $line\n" + } + } + + my $errors = {}; + check_prop($cfg, $schema, '', $errors); + + foreach my $k (keys %$errors) { + warn "parse error in '$filename' - '$k': $errors->{$k}\n"; + delete $cfg->{$k}; + } + + return $cfg; +} + +# generate simple key/value file +sub dump_config { + my ($schema, $filename, $cfg) = @_; + + # do fast check (avoid validate_schema($schema)) + die "got strange schema" if !$schema->{type} || + !$schema->{properties} || $schema->{type} ne 'object'; + + validate($cfg, $schema, "validation error in '$filename'\n"); + + my $data = ''; + + foreach my $k (keys %$cfg) { + $data .= "$k: $cfg->{$k}\n"; + } + + return $data; +} + +1; diff --git a/src/PVE/Network.pm b/src/PVE/Network.pm new file mode 100644 index 0000000..00639f6 --- /dev/null +++ b/src/PVE/Network.pm @@ -0,0 +1,352 @@ +package PVE::Network; + +use strict; +use warnings; +use PVE::Tools qw(run_command); +use PVE::ProcFSTools; +use PVE::INotify; +use File::Basename; + +# host network related utility functions + +sub setup_tc_rate_limit { + my ($iface, $rate, $burst, $debug) = @_; + + system("/sbin/tc class del dev $iface parent 1: classid 1:1 >/dev/null 2>&1"); + system("/sbin/tc filter del dev $iface parent ffff: protocol ip prio 50 estimator 1sec 8sec >/dev/null 2>&1"); + system("/sbin/tc qdisc del dev $iface ingress >/dev/null 2>&1"); + system("/sbin/tc qdisc del dev $iface root >/dev/null 2>&1"); + + return if !$rate; + + run_command("/sbin/tc qdisc add dev $iface handle ffff: ingress"); + + # this does not work wit virtio - don't know why (setting "mtu 64kb" does not help) + #run_command("/sbin/tc filter add dev $iface parent ffff: protocol ip prio 50 u32 match ip src 0.0.0.0/0 police rate ${rate}bps burst ${burst}b drop flowid :1"); + # so we use avrate instead + run_command("/sbin/tc filter add dev $iface parent ffff: " . + "protocol ip prio 50 estimator 1sec 8sec " . + "u32 match ip src 0.0.0.0/0 police avrate ${rate}bps drop flowid :1"); + + # tbf does not work for unknown reason + #$TC qdisc add dev $DEV root tbf rate $RATE latency 100ms burst $BURST + # so we use htb instead + run_command("/sbin/tc qdisc add dev $iface root handle 1: htb default 1"); + run_command("/sbin/tc class add dev $iface parent 1: classid 1:1 " . + "htb rate ${rate}bps burst ${burst}b"); + + if ($debug) { + print "DEBUG tc settings\n"; + system("/sbin/tc qdisc ls dev $iface"); + system("/sbin/tc class ls dev $iface"); + system("/sbin/tc filter ls dev $iface parent ffff:"); + } +} + +sub tap_rate_limit { + my ($iface, $rate) = @_; + + my $debug = 0; + $rate = int($rate*1024*1024); + my $burst = 1024*1024; + + setup_tc_rate_limit($iface, $rate, $burst, $debug); +} + +my $read_bridge_mtu = sub { + my ($bridge) = @_; + + my $mtu = PVE::Tools::file_read_firstline("/sys/class/net/$bridge/mtu"); + die "bridge '$bridge' does not exist\n" if !$mtu; + # avoid insecure dependency; + die "unable to parse mtu value" if $mtu !~ /^(\d+)$/; + $mtu = int($1); + + return $mtu; +}; + +my $parse_tap_devive_name = sub { + my ($iface, $noerr) = @_; + + my ($vmid, $devid); + + if ($iface =~ m/^tap(\d+)i(\d+)$/) { + $vmid = $1; + $devid = $2; + } elsif ($iface =~ m/^veth(\d+)\.(\d+)$/) { + $vmid = $1; + $devid = $2; + } else { + return undef if $noerr; + die "can't create firewall bridge for random interface name '$iface'\n"; + } + + return ($vmid, $devid); +}; + +my $compute_fwbr_names = sub { + my ($vmid, $devid) = @_; + + my $fwbr = "fwbr${vmid}i${devid}"; + # Note: the firewall use 'fwln+' to filter traffic to VMs + my $vethfw = "fwln${vmid}i${devid}"; + my $vethfwpeer = "fwpr${vmid}p${devid}"; + my $ovsintport = "fwln${vmid}o${devid}"; + + return ($fwbr, $vethfw, $vethfwpeer, $ovsintport); +}; + +my $cond_create_bridge = sub { + my ($bridge) = @_; + + if (! -d "/sys/class/net/$bridge") { + system("/sbin/brctl addbr $bridge") == 0 || + die "can't add bridge '$bridge'\n"; + } +}; + +my $bridge_add_interface = sub { + my ($bridge, $iface) = @_; + + system("/sbin/brctl addif $bridge $iface") == 0 || + die "can't add interface 'iface' to bridge '$bridge'\n"; +}; + +my $ovs_bridge_add_port = sub { + my ($bridge, $iface, $tag, $internal) = @_; + + my $cmd = "/usr/bin/ovs-vsctl add-port $bridge $iface"; + $cmd .= " tag=$tag" if $tag; + $cmd .= " -- set Interface $iface type=internal" if $internal; + system($cmd) == 0 || + die "can't add ovs port '$iface'\n"; +}; + +my $activate_interface = sub { + my ($iface) = @_; + + system("/sbin/ip link set $iface up") == 0 || + die "can't activate interface '$iface'\n"; +}; + +sub tap_create { + my ($iface, $bridge) = @_; + + die "unable to get bridge setting\n" if !$bridge; + + my $bridgemtu = &$read_bridge_mtu($bridge); + + eval { + PVE::Tools::run_command("/sbin/ifconfig $iface 0.0.0.0 promisc up mtu $bridgemtu"); + }; + die "interface activation failed\n" if $@; +} + +my $create_firewall_bridge_linux = sub { + my ($iface, $bridge) = @_; + + my ($vmid, $devid) = &$parse_tap_devive_name($iface); + my ($fwbr, $vethfw, $vethfwpeer) = &$compute_fwbr_names($vmid, $devid); + + my $bridgemtu = &$read_bridge_mtu($bridge); + + &$cond_create_bridge($fwbr); + &$activate_interface($fwbr); + + copy_bridge_config($bridge, $fwbr); + # create veth pair + if (! -d "/sys/class/net/$vethfw") { + system("/sbin/ip link add name $vethfw type veth peer name $vethfwpeer mtu $bridgemtu") == 0 || + die "can't create interface $vethfw\n"; + } + + # up vethpair + &$activate_interface($vethfw); + &$activate_interface($vethfwpeer); + + &$bridge_add_interface($fwbr, $vethfw); + &$bridge_add_interface($bridge, $vethfwpeer); + + return $fwbr; +}; + +my $create_firewall_bridge_ovs = sub { + my ($iface, $bridge, $tag) = @_; + + my ($vmid, $devid) = &$parse_tap_devive_name($iface); + my ($fwbr, undef, undef, $ovsintport) = &$compute_fwbr_names($vmid, $devid); + + my $bridgemtu = &$read_bridge_mtu($bridge); + + &$cond_create_bridge($fwbr); + &$activate_interface($fwbr); + + &$bridge_add_interface($fwbr, $iface); + + &$ovs_bridge_add_port($bridge, $ovsintport, $tag, 1); + &$activate_interface($ovsintport); + + # set the same mtu for ovs int port + PVE::Tools::run_command("/sbin/ifconfig $ovsintport mtu $bridgemtu"); + + &$bridge_add_interface($fwbr, $ovsintport); +}; + +my $cleanup_firewall_bridge = sub { + my ($iface) = @_; + + my ($vmid, $devid) = &$parse_tap_devive_name($iface, 1); + return if !defined($vmid); + my ($fwbr, $vethfw, $vethfwpeer, $ovsintport) = &$compute_fwbr_names($vmid, $devid); + + # cleanup old port config from any openvswitch bridge + if (-d "/sys/class/net/$ovsintport") { + run_command("/usr/bin/ovs-vsctl del-port $ovsintport", outfunc => sub {}, errfunc => sub {}); + } + + # delete old vethfw interface + if (-d "/sys/class/net/$vethfw") { + run_command("/sbin/ip link delete dev $vethfw", outfunc => sub {}, errfunc => sub {}); + } + + # cleanup fwbr bridge + if (-d "/sys/class/net/$fwbr") { + run_command("/sbin/ip link set dev $fwbr down", outfunc => sub {}, errfunc => sub {}); + run_command("/sbin/brctl delbr $fwbr", outfunc => sub {}, errfunc => sub {}); + } +}; + +sub tap_plug { + my ($iface, $bridge, $tag, $firewall) = @_; + + #cleanup old port config from any openvswitch bridge + eval {run_command("/usr/bin/ovs-vsctl del-port $iface", outfunc => sub {}, errfunc => sub {}) }; + + if (-d "/sys/class/net/$bridge/bridge") { + &$cleanup_firewall_bridge($iface); # remove stale devices + + my $newbridge = activate_bridge_vlan($bridge, $tag); + copy_bridge_config($bridge, $newbridge) if $bridge ne $newbridge; + + $newbridge = &$create_firewall_bridge_linux($iface, $newbridge) if $firewall; + + &$bridge_add_interface($newbridge, $iface); + } else { + &$cleanup_firewall_bridge($iface); # remove stale devices + + if ($firewall) { + &$create_firewall_bridge_ovs($iface, $bridge, $tag); + } else { + &$ovs_bridge_add_port($bridge, $iface, $tag); + } + } +} + +sub tap_unplug { + my ($iface) = @_; + + my $path= "/sys/class/net/$iface/brport/bridge"; + if (-l $path) { + my $bridge = basename(readlink($path)); + #avoid insecure dependency; + ($bridge) = $bridge =~ /(\S+)/; + + system("/sbin/brctl delif $bridge $iface") == 0 || + die "can't del interface '$iface' from bridge '$bridge'\n"; + + } + + &$cleanup_firewall_bridge($iface); +} + +sub copy_bridge_config { + my ($br0, $br1) = @_; + + return if $br0 eq $br1; + + my $br_configs = [ 'ageing_time', 'stp_state', 'priority', 'forward_delay', + 'hello_time', 'max_age', 'multicast_snooping', 'multicast_querier']; + + foreach my $sysname (@$br_configs) { + eval { + my $v0 = PVE::Tools::file_read_firstline("/sys/class/net/$br0/bridge/$sysname"); + my $v1 = PVE::Tools::file_read_firstline("/sys/class/net/$br1/bridge/$sysname"); + if ($v0 ne $v1) { + PVE::ProcFSTools::write_proc_entry("/sys/class/net/$br1/bridge/$sysname", $v0); + } + }; + warn $@ if $@; + } +} + +sub activate_bridge_vlan_slave { + my ($bridgevlan, $iface, $tag) = @_; + my $ifacevlan = "${iface}.$tag"; + + # create vlan on $iface is not already exist + if (! -d "/sys/class/net/$ifacevlan") { + system("/sbin/vconfig add $iface $tag") == 0 || + die "can't add vlan tag $tag to interface $iface\n"; + } + + # be sure to have the $ifacevlan up + &$activate_interface($ifacevlan); + + # test if $vlaniface is already enslaved in another bridge + my $path= "/sys/class/net/$ifacevlan/brport/bridge"; + if (-l $path) { + my $tbridge = basename(readlink($path)); + if ($tbridge ne $bridgevlan) { + die "interface $ifacevlan already exist in bridge $tbridge\n"; + } else { + # Port already attached to bridge: do nothing. + return; + } + } + + # add $ifacevlan to the bridge + &$bridge_add_interface($bridgevlan, $ifacevlan); +} + +sub activate_bridge_vlan { + my ($bridge, $tag_param) = @_; + + die "bridge '$bridge' is not active\n" if ! -d "/sys/class/net/$bridge"; + + return $bridge if !defined($tag_param); # no vlan, simply return + + my $tag = int($tag_param); + + die "got strange vlan tag '$tag_param'\n" if $tag < 1 || $tag > 4094; + + my $bridgevlan = "${bridge}v$tag"; + + my @ifaces = (); + my $dir = "/sys/class/net/$bridge/brif"; + PVE::Tools::dir_glob_foreach($dir, '((eth|bond)\d+)', sub { + push @ifaces, $_[0]; + }); + + die "no physical interface on bridge '$bridge'\n" if scalar(@ifaces) == 0; + + # add bridgevlan if it doesn't already exist + if (! -d "/sys/class/net/$bridgevlan") { + system("/sbin/brctl addbr $bridgevlan") == 0 || + die "can't add bridge $bridgevlan\n"; + } + + # for each physical interface (eth or bridge) bind them to bridge vlan + foreach my $iface (@ifaces) { + activate_bridge_vlan_slave($bridgevlan, $iface, $tag); + } + + #fixme: set other bridge flags + + # be sure to have the bridge up + system("/sbin/ip link set $bridgevlan up") == 0 || + die "can't up bridge $bridgevlan\n"; + + return $bridgevlan; +} + +1; diff --git a/src/PVE/PodParser.pm b/src/PVE/PodParser.pm new file mode 100644 index 0000000..7e31e19 --- /dev/null +++ b/src/PVE/PodParser.pm @@ -0,0 +1,108 @@ +package PVE::PodParser; + +use strict; +use warnings; +use Pod::Parser; +use base qw(Pod::Parser); + +my $currentYear = (localtime(time))[5] + 1900; + +my $stdinclude = { + pve_copyright => <. +EODATA +}; + +sub command { + my ($self, $cmd, $text, $line_num, $pod_para) = @_; + + if (($cmd eq 'include' && $text =~ m/^\s*(\S+)\s/)) { + my $incl = $1; + my $data = $stdinclude->{$incl} ? $stdinclude->{$incl} : + $self->{include}->{$incl}; + chomp $data; + $self->textblock("$data\n\n", $line_num, $pod_para); + } else { + $self->textblock($pod_para->raw_text(), $line_num, $pod_para); + } +} + +# helpers used to generate our manual pages + +sub schema_get_type_text { + my ($phash) = @_; + + if ($phash->{typetext}) { + return $phash->{typetext}; + } elsif ($phash->{enum}) { + return "(" . join(' | ', sort @{$phash->{enum}}) . ")"; + } elsif ($phash->{pattern}) { + return $phash->{pattern}; + } elsif ($phash->{type} eq 'integer' || $phash->{type} eq 'number') { + if (defined($phash->{minimum}) && defined($phash->{maximum})) { + return "$phash->{type} ($phash->{minimum} - $phash->{maximum})"; + } elsif (defined($phash->{minimum})) { + return "$phash->{type} ($phash->{minimum} - N)"; + } elsif (defined($phash->{maximum})) { + return "$phash->{type} (-N - $phash->{maximum})"; + } + } + + my $type = $phash->{type} || 'string'; + + return $type; +} + +# generta epop from JSON schema properties +sub dump_properties { + my ($properties) = @_; + + my $data = "=over 1\n\n"; + + my $idx_param = {}; # -vlan\d+ -scsi\d+ + + foreach my $key (sort keys %$properties) { + my $d = $properties->{$key}; + my $base = $key; + if ($key =~ m/^([a-z]+)(\d+)$/) { + my $name = $1; + next if $idx_param->{$name}; + $idx_param->{$name} = 1; + $base = "${name}[n]"; + } + + my $descr = $d->{description} || 'No description avalable.'; + chomp $descr; + + if (defined(my $dv = $d->{default})) { + my $multi = $descr =~ m/\n\n/; # multi paragraph ? + $descr .= $multi ? "\n\n" : " "; + $descr .= "Default value is '$dv'."; + } + + my $typetext = schema_get_type_text($d); + $data .= "=item $base: $typetext\n\n"; + $data .= "$descr\n\n"; + } + + $data .= "=back"; + + return $data; +} + +1; diff --git a/src/PVE/ProcFSTools.pm b/src/PVE/ProcFSTools.pm new file mode 100644 index 0000000..8bb0d72 --- /dev/null +++ b/src/PVE/ProcFSTools.pm @@ -0,0 +1,287 @@ +package PVE::ProcFSTools; + +use strict; +use warnings; +use POSIX; +use Time::HiRes qw (gettimeofday); +use IO::File; +use PVE::Tools; + +my $clock_ticks = POSIX::sysconf(&POSIX::_SC_CLK_TCK); + +my $cpuinfo; + +sub read_cpuinfo { + my $fn = '/proc/cpuinfo'; + + return $cpuinfo if $cpuinfo; + + my $res = { + user_hz => $clock_ticks, + model => 'unknown', + mhz => 0, + cpus => 1, + sockets => 1, + }; + + my $fh = IO::File->new ($fn, "r"); + return $res if !$fh; + + my $idhash = {}; + my $count = 0; + while (defined(my $line = <$fh>)) { + if ($line =~ m/^processor\s*:\s*\d+\s*$/i) { + $count++; + } elsif ($line =~ m/^model\s+name\s*:\s*(.*)\s*$/i) { + $res->{model} = $1 if $res->{model} eq 'unknown'; + } elsif ($line =~ m/^cpu\s+MHz\s*:\s*(\d+\.\d+)\s*$/i) { + $res->{mhz} = $1 if !$res->{mhz}; + } elsif ($line =~ m/^flags\s*:.*(vmx|svm)/) { + $res->{hvm} = 1; # Hardware Virtual Machine (Intel VT / AMD-V) + } elsif ($line =~ m/^physical id\s*:\s*(\d+)\s*$/i) { + $idhash->{$1} = 1; + } + } + + $res->{sockets} = scalar(keys %$idhash) || 1; + + $res->{cpus} = $count; + + $fh->close; + + $cpuinfo = $res; + + return $res; +} + +sub read_proc_uptime { + my $ticks = shift; + + my $line = PVE::Tools::file_read_firstline("/proc/uptime"); + if ($line && $line =~ m|^(\d+\.\d+)\s+(\d+\.\d+)\s*$|) { + if ($ticks) { + return (int($1*$clock_ticks), int($2*$clock_ticks)); + } else { + return (int($1), int($2)); + } + } + + return (0, 0); +} + +sub read_loadavg { + + my $line = PVE::Tools::file_read_firstline('/proc/loadavg'); + + if ($line =~ m|^(\d+\.\d+)\s+(\d+\.\d+)\s+(\d+\.\d+)\s+\d+/\d+\s+\d+\s*$|) { + return wantarray ? ($1, $2, $3) : $1; + } + + return wantarray ? (0, 0, 0) : 0; +} + +my $last_proc_stat; + +sub read_proc_stat { + my $res = { user => 0, nice => 0, system => 0, idle => 0 , sum => 0}; + + my $cpucount = 0; + + if (my $fh = IO::File->new ("/proc/stat", "r")) { + while (defined (my $line = <$fh>)) { + if ($line =~ m|^cpu\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s|) { + $res->{user} = $1; + $res->{nice} = $2; + $res->{system} = $3; + $res->{idle} = $4; + $res->{used} = $1+$2+$3; + $res->{iowait} = $5; + } elsif ($line =~ m|^cpu\d+\s|) { + $cpucount++; + } + } + $fh->close; + } + + $cpucount = 1 if !$cpucount; + + my $ctime = gettimeofday; # floating point time in seconds + + $res->{ctime} = $ctime; + $res->{cpu} = 0; + $res->{wait} = 0; + + $last_proc_stat = $res if !$last_proc_stat; + + my $diff = ($ctime - $last_proc_stat->{ctime}) * $clock_ticks * $cpucount; + + if ($diff > 1000) { # don't update too often + my $useddiff = $res->{used} - $last_proc_stat->{used}; + $useddiff = $diff if $useddiff > $diff; + $res->{cpu} = $useddiff/$diff; + my $waitdiff = $res->{iowait} - $last_proc_stat->{iowait}; + $waitdiff = $diff if $waitdiff > $diff; + $res->{wait} = $waitdiff/$diff; + $last_proc_stat = $res; + } else { + $res->{cpu} = $last_proc_stat->{cpu}; + $res->{wait} = $last_proc_stat->{wait}; + } + + return $res; +} + +sub read_proc_pid_stat { + my $pid = shift; + + my $statstr = PVE::Tools::file_read_firstline("/proc/$pid/stat"); + + if ($statstr && $statstr =~ m/^$pid \(.*\) (\S) (-?\d+) -?\d+ -?\d+ -?\d+ -?\d+ \d+ \d+ \d+ \d+ \d+ (\d+) (\d+) (-?\d+) (-?\d+) -?\d+ -?\d+ -?\d+ 0 (\d+) (\d+) (-?\d+) \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ -?\d+ -?\d+ \d+ \d+ \d+/) { + return { + status => $1, + utime => $3, + stime => $4, + starttime => $7, + vsize => $8, + rss => $9 * 4096, + }; + } + + return undef; +} + +sub check_process_running { + my ($pid, $pstart) = @_; + + # note: waitpid only work for child processes, but not + # for processes spanned by other processes. + # kill(0, pid) return succes for zombies. + # So we read the status form /proc/$pid/stat instead + + my $info = read_proc_pid_stat($pid); + + return $info && (!$pstart || ($info->{starttime} eq $pstart)) && ($info->{status} ne 'Z') ? $info : undef; +} + +sub read_proc_starttime { + my $pid = shift; + + my $info = read_proc_pid_stat($pid); + return $info ? $info->{starttime} : 0; +} + +sub read_meminfo { + + my $res = { + memtotal => 0, + memfree => 0, + memused => 0, + memshared => 0, + swaptotal => 0, + swapfree => 0, + swapused => 0, + }; + + my $fh = IO::File->new ("/proc/meminfo", "r"); + return $res if !$fh; + + my $d = {}; + while (my $line = <$fh>) { + if ($line =~ m/^(\S+):\s+(\d+)\s*kB/i) { + $d->{lc ($1)} = $2 * 1024; + } + } + close($fh); + + $res->{memtotal} = $d->{memtotal}; + $res->{memfree} = $d->{memfree} + $d->{buffers} + $d->{cached}; + $res->{memused} = $res->{memtotal} - $res->{memfree}; + + $res->{swaptotal} = $d->{swaptotal}; + $res->{swapfree} = $d->{swapfree}; + $res->{swapused} = $res->{swaptotal} - $res->{swapfree}; + + my $spages = PVE::Tools::file_read_firstline("/sys/kernel/mm/ksm/pages_sharing"); + $res->{memshared} = int($spages) * 4096; + + return $res; +} + +# memory usage of current process +sub read_memory_usage { + + my $res = { size => 0, resident => 0, shared => 0 }; + + my $ps = 4096; + + my $line = PVE::Tools::file_read_firstline("/proc/$$/statm"); + + if ($line =~ m/^(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s*/) { + $res->{size} = $1*$ps; + $res->{resident} = $2*$ps; + $res->{shared} = $3*$ps; + } + + return $res; +} + +sub read_proc_net_dev { + + my $res = {}; + + my $fh = IO::File->new ("/proc/net/dev", "r"); + return $res if !$fh; + + while (defined (my $line = <$fh>)) { + if ($line =~ m/^\s*(.*):\s*(\d+)\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+(\d+)\s+/) { + $res->{$1} = { + receive => $2, + transmit => $3, + }; + } + } + + close($fh); + + return $res; +} + +sub write_proc_entry { + my ($filename, $data) = @_;# + + my $fh = IO::File->new($filename, O_WRONLY); + die "unable to open file '$filename' - $!\n" if !$fh; + die "unable to write '$filename' - $!\n" unless print $fh $data; + die "closing file '$filename' failed - $!\n" unless close $fh; + $fh->close(); +} + +sub read_proc_net_route { + my $filename = "/proc/net/route"; + + my $res = []; + + my $fh = IO::File->new ($filename, "r"); + return $res if !$fh; + + my $int_to_quad = sub { + return join '.' => map { ($_[0] >> 8*(3-$_)) % 256 } (3, 2, 1, 0); + }; + + while (defined(my $line = <$fh>)) { + next if $line =~/^Iface\s+Destination/; # skip head + my ($iface, $dest, $gateway, $metric, $mask, $mtu) = (split(/\s+/, $line))[0,1,2,6,7,8]; + push @$res, { + dest => &$int_to_quad(hex($dest)), + gateway => &$int_to_quad(hex($gateway)), + mask => &$int_to_quad(hex($mask)), + metric => $metric, + mtu => $mtu, + iface => $iface, + }; + } + + return $res; +} + +1; diff --git a/src/PVE/RESTHandler.pm b/src/PVE/RESTHandler.pm new file mode 100644 index 0000000..4153192 --- /dev/null +++ b/src/PVE/RESTHandler.pm @@ -0,0 +1,577 @@ +package PVE::RESTHandler; + +use strict; +no strict 'refs'; # our autoload requires this +use warnings; +use PVE::SafeSyslog; +use PVE::Exception qw(raise raise_param_exc); +use PVE::JSONSchema; +use PVE::PodParser; +use HTTP::Status qw(:constants :is status_message); +use Text::Wrap; +use Storable qw(dclone); + +my $method_registry = {}; +my $method_by_name = {}; +my $method_path_lookup = {}; + +our $AUTOLOAD; # it's a package global + +sub api_clone_schema { + my ($schema) = @_; + + my $res = {}; + my $ref = ref($schema); + die "not a HASH reference" if !($ref && $ref eq 'HASH'); + + foreach my $k (keys %$schema) { + my $d = $schema->{$k}; + if ($k ne 'properties') { + $res->{$k} = ref($d) ? dclone($d) : $d; + next; + } + # convert indexed parameters like -net\d+ to -net[n] + foreach my $p (keys %$d) { + my $pd = $d->{$p}; + if ($p =~ m/^([a-z]+)(\d+)$/) { + if ($2 == 0) { + $p = "$1\[n\]"; + } else { + next; + } + } + $res->{$k}->{$p} = ref($pd) ? dclone($pd) : $pd; + } + } + + return $res; +} + +sub api_dump_full { + my ($tree, $index, $class, $prefix) = @_; + + $prefix = '' if !$prefix; + + my $ma = $method_registry->{$class}; + + foreach my $info (@$ma) { + + my $path = "$prefix/$info->{path}"; + $path =~ s/\/+$//; + + if ($info->{subclass}) { + api_dump_full($tree, $index, $info->{subclass}, $path); + } else { + next if !$path; + + # check if method is unique + my $realpath = $path; + $realpath =~ s/\{[^\}]+\}/\{\}/g; + my $fullpath = "$info->{method} $realpath"; + die "duplicate path '$realpath'" if $index->{$fullpath}; + $index->{$fullpath} = $info; + + # insert into tree + my $treedir = $tree; + my $res; + my $sp = ''; + foreach my $dir (split('/', $path)) { + next if !$dir; + $sp .= "/$dir"; + $res = (grep { $_->{text} eq $dir } @$treedir)[0]; + if ($res) { + $res->{children} = [] if !$res->{children}; + $treedir = $res->{children}; + } else { + $res = { + path => $sp, + text => $dir, + children => [], + }; + push @$treedir, $res; + $treedir = $res->{children}; + } + } + + if ($res) { + my $data = {}; + foreach my $k (keys %$info) { + next if $k eq 'code' || $k eq "match_name" || $k eq "match_re" || + $k eq "path"; + + my $d = $info->{$k}; + + if ($k eq 'parameters') { + $data->{$k} = api_clone_schema($d); + } else { + + $data->{$k} = ref($d) ? dclone($d) : $d; + } + } + $res->{info}->{$info->{method}} = $data; + }; + } + } +}; + +sub api_dump_cleanup_tree { + my ($tree) = @_; + + foreach my $rec (@$tree) { + delete $rec->{children} if $rec->{children} && !scalar(@{$rec->{children}}); + if ($rec->{children}) { + $rec->{leaf} = 0; + api_dump_cleanup_tree($rec->{children}); + } else { + $rec->{leaf} = 1; + } + } + +} + +sub api_dump { + my ($class, $prefix) = @_; + + my $tree = []; + + my $index = {}; + api_dump_full($tree, $index, $class); + api_dump_cleanup_tree($tree); + return $tree; +}; + +sub validate_method_schemas { + + foreach my $class (keys %$method_registry) { + my $ma = $method_registry->{$class}; + + foreach my $info (@$ma) { + PVE::JSONSchema::validate_method_info($info); + } + } +} + +sub register_method { + my ($self, $info) = @_; + + my $match_re = []; + my $match_name = []; + + my $errprefix; + + my $method; + if ($info->{subclass}) { + $errprefix = "register subclass $info->{subclass} at ${self}/$info->{path} -"; + $method = 'SUBCLASS'; + } else { + $errprefix = "register method ${self}/$info->{path} -"; + $info->{method} = 'GET' if !$info->{method}; + $method = $info->{method}; + } + + $method_path_lookup->{$self} = {} if !defined($method_path_lookup->{$self}); + my $path_lookup = $method_path_lookup->{$self}; + + die "$errprefix no path" if !defined($info->{path}); + + foreach my $comp (split(/\/+/, $info->{path})) { + die "$errprefix path compoment has zero length\n" if $comp eq ''; + my ($name, $regex); + if ($comp =~ m/^\{(\w+)(:(.*))?\}$/) { + $name = $1; + $regex = $3 ? $3 : '\S+'; + push @$match_re, $regex; + push @$match_name, $name; + } else { + $name = $comp; + push @$match_re, $name; + push @$match_name, undef; + } + + if ($regex) { + $path_lookup->{regex} = {} if !defined($path_lookup->{regex}); + + my $old_name = $path_lookup->{regex}->{match_name}; + die "$errprefix found changed regex match name\n" + if defined($old_name) && ($old_name ne $name); + my $old_re = $path_lookup->{regex}->{match_re}; + die "$errprefix found changed regex\n" + if defined($old_re) && ($old_re ne $regex); + $path_lookup->{regex}->{match_name} = $name; + $path_lookup->{regex}->{match_re} = $regex; + + die "$errprefix path match error - regex and fixed items\n" + if defined($path_lookup->{folders}); + + $path_lookup = $path_lookup->{regex}; + + } else { + $path_lookup->{folders}->{$name} = {} if !defined($path_lookup->{folders}->{$name}); + + die "$errprefix path match error - regex and fixed items\n" + if defined($path_lookup->{regex}); + + $path_lookup = $path_lookup->{folders}->{$name}; + } + } + + die "$errprefix duplicate method definition\n" + if defined($path_lookup->{$method}); + + if ($method eq 'SUBCLASS') { + foreach my $m (qw(GET PUT POST DELETE)) { + die "$errprefix duplicate method definition SUBCLASS and $m\n" if $path_lookup->{$m}; + } + } + $path_lookup->{$method} = $info; + + $info->{match_re} = $match_re; + $info->{match_name} = $match_name; + + $method_by_name->{$self} = {} if !defined($method_by_name->{$self}); + + if ($info->{name}) { + die "$errprefix method name already defined\n" + if defined($method_by_name->{$self}->{$info->{name}}); + + $method_by_name->{$self}->{$info->{name}} = $info; + } + + push @{$method_registry->{$self}}, $info; +} + +sub register_page_formatter { + my ($self, %config) = @_; + + my $format = $config{format} || + die "missing format"; + + my $path = $config{path} || + die "missing path"; + + my $method = $config{method} || + die "missing method"; + + my $code = $config{code} || + die "missing formatter code"; + + my $uri_param = {}; + my ($handler, $info) = $self->find_handler($method, $path, $uri_param); + die "unabe to find handler for '$method: $path'" if !($handler && $info); + + die "duplicate formatter for '$method: $path'" + if $info->{formatter} && $info->{formatter}->{$format}; + + $info->{formatter}->{$format} = $code; +} + +sub DESTROY {}; # avoid problems with autoload + +sub AUTOLOAD { + my ($this) = @_; + + # also see "man perldiag" + + my $sub = $AUTOLOAD; + (my $method = $sub) =~ s/.*:://; + + $method =~ s/.*:://; + + my $info = $this->map_method_by_name($method); + + *{$sub} = sub { + my $self = shift; + return $self->handle($info, @_); + }; + goto &$AUTOLOAD; +} + +sub method_attributes { + my ($self) = @_; + + return $method_registry->{$self}; +} + +sub map_method_by_name { + my ($self, $name) = @_; + + my $info = $method_by_name->{$self}->{$name}; + die "no such method '${self}::$name'\n" if !$info; + + return $info; +} + +sub map_path_to_methods { + my ($class, $stack, $uri_param, $pathmatchref) = @_; + + my $path_lookup = $method_path_lookup->{$class}; + + # Note: $pathmatchref can be used to obtain path including + # uri patterns like '/cluster/firewall/groups/{group}'. + # Used by pvesh to display help + if (defined($pathmatchref)) { + $$pathmatchref = '' if !$$pathmatchref; + } + + while (defined(my $comp = shift @$stack)) { + return undef if !$path_lookup; # not registerd? + if ($path_lookup->{regex}) { + my $name = $path_lookup->{regex}->{match_name}; + my $regex = $path_lookup->{regex}->{match_re}; + + return undef if $comp !~ m/^($regex)$/; + $uri_param->{$name} = $1; + $path_lookup = $path_lookup->{regex}; + $$pathmatchref .= '/{' . $name . '}' if defined($pathmatchref); + } elsif ($path_lookup->{folders}) { + $path_lookup = $path_lookup->{folders}->{$comp}; + $$pathmatchref .= '/' . $comp if defined($pathmatchref); + } else { + die "internal error"; + } + + return undef if !$path_lookup; + + if (my $info = $path_lookup->{SUBCLASS}) { + $class = $info->{subclass}; + + my $fd = $info->{fragmentDelimiter}; + + if (defined($fd)) { + # we only support the empty string '' (match whole URI) + die "unsupported fragmentDelimiter '$fd'" + if $fd ne ''; + + $stack = [ join ('/', @$stack) ] if scalar(@$stack) > 1; + } + $path_lookup = $method_path_lookup->{$class}; + } + } + + return undef if !$path_lookup; + + return ($class, $path_lookup); +} + +sub find_handler { + my ($class, $method, $path, $uri_param, $pathmatchref) = @_; + + my $stack = [ grep { length($_) > 0 } split('\/+' , $path)]; # skip empty fragments + + my ($handler_class, $path_info); + eval { + ($handler_class, $path_info) = $class->map_path_to_methods($stack, $uri_param, $pathmatchref); + }; + my $err = $@; + syslog('err', $err) if $err; + + return undef if !($handler_class && $path_info); + + my $method_info = $path_info->{$method}; + + return undef if !$method_info; + + return ($handler_class, $method_info); +} + +sub handle { + my ($self, $info, $param) = @_; + + my $func = $info->{code}; + + if (!($info->{name} && $func)) { + raise("Method lookup failed ('$info->{name}')\n", + code => HTTP_INTERNAL_SERVER_ERROR); + } + + if (my $schema = $info->{parameters}) { + # warn "validate ". Dumper($param}) . "\n" . Dumper($schema); + PVE::JSONSchema::validate($param, $schema); + # untaint data (already validated) + while (my ($key, $val) = each %$param) { + ($param->{$key}) = $val =~ /^(.*)$/s; + } + } + + my $result = &$func($param); + + # todo: this is only to be safe - disable? + if (my $schema = $info->{returns}) { + PVE::JSONSchema::validate($result, $schema, "Result verification vailed\n"); + } + + return $result; +} + +# generate usage information for command line tools +# +# $name ... the name of the method +# $prefix ... usually something like "$exename $cmd" ('pvesm add') +# $arg_param ... list of parameters we want to get as ordered arguments +# on the command line (or single parameter name for lists) +# $fixed_param ... do not generate and info about those parameters +# $format: +# 'long' ... default (list all options) +# 'short' ... command line only (one line) +# 'full' ... also include description +# $hidepw ... hide password option (use this if you provide a read passwork callback) +sub usage_str { + my ($self, $name, $prefix, $arg_param, $fixed_param, $format, $hidepw) = @_; + + $format = 'long' if !$format; + + my $info = $self->map_method_by_name($name); + my $schema = $info->{parameters}; + my $prop = $schema->{properties}; + + my $out = ''; + + my $arg_hash = {}; + + my $args = ''; + + $arg_param = [ $arg_param ] if $arg_param && !ref($arg_param); + + foreach my $p (@$arg_param) { + next if !$prop->{$p}; # just to be sure + my $pd = $prop->{$p}; + + $arg_hash->{$p} = 1; + $args .= " " if $args; + if ($pd->{format} && $pd->{format} =~ m/-list/) { + $args .= "{<$p>}"; + } else { + $args .= $pd->{optional} ? "[<$p>]" : "<$p>"; + } + } + + my $get_prop_descr = sub { + my ($k, $display_name) = @_; + + my $phash = $prop->{$k}; + + my $res = ''; + + my $descr = $phash->{description} || "no description available"; + chomp $descr; + + my $type = PVE::PodParser::schema_get_type_text($phash); + + if ($hidepw && $k eq 'password') { + $type = ''; + } + + my $defaulttxt = ''; + if (defined(my $dv = $phash->{default})) { + $defaulttxt = " (default=$dv)"; + } + my $tmp = sprintf " %-10s %s$defaulttxt\n", $display_name, "$type"; + my $indend = " "; + + $res .= Text::Wrap::wrap('', $indend, ($tmp)); + $res .= "\n", + $res .= Text::Wrap::wrap($indend, $indend, ($descr)) . "\n\n"; + + if (my $req = $phash->{requires}) { + my $tmp = "Requires option(s): "; + $tmp .= ref($req) ? join(', ', @$req) : $req; + $res .= Text::Wrap::wrap($indend, $indend, ($tmp)). "\n\n"; + } + + return $res; + }; + + my $argdescr = ''; + foreach my $k (@$arg_param) { + next if defined($fixed_param->{$k}); # just to be sure + next if !$prop->{$k}; # just to be sure + $argdescr .= &$get_prop_descr($k, "<$k>"); + } + + my $idx_param = {}; # -vlan\d+ -scsi\d+ + + my $opts = ''; + foreach my $k (sort keys %$prop) { + next if $arg_hash->{$k}; + next if defined($fixed_param->{$k}); + + my $type = $prop->{$k}->{type} || 'string'; + + next if $hidepw && ($k eq 'password') && !$prop->{$k}->{optional}; + + my $base = $k; + if ($k =~ m/^([a-z]+)(\d+)$/) { + my $name = $1; + next if $idx_param->{$name}; + $idx_param->{$name} = 1; + $base = "${name}[n]"; + } + + $opts .= &$get_prop_descr($k, "-$base"); + + if (!$prop->{$k}->{optional}) { + $args .= " " if $args; + $args .= "-$base <$type>" + } + } + + $out .= "USAGE: " if $format ne 'short'; + + $out .= "$prefix $args"; + + $out .= $opts ? " [OPTIONS]\n" : "\n"; + + return $out if $format eq 'short'; + + if ($info->{description} && $format eq 'full') { + my $desc = Text::Wrap::wrap(' ', ' ', ($info->{description})); + $out .= "\n$desc\n\n"; + } + + $out .= $argdescr if $argdescr; + + $out .= $opts if $opts; + + return $out; +} + +sub cli_handler { + my ($self, $prefix, $name, $args, $arg_param, $fixed_param, $pwcallback) = @_; + + my $info = $self->map_method_by_name($name); + + my $res; + eval { + my $param = PVE::JSONSchema::get_options($info->{parameters}, $args, $arg_param, $fixed_param, $pwcallback); + $res = $self->handle($info, $param); + }; + if (my $err = $@) { + my $ec = ref($err); + + die $err if !$ec || $ec ne "PVE::Exception" || !$err->is_param_exc(); + + $err->{usage} = $self->usage_str($name, $prefix, $arg_param, $fixed_param, 'short', $pwcallback); + + die $err; + } + + return $res; +} + +# utility methods +# note: this modifies the original hash by adding the id property +sub hash_to_array { + my ($hash, $idprop) = @_; + + my $res = []; + return $res if !$hash; + + foreach my $k (keys %$hash) { + $hash->{$k}->{$idprop} = $k; + push @$res, $hash->{$k}; + } + + return $res; +} + +1; diff --git a/src/PVE/SafeSyslog.pm b/src/PVE/SafeSyslog.pm new file mode 100644 index 0000000..63b37f8 --- /dev/null +++ b/src/PVE/SafeSyslog.pm @@ -0,0 +1,51 @@ +package PVE::SafeSyslog; + +use strict; +use warnings; +use File::Basename; +use Sys::Syslog (); +use Encode; + +use vars qw($VERSION @ISA @EXPORT); + +$VERSION = '1.00'; + +require Exporter; + +@ISA = qw(Exporter); + +@EXPORT = qw(syslog initlog); + +my $log_tag = "unknown"; + +# never log to console - thats too slow, and +# it corrupts the DBD database connection! + +sub syslog { + eval { Sys::Syslog::syslog (@_); }; # ignore errors +} + +sub initlog { + my ($tag, $facility) = @_; + + if ($tag) { + $tag = basename($tag); + + $tag = encode("ascii", decode_utf8($tag)); + + $log_tag = $tag; + } + + $facility = "daemon" if !$facility; + + # never log to console - thats too slow + Sys::Syslog::setlogsock ('unix'); + + Sys::Syslog::openlog ($log_tag, 'pid', $facility); +} + +sub tag { + return $log_tag; +} + +1; diff --git a/src/PVE/SectionConfig.pm b/src/PVE/SectionConfig.pm new file mode 100644 index 0000000..06ebbe7 --- /dev/null +++ b/src/PVE/SectionConfig.pm @@ -0,0 +1,429 @@ +package PVE::SectionConfig; + +use strict; +use warnings; +use Digest::SHA; +use PVE::Exception qw(raise_param_exc); +use PVE::JSONSchema qw(get_standard_option); + +use Data::Dumper; + +my $defaultData = { + options => {}, + plugins => {}, + plugindata => {}, + propertyList => {}, +}; + +sub private { + die "overwrite me"; + return $defaultData; +} + +sub register { + my ($class) = @_; + + my $type = $class->type(); + my $pdata = $class->private(); + + my $plugindata = $class->plugindata(); + $pdata->{plugindata}->{$type} = $plugindata; + $pdata->{plugins}->{$type} = $class; +} + +sub type { + die "overwrite me"; +} + +sub properties { + return {}; +} + +sub options { + return {}; +} + +sub plugindata { + return {}; +} + +sub createSchema { + my ($class) = @_; + + my $pdata = $class->private(); + my $propertyList = $pdata->{propertyList}; + + return { + type => "object", + additionalProperties => 0, + properties => $propertyList, + }; +} + +sub updateSchema { + my ($class) = @_; + + my $pdata = $class->private(); + my $propertyList = $pdata->{propertyList}; + my $plugins = $pdata->{plugins}; + + my $props = {}; + + foreach my $p (keys %$propertyList) { + next if $p eq 'type'; + if (!$propertyList->{$p}->{optional}) { + $props->{$p} = $propertyList->{$p}; + next; + } + foreach my $t (keys %$plugins) { + my $opts = $pdata->{options}->{$t}; + next if !defined($opts->{$p}); + if (!$opts->{$p}->{fixed}) { + $props->{$p} = $propertyList->{$p}; + } + } + } + + $props->{digest} = get_standard_option('pve-config-digest'); + + $props->{delete} = { + type => 'string', format => 'pve-configid-list', + description => "A list of settings you want to delete.", + maxLength => 4096, + optional => 1, + }; + + return { + type => "object", + additionalProperties => 0, + properties => $props, + }; +} + +sub init { + my ($class) = @_; + + my $pdata = $class->private(); + + foreach my $k (qw(options plugins plugindata propertyList)) { + $pdata->{$k} = {} if !$pdata->{$k}; + } + + my $plugins = $pdata->{plugins}; + my $propertyList = $pdata->{propertyList}; + + foreach my $type (keys %$plugins) { + my $props = $plugins->{$type}->properties(); + foreach my $p (keys %$props) { + die "duplicate property '$p'" if defined($propertyList->{$p}); + my $res = $propertyList->{$p} = {}; + my $data = $props->{$p}; + for my $a (keys %$data) { + $res->{$a} = $data->{$a}; + } + $res->{optional} = 1; + } + } + + foreach my $type (keys %$plugins) { + my $opts = $plugins->{$type}->options(); + foreach my $p (keys %$opts) { + die "undefined property '$p'" if !$propertyList->{$p}; + } + $pdata->{options}->{$type} = $opts; + } + + $propertyList->{type}->{type} = 'string'; + $propertyList->{type}->{enum} = [keys %$plugins]; +} + +sub lookup { + my ($class, $type) = @_; + + my $pdata = $class->private(); + my $plugin = $pdata->{plugins}->{$type}; + + die "unknown section type '$type'\n" if !$plugin; + + return $plugin; +} + +sub lookup_types { + my ($class) = @_; + + my $pdata = $class->private(); + + return [ keys %{$pdata->{plugins}} ]; +} + +sub decode_value { + my ($class, $type, $key, $value) = @_; + + return $value; +} + +sub encode_value { + my ($class, $type, $key, $value) = @_; + + return $value; +} + +sub check_value { + my ($class, $type, $key, $value, $storeid, $skipSchemaCheck) = @_; + + my $pdata = $class->private(); + + return $value if $key eq 'type' && $type eq $value; + + my $opts = $pdata->{options}->{$type}; + die "unknown section type '$type'\n" if !$opts; + + die "unexpected property '$key'\n" if !defined($opts->{$key}); + + my $schema = $pdata->{propertyList}->{$key}; + die "unknown property type\n" if !$schema; + + my $ct = $schema->{type}; + + $value = 1 if $ct eq 'boolean' && !defined($value); + + die "got undefined value\n" if !defined($value); + + die "property contains a line feed\n" if $value =~ m/[\n\r]/; + + if (!$skipSchemaCheck) { + my $errors = {}; + PVE::JSONSchema::check_prop($value, $schema, '', $errors); + if (scalar(keys %$errors)) { + die "$errors->{$key}\n" if $errors->{$key}; + die "$errors->{_root}\n" if $errors->{_root}; + die "unknown error\n"; + } + } + + return $value; +} + +sub parse_section_header { + my ($class, $line) = @_; + + if ($line =~ m/^(\S+):\s*(\S+)\s*$/) { + my ($type, $sectionId) = ($1, $2); + my $errmsg = undef; # set if you want to skip whole section + my $config = {}; # to return additional attributes + return ($type, $sectionId, $errmsg, $config); + } + return undef; +} + +sub format_section_header { + my ($class, $type, $sectionId) = @_; + + return "$type: $sectionId\n"; +} + + +sub parse_config { + my ($class, $filename, $raw) = @_; + + my $pdata = $class->private(); + + my $ids = {}; + my $order = {}; + + my $digest = Digest::SHA::sha1_hex(defined($raw) ? $raw : ''); + + my $pri = 1; + + my $lineno = 0; + + while ($raw && $raw =~ s/^(.*?)(\n|$)//) { + my $line = $1; + $lineno++; + + next if $line =~ m/^\#/; + next if $line =~ m/^\s*$/; + + my $errprefix = "file $filename line $lineno"; + + my ($type, $sectionId, $errmsg, $config) = $class->parse_section_header($line); + if ($config) { + my $ignore = 0; + + my $plugin; + + if ($errmsg) { + $ignore = 1; + chomp $errmsg; + warn "$errprefix (skip section '$sectionId'): $errmsg\n"; + } elsif (!$type) { + $ignore = 1; + warn "$errprefix (skip section '$sectionId'): missing type - internal error\n"; + } else { + if (!($plugin = $pdata->{plugins}->{$type})) { + $ignore = 1; + warn "$errprefix (skip section '$sectionId'): unsupported type '$type'\n"; + } + } + + while ($raw && $raw =~ s/^(.*?)(\n|$)//) { + $line = $1; + $lineno++; + + next if $line =~ m/^\#/; + last if $line =~ m/^\s*$/; + + next if $ignore; # skip + + $errprefix = "file $filename line $lineno"; + + if ($line =~ m/^\s+(\S+)(\s+(.*\S))?\s*$/) { + my ($k, $v) = ($1, $3); + + eval { + die "duplicate attribute\n" if defined($config->{$k}); + $config->{$k} = $plugin->check_value($type, $k, $v, $sectionId); + }; + warn "$errprefix (section '$sectionId') - unable to parse value of '$k': $@" if $@; + + } else { + warn "$errprefix (section '$sectionId') - ignore config line: $line\n"; + } + } + + if (!$ignore && $type && $plugin && $config) { + $config->{type} = $type; + eval { $ids->{$sectionId} = $plugin->check_config($sectionId, $config, 1, 1); }; + warn "$errprefix (skip section '$sectionId'): $@" if $@; + $order->{$sectionId} = $pri++; + } + + } else { + warn "$errprefix - ignore config line: $line\n"; + } + } + + + my $cfg = { ids => $ids, order => $order, digest => $digest}; + + return $cfg; +} + +sub check_config { + my ($class, $sectionId, $config, $create, $skipSchemaCheck) = @_; + + my $type = $class->type(); + my $pdata = $class->private(); + my $opts = $pdata->{options}->{$type}; + + my $settings = { type => $type }; + + foreach my $k (keys %$config) { + my $value = $config->{$k}; + + die "can't change value of fixed parameter '$k'\n" + if !$create && $opts->{$k}->{fixed}; + + if (defined($value)) { + my $tmp = $class->check_value($type, $k, $value, $sectionId, $skipSchemaCheck); + $settings->{$k} = $class->decode_value($type, $k, $tmp); + } else { + die "got undefined value for option '$k'\n"; + } + } + + if ($create) { + # check if we have a value for all required options + foreach my $k (keys %$opts) { + next if $opts->{$k}->{optional}; + die "missing value for required option '$k'\n" + if !defined($config->{$k}); + } + } + + return $settings; +} + +my $format_config_line = sub { + my ($schema, $key, $value) = @_; + + my $ct = $schema->{type}; + + if ($ct eq 'boolean') { + return $value ? "\t$key\n" : ''; + } else { + return "\t$key $value\n" if "$value" ne ''; + } +}; + +sub write_config { + my ($class, $filename, $cfg) = @_; + + my $pdata = $class->private(); + my $propertyList = $pdata->{propertyList}; + + my $out = ''; + + my $ids = $cfg->{ids}; + my $order = $cfg->{order}; + + my $maxpri = 0; + foreach my $sectionId (keys %$ids) { + my $pri = $order->{$sectionId}; + $maxpri = $pri if $pri && $pri > $maxpri; + } + foreach my $sectionId (keys %$ids) { + if (!defined ($order->{$sectionId})) { + $order->{$sectionId} = ++$maxpri; + } + } + + foreach my $sectionId (sort {$order->{$a} <=> $order->{$b}} keys %$ids) { + my $scfg = $ids->{$sectionId}; + my $type = $scfg->{type}; + my $opts = $pdata->{options}->{$type}; + + die "unknown section type '$type'\n" if !$opts; + + my $data = $class->format_section_header($type, $sectionId); + if ($scfg->{comment}) { + my $k = 'comment'; + my $v = $class->encode_value($type, $k, $scfg->{$k}); + $data .= &$format_config_line($propertyList->{$k}, $k, $v); + } + + $data .= "\tdisable\n" if $scfg->{disable}; + + my $done_hash = { comment => 1, disable => 1}; + + foreach my $k (keys %$opts) { + next if $opts->{$k}->{optional}; + $done_hash->{$k} = 1; + my $v = $scfg->{$k}; + die "section '$sectionId' - missing value for required option '$k'\n" + if !defined ($v); + $v = $class->encode_value($type, $k, $v); + $data .= &$format_config_line($propertyList->{$k}, $k, $v); + } + + foreach my $k (keys %$opts) { + next if defined($done_hash->{$k}); + my $v = $scfg->{$k}; + next if !defined($v); + $v = $class->encode_value($type, $k, $v); + $data .= &$format_config_line($propertyList->{$k}, $k, $v); + } + + $out .= "$data\n"; + } + + return $out; +} + +sub assert_if_modified { + my ($cfg, $digest) = @_; + + PVE::Tools::assert_if_modified($cfg->{digest}, $digest); +} + +1; diff --git a/src/PVE/Tools.pm b/src/PVE/Tools.pm new file mode 100644 index 0000000..827ca58 --- /dev/null +++ b/src/PVE/Tools.pm @@ -0,0 +1,1046 @@ +package PVE::Tools; + +use strict; +use warnings; +use POSIX qw(EINTR); +use IO::Socket::INET; +use IO::Select; +use File::Basename; +use File::Path qw(make_path); +use IO::File; +use IO::Dir; +use IPC::Open3; +use Fcntl qw(:DEFAULT :flock); +use base 'Exporter'; +use URI::Escape; +use Encode; +use Digest::SHA; +use Text::ParseWords; +use String::ShellQuote; +use Time::HiRes qw(usleep gettimeofday tv_interval); + +# avoid warning when parsing long hex values with hex() +no warnings 'portable'; # Support for 64-bit ints required + +our @EXPORT_OK = qw( +$IPV6RE +$IPV4RE +lock_file +lock_file_full +run_command +file_set_contents +file_get_contents +file_read_firstline +dir_glob_regex +dir_glob_foreach +split_list +template_replace +safe_print +trim +extract_param +); + +my $pvelogdir = "/var/log/pve"; +my $pvetaskdir = "$pvelogdir/tasks"; + +mkdir $pvelogdir; +mkdir $pvetaskdir; + +my $IPV4OCTET = "(?:25[0-5]|(?:[1-9]|1[0-9]|2[0-4])?[0-9])"; +our $IPV4RE = "(?:(?:$IPV4OCTET\\.){3}$IPV4OCTET)"; +my $IPV6H16 = "(?:[0-9a-fA-F]{1,4})"; +my $IPV6LS32 = "(?:(?:$IPV4RE|$IPV6H16:$IPV6H16))"; + +our $IPV6RE = "(?:" . + "(?:(?:" . "(?:$IPV6H16:){6})$IPV6LS32)|" . + "(?:(?:" . "::(?:$IPV6H16:){5})$IPV6LS32)|" . + "(?:(?:(?:" . "$IPV6H16)?::(?:$IPV6H16:){4})$IPV6LS32)|" . + "(?:(?:(?:(?:$IPV6H16:){0,1}$IPV6H16)?::(?:$IPV6H16:){3})$IPV6LS32)|" . + "(?:(?:(?:(?:$IPV6H16:){0,2}$IPV6H16)?::(?:$IPV6H16:){2})$IPV6LS32)|" . + "(?:(?:(?:(?:$IPV6H16:){0,3}$IPV6H16)?::(?:$IPV6H16:){1})$IPV6LS32)|" . + "(?:(?:(?:(?:$IPV6H16:){0,4}$IPV6H16)?::" . ")$IPV6LS32)|" . + "(?:(?:(?:(?:$IPV6H16:){0,5}$IPV6H16)?::" . ")$IPV6H16)|" . + "(?:(?:(?:(?:$IPV6H16:){0,6}$IPV6H16)?::" . ")))"; + +sub run_with_timeout { + my ($timeout, $code, @param) = @_; + + die "got timeout\n" if $timeout <= 0; + + my $prev_alarm; + + my $sigcount = 0; + + my $res; + + local $SIG{ALRM} = sub { $sigcount++; }; # catch alarm outside eval + + eval { + local $SIG{ALRM} = sub { $sigcount++; die "got timeout\n"; }; + local $SIG{PIPE} = sub { $sigcount++; die "broken pipe\n" }; + local $SIG{__DIE__}; # see SA bug 4631 + + $prev_alarm = alarm($timeout); + + $res = &$code(@param); + + alarm(0); # avoid race conditions + }; + + my $err = $@; + + alarm($prev_alarm) if defined($prev_alarm); + + die "unknown error" if $sigcount && !$err; # seems to happen sometimes + + die $err if $err; + + return $res; +} + +# flock: we use one file handle per process, so lock file +# can be called multiple times and succeeds for the same process. + +my $lock_handles = {}; + +sub lock_file_full { + my ($filename, $timeout, $shared, $code, @param) = @_; + + $timeout = 10 if !$timeout; + + my $mode = $shared ? LOCK_SH : LOCK_EX; + + my $lock_func = sub { + if (!$lock_handles->{$$}->{$filename}) { + $lock_handles->{$$}->{$filename} = new IO::File (">>$filename") || + die "can't open file - $!\n"; + } + + if (!flock ($lock_handles->{$$}->{$filename}, $mode|LOCK_NB)) { + print STDERR "trying to aquire lock..."; + my $success; + while(1) { + $success = flock($lock_handles->{$$}->{$filename}, $mode); + # try again on EINTR (see bug #273) + if ($success || ($! != EINTR)) { + last; + } + } + if (!$success) { + print STDERR " failed\n"; + die "can't aquire lock - $!\n"; + } + print STDERR " OK\n"; + } + }; + + my $res; + + eval { run_with_timeout($timeout, $lock_func); }; + my $err = $@; + if ($err) { + $err = "can't lock file '$filename' - $err"; + } else { + eval { $res = &$code(@param) }; + $err = $@; + } + + if (my $fh = $lock_handles->{$$}->{$filename}) { + $lock_handles->{$$}->{$filename} = undef; + close ($fh); + } + + if ($err) { + $@ = $err; + return undef; + } + + $@ = undef; + + return $res; +} + + +sub lock_file { + my ($filename, $timeout, $code, @param) = @_; + + return lock_file_full($filename, $timeout, 0, $code, @param); +} + +sub file_set_contents { + my ($filename, $data, $perm) = @_; + + $perm = 0644 if !defined($perm); + + my $tmpname = "$filename.tmp.$$"; + + eval { + my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm); + die "unable to open file '$tmpname' - $!\n" if !$fh; + die "unable to write '$tmpname' - $!\n" unless print $fh $data; + die "closing file '$tmpname' failed - $!\n" unless close $fh; + }; + my $err = $@; + + if ($err) { + unlink $tmpname; + die $err; + } + + if (!rename($tmpname, $filename)) { + my $msg = "close (rename) atomic file '$filename' failed: $!\n"; + unlink $tmpname; + die $msg; + } +} + +sub file_get_contents { + my ($filename, $max) = @_; + + my $fh = IO::File->new($filename, "r") || + die "can't open '$filename' - $!\n"; + + my $content = safe_read_from($fh, $max); + + close $fh; + + return $content; +} + +sub file_read_firstline { + my ($filename) = @_; + + my $fh = IO::File->new ($filename, "r"); + return undef if !$fh; + my $res = <$fh>; + chomp $res if $res; + $fh->close; + return $res; +} + +sub safe_read_from { + my ($fh, $max, $oneline) = @_; + + $max = 32768 if !$max; + + my $br = 0; + my $input = ''; + my $count; + while ($count = sysread($fh, $input, 8192, $br)) { + $br += $count; + die "input too long - aborting\n" if $br > $max; + if ($oneline && $input =~ m/^(.*)\n/) { + $input = $1; + last; + } + } + die "unable to read input - $!\n" if !defined($count); + + return $input; +} + +sub run_command { + my ($cmd, %param) = @_; + + my $old_umask; + my $cmdstr; + + if (!ref($cmd)) { + $cmdstr = $cmd; + if ($cmd =~ m/|/) { + # see 'man bash' for option pipefail + $cmd = [ '/bin/bash', '-c', "set -o pipefail && $cmd" ]; + } else { + $cmd = [ $cmd ]; + } + } else { + $cmdstr = cmd2string($cmd); + } + + my $errmsg; + my $laststderr; + my $timeout; + my $oldtimeout; + my $pid; + + my $outfunc; + my $errfunc; + my $logfunc; + my $input; + my $output; + my $afterfork; + + eval { + + foreach my $p (keys %param) { + if ($p eq 'timeout') { + $timeout = $param{$p}; + } elsif ($p eq 'umask') { + $old_umask = umask($param{$p}); + } elsif ($p eq 'errmsg') { + $errmsg = $param{$p}; + } elsif ($p eq 'input') { + $input = $param{$p}; + } elsif ($p eq 'output') { + $output = $param{$p}; + } elsif ($p eq 'outfunc') { + $outfunc = $param{$p}; + } elsif ($p eq 'errfunc') { + $errfunc = $param{$p}; + } elsif ($p eq 'logfunc') { + $logfunc = $param{$p}; + } elsif ($p eq 'afterfork') { + $afterfork = $param{$p}; + } else { + die "got unknown parameter '$p' for run_command\n"; + } + } + + if ($errmsg) { + my $origerrfunc = $errfunc; + $errfunc = sub { + if ($laststderr) { + if ($origerrfunc) { + &$origerrfunc("$laststderr\n"); + } else { + print STDERR "$laststderr\n" if $laststderr; + } + } + $laststderr = shift; + }; + } + + my $reader = $output && $output =~ m/^>&/ ? $output : IO::File->new(); + my $writer = $input && $input =~ m/^<&/ ? $input : IO::File->new(); + my $error = IO::File->new(); + + # try to avoid locale related issues/warnings + my $lang = $param{lang} || 'C'; + + my $orig_pid = $$; + + eval { + local $ENV{LC_ALL} = $lang; + + # suppress LVM warnings like: "File descriptor 3 left open"; + local $ENV{LVM_SUPPRESS_FD_WARNINGS} = "1"; + + $pid = open3($writer, $reader, $error, @$cmd) || die $!; + + # if we pipe fron STDIN, open3 closes STDIN, so we we + # a perl warning "Filehandle STDIN reopened as GENXYZ .. " + # as soon as we open a new file. + # to avoid that we open /dev/null + if (!ref($writer) && !defined(fileno(STDIN))) { + POSIX::close(0); + open(STDIN, "add($reader) if ref($reader); + $select->add($error); + + my $outlog = ''; + my $errlog = ''; + + my $starttime = time(); + + while ($select->count) { + my @handles = $select->can_read(1); + + foreach my $h (@handles) { + my $buf = ''; + my $count = sysread ($h, $buf, 4096); + if (!defined ($count)) { + my $err = $!; + kill (9, $pid); + waitpid ($pid, 0); + die $err; + } + $select->remove ($h) if !$count; + if ($h eq $reader) { + if ($outfunc || $logfunc) { + eval { + $outlog .= $buf; + while ($outlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) { + my $line = $1; + &$outfunc($line) if $outfunc; + &$logfunc($line) if $logfunc; + } + }; + my $err = $@; + if ($err) { + kill (9, $pid); + waitpid ($pid, 0); + die $err; + } + } else { + print $buf; + *STDOUT->flush(); + } + } elsif ($h eq $error) { + if ($errfunc || $logfunc) { + eval { + $errlog .= $buf; + while ($errlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) { + my $line = $1; + &$errfunc($line) if $errfunc; + &$logfunc($line) if $logfunc; + } + }; + my $err = $@; + if ($err) { + kill (9, $pid); + waitpid ($pid, 0); + die $err; + } + } else { + print STDERR $buf; + *STDERR->flush(); + } + } + } + } + + &$outfunc($outlog) if $outfunc && $outlog; + &$logfunc($outlog) if $logfunc && $outlog; + + &$errfunc($errlog) if $errfunc && $errlog; + &$logfunc($errlog) if $logfunc && $errlog; + + waitpid ($pid, 0); + + if ($? == -1) { + die "failed to execute\n"; + } elsif (my $sig = ($? & 127)) { + die "got signal $sig\n"; + } elsif (my $ec = ($? >> 8)) { + if (!($ec == 24 && ($cmdstr =~ m|^(\S+/)?rsync\s|))) { + if ($errmsg && $laststderr) { + my $lerr = $laststderr; + $laststderr = undef; + die "$lerr\n"; + } + die "exit code $ec\n"; + } + } + + alarm(0); + }; + + my $err = $@; + + alarm(0); + + if ($errmsg && $laststderr) { + &$errfunc(undef); # flush laststderr + } + + umask ($old_umask) if defined($old_umask); + + alarm($oldtimeout) if $oldtimeout; + + if ($err) { + if ($pid && ($err eq "got timeout\n")) { + kill (9, $pid); + waitpid ($pid, 0); + die "command '$cmdstr' failed: $err"; + } + + if ($errmsg) { + $err =~ s/^usermod:\s*// if $cmdstr =~ m|^(\S+/)?usermod\s|; + die "$errmsg: $err"; + } else { + die "command '$cmdstr' failed: $err"; + } + } + + return undef; +} + +sub split_list { + my $listtxt = shift || ''; + + return split (/\0/, $listtxt) if $listtxt =~ m/\0/; + + $listtxt =~ s/[,;]/ /g; + $listtxt =~ s/^\s+//; + + my @data = split (/\s+/, $listtxt); + + return @data; +} + +sub trim { + my $txt = shift; + + return $txt if !defined($txt); + + $txt =~ s/^\s+//; + $txt =~ s/\s+$//; + + return $txt; +} + +# simple uri templates like "/vms/{vmid}" +sub template_replace { + my ($tmpl, $data) = @_; + + return $tmpl if !$tmpl; + + my $res = ''; + while ($tmpl =~ m/([^{]+)?({([^}]+)})?/g) { + $res .= $1 if $1; + $res .= ($data->{$3} || '-') if $2; + } + return $res; +} + +sub safe_print { + my ($filename, $fh, $data) = @_; + + return if !$data; + + my $res = print $fh $data; + + die "write to '$filename' failed\n" if !$res; +} + +sub debmirrors { + + return { + 'at' => 'ftp.at.debian.org', + 'au' => 'ftp.au.debian.org', + 'be' => 'ftp.be.debian.org', + 'bg' => 'ftp.bg.debian.org', + 'br' => 'ftp.br.debian.org', + 'ca' => 'ftp.ca.debian.org', + 'ch' => 'ftp.ch.debian.org', + 'cl' => 'ftp.cl.debian.org', + 'cz' => 'ftp.cz.debian.org', + 'de' => 'ftp.de.debian.org', + 'dk' => 'ftp.dk.debian.org', + 'ee' => 'ftp.ee.debian.org', + 'es' => 'ftp.es.debian.org', + 'fi' => 'ftp.fi.debian.org', + 'fr' => 'ftp.fr.debian.org', + 'gr' => 'ftp.gr.debian.org', + 'hk' => 'ftp.hk.debian.org', + 'hr' => 'ftp.hr.debian.org', + 'hu' => 'ftp.hu.debian.org', + 'ie' => 'ftp.ie.debian.org', + 'is' => 'ftp.is.debian.org', + 'it' => 'ftp.it.debian.org', + 'jp' => 'ftp.jp.debian.org', + 'kr' => 'ftp.kr.debian.org', + 'mx' => 'ftp.mx.debian.org', + 'nl' => 'ftp.nl.debian.org', + 'no' => 'ftp.no.debian.org', + 'nz' => 'ftp.nz.debian.org', + 'pl' => 'ftp.pl.debian.org', + 'pt' => 'ftp.pt.debian.org', + 'ro' => 'ftp.ro.debian.org', + 'ru' => 'ftp.ru.debian.org', + 'se' => 'ftp.se.debian.org', + 'si' => 'ftp.si.debian.org', + 'sk' => 'ftp.sk.debian.org', + 'tr' => 'ftp.tr.debian.org', + 'tw' => 'ftp.tw.debian.org', + 'gb' => 'ftp.uk.debian.org', + 'us' => 'ftp.us.debian.org', + }; +} + +my $keymaphash = { + 'dk' => ['Danish', 'da', 'qwerty/dk-latin1.kmap.gz', 'dk', 'nodeadkeys'], + 'de' => ['German', 'de', 'qwertz/de-latin1-nodeadkeys.kmap.gz', 'de', 'nodeadkeys' ], + 'de-ch' => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz', 'ch', 'de_nodeadkeys' ], + 'en-gb' => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', undef], + 'en-us' => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz', 'us', undef ], + 'es' => ['Spanish', 'es', 'qwerty/es.kmap.gz', 'es', 'nodeadkeys'], + #'et' => [], # Ethopia or Estonia ?? + 'fi' => ['Finnish', 'fi', 'qwerty/fi-latin1.kmap.gz', 'fi', 'nodeadkeys'], + #'fo' => ['Faroe Islands', 'fo', ???, 'fo', 'nodeadkeys'], + 'fr' => ['French', 'fr', 'azerty/fr-latin1.kmap.gz', 'fr', 'nodeadkeys'], + 'fr-be' => ['Belgium-French', 'fr-be', 'azerty/be2-latin1.kmap.gz', 'be', 'nodeadkeys'], + 'fr-ca' => ['Canada-French', 'fr-ca', 'qwerty/cf.kmap.gz', 'ca', 'fr-legacy'], + 'fr-ch' => ['Swiss-French', 'fr-ch', 'qwertz/fr_CH-latin1.kmap.gz', 'ch', 'fr_nodeadkeys'], + #'hr' => ['Croatia', 'hr', 'qwertz/croat.kmap.gz', 'hr', ??], # latin2? + 'hu' => ['Hungarian', 'hu', 'qwertz/hu.kmap.gz', 'hu', undef], + 'is' => ['Icelandic', 'is', 'qwerty/is-latin1.kmap.gz', 'is', 'nodeadkeys'], + 'it' => ['Italian', 'it', 'qwerty/it2.kmap.gz', 'it', 'nodeadkeys'], + 'jp' => ['Japanese', 'ja', 'qwerty/jp106.kmap.gz', 'jp', undef], + 'lt' => ['Lithuanian', 'lt', 'qwerty/lt.kmap.gz', 'lt', 'std'], + #'lv' => ['Latvian', 'lv', 'qwerty/lv-latin4.kmap.gz', 'lv', ??], # latin4 or latin7? + 'mk' => ['Macedonian', 'mk', 'qwerty/mk.kmap.gz', 'mk', 'nodeadkeys'], + 'nl' => ['Dutch', 'nl', 'qwerty/nl.kmap.gz', 'nl', undef], + #'nl-be' => ['Belgium-Dutch', 'nl-be', ?, ?, ?], + 'no' => ['Norwegian', 'no', 'qwerty/no-latin1.kmap.gz', 'no', 'nodeadkeys'], + 'pl' => ['Polish', 'pl', 'qwerty/pl.kmap.gz', 'pl', undef], + 'pt' => ['Portuguese', 'pt', 'qwerty/pt-latin1.kmap.gz', 'pt', 'nodeadkeys'], + 'pt-br' => ['Brazil-Portuguese', 'pt-br', 'qwerty/br-latin1.kmap.gz', 'br', 'nodeadkeys'], + #'ru' => ['Russian', 'ru', 'qwerty/ru.kmap.gz', 'ru', undef], # dont know? + 'si' => ['Slovenian', 'sl', 'qwertz/slovene.kmap.gz', 'si', undef], + 'se' => ['Swedish', 'sv', 'qwerty/se-latin1.kmap.gz', 'se', 'nodeadkeys'], + #'th' => [], + 'tr' => ['Turkish', 'tr', 'qwerty/trq.kmap.gz', 'tr', undef], +}; + +my $kvmkeymaparray = []; +foreach my $lc (keys %$keymaphash) { + push @$kvmkeymaparray, $keymaphash->{$lc}->[1]; +} + +sub kvmkeymaps { + return $keymaphash; +} + +sub kvmkeymaplist { + return $kvmkeymaparray; +} + +sub extract_param { + my ($param, $key) = @_; + + my $res = $param->{$key}; + delete $param->{$key}; + + return $res; +} + +# Note: we use this to wait until vncterm/spiceterm is ready +sub wait_for_vnc_port { + my ($port, $timeout) = @_; + + $timeout = 5 if !$timeout; + my $sleeptime = 0; + my $starttime = [gettimeofday]; + my $elapsed; + + while (($elapsed = tv_interval($starttime)) < $timeout) { + if (my $fh = IO::File->new ("/proc/net/tcp", "r")) { + while (defined (my $line = <$fh>)) { + if ($line =~ m/^\s*\d+:\s+([0-9A-Fa-f]{8}):([0-9A-Fa-f]{4})\s/) { + if ($port == hex($2)) { + close($fh); + return 1; + } + } + } + close($fh); + } + $sleeptime += 100000 if $sleeptime < 1000000; + usleep($sleeptime); + } + + return undef; +} + +sub next_unused_port { + my ($range_start, $range_end) = @_; + + # We use a file to register allocated ports. + # Those registrations expires after $expiretime. + # We use this to avoid race conditions between + # allocation and use of ports. + + my $filename = "/var/tmp/pve-reserved-ports"; + + my $code = sub { + + my $expiretime = 5; + my $ctime = time(); + + my $ports = {}; + + if (my $fh = IO::File->new ($filename, "r")) { + while (my $line = <$fh>) { + if ($line =~ m/^(\d+)\s(\d+)$/) { + my ($port, $timestamp) = ($1, $2); + if (($timestamp + $expiretime) > $ctime) { + $ports->{$port} = $timestamp; # not expired + } + } + } + } + + my $newport; + + for (my $p = $range_start; $p < $range_end; $p++) { + next if $ports->{$p}; # reserved + + my $sock = IO::Socket::INET->new(Listen => 5, + LocalAddr => '0.0.0.0', + LocalPort => $p, + ReuseAddr => 1, + Proto => 0); + + if ($sock) { + close($sock); + $newport = $p; + $ports->{$p} = $ctime; + last; + } + } + + my $data = ""; + foreach my $p (keys %$ports) { + $data .= "$p $ports->{$p}\n"; + } + + file_set_contents($filename, $data); + + return $newport; + }; + + my $p = lock_file($filename, 10, $code); + die $@ if $@; + + die "unable to find free port (${range_start}-${range_end})\n" if !$p; + + return $p; +} + +sub next_migrate_port { + return next_unused_port(60000, 60050); +} + +sub next_vnc_port { + return next_unused_port(5900, 6000); +} + +sub next_spice_port { + return next_unused_port(61000, 61099); +} + +# NOTE: NFS syscall can't be interrupted, so alarm does +# not work to provide timeouts. +# from 'man nfs': "Only SIGKILL can interrupt a pending NFS operation" +# So the spawn external 'df' process instead of using +# Filesys::Df (which uses statfs syscall) +sub df { + my ($path, $timeout) = @_; + + my $cmd = [ 'df', '-P', '-B', '1', $path]; + + my $res = { + total => 0, + used => 0, + avail => 0, + }; + + my $parser = sub { + my $line = shift; + if (my ($fsid, $total, $used, $avail) = $line =~ + m/^(\S+.*)\s+(\d+)\s+(\d+)\s+(\d+)\s+\d+%\s.*$/) { + $res = { + total => $total, + used => $used, + avail => $avail, + }; + } + }; + eval { run_command($cmd, timeout => $timeout, outfunc => $parser); }; + warn $@ if $@; + + return $res; +} + +# UPID helper +# We use this to uniquely identify a process. +# An 'Unique Process ID' has the following format: +# "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user" + +sub upid_encode { + my $d = shift; + + # Note: pstart can be > 32bit if uptime > 497 days, so this can result in + # more that 8 characters for pstart + return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid}, + $d->{pstart}, $d->{starttime}, $d->{type}, $d->{id}, + $d->{user}); +} + +sub upid_decode { + my ($upid, $noerr) = @_; + + my $res; + my $filename; + + # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user" + # Note: allow up to 9 characters for pstart (work until 20 years uptime) + if ($upid =~ m/^UPID:([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8,9}):([0-9A-Fa-f]{8}):([^:\s]+):([^:\s]*):([^:\s]+):$/) { + $res->{node} = $1; + $res->{pid} = hex($3); + $res->{pstart} = hex($4); + $res->{starttime} = hex($5); + $res->{type} = $6; + $res->{id} = $7; + $res->{user} = $8; + + my $subdir = substr($5, 7, 8); + $filename = "$pvetaskdir/$subdir/$upid"; + + } else { + return undef if $noerr; + die "unable to parse worker upid '$upid'\n"; + } + + return wantarray ? ($res, $filename) : $res; +} + +sub upid_open { + my ($upid) = @_; + + my ($task, $filename) = upid_decode($upid); + + my $dirname = dirname($filename); + make_path($dirname); + + my $wwwid = getpwnam('www-data') || + die "getpwnam failed"; + + my $perm = 0640; + + my $outfh = IO::File->new ($filename, O_WRONLY|O_CREAT|O_EXCL, $perm) || + die "unable to create output file '$filename' - $!\n"; + chown $wwwid, -1, $outfh; + + return $outfh; +}; + +sub upid_read_status { + my ($upid) = @_; + + my ($task, $filename) = upid_decode($upid); + my $fh = IO::File->new($filename, "r"); + return "unable to open file - $!" if !$fh; + my $maxlen = 4096; + sysseek($fh, -$maxlen, 2); + my $readbuf = ''; + my $br = sysread($fh, $readbuf, $maxlen); + close($fh); + if ($br) { + return "unable to extract last line" + if $readbuf !~ m/\n?(.+)$/; + my $line = $1; + if ($line =~ m/^TASK OK$/) { + return 'OK'; + } elsif ($line =~ m/^TASK ERROR: (.+)$/) { + return $1; + } else { + return "unexpected status"; + } + } + return "unable to read tail (got $br bytes)"; +} + +# useful functions to store comments in config files +sub encode_text { + my ($text) = @_; + + # all control and hi-bit characters, and ':' + my $unsafe = "^\x20-\x39\x3b-\x7e"; + return uri_escape(Encode::encode("utf8", $text), $unsafe); +} + +sub decode_text { + my ($data) = @_; + + return Encode::decode("utf8", uri_unescape($data)); +} + +sub decode_utf8_parameters { + my ($param) = @_; + + foreach my $p (qw(comment description firstname lastname)) { + $param->{$p} = decode('utf8', $param->{$p}) if $param->{$p}; + } + + return $param; +} + +sub random_ether_addr { + + my ($seconds, $microseconds) = gettimeofday; + + my $rand = Digest::SHA::sha1_hex($$, rand(), $seconds, $microseconds); + + my $mac = ''; + for (my $i = 0; $i < 6; $i++) { + my $ss = hex(substr($rand, $i*2, 2)); + if (!$i) { + $ss &= 0xfe; # clear multicast + $ss |= 2; # set local id + } + $ss = sprintf("%02X", $ss); + + if (!$i) { + $mac .= "$ss"; + } else { + $mac .= ":$ss"; + } + } + + return $mac; +} + +sub shellquote { + my $str = shift; + + return String::ShellQuote::shell_quote($str); +} + +sub cmd2string { + my ($cmd) = @_; + + die "no arguments" if !$cmd; + + return $cmd if !ref($cmd); + + my @qa = (); + foreach my $arg (@$cmd) { push @qa, shellquote($arg); } + + return join (' ', @qa); +} + +# split an shell argument string into an array, +sub split_args { + my ($str) = @_; + + return $str ? [ Text::ParseWords::shellwords($str) ] : []; +} + +sub dump_logfile { + my ($filename, $start, $limit, $filter) = @_; + + my $lines = []; + my $count = 0; + + my $fh = IO::File->new($filename, "r"); + if (!$fh) { + $count++; + push @$lines, { n => $count, t => "unable to open file - $!"}; + return ($count, $lines); + } + + $start = 0 if !$start; + $limit = 50 if !$limit; + + my $line; + + if ($filter) { + # duplicate code, so that we do not slow down normal path + while (defined($line = <$fh>)) { + next if $line !~ m/$filter/; + next if $count++ < $start; + next if $limit <= 0; + chomp $line; + push @$lines, { n => $count, t => $line}; + $limit--; + } + } else { + while (defined($line = <$fh>)) { + next if $count++ < $start; + next if $limit <= 0; + chomp $line; + push @$lines, { n => $count, t => $line}; + $limit--; + } + } + + close($fh); + + # HACK: ExtJS store.guaranteeRange() does not like empty array + # so we add a line + if (!$count) { + $count++; + push @$lines, { n => $count, t => "no content"}; + } + + return ($count, $lines); +} + +sub dir_glob_regex { + my ($dir, $regex) = @_; + + my $dh = IO::Dir->new ($dir); + return wantarray ? () : undef if !$dh; + + while (defined(my $tmp = $dh->read)) { + if (my @res = $tmp =~ m/^($regex)$/) { + $dh->close; + return wantarray ? @res : $tmp; + } + } + $dh->close; + + return wantarray ? () : undef; +} + +sub dir_glob_foreach { + my ($dir, $regex, $func) = @_; + + my $dh = IO::Dir->new ($dir); + if (defined $dh) { + while (defined(my $tmp = $dh->read)) { + if (my @res = $tmp =~ m/^($regex)$/) { + &$func (@res); + } + } + } +} + +sub assert_if_modified { + my ($digest1, $digest2) = @_; + + if ($digest1 && $digest2 && ($digest1 ne $digest2)) { + die "detected modified configuration - file changed by other user? Try again.\n"; + } +} + +# Digest for short strings +# like FNV32a, but we only return 31 bits (positive numbers) +sub fnv31a { + my ($string) = @_; + + my $hval = 0x811c9dc5; + + foreach my $c (unpack('C*', $string)) { + $hval ^= $c; + $hval += ( + (($hval << 1) ) + + (($hval << 4) ) + + (($hval << 7) ) + + (($hval << 8) ) + + (($hval << 24) ) ); + $hval = $hval & 0xffffffff; + } + return $hval & 0x7fffffff; +} + +sub fnv31a_hex { return sprintf("%X", fnv31a(@_)); } + +1;