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
4b75c5bb
Commit
4b75c5bb
authored
Oct 13, 2016
by
Francesc Guasch
Browse files
Fork before executing requests
parent
b6070c40
Changes
8
Hide whitespace changes
Inline
Side-by-side
lib/Ravada.pm
View file @
4b75c5bb
...
...
@@ -36,7 +36,7 @@ our $FILE_CONFIG = "/etc/ravada.conf";
our
$CONNECTOR
;
our
$CONFIG
=
{};
our
$DEBUG
;
our
$CAN_FORK
=
0
;
our
$CAN_FORK
=
1
;
has
'
vm
'
=>
(
...
...
@@ -113,6 +113,7 @@ sub _create_vm_kvm {
eval
{
$vm_kvm
=
Ravada::VM::
KVM
->
new
(
connector
=>
(
$self
->
connector
or
$CONNECTOR
))
};
my
$err_kvm
=
$@
;
return
(
undef
,
$err_kvm
)
if
!
$vm_kvm
;
return
(
$vm_kvm
,
$err_kvm
);
my
(
$internal_vm
,
$storage
);
eval
{
...
...
@@ -131,6 +132,7 @@ sub _refresh_vm_kvm {
sleep
1
;
my
@vms
;
eval
{
@vms
=
$self
->
vm
};
warn
$@
if
$@
;
return
if
$@
&&
$@
=~
/No VMs found/i
;
die
$@
if
$@
;
...
...
@@ -498,7 +500,6 @@ sub process_requests {
my
$self
=
shift
;
my
$debug
=
shift
;
my
$dont_fork
=
shift
;
$dont_fork
=
1
if
!
$CAN_FORK
;
$self
->
_wait_pids_nohang
();
$self
->
_check_vms
();
...
...
@@ -515,23 +516,18 @@ sub process_requests {
my
(
$n_retry
)
=
$req
->
status
()
=~
/retry (\d+)/
;
$n_retry
=
0
if
!
$n_retry
;
$req
->
status
('
working
');
eval
{
$self
->
_execute
(
$req
,
$dont_fork
)
};
my
$err
=
$@
;
$req
->
error
(
$err
or
'');
if
(
$err
=~
/libvirt error code: 38/
)
{
my
$err
=
$self
->
_execute
(
$req
,
$dont_fork
);
$req
->
error
(
$err
)
if
$err
;
if
(
$err
&&
$err
=~
/libvirt error code: 38/
)
{
if
(
$n_retry
<
3
)
{
warn
$req
->
id
.
"
"
.
$req
->
command
.
"
to retry
"
if
$DEBUG
;
$req
->
status
("
retry
"
.++
$n_retry
)
}
$self
->
_refresh_vm_kvm
();
}
else
{
$req
->
status
('
done
');
}
warn
"
req
"
.
$req
->
id
.
"
, command:
"
.
$req
->
command
.
"
, status:
"
.
$req
->
status
()
.
"
, error: '
"
.
(
$req
->
error
or
'
NONE
')
.
"
'
"
if
$DEBUG
||
$debug
;
$self
->
_refresh_vm_kvm
()
if
$req
->
command
=~
/create|remove/i
;
}
$sth
->
finish
;
}
...
...
@@ -566,11 +562,34 @@ sub _execute {
my
$sub
=
$self
->
_req_method
(
$request
->
command
);
die
"
Unknown command
"
.
$request
->
command
if
!
$sub
;
confess
"
Unknown command
"
.
$request
->
command
if
!
$sub
;
return
$sub
->
(
$self
,
$request
,
$dont_fork
);
if
(
$dont_fork
||
!
$CAN_FORK
)
{
eval
{
$sub
->
(
$self
,
$request
)
};
my
$err
=
(
$@
or
'');
$request
->
error
(
$err
);
$request
->
status
('
done
');
return
$err
;
}
my
$pid
=
fork
();
die
"
I can't fork
"
if
!
defined
$pid
;
if
(
$pid
==
0
)
{
$request
->
status
("
forked $$
");
eval
{
$request
->
status
("
calling
"
.
$request
->
command
);
$sub
->
(
$self
,
$request
);
};
my
$err
=
(
$@
or
'');
$request
->
error
(
$err
);
$request
->
status
('
done
');
exit
;
}
$self
->
_add_pid
(
$pid
,
$request
->
id
);
$self
->
_refresh_vm_kvm
();
return
'';
}
sub
_cmd_domdisplay
{
...
...
@@ -591,7 +610,7 @@ sub _cmd_domdisplay {
}
sub
_do
_cmd_create
{
sub
_cmd_create
{
my
$self
=
shift
;
my
$request
=
shift
;
...
...
@@ -611,8 +630,20 @@ sub _wait_pids_nohang {
my
$kid
=
waitpid
(
-
1
,
WNOHANG
);
return
if
!
$kid
||
$kid
==
-
1
;
warn
"
Kid
$kid
finished
"
if
$DEBUG
;
$self
->
_set_req_done
(
$kid
)
;
delete
$self
->
{
pids
}
->
{
$kid
};
}
sub
_set_req_done
{
my
$self
=
shift
;
my
$pid
=
shift
;
my
$id_request
=
$self
->
{
pids
}
->
{
$pid
};
return
if
!
$id_request
;
my
$req
=
Ravada::
Request
->
open
(
$id_request
);
$req
->
status
('
done
')
if
$req
->
status
=~
/working/i
;
}
sub
_wait_pids
{
...
...
@@ -626,8 +657,10 @@ sub _wait_pids {
# warn "Checking for pid '$pid' created at ".localtime($self->{pids}->{$pid});
my
$kid
=
waitpid
(
$pid
,
0
);
# warn "Found $kid";
$self
->
_set_req_done
(
$pid
);
delete
$self
->
{
pids
}
->
{
$kid
};
return
if
$kid
==
$pid
;
}
}
...
...
@@ -635,39 +668,12 @@ sub _wait_pids {
sub
_add_pid
{
my
$self
=
shift
;
my
$pid
=
shift
;
my
$id_req
=
shift
;
$self
->
{
pids
}
->
{
$pid
}
=
time
;
}
sub
_cmd_create
{
my
$self
=
shift
;
my
$request
=
shift
;
my
$dont_fork
=
shift
;
return
$self
->
_do_cmd_create
(
$request
)
if
$dont_fork
;
$self
->
_wait_pids
(
$request
);
$request
->
status
('
forking
');
my
$pid
=
fork
();
if
(
!
defined
$pid
)
{
$request
->
status
('
done
');
$request
->
error
("
I can't fork
");
return
;
}
if
(
$pid
==
0
)
{
$self
->
_do_cmd_create
(
$request
);
exit
;
}
$self
->
_add_pid
(
$pid
);
return
;
$self
->
{
pids
}
->
{
$pid
}
=
$id_req
;
}
sub
_do
_cmd_remove
{
sub
_cmd_remove
{
my
$self
=
shift
;
my
$request
=
shift
;
...
...
@@ -679,32 +685,6 @@ sub _do_cmd_remove {
}
sub
_cmd_remove
{
my
$self
=
shift
;
my
$request
=
shift
;
my
$dont_fork
=
shift
;
return
$self
->
_do_cmd_remove
(
$request
)
if
$dont_fork
||
!
$CAN_FORK
;
$self
->
_wait_pids
(
$request
);
$request
->
status
('
forking
');
my
$pid
=
fork
();
if
(
!
defined
$pid
)
{
$request
->
status
('
done
');
$request
->
error
("
I can't fork
");
return
;
}
if
(
$pid
==
0
)
{
$self
->
_do_cmd_remove
(
$request
);
exit
;
}
$self
->
_add_pid
(
$pid
);
return
;
}
sub
_cmd_pause
{
my
$self
=
shift
;
my
$request
=
shift
;
...
...
@@ -746,8 +726,9 @@ sub _cmd_start {
my
$self
=
shift
;
my
$request
=
shift
;
$request
->
status
(
'
working
'
);
$request
->
status
(
"
working
$$
"
);
my
$name
=
$request
->
args
('
name
');
my
$domain
=
$self
->
search_domain
(
$name
);
die
"
Unknown domain '
$name
'
"
if
!
$domain
;
...
...
lib/Ravada/Domain.pm
View file @
4b75c5bb
...
...
@@ -426,7 +426,7 @@ sub clones {
return
@clones
;
}
=head2
=head2
list_files_base
Returns a list of the filenames of this base-type domain
...
...
lib/Ravada/Request.pm
View file @
4b75c5bb
...
...
@@ -288,26 +288,6 @@ sub prepare_base {
}
=head2 list_vm_types
Returns a list of VM types
my $req = Ravada::Request->list_vm_types();
my $types = $req->result;
=cut
sub
list_vm_types
{
my
$proto
=
shift
;
my
$class
=
ref
(
$proto
)
||
$proto
;
my
$self
=
{};
bless
(
$self
,
$class
);
return
$self
->
_new_request
(
command
=>
'
list_vm_types
'
);
}
=head2 ping_backend
Returns wether the backend is alive or not
...
...
@@ -357,9 +337,10 @@ sub _new_request {
delete
$args
{
name
};
}
if
(
ref
$args
{
args
}
)
{
$args
{
args
}
->
{
uid
}
=
$args
{
args
}
->
{
id_owner
}
if
!
exists
$args
{
args
}
->
{
uid
};
$args
{
args
}
=
encode_json
(
$args
{
args
});
}
_init_connector
()
if
!
$CONNECTOR
||
!
$$CONNECTOR
;
my
$sth
=
$$CONNECTOR
->
dbh
->
prepare
(
...
...
@@ -448,7 +429,7 @@ sub _send_message {
my
$uid
;
eval
{
$uid
=
$self
->
args
('
id_owner
')
};
eval
{
$uid
=
$self
->
args
('
uid
')
};
eval
{
$uid
=
$self
->
args
('
uid
')
}
if
!
$uid
;
return
if
!
$uid
;
my
$domain_name
;
...
...
@@ -472,7 +453,7 @@ sub _remove_unnecessary_messages {
my
$uid
;
eval
{
$uid
=
$self
->
args
('
id_owner
')
};
eval
{
$uid
=
$self
->
args
('
uid
')
};
eval
{
$uid
=
$self
->
args
('
uid
')
}
if
!
$uid
;
return
if
!
$uid
;
my
$sth
=
$$CONNECTOR
->
dbh
->
prepare
(
...
...
lib/Ravada/VM/KVM.pm
View file @
4b75c5bb
...
...
@@ -25,7 +25,7 @@ with 'Ravada::VM';
has
vm
=>
(
isa
=>
'
Sys::Virt
'
,
is
=>
'
r
o
'
,
is
=>
'
r
w
'
,
builder
=>
'
connect
'
,
lazy
=>
1
);
...
...
@@ -81,9 +81,14 @@ sub connect {
,
readonly
=>
$self
->
mode
);
}
$vm
->
register_close_callback
(
\
&_reconnect
);
return
$vm
;
}
sub
_reconnect
{
warn
"
Disconnected
";
}
sub
_load_storage_pool
{
my
$self
=
shift
;
...
...
@@ -163,13 +168,17 @@ sub search_domain {
my
$self
=
shift
;
my
$name
=
shift
or
confess
"
Missing name
";
for
(
$self
->
vm
->
list_all_domains
())
{
next
if
$_
->
get_name
ne
$name
;
my
@all_domains
;
eval
{
@all_domains
=
$self
->
vm
->
list_all_domains
()
};
die
$@
if
$@
;
for
my
$dom
(
@all_domains
)
{
next
if
$dom
->
get_name
ne
$name
;
my
$domain
;
eval
{
$domain
=
Ravada::Domain::
KVM
->
new
(
domain
=>
$
_
domain
=>
$
dom
,
storage
=>
$self
->
storage_pool
,
readonly
=>
$self
->
readonly
);
...
...
@@ -260,6 +269,7 @@ sub search_volume {
my
$vol
;
eval
{
$vol
=
$self
->
storage_pool
->
get_volume_by_name
(
$name
)
};
die
$@
if
$@
;
return
$vol
;
}
...
...
@@ -292,7 +302,9 @@ sub _domain_create_from_iso {
my
$dom
=
$self
->
vm
->
define_domain
(
$xml
->
toString
());
$dom
->
create
if
$args
{
active
};
my
$domain
=
Ravada::Domain::
KVM
->
new
(
domain
=>
$dom
,
storage
=>
$self
->
storage_pool
);
$domain
->
_insert_db
(
name
=>
$args
{
name
},
id_owner
=>
$args
{
id_owner
});
return
$domain
;
}
...
...
t/30_request.t
View file @
4b75c5bb
...
...
@@ -56,18 +56,6 @@ sub test_remove_domain {
}
sub
wait_request
{
my
$req
=
shift
;
my
$status
=
'';
for
(
1
..
100
)
{
last
if
$req
->
status
eq
'
done
';
next
if
$req
->
status
eq
$status
;
diag
("
Request
"
.
$req
->
command
.
"
"
.
$req
->
status
);
$status
=
$req
->
status
;
sleep
1
;
}
}
sub
test_req_create_domain_iso
{
my
$vm_name
=
shift
;
...
...
@@ -83,6 +71,7 @@ sub test_req_create_domain_iso {
);
ok
(
$req
);
ok
(
$req
->
status
);
ok
(
$req
->
args
('
id_owner
'));
ok
(
defined
$req
->
args
->
{
name
}
...
...
@@ -93,14 +82,15 @@ sub test_req_create_domain_iso {
ok
(
$req
->
status
eq
'
requested
'
,"
Status of request is
"
.
$req
->
status
.
"
it should be requested
");
$ravada
->
_
process_requests
_dont_fork
();
$ravada
->
process_requests
();
wait_request
(
$req
)
;
sleep
1
;
$ravada
->
_wait_pids
();
wait_request
(
$req
);
ok
(
$req
->
status
eq
'
done
'
,"
Status of request is
"
.
$req
->
status
.
"
it should be done
");
ok
(
!
$req
->
error
,"
Error
"
.
$req
->
error
.
"
creating domain
"
.
$name
);
,"
Status of request is
"
.
$req
->
status
.
"
it should be done
")
or
exit
;
ok
(
!
$req
->
error
,"
Error
"
.
$req
->
error
.
"
creating domain
"
.
$name
)
or
exit
;
test_unread_messages
(
$USER
,
1
,
"
[
$vm_name
] create domain
$name
");
my
$req2
=
Ravada::
Request
->
open
(
$req
->
id
);
...
...
@@ -180,21 +170,6 @@ sub test_req_remove_domain_name {
}
sub
test_list_vm_types
{
my
$vm_name
=
shift
or
confess
"
Missing vm name
";
return
if
$vm_name
=~
/Void/i
;
my
$req
=
Ravada::
Request
->
list_vm_types
();
$ravada
->
process_requests
();
ok
(
$req
->
status
eq
'
done
'
,"
Status of request is
"
.
$req
->
status
.
"
it should be done
");
ok
(
!
$req
->
error
,"
Error
"
.
(
$req
->
error
or
'')
.
"
requesting VM types
");
my
$result
=
$req
->
result
();
ok
(
ref
$result
eq
'
ARRAY
',"
Expecting ARRAY , got
"
.
ref
(
$result
));
}
sub
test_unread_messages
{
my
(
$user
,
$n_unread
,
$test
)
=
@_
;
confess
"
Missing test name
"
if
!
$test
;
...
...
@@ -225,8 +200,6 @@ for my $vm_name ( qw(Void KVM)) {
skip
(
$msg
,
10
)
if
!
$vm
;
diag
("
Testing requests with
"
.
(
ref
$vm
or
'
<UNDEF>
'));
remove_old_domains
();
remove_old_disks
();
my
$domain_iso0
=
test_req_create_domain_iso
(
$vm_name
);
test_req_remove_domain_obj
(
$vm
,
$domain_iso0
)
if
$domain_iso0
;
...
...
@@ -237,7 +210,6 @@ for my $vm_name ( qw(Void KVM)) {
my
$domain_base
=
test_req_create_base
(
$vm
);
test_req_remove_domain_name
(
$vm
,
$domain_base
->
name
)
if
$domain_base
;
test_list_vm_types
(
$vm_name
);
};
}
...
...
t/35_request_start.t
View file @
4b75c5bb
use
warnings
;
use
strict
;
use
Carp
qw(confess)
;
use
Data::
Dumper
;
use
Test::
More
;
use
Test::SQL::
Data
;
...
...
@@ -15,16 +17,17 @@ my $test = Test::SQL::Data->new(config => 't/etc/sql.conf');
my
$RAVADA
=
rvd_back
(
$test
->
connector
,
'
t/etc/ravada.conf
');
my
$USER
=
create_user
('
foo
','
bar
',
1
);
my
@ARG_CREATE_DOM
;
sub
test_request_start
{
}
my
@ARG_CREATE_DOM
=
(
id_owner
=>
$USER
->
id
,
id_iso
=>
1
);
sub
test_remove_domain
{
my
$vm_name
=
shift
;
my
$name
=
shift
;
my
$domain
=
$name
if
ref
(
$name
);
$domain
=
$RAVADA
->
search_domain
(
$name
,
1
);
my
$vm
=
rvd_back
->
search_vm
(
$vm_name
)
or
confess
"
I can't find vm
$vm_name
";
diag
("
[
$vm_name
] removing domain
$name
");
my
$domain
=
$vm
->
search_domain
(
$name
,
1
);
my
$disks_not_removed
=
0
;
...
...
@@ -36,26 +39,26 @@ sub test_remove_domain {
};
ok
(
!
$@
,
"
Error removing domain
$name
"
.
ref
(
$domain
)
.
"
: $@
")
or
exit
;
ok
(
!
-
e
$domain
->
file_base_img
,"
Image file was not removed
"
.
$domain
->
file_base_img
)
if
$domain
->
file_base_img
;
for
(
@disks
)
{
ok
(
!-
e
$_
,"
Disk
$_
should be removed
")
or
$disks_not_removed
++
;
}
}
$domain
=
$
RAVADA
->
search_domain
(
$name
,
1
);
ok
(
!
$domain
,
"
I can't r
emov
e
old domain
$name
")
or
exit
;
$domain
=
$
vm
->
search_domain
(
$name
,
1
);
ok
(
!
$domain
,
"
R
emov
ing
old domain
$name
")
or
exit
;
ok
(
!
$disks_not_removed
,"
$disks_not_removed
disks not removed from domain
$name
");
}
sub
test_new_domain
{
my
$vm_name
=
shift
;
my
$name
=
shift
;
test_remove_domain
(
$
name
);
my
$vm
=
rvd_back
->
search_vm
(
$vm_
name
);
diag
("
Creating domain
$name
");
my
$domain
=
$RAVADA
->
create_domain
(
name
=>
$name
,
@ARG_CREATE_DOM
,
active
=>
0
);
# test_remove_domain($vm_name, $name);
diag
("
[
$vm_name
] Creating domain
$name
");
my
$domain
=
$vm
->
create_domain
(
name
=>
$name
,
@ARG_CREATE_DOM
,
active
=>
0
);
ok
(
$domain
,"
Domain not created
");
...
...
@@ -64,39 +67,47 @@ sub test_new_domain {
sub
test_start
{
my
$vm_name
=
shift
;
my
$name
=
new_domain_name
();
test_remove_domain
(
$name
);
#
test_remove_domain(
$vm_name,
$name);
my
$vm
=
rvd_back
->
search_vm
(
$vm_name
);
my
$req
=
Ravada::
Request
->
start_domain
(
name
=>
"
does not exists
"
,
uid
=>
$USER
->
id
);
$RAVADA
->
_
process_requests
_dont_fork
();
$RAVADA
->
process_requests
();
ok
(
$req
->
status
eq
'
done
',
"
Req
"
.
$req
->
{
id
}
.
"
expecting status done, got
"
.
$req
->
status
);
wait_request
(
$req
);
ok
(
$req
->
status
eq
'
done
',
"
[
$vm_name
] Req
"
.
$req
->
{
id
}
.
"
expecting status done, got
"
.
$req
->
status
);
ok
(
$req
->
error
&&
$req
->
error
=~
/unknown/i
,"
Req
"
.
$req
->
{
id
}
.
"
expecting unknown domain error , got
"
,"
[
$vm_name
]
Req
"
.
$req
->
{
id
}
.
"
expecting unknown domain error , got
"
.
(
$req
->
error
or
'
<NULL>
'))
or
return
;
$req
=
undef
;
#####################################################################3
#
# start
test_new_domain
(
$name
);
test_new_domain
(
$vm_name
,
$name
);
my
$domain
=
$
RAVADA
->
search_domain
(
$name
);
my
$domain
=
$
vm
->
search_domain
(
$name
);
ok
(
!
$domain
->
is_active
,"
Domain
$name
should be inactive
")
or
return
;
my
$req2
=
Ravada::
Request
->
start_domain
(
name
=>
$name
,
uid
=>
$USER
->
id
);
my
$req2
=
Ravada::
Request
->
start_domain
(
name
=>
$name
,
uid
=>
$USER
->
id
);
$RAVADA
->
process_requests
();
ok
(
$req2
->
status
eq
'
done
');
wait_request
(
$req2
);
ok
(
$req2
->
status
eq
'
done
',"
Expecting request status 'done' , got
"
.
$req2
->
status
);
$domain
->
start
(
$USER
)
if
!
$domain
->
is_active
();
ok
(
$domain
->
is_active
);
my
$domain2
=
$
RAVADA
->
search_domain
(
$name
);
my
$domain2
=
$
vm
->
search_domain
(
$name
);
ok
(
$domain2
->
is_active
);
$req2
=
undef
;
...
...
@@ -107,12 +118,14 @@ sub test_start {
my
$req3
=
Ravada::
Request
->
shutdown_domain
(
name
=>
$name
,
uid
=>
$USER
->
id
);
$RAVADA
->
process_requests
();
ok
(
$req3
->
status
eq
'
done
');
wait_request
(
$req3
);
ok
(
$req3
->
status
eq
'
done
',"
[
$vm_name
] expecting request done , got
"
.
$req3
->
status
);
ok
(
!
$req3
->
error
,"
Error shutting down domain
$name
, expecting ''. Got '
"
.
$req3
->
error
);
ok
(
!
$domain
->
is_active
,
"
Domain
$name
should not be active
");
my
$domain3
=
$
RAVADA
->
search_domain
(
$name
);
my
$domain3
=
$
vm
->
search_domain
(
$name
);
ok
(
!
$domain3
->
is_active
,"
Domain
$name
should not be active
");
return
$domain3
;
...
...
@@ -127,28 +140,24 @@ remove_old_disks();
my
$vmm
;
eval
{
$vmm
=
$RAVADA
->
search_vm
('
kvm
');
@ARG_CREATE_DOM
=
(
id_iso
=>
1
,
vm
=>
'
kvm
',
id_owner
=>
$USER
->
id
)
if
$vmm
;
for
my
$vm_name
(
qw(KVM Void)
)
{
$vmm
=
$RAVADA
->
search_vm
(
$vm_name
);
if
(
!
$vmm
)
{
$vmm
=
$RAVADA
->
search_vm
('
lxc
')
;
@ARG_CREATE_DOM
=
(
id_template
=>
1
,
vm
=>
'
LXC
',
id_owner
=>
$USER
->
id
)
;
}
SKIP:
{
my
$msg
=
"
SKIPPED: Virtual manager
$vm_name
not found
"
;
diag
(
$msg
)
if
!
$vmm
;
skip
(
$msg
,
10
)
if
!
$vmm
;
}
if
$RAVADA
;
diag
("
Testing VM
$vm_name
");
my
$domain
=
test_start
(
$vm_name
);
SKIP:
{
my
$msg
=
"
SKIPPED: No virtual managers found
"
;
diag
(
$msg
)
if
!
$vmm
;
skip
(
$msg
,
10
)
if
!
$vmm
;
$domain
->
shutdown_now
(
$USER
)
if
$domain
;
$domain
->
remove
(
user_admin
())
if
$domain
;
}
;
}
remove_old_domains
();
remove_old_disks
();
my
$domain
=
test_start
();
remove_old_domains
();
$domain
->
shutdown_now
(
$USER
)
if
$domain
;
$domain
->
remove
(
user_admin
())
if
$domain
;
};
remove_old_disks
();
done_testing
();
t/front/20_create_domain.t
View file @
4b75c5bb
...
...
@@ -86,7 +86,6 @@ for my $vm_name ('kvm','lxc') {
my
$name
=
new_domain_name
();
my
$req
=
$RVD_FRONT
->
create_domain
(
name
=>
$name