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
cd53759d
Commit
cd53759d
authored
Feb 19, 2020
by
fv3rdugo
Browse files
Merge branch 'develop' into 369_dockers
parents
ea7304e1
3a9c9a75
Changes
93
Expand all
Hide whitespace changes
Inline
Side-by-side
CONTRIBUTING.md
View file @
cd53759d
...
...
@@ -28,14 +28,6 @@ mentor first timers.
If this is something you think you can fix, then
[
fork Ravada
](
https://help.github.com/articles/fork-a-repo
)
and create a branch with a descriptive name. We prepend the issue number to
the branch so it is easier to follow.
A good branch name would be (where issue #77 is the one you're working on):
```
sh
git checkout
-b
fix/77_start_machine
```
## 4. Code Style
...
...
@@ -172,25 +164,15 @@ After working on your changes you need to Push it (upload) your newly created br
Pull requests or PR are proposed changes to a repository submitted by a user and accepted or rejected by a repository's collaborators.
When your changes are done, you should switch back to your master branch and make sure it's
up to date with Ravada's master branch:
```
sh
git remote add upstream git@github.com:UPC/ravada.git
git checkout master
git pull --rebase origin master
```
Then update your feature branch from your local copy of master, and push it!
Send your changes to github *pushing* them up:
```
sh
git checkout 325_boost_performance
git rebase master
git push --set-upstream origin 325_boost_performance
git push
```
Finally, go to our GitHub repository and
[create a Pull Request](https://github.com/
UPC/ravada/
pulls)
Finally, go to
y
our GitHub repository and
[create a Pull Request](https://github.com/pulls)
### 10.1 How to Write a Title for a Pull Request
...
...
@@ -211,9 +193,9 @@ To learn more about rebasing in Git, there are a lot of
but here's the suggested workflow:
```
sh
git
checkout 325_boost_performance
git
pull --rebase origin master
git
push --force-with-lease origin 325_boost_performance
git
remote add upstream https://github.com/UPC/ravada.git
git
fetch upstream
git
rebase upstream/develop
```
### 10.3 Merging a PR (maintainers only)
...
...
@@ -227,3 +209,14 @@ A PR can only be merged into master by a maintainer if:
Any maintainer is allowed to merge a PR if all of these conditions are
met.
### 11 Reset my fork to upstream
```
sh
git remote add upstream https://github.com/UPC/ravada
git fetch upstream
git checkout develop
git reset --hard upstream/develop
git push origin develop --force
```
debian/control-debian-10
View file @
cd53759d
...
...
@@ -4,7 +4,7 @@ Architecture: all
Section: utils
Priority: optional
Maintainer: Francesc Guasch <frankie@telecos.upc.edu>
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-ssh2-perl, bridge-utils, libencode-locale-perl
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-ssh2-perl, bridge-utils, libencode-locale-perl
, libpbkdf2-tiny-perl
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
debian/control-ubuntu-18.04
View file @
cd53759d
...
...
@@ -4,7 +4,7 @@ Architecture: all
Section: utils
Priority: optional
Maintainer: Francesc Guasch <frankie@telecos.upc.edu>
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-bin,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-ssh2-perl, bridge-utils, libencode-locale-perl
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-bin,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-ssh2-perl, bridge-utils, libencode-locale-perl
, libpbkdf2-tiny-perl
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
debian/control-ubuntu-19.04
View file @
cd53759d
...
...
@@ -4,7 +4,7 @@ Architecture: all
Section: utils
Priority: optional
Maintainer: Francesc Guasch <frankie@telecos.upc.edu>
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-ssh2-perl, bridge-utils
Depends: perl (>=5.18),libmojolicious-perl,mysql-common,libauthen-passphrase-perl, libdatetime-perl, libdbd-mysql-perl,libdbi-perl,libdbix-connector-perl,libipc-run3-perl,libio-stringy-perl,libnet-ldap-perl,libproc-pid-file-perl,libvirt-daemon-system,libsys-virt-perl,libxml-libxml-perl,libconfig-yaml-perl,libmoose-perl,libjson-xs-perl,qemu-utils,perlmagick,libmoosex-types-netaddr-ip-perl,libio-interface-perl,libiptables-chainmgr-perl,libnet-dns-perl,wget,liblocale-maketext-lexicon-perl,libmojolicious-plugin-i18n-perl,libdbd-sqlite3-perl, debconf (>= 0.2.26), adduser, libdigest-sha-perl, qemu-kvm, net-tools, libfile-rsync-perl, libnet-ssh2-perl, bridge-utils
, libpbkdf2-tiny-perl
Description: Remote Virtual Desktops Manager
Ravada is a software that allows the user to connect to a
remote virtual desktop.
etc/rvd_front.conf.example
View file @
cd53759d
...
...
@@ -2,6 +2,7 @@
hypnotoad => {
pid_file => '/var/run/ravada/rvd_front.pid'
,listen => ['http://*:8081']
,proxy => 1
}
,dir => {
templates => '/usr/share/ravada/templates'
...
...
lib/Ravada.pm
View file @
cd53759d
...
...
@@ -15,8 +15,9 @@ use Moose;
use
POSIX
qw(WNOHANG)
;
use
Time::
HiRes
qw(gettimeofday tv_interval)
;
use
YAML
;
use
MIME::
Base64
;
use
Socket
qw( inet_aton inet_ntoa )
;
use
Image::Magick::
Q16
;
no
warnings
"
experimental::signatures
";
use
feature
qw(signatures)
;
...
...
@@ -160,7 +161,7 @@ sub _init_user_daemon {
sub
_update_user_grants
{
my
$self
=
shift
;
$self
->
_init_user_daemon
();
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
SELECT id FROM users
");
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
SELECT id FROM users
WHERE is_temporary=0
");
my
$id
;
$sth
->
execute
;
$sth
->
bind_columns
(
\
$id
);
...
...
@@ -168,7 +169,13 @@ sub _update_user_grants {
my
$user
=
Ravada::Auth::
SQL
->
search_by_id
(
$id
);
next
if
$user
->
name
()
eq
$USER_DAEMON_NAME
;
next
if
$user
->
grants
();
my
%grants
=
$user
->
grants
();
for
my
$key
(
keys
%grants
)
{
delete
$grants
{
$key
}
if
!
defined
$grants
{
$key
};
}
next
if
keys
%grants
;
$USER_DAEMON
->
grant_user_permissions
(
$user
);
$USER_DAEMON
->
grant_admin_permissions
(
$user
)
if
$user
->
is_admin
;
}
...
...
@@ -449,7 +456,28 @@ sub _update_isos {
,
xml_volume
=>
'
jessie-volume.xml
'
,
min_disk_size
=>
'
10
'
}
,
kali_64
=>
{
name
=>
'
Kali Linux 2020
'
,
description
=>
'
Kali Linux 2020 64 Bits
'
,
arch
=>
'
amd64
'
,
xml
=>
'
jessie-amd64.xml
'
,
xml_volume
=>
'
jessie-volume.xml
'
,
url
=>
'
https://cdimage.kali.org/kali-2020.\d+/
'
,
file_re
=>
'
kali-linux-2020.\d+-installer-amd64.iso
'
,
sha256_url
=>
'
$url/SHA256SUMS
'
,
min_disk_size
=>
'
10
'
}
,
kali_64_netinst
=>
{
name
=>
'
Kali Linux 2020 (NetInstaller)
'
,
description
=>
'
Kali Linux 2020 64 Bits (light NetInstall)
'
,
arch
=>
'
amd64
'
,
xml
=>
'
jessie-amd64.xml
'
,
xml_volume
=>
'
jessie-volume.xml
'
,
url
=>
'
https://cdimage.kali.org/kali-2020.\d+/
'
,
file_re
=>
'
kali-linux-2020.\d+-installer-netinst-amd64.iso
'
,
sha256_url
=>
'
$url/SHA256SUMS
'
,
min_disk_size
=>
'
10
'
}
,
windows_7
=>
{
name
=>
'
Windows 7
'
,
description
=>
'
Windows 7 64 bits. Requires an user provided ISO image.
'
...
...
@@ -526,7 +554,7 @@ sub _scheduled_fedora_releases($self,$data) {
name
=>
'
Fedora
'
.
$release
,
description
=>
"
RedHat Fedora
$release
Workstation 64 bits
"
,
url
=>
'
http://ftp.halifax.rwth-aachen.de/fedora/linux/releases/
'
.
$release
.
'
/Workstation/x86_64/iso/Fedora-Workstation-
netinst
-x86_64-
'
.
$release
.
'
/Workstation/x86_64/iso/Fedora-Workstation-
.*
-x86_64-
'
.
$release
.
'
-.*\.iso
'
,
arch
=>
'
amd64
'
,
xml
=>
'
xenial64-amd64.xml
'
...
...
@@ -990,7 +1018,7 @@ sub _null_grants($self) {
$sth
->
execute
;
my
(
$count
)
=
$sth
->
fetchrow
;
exit
if
!
$count
&&
$self
->
{
_null
}
++
;
warn
"
No null grants found
"
if
!
$count
&&
$self
->
{
_null
_grants
}
++
;
return
$count
;
}
...
...
@@ -1225,7 +1253,7 @@ sub _upgrade_tables {
$self
->
_upgrade_table
('
iso_images
','
device
','
varchar(255)
');
$self
->
_upgrade_table
('
iso_images
','
min_disk_size
','
int (11) DEFAULT NULL
');
$self
->
_upgrade_table
('
users
','
language
','
char(
3
) DEFAULT NULL
');
$self
->
_upgrade_table
('
users
','
language
','
char(
40
) DEFAULT NULL
');
if
(
$self
->
_upgrade_table
('
users
','
is_external
','
int(11) DEFAULT 0
'))
{
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
(
"
UPDATE users set is_external=1 WHERE password='*LK* no pss'
"
...
...
@@ -1233,6 +1261,7 @@ sub _upgrade_tables {
$sth
->
execute
;
}
$self
->
_upgrade_table
('
users
','
external_auth
','
char(32) DEFAULT NULL
');
$self
->
_upgrade_table
('
users
','
date_created
','
timestamp DEFAULT CURRENT_TIMESTAMP
');
$self
->
_upgrade_table
('
networks
','
requires_password
','
int(11)
');
$self
->
_upgrade_table
('
networks
','
n_order
','
int(11) not null default 0
');
...
...
@@ -1262,7 +1291,13 @@ sub _upgrade_tables {
$self
->
_upgrade_table
('
domains
','
is_pool
','
int NOT NULL default 0
');
$self
->
_upgrade_table
('
domains
','
needs_restart
','
int not null default 0
');
$self
->
_upgrade_table
('
domains
','
screenshot
','
BLOB
');
if
(
$self
->
_upgrade_table
('
domains
','
screenshot
','
BLOB
'))
{
$self
->
_upgrade_screenshots
();
}
$self
->
_upgrade_table
('
domains_network
','
allowed
','
int not null default 1
');
$self
->
_upgrade_table
('
iptables
','
id_vm
','
int DEFAULT NULL
');
...
...
@@ -1427,6 +1462,12 @@ sub _check_config($config_orig = {} , $valid_config = \%VALID_CONFIG ) {
warn
"
Error: Unknown config entry
\n
"
.
Dumper
(
\
%config
)
if
!
$
0
=~
/\.t$/
;
return
0
;
}
warn
"
Warning: LDAP authentication with match is discouraged. Try bind.
\n
"
if
exists
$config_orig
->
{
ldap
}
&&
exists
$config_orig
->
{
ldap
}
->
{
auth
}
&&
$config_orig
->
{
ldap
}
->
{
auth
}
=~
/match/
&&
$
0
!~
/\.t$/
;
return
1
;
}
...
...
@@ -1579,6 +1620,7 @@ sub create_domain {
my
$start
=
$args
{
start
};
my
$id_base
=
$args
{
id_base
};
my
$data
=
delete
$args
{
data
};
my
$id_owner
=
$args
{
id_owner
}
or
confess
"
Error: missing id_owner
"
.
Dumper
(
\
%args
);
_check_args
(
\
%args
,
qw(iso_file id_base id_iso id_owner name active swap memory disk id_template start remote_ip request vm add_to_pool)
);
...
...
@@ -1637,6 +1679,12 @@ sub create_domain {
die
$error
if
$error
&&
!
$request
;
$request
->
error
(
$error
)
if
$error
;
}
Ravada::
Request
->
add_hardware
(
uid
=>
$args
{
id_owner
}
,
id_domain
=>
$domain
->
id
,
name
=>
'
disk
'
,
data
=>
{
size
=>
$data
,
type
=>
'
data
'
}
)
if
$domain
&&
$data
;
return
$domain
;
}
...
...
@@ -2410,10 +2458,11 @@ sub _do_execute_command {
$err
=~
s/(.*?)retry.?/$1/i
;
$request
->
error
(
$err
)
if
$err
;
}
}
}
else
{
$request
->
status
('
done
')
if
$request
->
status
()
ne
'
done
'
&&
$request
->
status
()
!~
/^retry/i
;
}
}
sub
_cmd_manage_pools
($self, $request) {
...
...
@@ -2505,16 +2554,33 @@ sub _cmd_copy_screenshot {
my
$id_base
=
$domain
->
id_base
;
my
$base
=
$self
->
search_domain_by_id
(
$id_base
);
if
(
!
$domain
->
file_
screenshot
)
{
if
(
!
$domain
->
screenshot
)
{
die
"
I don't have the screenshot of the domain
"
.
$domain
->
name
;
}
else
{
$base
->
_data
(
screenshot
=>
$domain
->
_data
('
screenshot
'));
}
}
my
$base_screenshot
=
$domain
->
fil
e_screenshot
();
sub
_upgrad
e_screenshot
s
($self) {
$base_screenshot
=~
s{(.*)/\d+\.(\w+)}{$1/$id_base.$2}
;
$base
->
_post_screenshot
(
$base_screenshot
);
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
(
"
SELECT id, name, file_screenshot FROM domains WHERE file_screenshot like '%'
"
);
$sth
->
execute
();
copy
(
$domain
->
file_screenshot
,
$base_screenshot
);
my
$sth_update
=
$CONNECTOR
->
dbh
->
prepare
(
"
UPDATE domains set screenshot = ? WHERE id=?
"
);
while
(
my
(
$id
,
$name
,
$file_path
)
=
$sth
->
fetchrow
)
{
next
if
!
-
e
$file_path
;
warn
"
INFO: converting screenshot from
$name
";
my
$file
=
new
Image::Magick::
Q16
;
$file
->
Read
(
$file_path
);
my
@blobs
=
$file
->
ImageToBlob
(
magick
=>
'
png
');
eval
{
$sth_update
->
execute
(
encode_base64
(
$blobs
[
0
]),
$id
);
};
warn
$@
;
}
}
...
...
@@ -2644,6 +2710,11 @@ sub _cmd_remove {
$self
->
remove_domain
(
name
=>
$request
->
args
('
name
'),
uid
=>
$request
->
args
('
uid
'));
}
sub
_cmd_restore_domain
($self,$request) {
my
$domain
=
Ravada::
Domain
->
open
(
$request
->
args
('
id_domain
'));
return
$domain
->
restore
(
Ravada::Auth::
SQL
->
search_by_id
(
$request
->
args
('
uid
')));
}
sub
_cmd_pause
{
my
$self
=
shift
;
my
$request
=
shift
;
...
...
@@ -2703,7 +2774,8 @@ sub _cmd_open_iptables {
sub
_cmd_clone
($self, $request) {
return
_req_clone_many
(
$self
,
$request
)
if
$request
->
defined_arg
('
number
');
return
_req_clone_many
(
$self
,
$request
)
if
$request
->
defined_arg
('
number
')
&&
$request
->
defined_arg
('
number
')
>
1
;
my
$domain
=
Ravada::
Domain
->
open
(
$request
->
args
('
id_domain
'))
or
confess
"
Error: Domain
"
.
$request
->
args
('
id_domain
')
.
"
not found
";
...
...
@@ -2714,7 +2786,7 @@ sub _cmd_clone($self, $request) {
my
$user
=
Ravada::Auth::
SQL
->
search_by_id
(
$request
->
args
('
uid
'))
or
die
"
Error: User missing, id:
"
.
$request
->
args
('
uid
');
$args
->
{
user
}
=
$user
;
for
(
qw(id_domain uid at )
)
{
for
(
qw(id_domain uid at
number
)
)
{
delete
$args
->
{
$_
};
}
...
...
@@ -2734,6 +2806,15 @@ sub _req_clone_many($self, $request) {
my
$domains
=
$self
->
list_domains_data
();
my
%domain_exists
=
map
{
$_
->
{
name
}
=>
1
}
@$domains
;
if
(
!
$base
->
is_base
)
{
my
$uid
=
$request
->
defined_arg
('
uid
');
confess
Dumper
(
$request
)
if
!
$uid
;
my
$req_prepare
=
Ravada::
Request
->
prepare_base
(
id_domain
=>
$base
->
id
,
uid
=>
$uid
);
$args
->
{
after_request
}
=
$req_prepare
->
id
;
}
my
@reqs
;
for
(
1
..
$number
)
{
my
$n
=
$_
;
...
...
@@ -2798,7 +2879,7 @@ sub _cmd_dettach($self, $request) {
$domain
->
dettach
(
$user
);
}
sub
_cmd_rebase
_volumes
($self, $request) {
sub
_cmd_rebase
($self, $request) {
my
$domain
=
Ravada::
Domain
->
open
(
$request
->
id_domain
);
my
$user
=
Ravada::Auth::
SQL
->
search_by_id
(
$request
->
args
('
uid
'));
...
...
@@ -2806,14 +2887,15 @@ sub _cmd_rebase_volumes($self, $request) {
if
!
$user
->
is_admin
;
if
(
$domain
->
is_active
)
{
Ravada::
Request
->
shutdown_domain
(
uid
=>
$user
->
id
,
id_domain
=>
$domain
->
id
,
timeout
=>
120
);
$request
->
status
("
requested
"
);
die
"
Error
: domain
"
.
$domain
->
name
.
"
is
still active, shut it down to rebase
\n
"
my
$req_shutdown
=
Ravada::
Request
->
shutdown_domain
(
uid
=>
$user
->
id
,
id_domain
=>
$domain
->
id
,
timeout
=>
120
);
$request
->
after_request
(
$req_shutdown
->
id
);
die
"
Warning
: domain
"
.
$domain
->
name
.
"
is
up, retry.
\n
"
}
$request
->
status
('
working
');
my
$new_base
=
Ravada::
Domain
->
open
(
$request
->
args
('
id_base
'));
$domain
->
rebase_volumes
(
$new_base
);
$domain
->
rebase
(
$user
,
$new_base
);
}
...
...
@@ -2886,12 +2968,26 @@ sub _cmd_remove_base {
die
"
Unknown domain id '
$id_domain
'
\n
"
if
!
$domain
;
$domain
->
_vm
->
disconnect
();
$self
->
_disconnect_vm
();
$domain
->
remove_base
(
$user
);
}
sub
_cmd_spinoff
($self, $request) {
my
$id_domain
=
$request
->
id_domain
or
confess
"
Missing request id_domain
";
my
$uid
=
$request
->
args
('
uid
')
or
confess
"
Missing argument uid
";
my
$user
=
Ravada::Auth::
SQL
->
search_by_id
(
$uid
);
my
$domain
=
$self
->
search_domain_by_id
(
$id_domain
);
die
"
Unknown domain id '
$id_domain
'
\n
"
if
!
$domain
;
$domain
->
spinoff
();
}
sub
_cmd_hybernate
{
my
$self
=
shift
;
...
...
@@ -2983,7 +3079,7 @@ sub _cmd_change_hardware {
$domain
->
change_hardware
(
$request
->
args
('
hardware
')
,
$request
->
arg
s
('
index
')
,
$request
->
defined_
arg
('
index
')
,
$request
->
args
('
data
')
);
}
...
...
@@ -3168,24 +3264,6 @@ sub _cmd_refresh_vms($self, $request=undef) {
$self
->
_refresh_volatile_domains
();
}
sub
_cmd_change_max_memory
($self, $request) {
my
$uid
=
$request
->
args
('
uid
');
my
$id_domain
=
$request
->
args
('
id_domain
');
my
$memory
=
$request
->
args
('
ram
');
my
$domain
=
$self
->
search_domain_by_id
(
$id_domain
);
$domain
->
set_max_mem
(
$memory
);
}
sub
_cmd_change_curr_memory
($self, $request) {
my
$uid
=
$request
->
args
('
uid
');
my
$id_domain
=
$request
->
args
('
id_domain
');
my
$memory
=
$request
->
args
('
ram
');
my
$domain
=
$self
->
search_domain_by_id
(
$id_domain
);
$domain
->
set_memory
(
$memory
);
}
sub
_cmd_shutdown_node
($self, $request) {
my
$id_node
=
$request
->
args
('
id_node
');
my
$node
=
Ravada::
VM
->
open
(
$id_node
);
...
...
@@ -3402,15 +3480,19 @@ sub _remove_unnecessary_downs($self, $domain) {
sub
_refresh_volatile_domains
($self) {
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
(
"
SELECT id, name, id_vm FROM domains WHERE is_volatile=1
"
"
SELECT id, name, id_vm
, id_owner
FROM domains WHERE is_volatile=1
"
);
$sth
->
execute
();
while
(
my
(
$id_domain
,
$name
,
$id_vm
)
=
$sth
->
fetchrow
)
{
while
(
my
(
$id_domain
,
$name
,
$id_vm
,
$id_owner
)
=
$sth
->
fetchrow
)
{
my
$domain
=
Ravada::
Domain
->
open
(
id
=>
$id_domain
,
_force
=>
1
);
if
(
!
$domain
||
$domain
->
status
eq
'
down
'
||
!
$domain
->
is_active
)
{
if
(
$domain
)
{
$domain
->
_post_shutdown
(
user
=>
$USER_DAEMON
);
$domain
->
remove
(
$USER_DAEMON
);
}
else
{
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
DELETE FROM users WHERE id=?
");
$sth
->
execute
(
$id_owner
);
$sth
->
finish
;
}
my
$sth_del
=
$CONNECTOR
->
dbh
->
prepare
("
DELETE FROM domains WHERE id=?
");
$sth_del
->
execute
(
$id_domain
);
...
...
@@ -3458,11 +3540,11 @@ sub _cmd_set_base_vm {
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
');
$self
->
_wait_pids
();
}
sub
_req_method
{
...
...
@@ -3477,6 +3559,7 @@ sub _req_method {
,
pause
=>
\
&_cmd_pause
,
create
=>
\
&_cmd_create
,
remove
=>
\
&_cmd_remove
,
restore_domain
=>
\
&_cmd_restore_domain
,
resume
=>
\
&_cmd_resume
,
dettach
=>
\
&_cmd_dettach
,
cleanup
=>
\
&_cmd_cleanup
...
...
@@ -3488,9 +3571,12 @@ sub _req_method {
,
add_disk
=>
\
&_cmd_add_disk
,
copy_screenshot
=>
\
&_cmd_copy_screenshot
,
cmd_cleanup
=>
\
&_cmd_cleanup
,
remove_base
=>
\
&_cmd_remove_base
,
spinoff
=>
\
&_cmd_spinoff
,
set_base_vm
=>
\
&_cmd_set_base_vm
,
remove_base_vm
=>
\
&_cmd_set_base_vm
,
refresh_vms
=>
\
&_cmd_refresh_vms
,
ping_backend
=>
\
&_cmd_ping_backend
,
prepare_base
=>
\
&_cmd_prepare_base
...
...
@@ -3499,7 +3585,8 @@ sub _req_method {
,
list_vm_types
=>
\
&_cmd_list_vm_types
,
enforce_limits
=>
\
&_cmd_enforce_limits
,
force_shutdown
=>
\
&_cmd_force_shutdown
,
rebase_volumes
=>
\
&_cmd_rebase_volumes
,
rebase
=>
\
&_cmd_rebase
,
refresh_storage
=>
\
&_cmd_refresh_storage
,
refresh_machine
=>
\
&_cmd_refresh_machine
,
domain_autostart
=>
\
&_cmd_domain_autostart
...
...
@@ -3507,8 +3594,6 @@ sub _req_method {
,
add_hardware
=>
\
&_cmd_add_hardware
,
remove_hardware
=>
\
&_cmd_remove_hardware
,
change_hardware
=>
\
&_cmd_change_hardware
,
change_max_memory
=>
\
&_cmd_change_max_memory
,
change_curr_memory
=>
\
&_cmd_change_curr_memory
# Domain ports
,
expose
=>
\
&_cmd_expose
...
...
@@ -3692,6 +3777,26 @@ sub _enforce_limits_active($self, $request) {
}
}
sub
_clean_temporary_users
($self) {
my
$sth_users
=
$CONNECTOR
->
dbh
->
prepare
(
"
SELECT u.id, d.id, u.date_created
"
.
"
FROM users u LEFT JOIN domains d
"
.
"
ON u.id = d.id_owner
"
.
"
WHERE u.is_temporary = 1 AND u.date_created < ?
"
);
my
$sth_del
=
$CONNECTOR
->
dbh
->
prepare
(
"
DELETE FROM users
"
.
"
WHERE is_temporary = 1 AND id=?
"
);
my
$one_day
=
_date_now
(
-
24
*
60
*
60
);
$sth_users
->
execute
(
$one_day
);
while
(
my
(
$id_user
,
$id_domain
,
$date_created
)
=
$sth_users
->
fetchrow
)
{
next
if
$id_domain
;
$sth_del
->
execute
(
$id_user
);
}
}
sub
_clean_volatile_machines
($self, %args) {
my
$request
=
delete
$args
{
request
};
...
...
@@ -3706,8 +3811,13 @@ sub _clean_volatile_machines($self, %args) {
);
if
(
$domain_real
)
{
next
if
$domain_real
->
domain
&&
$domain_real
->
is_active
;
$domain_real
->
_post_shutdown
();
$domain_real
->
remove
(
$USER_DAEMON
);
eval
{
$domain_real
->
_post_shutdown
()
};
warn
$@
if
$@
;
eval
{
$domain_real
->
remove
(
$USER_DAEMON
)
};
warn
$@
if
$@
;
}
elsif
(
$domain
->
{
id_owner
})
{
my
$sth
=
$CONNECTOR
->
dbh
->
prepare
("
DELETE FROM users where id=?
");
$sth
->
execute
(
$domain
->
{
id_owner
});
}
$sth_remove
->
execute
(
$domain
->
{
id
});
...
...
@@ -3755,7 +3865,6 @@ sub _cmd_open_exposed_ports($self, $request) {
}
sub
DESTROY
($self) {
$self
->
_wait_pids
();
}
=head2 version
...
...
lib/Ravada/Auth/LDAP.pm
View file @
cd53759d
...
...
@@ -13,7 +13,10 @@ use Authen::Passphrase;
use
Authen::Passphrase::
SaltedDigest
;
use
Carp
qw(carp)
;
use
Data::
Dumper
;
use
Digest::
SHA
qw(sha1_hex)
;
use
Digest::
SHA
qw(sha1_hex sha256_hex)
;
use
Encode
;
use
PBKDF2::
Tiny
qw/derive/
;
use
MIME::
Base64
;
use
Moose
;
use
Net::
LDAP
;
use
Net::
LDAPS
;
...
...
@@ -43,6 +46,11 @@ our $STATUS_EOF = 1;
our
$STATUS_DISCONNECTED
=
81
;
our
$STATUS_BAD_FILTER
=
89
;
our
$PBKDF2_SALT_LENGTH
=
64
;
our
$PBKDF2_ITERATIONS_LENGTH
=
4
;
our
$PBKDF2_HASH_LENGTH
=
256
;
our
$PBKDF2_LENGTH
=
$PBKDF2_SALT_LENGTH
+
$PBKDF2_ITERATIONS_LENGTH
+
$PBKDF2_HASH_LENGTH
;
=head2 BUILD
Internal OO build
...
...
@@ -64,8 +72,7 @@ Adds a new user in the LDAP directory
=cut
sub
add_user
{
my
(
$name
,
$password
,
$is_admin
)
=
@_
;
sub
add_user
($name, $password, $storage='rfc2307', $algorithm=undef ) {
_init_ldap_admin
();
...
...
@@ -76,8 +83,6 @@ sub add_user {
if
!
_dc_base
();
my
(
$givenName
,
$sn
)
=
$name
=~
m{(\w+)\.(.*)}
;
my
$apr
=
Authen::Passphrase::
SaltedDigest
->
new
(
passphrase
=>
$password
,
algorithm
=>
"
MD5
");
my
%entry
=
(
cn
=>
$name
,
uid
=>
$name
...
...
@@ -87,7 +92,7 @@ sub add_user {
,
givenName
=>
(
$givenName
or
$name
)
,
sn
=>
(
$sn
or
$name
)
# , homeDirectory => "/home/$name"
,
userPassword
=>
$apr
->
as_rfc2307
(
)
,
userPassword
=>
_password_store
(
$password
,
$storage
,
$algorithm
)
);
my
$dn
=
"
cn=
$name
,
"
.
_dc_base
();
...
...
@@ -97,6 +102,51 @@ sub add_user {
}
}
sub
_password_store
($password, $storage, $algorithm) {
return
_password_rfc2307
(
$password
,
$algorithm
)
if
lc
(
$storage
)
eq
'
rfc2307
';
return
_password_pbkdf2
(
$password
,
$algorithm
)
if
lc
(
$storage
)
eq
'
pbkdf2
';
confess
"
Error: Unknown storage '
$storage
'
";
}
sub
_password_pbkdf2
($password, $algorithm='SHA-256') {