Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
Open sidebar
Projets publics
Ravada-Mirror
Commits
8c7680dd
Commit
8c7680dd
authored
Mar 24, 2020
by
Francesc Guasch
Browse files
Merge branch 'master' of
https://github.com/UPC/ravada
parents
93325365
ec68c9da
Changes
15
Hide whitespace changes
Inline
Side-by-side
lib/Ravada.pm
View file @
8c7680dd
...
...
@@ -878,6 +878,7 @@ sub _add_indexes_generic($self) {
my
%index
=
(
requests
=>
[
"
index(status,at_time)
"
,"
index(id,date_changed,status,at_time)
"
,"
index(date_changed)
"
,"
index(start_time,command,status,pid)
"
]
...
...
@@ -887,6 +888,9 @@ sub _add_indexes_generic($self) {
,
iptables
=>
[
"
index(id_domain,time_deleted,time_req)
"
]
,
messages
=>
[
"
index(id_request,date_send)
"
]
);
for
my
$table
(
keys
%index
)
{
my
$known
=
$self
->
_get_indexes
(
$table
);
...
...
@@ -1687,18 +1691,13 @@ sub create_domain {
my
$user
=
Ravada::Auth::
SQL
->
search_by_id
(
$id_owner
);
$request
->
status
("
creating machine
")
if
$request
;
if
(
$base
&&
$base
->
is_base
)
{
if
(
$base
&&
$base
->
is_base
&&
$base
->
volatile_clones
||
$user
->
is_temporary
)
{
$request
->
status
("
balancing
")
if
$request
;
$vm
=
$vm
->
balance_vm
(
$base
)
or
die
"
Error: No free nodes available.
";
$request
->
status
("
creating machine on
"
.
$vm
->
name
)
if
$request
;
}
confess
"
No vm found, request =
"
.
Dumper
(
request
=>
$request
)
if
!
$vm
;
carp
"
WARNING: no VM defined, we will use
"
.
$vm
->
name
if
!
$vm_name
&&
!
$id_base
;
confess
"
I can't find any vm
"
.
Dumper
(
$self
->
vm
)
if
!
$vm
;
confess
"
Error: missing vm
"
if
!
$vm
;
my
$domain
;
eval
{
$domain
=
$vm
->
create_domain
(
%args
)};
...
...
@@ -2689,7 +2688,7 @@ sub _can_fork {
delete
$reqs
{
$pid
}
if
!
$request
||
$request
->
status
eq
'
done
';
}
my
$n_pids
=
scalar
(
keys
%reqs
);
return
1
if
$n_pids
<
=
$req
->
requests_limit
();
return
1
if
$n_pids
<
$req
->
requests_limit
();
my
$msg
=
$req
->
command
.
"
waiting for processes to finish
"
...
...
@@ -3590,9 +3589,12 @@ sub _cmd_cleanup($self, $request) {
$self
->
_clean_volatile_machines
(
request
=>
$request
);
$self
->
_clean_temporary_users
(
);
$self
->
_clean_requests
('
cleanup
',
$request
);
$self
->
_clean_requests
('
cleanup
',
$request
,'
done
');
$self
->
_clean_requests
('
enforce_limits
',
$request
,'
done
');
$self
->
_clean_requests
('
refresh_vms
',
$request
,'
done
');
for
my
$cmd
(
qw(cleanup enforce_limits refresh_vms
manage_pools refresh_machine screenshot
open_iptables ping_backend
)
)
{
$self
->
_clean_requests
(
$cmd
,
$request
,'
done
');
}
}
sub
_req_method
{
...
...
lib/Ravada/Domain.pm
View file @
8c7680dd
...
...
@@ -293,6 +293,7 @@ sub _vm_disconnect {
}
sub
_around_start
($orig, $self, @arg) {
$self
->
_start_preconditions
(
@arg
);
my
%arg
;
...
...
@@ -305,25 +306,51 @@ sub _around_start($orig, $self, @arg) {
my
$listen_ip
=
delete
$arg
{
listen_ip
};
my
$remote_ip
=
$arg
{
remote_ip
};
if
(
!
defined
$listen_ip
)
{
my
$display_ip
;
if
(
$remote_ip
)
{
my
$set_password
=
0
;
my
$network
=
Ravada::
Network
->
new
(
address
=>
$remote_ip
);
$set_password
=
1
if
$network
->
requires_password
();
$display_ip
=
$self
->
_listen_ip
(
$remote_ip
);
$arg
{
set_password
}
=
$set_password
;
}
else
{
$display_ip
=
$self
->
_listen_ip
();
for
(;;)
{
eval
{
$self
->
_start_checks
(
@arg
)
};
if
(
$@
&&
$@
=~
/base file not found/
&&
!
$self
->
_vm
->
is_local
)
{
$self
->
_request_set_base
();
next
;
}
if
(
!
defined
$listen_ip
)
{
my
$display_ip
;
if
(
$remote_ip
)
{
my
$set_password
=
0
;
my
$network
=
Ravada::
Network
->
new
(
address
=>
$remote_ip
);
$set_password
=
1
if
$network
->
requires_password
();
$display_ip
=
$self
->
_listen_ip
(
$remote_ip
);
$arg
{
set_password
}
=
$set_password
;
}
else
{
$display_ip
=
$self
->
_listen_ip
();
}
$arg
{
listen_ip
}
=
$display_ip
;
}
$arg
{
listen_ip
}
=
$display_ip
;
eval
{
$self
->
$orig
(
%arg
)
};
last
if
!
$@
;
warn
$@
if
$@
;
if
(
$@
&&
$self
->
id_base
&&
!
$self
->
_vm
->
is_local
&&
$self
->
_vm
->
enabled
)
{
$self
->
_request_set_base
();
next
;
}
die
$@
;
}
my
$ret
=
$self
->
$orig
(
%arg
);
$self
->
_post_start
(
%arg
);
}
sub
_request_set_base
($self) {
my
$base
=
Ravada::
Domain
->
open
(
$self
->
id_base
);
$base
->
_set_base_vm_db
(
$self
->
_vm
->
id
,
0
);
Ravada::
Request
->
set_base_vm
(
uid
=>
Ravada::Utils::
user_daemon
->
id
,
id_domain
=>
$base
->
id
,
id_vm
=>
$self
->
_vm
->
id
,
at
=>
time
+
int
(
rand
(
10
))
);
my
$vm_local
=
$self
->
_vm
->
new
(
host
=>
'
localhost
'
);
$self
->
_set_vm
(
$vm_local
,
1
);
}
sub
_start_preconditions
{
my
(
$self
)
=
@_
;
...
...
@@ -348,9 +375,18 @@ sub _start_preconditions{
_allow_manage
(
@
_
);
}
#_check_used_memory(@_);
$self
->
status
('
starting
');
}
sub
_start_checks
($self, @args) {
return
if
$self
->
_search_already_started
('
fast
');
$self
->
status
('
starting
');
my
(
$id_vm
,
$request
);
if
(
!
scalar
(
@args
)
%
2
)
{
my
%args
=
@args
;
$id_vm
=
delete
$args
{
id_vm
};
$request
=
delete
$args
{
request
}
if
exists
$args
{
request
};
}
# if it is a clone ( it is not a base )
if
(
$self
->
id_base
)
{
# $self->_set_last_vm(1)
...
...
@@ -358,6 +394,7 @@ sub _start_preconditions{
my
$vm_local
=
$self
->
_vm
->
new
(
host
=>
'
localhost
'
);
$self
->
_set_vm
(
$vm_local
,
1
);
}
$self
->
_check_tmp_volumes
();
my
$vm
;
if
(
$id_vm
)
{
$vm
=
Ravada::
VM
->
open
(
$id_vm
);
...
...
@@ -377,7 +414,6 @@ sub _start_preconditions{
my
$vm_local
=
$self
->
_vm
->
new
(
host
=>
'
localhost
'
);
$self
->
_set_vm
(
$vm_local
,
1
);
}
$self
->
status
('
starting
');
$self
->
_check_free_vm_memory
();
#TODO: remove them and make it more general now we have nodes
#$self->_check_cpu_usage($request);
...
...
@@ -441,10 +477,25 @@ sub _balance_vm($self) {
my
$base
;
$base
=
Ravada::
Domain
->
open
(
$self
->
id_base
)
if
$self
->
id_base
;
my
$vm_free
=
$self
->
_vm
->
balance_vm
(
$base
);
return
if
!
$vm_free
;
my
$vm_free
;
for
(;;)
{
$vm_free
=
$self
->
_vm
->
balance_vm
(
$base
);
return
if
!
$vm_free
;
$self
->
migrate
(
$vm_free
)
if
$vm_free
->
id
!=
$self
->
_vm
->
id
;
last
if
$vm_free
->
id
==
$self
->
_vm
->
id
;
eval
{
$self
->
migrate
(
$vm_free
)
};
last
if
!
$@
;
if
(
$@
&&
$@
=~
/file not found/i
)
{
$base
->
_set_base_vm_db
(
$vm_free
->
id
,
0
);
Ravada::
Request
->
set_base_vm
(
uid
=>
Ravada::Utils::
user_daemon
->
id
,
id_domain
=>
$base
->
id
,
id_vm
=>
$vm_free
->
id
);
next
;
}
die
$@
;
}
return
$vm_free
->
id
;
}
...
...
@@ -494,6 +545,8 @@ sub _allow_remove($self, $user) {
return
if
!
$self
->
is_known
();
# already removed
confess
"
Error: arg user is not Ravada::Auth object
"
if
!
ref
(
$user
);
die
"
ERROR: remove not allowed for user
"
.
$user
->
name
unless
$user
->
can_remove_machine
(
$self
);
...
...
@@ -657,7 +710,8 @@ sub prepare_base($self, $with_cd) {
for
my
$volume
(
$self
->
list_volumes_info
())
{
my
$base_file
=
$volume
->
base_filename
;
next
if
!
$base_file
||
$base_file
=~
/\.iso$/
;
die
"
Error: file '
$base_file
' already exists
"
if
$self
->
_vm
->
file_exists
(
$base_file
);
confess
"
Error: file '
$base_file
' already exists in
"
.
$self
->
_vm
->
name
if
$self
->
_vm
->
file_exists
(
$base_file
);
}
for
my
$volume
(
$self
->
list_volumes_info
())
{
...
...
@@ -812,12 +866,43 @@ sub _check_free_vm_memory {
return
if
$vm_free_mem
>
$self
->
_vm
->
min_free_memory
;
my
$msg
=
"
Error: No free memory. Only
"
.
_gb
(
$vm_free_mem
)
.
"
out of
"
my
$msg
=
"
Error: No free memory
in
"
.
$self
->
_vm
->
name
.
"
. Only
"
.
_gb
(
$vm_free_mem
)
.
"
out of
"
.
_gb
(
$self
->
_vm
->
min_free_memory
)
.
"
GB required.
\n
";
die
$msg
;
}
sub
_check_tmp_volumes
($self) {
confess
"
Error: only clones temporary volumes can be checked.
"
if
!
$self
->
id_base
;
for
my
$vol
(
$self
->
list_volumes_info
)
{
next
unless
$vol
->
file
&&
$vol
->
file
=~
/\.(TMP|SWAP)\./
;
next
if
$self
->
_vm
->
file_exists
(
$vol
->
file
);
my
$base
=
Ravada::
Domain
->
open
(
$self
->
id_base
);
if
(
!
$self
->
is_local
)
{
Ravada::
Request
->
set_base_vm
(
id_domain
=>
$base
->
id
,
id_vm
=>
$self
->
_vm
->
id
,
uid
=>
Ravada::Utils::
user_daemon
->
id
);
confess
"
Error: base file not found in node
"
.
$self
->
_vm
->
name
.
"
"
.
$vol
->
file
;
}
my
@volumes
=
$base
->
list_files_base_target
;
my
(
$file_base
)
=
grep
{
$_
->
[
1
]
eq
$vol
->
info
->
{
target
}
}
@volumes
;
if
(
!
$file_base
)
{
warn
"
Error: I can't find base volume for target
"
.
$vol
->
info
->
{
target
}
.
Dumper
(
\
@volumes
);
}
my
$vol_base
=
Ravada::
Volume
->
new
(
file
=>
$file_base
->
[
0
]
,
vm
=>
$self
->
_vm
);
$vol_base
->
clone
(
file
=>
$vol
->
file
);
warn
"
cloned
"
.
$self
->
name
.
"
"
.
$self
->
_vm
->
name
.
"
"
.
$vol_base
->
vm
->
name
.
"
"
.
$vol
->
info
->
{
target
};
}
}
sub
_check_cpu_usage
($self, $request=undef){
return
if
ref
(
$self
)
=~
/Void/i
;
...
...
@@ -1909,18 +1994,54 @@ sub remove_base($self, $user) {
return
$self
->
_do_remove_base
(
$user
);
}
sub
_do_remove_base
($self, $user) {
if
(
$self
->
is_base
)
{
for
my
$vm
(
$self
->
list_vms
)
{
$self
->
remove_base_vm
(
vm
=>
$vm
,
user
=>
$user
)
if
!
$vm
->
is_local
;
}
sub
_cascade_remove_base_in_nodes
($self) {
my
$req_nodes
;
for
my
$vm
(
$self
->
list_vms
)
{
next
if
$vm
->
is_local
;
my
@after
;
push
@after
,(
after_request
=>
$req_nodes
->
id
)
if
$req_nodes
;
$req_nodes
=
Ravada::
Request
->
remove_base_vm
(
id_vm
=>
$vm
->
id
,
id_domain
=>
$self
->
id
,
uid
=>
Ravada::Utils::
user_daemon
->
id
,
@after
);
}
$self
->
is_base
(
0
);
if
(
$req_nodes
)
{
my
$vm_local
=
$self
->
_vm
->
new
(
host
=>
'
localhost
'
);
Ravada::
Request
->
remove_base_vm
(
id_vm
=>
$vm_local
->
id
,
id_domain
=>
$self
->
id
,
uid
=>
Ravada::Utils::
user_daemon
->
id
,
after_request
=>
$req_nodes
->
id
);
$self
->
is_base
(
0
);
}
return
$req_nodes
;
}
sub
_do_remove_base
($self, $user) {
return
if
$self
->
is_base
&&
$self
->
is_local
&&
$self
->
_cascade_remove_base_in_nodes
();
$self
->
is_base
(
0
)
if
$self
->
is_local
;
my
$vm_local
=
$self
->
_vm
->
new
(
host
=>
'
localhost
'
);
for
my
$vol
(
$self
->
list_volumes_info
)
{
next
if
!
$vol
->
file
||
$vol
->
file
=~
/\.iso$/
;
my
$backing_file
=
$vol
->
backing_file
;
next
if
!
$backing_file
;
# confess "Error: no backing file for ".$vol->file if !$backing_file;
if
(
!
$self
->
is_local
)
{
my
(
$dir
)
=
$backing_file
=~
m{(.*/)}
;
if
(
$self
->
_vm
->
shared_storage
(
$vm_local
,
$dir
)
)
{
next
;
}
$self
->
_vm
->
remove_file
(
$vol
->
file
);
$self
->
_vm
->
remove_file
(
$backing_file
);
$self
->
_vm
->
refresh_storage_pools
();
return
;
}
$vol
->
block_commit
();
unlink
$vol
->
file
or
die
"
$!
"
.
$vol
->
file
;
my
@stat
=
stat
(
$backing_file
);
...
...
@@ -1958,20 +2079,10 @@ sub _pre_remove_base {
sub
_post_remove_base
{
my
$self
=
shift
;
return
if
!
$self
->
_vm
->
is_local
;
$self
->
_remove_base_db
(
@
_
);
$self
->
_post_remove_base_domain
();
$self
->
_remove_all_bases
();
}
sub
_remove_all_bases
($self) {
my
$sth
=
$$CONNECTOR
->
dbh
->
prepare
("
SELECT id_vm FROM bases_vm
"
.
"
WHERE id_domain=? AND enabled=1
"
);
$sth
->
execute
(
$self
->
id
);
while
(
my
(
$id_vm
)
=
$sth
->
fetchrow
)
{
$self
->
remove_base_vm
(
id_vm
=>
$id_vm
);
}
}
sub
_post_spinoff
($self) {
...
...
@@ -3681,19 +3792,12 @@ sub _pre_migrate($self, $node, $request = undef) {
my
$base
=
Ravada::
Domain
->
open
(
$self
->
id_base
);
confess
"
ERROR: base id
"
.
$self
->
id_base
.
"
not found.
"
if
!
$base
;
die
"
ERROR: Base
"
.
$base
->
name
.
"
files not migrated to
"
.
$node
->
name
confess
"
ERROR: Base
"
.
$base
->
name
.
"
files not migrated to
"
.
$node
->
name
if
!
$base
->
base_in_vm
(
$node
->
id
);
for
my
$file
(
$base
->
list_files_base
)
{
my
(
$name
)
=
$file
=~
m{.*/(.*)}
;
my
$vol_path
=
$node
->
search_volume_path
(
$name
);
die
"
ERROR:
$file
not found in
"
.
$node
->
host
if
!
$vol_path
;
die
"
ERROR:
$name
found at
$vol_path
instead
$file
"
if
$vol_path
ne
$file
;
next
if
$node
->
file_exists
(
$file
);
confess
"
ERROR: file not found
$file
in
"
.
$node
->
host
;
}
$self
->
_set_base_vm_db
(
$node
->
id
,
0
);
...
...
@@ -3782,13 +3886,9 @@ sub set_base_vm($self, %args) {
$value
=
1
if
!
defined
$value
;
if
(
$vm
->
is_local
)
{
$self
->
_set_vm
(
$vm
,
1
);
$self
->
_set_vm
(
$vm
,
1
);
# force set vm on domain
if
(
!
$value
)
{
$request
->
status
("
working
","
Removing base
")
if
$request
;
for
my
$vm_node
(
$self
->
list_vms
)
{
$self
->
set_base_vm
(
vm
=>
$vm_node
,
user
=>
$user
,
value
=>
0
,
request
=>
$request
)
if
!
$vm_node
->
is_local
;
}
$self
->
_set_base_vm_db
(
$vm
->
id
,
$value
);
$self
->
remove_base
(
$user
);
}
else
{
...
...
@@ -3800,20 +3900,8 @@ sub set_base_vm($self, %args) {
if
$request
;
$self
->
migrate
(
$vm
,
$request
);
}
else
{
if
(
$vm
->
is_active
)
{
my
$vm_local
=
$self
->
_vm
->
new
(
host
=>
'
localhost
'
);
for
my
$file
(
$self
->
list_files_base
())
{
my
(
$path
)
=
$file
=~
m{(.*/)}
;
next
if
$vm_local
->
shared_storage
(
$vm
,
$path
);
confess
"
Error: file has non-valid characters
"
if
$file
=~
/[*;&'" ]/
;
my
(
$out
,
$err
);
eval
{
(
$out
,
$err
)
=
$vm
->
remove_file
(
$file
)
if
$vm
->
file_exists
(
$file
);
};
$err
=
$@
if
!
$err
&&
$@
;
warn
$err
if
$err
;
}
}
$self
->
_set_vm
(
$vm
,
1
);
# force set vm on domain
$self
->
_do_remove_base
(
$user
);
}
if
(
!
$vm
->
is_local
)
{
...
...
@@ -3843,6 +3931,7 @@ sub remove_base_vm($self, %args) {
confess
"
ERROR: Unknown arguments
"
.
join
('
,
',
sort
keys
%args
)
.
"
, valid are user and vm.
"
if
keys
%args
;
warn
$vm
->
name
;
return
$self
->
set_base_vm
(
vm
=>
$vm
,
user
=>
$user
,
value
=>
0
);
}
...
...
@@ -3883,7 +3972,7 @@ Returns a list for virtual machine managers where this domain is base
sub
list_vms
($self) {
confess
"
Domain is not base
"
if
!
$self
->
is_base
;
my
$sth
=
$$CONNECTOR
->
dbh
->
prepare
("
SELECT id_vm FROM bases_vm WHERE id_domain=?
");
my
$sth
=
$$CONNECTOR
->
dbh
->
prepare
("
SELECT id_vm FROM bases_vm WHERE id_domain=?
AND enabled = 1
");
$sth
->
execute
(
$self
->
id
);
my
@vms
;
while
(
my
$id_vm
=
$sth
->
fetchrow
)
{
...
...
lib/Ravada/Domain/KVM.pm
View file @
8c7680dd
...
...
@@ -662,9 +662,12 @@ sub start {
}
return
if
!
$error
||
$error
=~
/already running/i
;
if
(
$error
=~
/libvirt error code: 38,/
)
{
warn
"
Error starting
"
.
$self
->
name
.
"
on
"
.
$self
->
_vm
->
name
;
if
(
!
$self
->
_vm
->
is_local
)
{
warn
"
Disabling node
"
.
$self
->
_vm
->
name
();
$self
->
_vm
->
enabled
(
0
);
if
(
$error
!~
/backing file/
)
{
warn
"
Disabling node
"
.
$self
->
_vm
->
name
();
$self
->
_vm
->
enabled
(
0
);
}
}
die
$error
;
}
elsif
(
$error
=~
/libvirt error code: 9, .*already defined with uuid/
)
{
...
...
lib/Ravada/Request.pm
View file @
8c7680dd
...
...
@@ -129,11 +129,16 @@ our %CMD_SEND_MESSAGE = map { $_ => 1 }
change_owner
add_hardware remove_hardware set_driver change_hardware
expose remove_expose
set_base_vm
rebase rebase_volumes
shutdown_node start_node
)
;
our
%CMD_NO_DUPLICATE
=
map
{
$_
=>
1
}
qw(
set_base_vm
remove_base_vm
)
;
our
$TIMEOUT_SHUTDOWN
=
120
;
our
$CONNECTOR
;
...
...
@@ -151,8 +156,9 @@ our %COMMAND = (
,
disk
=>
{
limit
=>
1
,
commands
=>
['
prepare_base
','
remove_base
','
set_base_vm
','
rebase_volumes
'
,
'
remove_base_vm
'
,
'
screenshot
'
,
'
manage_pools
'
]
]
,
priority
=>
6
}
,
important
=>
{
...
...
@@ -163,7 +169,7 @@ our %COMMAND = (
,
secondary
=>
{
limit
=>
50
,
priority
=>
2
,
commands
=>
['
shutdown
','
shutdown_now
']
,
commands
=>
['
shutdown
','
shutdown_now
'
,
'
manage_pools
'
]
}
);
lock_hash
%COMMAND
;
...
...
@@ -491,19 +497,30 @@ sub new_request($self, $command, @args) {
);
}
sub
_duplicated_request
($command, $args) {
return
if
!
$args
;
my
$args_d
=
decode_json
(
$args
);
sub
_duplicated_request
($self=undef, $command=undef, $args=undef) {
my
$args_d
;
if
(
$self
)
{
confess
"
Error: do not supply args if you supply request
"
if
$args
;
confess
"
Error: do not supply command if you supply request
"
if
$command
;
$args_d
=
$self
->
args
;
$command
=
$self
->
command
;
}
else
{
$args_d
=
decode_json
(
$args
);
}
delete
$args_d
->
{
uid
};
delete
$args_d
->
{
at
};
my
$sth
=
$$CONNECTOR
->
dbh
->
prepare
(
"
SELECT id,args FROM requests WHERE status='requested'
"
.
"
AND command=?
"
);
$sth
->
execute
(
$command
);
while
(
my
(
$id
,
$args_found
)
=
$sth
->
fetchrow
)
{
next
if
$self
&&
$self
->
id
==
$id
;
my
$args_found_d
=
decode_json
(
$args_found
);
delete
$args_found_d
->
{
uid
};
delete
$args_found_d
->
{
at
};
next
if
join
("
.
",
sort
keys
%$args_d
)
ne
join
("
.
",
sort
keys
%$args_found_d
);
my
$args_d_s
=
join
("
.
",
map
{
$args_d
->
{
$_
}
}
sort
keys
%$args_d
);
...
...
@@ -555,8 +572,9 @@ sub _new_request {
}
_init_connector
()
if
!
$CONNECTOR
||
!
$$CONNECTOR
;
if
(
$args
{
command
}
=~
/^(clone|manage_pools|list_isos)$/
||
$CMD_NO_DUPLICATE
{
$args
{
command
}}
||
(
$no_duplicate
&&
$args
{
command
}
=~
/^(screenshot)$/
))
{
if
(
_duplicated_request
(
$args
{
command
},
$args
{
args
})
if
(
_duplicated_request
(
undef
,
$args
{
command
},
$args
{
args
})
||
(
$args
{
command
}
ne
'
clone
'
&&
done_recently
(
undef
,
60
,
$args
{
command
})))
{
# warn "Warning: duplicated request for $args{command} $args{args}";
return
;
...
...
@@ -1193,13 +1211,18 @@ sub _requested($command, %fields) {
}
sub
stop
($self) {
my
$stale
=
'';
my
$run_time
=
'';
if
(
$self
->
start_time
)
{
$run_time
=
time
-
$self
->
start_time
;
$stale
=
"
, stale for
$run_time
seconds.
";
}
warn
"
Killing
"
.
$self
->
command
.
"
, pid:
"
.
$self
->
pid
.
"
, stale for
"
.
(
time
-
$self
->
start_time
)
.
"
seconds
\n
";
my
$ok
=
kill
(
15
,
$self
->
pid
);
$self
->
status
('
done
',"
Killed start process after
"
.
(
time
-
$self
->
start_time
)
.
"
seconds
\n
");
.
"
, pid:
"
.
(
$self
->
pid
or
'
<UNDEF>
')
.
$stale
.
"
\n
";
kill
(
15
,
$self
->
pid
)
if
$self
->
pid
;
$self
->
status
('
done
',"
Killed start process after
$run_time
seconds.
");
}
sub
priority
($self) {
...
...
lib/Ravada/VM.pm
View file @
8c7680dd
...
...
@@ -626,7 +626,8 @@ sub _interface_ip($self, $remote_ip=undef) {
my
%route
;
my
(
$default_gw
,
$default_ip
);
my
$remote_ip_addr
=
NetAddr::
IP
->
new
(
$remote_ip
);
my
$remote_ip_addr
=
NetAddr::
IP
->
new
(
$remote_ip
)
or
confess
"
I can't find netaddr for
$remote_ip
";
for
my
$line
(
split
(
/\n/
,
$out
)
)
{
if
(
$line
=~
m{^default via ([\d\.]+)}
)
{
...
...
@@ -638,7 +639,8 @@ sub _interface_ip($self, $remote_ip=undef) {
return
$ip
if
$remote_ip
&&
$remote_ip
eq
$ip
;
my
$netaddr
=
NetAddr::
IP
->
new
(
$network
);
my
$netaddr
=
NetAddr::
IP
->
new
(
$network
)
or
confess
"
I can't find netaddr for
$network
";
return
$ip
if
$remote_ip_addr
->
within
(
$netaddr
);
$default_ip
=
$ip
if
!
defined
$default_ip
&&
$ip
!~
/^127\./
;
...
...
@@ -930,7 +932,7 @@ Returns the minimun free memory necessary to start a new virtual machine
sub
min_free_memory
{
my
$self
=
shift
;
return
$self
->
_data
('
min_free_memory
');
return
(
$self
->
_data
('
min_free_memory
')
or
$
Ravada::Domain::
MIN_FREE_MEMORY
)
;
}
=head2 max_load
...
...
@@ -985,6 +987,27 @@ sub is_local($self) {
return
0
;
}
=head2 is_locked
This node has requests running or waiting to be run
=cut
sub
is_locked
($self) {
my
$sth
=
$$CONNECTOR
->
dbh
->
prepare
("
SELECT id, at_time, args FROM requests
"
.
"
WHERE status <> 'done'
"
);
$sth
->
execute
;
my
(
$id
,
$at
,
$args
);
$sth
->
bind_columns
(
\
(
$id
,
$at
,
$args
));
while
(
$sth
->
fetch
)
{
next
if
defined
$at
&&
$at
<
time
+
2
;
next
if
!
$args
;
my
$args_d
=
decode_json
(
$args
);
return
1
if
exists
$args_d
->
{
id_vm
}
&&
$args_d
->
{
id_vm
}
==
$self
->
id
}
return
0
;
}
=head2 list_nodes
...
...
@@ -1279,10 +1302,12 @@ sub file_exists( $self, $file ) {
my
$ssh
=
(
$self
->
{
_ssh
}
or
$self
->
_connect_ssh
());
die
"
Error: no ssh connection to
"
.
$self
->
name
if
!
$ssh
;
my
$io
=
IO::
Scalar
->
new
();
my
$ok
=
$ssh
->
scp_get
(
$file
,
$io
);
confess
"
Error: dangerous filename '
$file
'
"
if
$file
=~
/[`|"(\\\[]/
;
my
(
$out
,
$err
)
=
$self
->
run_command
("
/bin/ls -1
$file
");
return
$ok
;
return
1
if
!
$err
;