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
e29c17ac
Commit
e29c17ac
authored
May 11, 2016
by
Francesc Guasch
Browse files
Requests create and remove domains now
parent
99badc35
Changes
10
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
e29c17ac
...
...
@@ -4,3 +4,4 @@ Makefile
blib
pm_to_blib
t/db
db
lib/Ravada.pm
View file @
e29c17ac
...
...
@@ -3,6 +3,7 @@ package Ravada;
use
warnings
;
use
strict
;
use
Data::
Dumper
;
use
DBIx::
Connector
;
use
Moose
;
use
YAML
;
...
...
@@ -63,6 +64,15 @@ sub create_domain {
return
$self
->
vm
->
[
0
]
->
create_domain
(
@
_
);
}
sub
remove_domain
{
my
$self
=
shift
;
my
$name
=
shift
or
confess
"
Missing domain name
";
my
$domain
=
$self
->
search_domain
(
$name
)
or
confess
"
ERROR: I can't find domain
$name
";
$domain
->
remove
();
}
sub
search_domain
{
my
$self
=
shift
;
my
$name
=
shift
;
...
...
@@ -93,4 +103,35 @@ sub remove_volume {
}
}
sub
process_requests
{
my
$self
=
shift
;
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
SELECT id FROM requests WHERE status='requested'
");
$sth
->
execute
;
while
(
my
(
$id
)
=
$sth
->
fetchrow
)
{
$self
->
_execute
(
Ravada::
Request
->
open
(
$id
));
}
$sth
->
finish
;
}
sub
_execute
{
my
$self
=
shift
;
my
$request
=
shift
;
if
(
$request
->
command
()
eq
'
create
'
)
{
$request
->
status
('
working
');
eval
{
$self
->
create_domain
(
%
{
$request
->
args
})
};
$request
->
status
('
done
');
$request
->
error
(
$@
);
}
elsif
(
$request
->
command
eq
'
remove
')
{
$request
->
status
('
working
');
eval
{
$self
->
remove_domain
(
$request
->
args
('
name
'))
};
$request
->
status
('
done
');
$request
->
error
(
$@
);
}
else
{
die
"
Unknown command
"
.
$request
->
command
;
}
}
1
;
lib/Ravada/Domain/KVM.pm
View file @
e29c17ac
...
...
@@ -3,6 +3,7 @@ package Ravada::Domain::KVM;
use
warnings
;
use
strict
;
use
Carp
qw(cluck croak)
;
use
Data::
Dumper
;
use
IPC::
Run3
qw(run3)
;
use
Moose
;
...
...
@@ -92,15 +93,18 @@ sub remove_disks {
sub
vol_remove
{
my
$self
=
shift
;
my
$file
=
shift
;
my
$warning
=
shift
;
my
(
$name
)
=
$file
=~
m{.*/(.*)}
if
$file
=~
m{/}
;
my
$vol
;
eval
{
$vol
=
$self
->
storage
->
get_volume_by_name
(
$name
)
};
if
(
!
$vol
)
{
warn
"
WARNING: I can't find volum
n
e
$name
\n
"
;
#
cluck
"WARNING: I can't find volume $name
" if !$warning
;
return
;
}
$vol
->
delete
();
return
1
;
}
sub
remove
{
...
...
@@ -109,19 +113,33 @@ sub remove {
$self
->
_wait_down
();
$self
->
vol_remove
(
$self
->
file_base_img
)
if
$self
->
file_base_img
();
$self
->
vol_remove
(
$self
->
file_base_img
,
1
)
if
$self
->
file_base_img
();
$self
->
domain
->
destroy
if
$self
->
domain
->
is_active
();
$self
->
remove_disks
();
$self
->
remove_file_image
();
$self
->
domain
->
undefine
();
$self
->
_remove_domain_db
();
}
sub
_remove_domain_db
{
my
$self
=
shift
;
my
$sth
=
$self
->
connector
->
dbh
->
prepare
("
DELETE FROM domains
"
.
"
WHERE id=?
");
$sth
->
execute
(
$self
->
id
);
$sth
->
finish
;
}
sub
remove_file_image
{
my
$self
=
shift
;
my
$file
=
$self
->
file_base_img
;
$self
->
vol_remove
(
$file
)
if
$file
;
return
if
!
$file
;
$self
->
vol_remove
(
$file
,
1
);
unlink
$file
or
die
"
$!
$file
"
if
-
e
$file
;
}
...
...
lib/Ravada/Request.pm
0 → 100644
View file @
e29c17ac
package
Ravada::
Request
;
use
strict
;
use
warnings
;
use
Carp
qw(confess)
;
use
JSON::
XS
;
use
Ravada
;
use
vars
qw($AUTOLOAD)
;
=pod
Request a command to the ravada backend
=cut
our
%FIELD
=
map
{
$_
=>
1
}
qw(error)
;
our
%FIELD_RO
=
map
{
$_
=>
1
}
qw(name)
;
our
$CONNECTOR
=
$
Ravada::
CONNECTOR
;
sub
request
{
my
$proto
=
shift
;
my
$class
=
ref
(
$proto
)
||
$proto
;
my
$self
=
{};
bless
(
$self
,
$class
);
return
$self
;
}
sub
open
{
my
$proto
=
shift
;
my
$class
=
ref
(
$proto
)
||
$proto
;
my
$id
=
shift
or
confess
"
Missing request id
";
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
SELECT * FROM requests
"
.
"
WHERE id=?
");
$sth
->
execute
(
$id
);
my
$row
=
$sth
->
fetchrow_hashref
;
confess
"
I can't find id=
$id
"
if
!
defined
$row
;
$sth
->
finish
;
my
$args
=
decode_json
(
$row
->
{
args
})
if
$row
->
{
args
};
$args
=
{}
if
!
$args
;
$row
->
{
args
}
=
$args
;
bless
(
$row
,
$class
);
return
$row
;
}
=head2 create_domain
my $req = Ravada::Request->create_domain( name => 'bla'
, id_iso => 1
);
=cut
sub
create_domain
{
my
$proto
=
shift
;
my
$class
=
ref
(
$proto
)
||
$proto
;
my
%args
=
@_
;
confess
"
Missing domain name
"
if
!
$args
{
name
};
my
$self
=
{};
bless
(
$self
,
$class
);
return
$self
->
_new_request
(
command
=>
'
create
'
,
args
=>
encode_json
(
\
%args
));
}
=head2 remove_domain
my $req = Ravada::Request->create_domain( name => 'bla'
, id_iso => 1
);
=cut
sub
remove_domain
{
my
$proto
=
shift
;
my
$class
=
ref
(
$proto
)
||
$proto
;
my
$name
=
shift
;
$name
=
$name
->
name
if
ref
(
$name
)
=~
/Domain/
;
my
%args
=
(
name
=>
$name
)
or
confess
"
Missing domain name
";
my
$self
=
{};
bless
(
$self
,
$class
);
return
$self
->
_new_request
(
command
=>
'
remove
'
,
args
=>
encode_json
({
name
=>
$name
}));
}
sub
_new_request
{
my
$self
=
shift
;
my
%args
=
@_
;
$args
{
status
}
=
'
requested
';
if
(
$args
{
name
})
{
$args
{
domain_name
}
=
$args
{
name
};
delete
$args
{
name
};
}
$CONNECTOR
=
$
Ravada::
CONNECTOR
if
!
defined
$CONNECTOR
;
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
(
"
INSERT INTO requests (
"
.
join
("
,
",
sort
keys
%args
)
.
"
)
"
.
"
VALUES (
"
.
join
("
,
",
map
{
'
?
'
}
keys
%args
)
.
"
)
"
);
$sth
->
execute
(
map
{
$args
{
$_
}
}
sort
keys
%args
);
$sth
->
finish
;
$self
->
{
id
}
=
$self
->
last_insert_id
();
return
$self
->
open
(
$self
->
{
id
});
}
sub
last_insert_id
{
my
$self
=
shift
;
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
SELECT last_insert_rowid()
");
$sth
->
execute
;
my
(
$id
)
=
$sth
->
fetchrow
;
$sth
->
finish
;
return
$id
;
}
sub
status
{
my
$self
=
shift
;
my
$status
=
shift
;
if
(
!
defined
$status
)
{
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
SELECT * FROM requests
"
.
"
WHERE id=?
");
$sth
->
execute
(
$self
->
{
id
});
my
$row
=
$sth
->
fetchrow_hashref
;
$sth
->
finish
;
return
(
$row
->
{
status
}
or
'
unknown
');
}
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
UPDATE requests set status=?
"
.
"
WHERE id=?
");
$sth
->
execute
(
$status
,
$self
->
{
id
});
$sth
->
finish
;
return
$status
;
}
sub
command
{
my
$self
=
shift
;
return
$self
->
{
command
};
}
sub
args
{
my
$self
=
shift
;
my
$name
=
shift
;
return
$self
->
{
args
}
if
!
$name
;
confess
"
Unknown argument
$name
"
if
!
exists
$self
->
{
args
}
->
{
name
};
return
$self
->
{
args
}
->
{
$name
};
}
sub
AUTOLOAD
{
my
$self
=
shift
;
my
$name
=
$AUTOLOAD
;
my
$value
=
shift
;
$name
=~
s/.*://
;
$name
=~
tr/[a-z]/_/c
;
confess
"
ERROR: Unknown field
$name
"
if
!
exists
$self
->
{
$name
}
||
!
exists
$FIELD
{
$name
};
if
(
!
defined
$value
)
{
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
SELECT * FROM requests
"
.
"
WHERE id=?
");
$sth
->
execute
(
$self
->
{
id
});
my
$row
=
$sth
->
fetchrow_hashref
;
$sth
->
finish
;
return
$row
->
{
$name
};
}
confess
"
ERROR: field
$name
is read only
"
if
$FIELD_RO
{
$name
};
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
UPDATE requests set
$name
=?
"
.
"
WHERE id=?
");
$sth
->
execute
(
$value
,
$self
->
{
id
});
$sth
->
finish
;
return
$value
;
}
1
;
lib/Ravada/VM.pm
View file @
e29c17ac
...
...
@@ -4,6 +4,7 @@ use strict;
package
Ravada::
VM
;
use
Carp
qw(croak)
;
use
Data::
Dumper
;
use
Moose::
Role
;
requires
'
connect
';
...
...
@@ -67,11 +68,16 @@ sub _domain_insert_db {
my
%field
=
@_
;
croak
"
Field name is mandatory
"
.
Dumper
(
\
%field
)
if
!
exists
$field
{
name
};
my
$
sth
=
$self
->
connector
->
dbh
->
prepare
(
"
INSERT INTO domains
"
my
$
query
=
"
INSERT INTO domains
"
.
"
(
"
.
join
("
,
",
sort
keys
%field
)
.
"
)
"
.
"
VALUES (
"
.
join
("
,
",
map
{
'
?
'
}
keys
%field
)
.
"
)
"
);
$sth
->
execute
(
map
{
$field
{
$_
}
}
sort
keys
%field
);
;
my
$sth
=
$self
->
connector
->
dbh
->
prepare
(
$query
);
eval
{
$sth
->
execute
(
map
{
$field
{
$_
}
}
sort
keys
%field
)
};
if
(
$@
)
{
warn
"
$query
\n
"
.
Dumper
(
\
%field
);
die
$@
;
}
$sth
->
finish
;
}
...
...
sql/sqlite/requests.sql
0 → 100644
View file @
e29c17ac
CREATE
TABLE
`requests`
(
`id`
integer
primary
key
AUTOINCREMENT
,
`command`
char
(
32
)
DEFAULT
NULL
,
`args`
char
(
255
)
DEFAULT
NULL
,
`date_req`
datetime
DEFAULT
NULL
,
`date_changed`
datetime
default
current_timestamp
,
`status`
char
(
1
)
DEFAULT
NULL
,
`error`
varchar
(
255
)
DEFAULT
NULL
,
`id_domain`
int
(
11
)
DEFAULT
NULL
,
`domain_name`
char
(
80
)
DEFAULT
NULL
);
t/20_domain_kvm.t
View file @
e29c17ac
...
...
@@ -34,12 +34,36 @@ sub test_remove_domain {
die
"
I can't remove old domain
$name
"
if
$domain
;
ok
(
!
search_domain_db
(
$name
),"
Domain
$name
still in db
");
}
sub
test_remove_domain_by_name
{
my
$name
=
shift
;
diag
("
Removing domain
$name
");
$ravada
->
remove_domain
(
$name
);
my
$domain
=
$ravada
->
search_domain
(
$name
);
die
"
I can't remove old domain
$name
"
if
$domain
;
}
sub
search_domain_db
{
my
$name
=
shift
;
my
$sth
=
$test
->
dbh
->
prepare
("
SELECT * FROM domains WHERE name=?
");
$sth
->
execute
(
$name
);
my
$row
=
$sth
->
fetchrow_hashref
;
return
$row
;
}
sub
test_new_domain
{
my
(
$name
)
=
$
0
=~
m{.*/(.*)}
;
my
(
$name
)
=
$
0
=~
m{.*/(.*)
\.t
}
;
test_remove_domain
(
$name
);
diag
("
Creating domain
$name
");
my
$domain
=
$ravada
->
create_domain
(
name
=>
$name
,
id_iso
=>
1
);
ok
(
$domain
,"
Domain not created
");
...
...
@@ -52,11 +76,8 @@ sub test_new_domain {
run3
(
\
@cmd
,
\
$in
,
\
$out
,
\
$err
);
ok
(
!
$?
,"
@cmd
\$
?=$? , it should be 0
$err
$out
");
my
$sth
=
$test
->
dbh
->
prepare
("
SELECT * FROM domains WHERE name=?
");
$sth
->
execute
(
$domain
->
name
);
my
$row
=
$sth
->
fetchrow_hashref
;
my
$row
=
search_domain_db
(
$domain
->
name
);
ok
(
$row
->
{
name
}
&&
$row
->
{
name
}
eq
$domain
->
name
,"
I can't find the domain at the db
");
$sth
->
finish
;
return
$domain
;
}
...
...
@@ -75,11 +96,22 @@ sub test_prepare_base {
################################################################
test_vm_kvm
();
my
$domain
=
test_new_domain
();
{
my
$domain
=
test_new_domain
();
if
(
ok
(
$domain
,"
test domain not created
"))
{
test_prepare_base
(
$domain
);
test_remove_domain
(
$domain
->
name
);
if
(
ok
(
$domain
,"
test domain not created
"))
{
test_prepare_base
(
$domain
);
test_remove_domain
(
$domain
->
name
);
}
}
{
my
$domain
=
test_new_domain
();
if
(
ok
(
$domain
,"
test domain not created
"))
{
test_remove_domain_by_name
(
$domain
->
name
);
}
}
done_testing
();
t/30_request.t
0 → 100644
View file @
e29c17ac
use
warnings
;
use
strict
;
use
Test::
More
;
use
Test::SQL::
Data
;
use_ok
('
Ravada
');
use_ok
('
Ravada::Request
');
my
$test
=
Test::SQL::
Data
->
new
(
config
=>
'
t/etc/ravada.conf
');
my
$ravada
=
Ravada
->
new
(
connector
=>
$test
->
connector
);
my
(
$DOMAIN_NAME
)
=
$
0
=~
m{.*/(.*)\.}
;
my
$DOMAIN_NAME_SON
=
$DOMAIN_NAME
.
"
_son
";
sub
test_empty_request
{
my
$request
=
$ravada
->
request
();
ok
(
$request
);
}
sub
test_remove_domain
{
my
$name
=
shift
;
my
$domain
=
$name
if
ref
(
$name
);
$domain
=
$ravada
->
search_domain
(
$name
);
if
(
$domain
)
{
diag
("
Removing domain
$name
");
eval
{
$domain
->
remove
()
};
ok
(
!
$@
,
"
Error removing domain
$name
: $@
")
or
exit
;
ok
(
!
-
e
$domain
->
file_base_img
,"
Image file was not removed
"
.
$domain
->
file_base_img
)
if
$domain
->
file_base_img
;
}
$domain
=
$ravada
->
search_domain
(
$name
);
ok
(
!
$domain
,
"
I can't remove old domain
$name
")
or
exit
;
}
sub
test_req_create_domain_iso
{
my
$name
=
$DOMAIN_NAME
.
"
_iso
";
my
$req
=
Ravada::
Request
->
create_domain
(
name
=>
$name
,
id_iso
=>
1
);
ok
(
$req
);
ok
(
$req
->
status
);
ok
(
defined
$req
->
args
->
{
name
}
&&
$req
->
args
->
{
name
}
eq
$name
,"
Expecting args->{name} eq
$name
"
.
"
,got '
"
.
(
$req
->
args
->
{
name
}
or
'
<UNDEF>
')
.
"
'
");
ok
(
$req
->
status
eq
'
requested
'
,"
Status of request is
"
.
$req
->
status
.
"
it should be requested
");
$ravada
->
process_requests
();
ok
(
$req
->
status
eq
'
done
'
,"
Status of request is
"
.
$req
->
status
.
"
it should be done
");
ok
(
!
$req
->
error
,"
Error
"
.
$req
->
error
.
"
creating domain
"
.
$name
);
my
$domain
=
$ravada
->
search_domain
(
$name
);
ok
(
$domain
,"
I can't find domain
$name
");
return
$domain
;
}
sub
test_req_remove_domain_obj
{
my
$domain
=
shift
;
my
$req
=
Ravada::
Request
->
remove_domain
(
$domain
);
$ravada
->
process_requests
();
my
$domain2
=
$ravada
->
search_domain
(
$domain
->
name
);
ok
(
!
$domain2
,"
Domain
"
.
$domain
->
name
.
"
should be removed
");
ok
(
!
$req
->
error
,"
Error
"
.
$req
->
error
.
"
removing domain
"
.
$domain
->
name
);
}
sub
test_req_remove_domain_name
{
my
$name
=
shift
;
my
$req
=
Ravada::
Request
->
remove_domain
(
$name
);
$ravada
->
process_requests
();
my
$domain
=
$ravada
->
search_domain
(
$name
);
ok
(
!
$domain
,"
Domain
$name
should be removed
");
ok
(
!
$req
->
error
,"
Error
"
.
$req
->
error
.
"
removing domain
$name
");
}
################################################
test_remove_domain
(
$DOMAIN_NAME
.
"
_iso
");
{
my
$domain
=
test_req_create_domain_iso
();
test_req_remove_domain_obj
(
$domain
)
if
$domain
;
}
{
my
$domain
=
test_req_create_domain_iso
();
test_req_remove_domain_name
(
$domain
->
name
)
if
$domain
;
}
test_remove_domain
(
$DOMAIN_NAME
.
"
_iso
");
done_testing
();
t/db/20_domain_kvm.db
deleted
100644 → 0
View file @
99badc35
File deleted
t/etc/ravada.conf
View file @
e29c17ac
sql
:
- ../../
sql
/
sqlite
/
iso_images
.
sql
- ../../
sql
/
sqlite
/
domains
.
sql
- ../../
sql
/
sqlite
/
requests
.
sql
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment