Ravada.pm 35.5 KB
Newer Older
1
2
3
4
5
package Ravada;

use warnings;
use strict;

6
our $VERSION = '0.2.6';
Francesc Guasch's avatar
Francesc Guasch committed
7

8
use Carp qw(carp croak);
9
use Data::Dumper;
10
use DBIx::Connector;
11
use Hash::Util qw(lock_hash);
12
use Moose;
Francesc Guasch's avatar
Francesc Guasch committed
13
use POSIX qw(WNOHANG);
14
15
use YAML;

16
17
use Socket qw( inet_aton inet_ntoa );

Francesc Guasch's avatar
Francesc Guasch committed
18
use Ravada::Auth;
19
use Ravada::Request;
20
use Ravada::VM::KVM;
21
use Ravada::VM::Void;
22

Francesc Guasch's avatar
Francesc Guasch committed
23
24
25
26
27
28
29
30
31
32
33
34
=head1 NAME

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

35
36
37
38
39
40
41

our $FILE_CONFIG = "/etc/ravada.conf";

###########################################################################

our $CONNECTOR;
our $CONFIG = {};
42
our $DEBUG;
43
our $CAN_FORK = 1;
44
our $CAN_LXC = 0;
45
46
47
48

# Seconds to wait for other long process
our $SECONDS_WAIT_CHILDREN = 2;
# Limit for long processes
49
our $LIMIT_PROCESS = 2;
50
51
our $LIMIT_HUGE_PROCESS = 1;

52
53
our $DIR_SQL = "sql/mysql";
$DIR_SQL = "/usr/share/doc/ravada/sql/mysql" if ! -e $DIR_SQL;
54

55
# LONG commands take long
56
57
our %HUGE_COMMAND = map { $_ => 1 } qw(download);
our %LONG_COMMAND =  map { $_ => 1 } (qw(prepare_base remove_base screenshot ), keys %HUGE_COMMAND);
58

59
60
61
our $USER_DAEMON;
our $USER_DAEMON_NAME = 'daemon';

62
63
64
65
66
67
68
69
has 'vm' => (
          is => 'ro'
        ,isa => 'ArrayRef'
       ,lazy => 1
     , builder => '_create_vm'
);

has 'connector' => (
70
71
72
73
74
75
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
76
77
);

78
79
80
81
82
83
has 'warn_error' => (
    is => 'rw'
    ,isa => 'Bool'
    ,default => sub { 1 }
);

Francesc Guasch's avatar
Francesc Guasch committed
84
85
86
87
88
89
90
=head2 BUILD

Internal constructor

=cut


91
92
sub BUILD {
    my $self = shift;
93
    if ($self->config()) {
94
        _init_config($self->config);
95
    } else {
Francesc Guasch's avatar
Francesc Guasch committed
96
        _init_config($FILE_CONFIG) if -e $FILE_CONFIG;
97
    }
98

Francesc Guasch's avatar
Francesc Guasch committed
99
    if ( $self->connector ) {
joansp's avatar
joansp committed
100
        $CONNECTOR = $self->connector
Francesc Guasch's avatar
Francesc Guasch committed
101
102
    } else {
        $CONNECTOR = $self->_connect_dbh();
103
        $self->connector($CONNECTOR);
Francesc Guasch's avatar
Francesc Guasch committed
104
    }
Francesc Guasch's avatar
Francesc Guasch committed
105
    Ravada::Auth::init($CONFIG);
106

107
    $self->_create_tables();
108
    $self->_upgrade_tables();
Francesc Guasch's avatar
Francesc Guasch committed
109
    $self->_init_user_daemon();
110
111
112
    $self->_update_data();
}

113
114
115
116
117
118
119
120
121
122
123
124
125
126
sub _init_user_daemon {
    my $self = shift;
    return if $USER_DAEMON;

    $USER_DAEMON = Ravada::Auth::SQL->new(name => $USER_DAEMON_NAME);
    if (!$USER_DAEMON->id) {
        $USER_DAEMON = Ravada::Auth::SQL::add_user(
            name => $USER_DAEMON_NAME,
            is_admin => 1
        );
        $USER_DAEMON = Ravada::Auth::SQL->new(name => $USER_DAEMON_NAME);
    }

}
127
128
sub _update_user_grants {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
129
    $self->_init_user_daemon();
130
131
132
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM users");
    my $id;
    $sth->execute;
Francesc Guasch's avatar
Francesc Guasch committed
133
    $sth->bind_columns(\$id);
134
135
    while ($sth->fetch) {
        my $user = Ravada::Auth::SQL->search_by_id($id);
Francesc Guasch's avatar
Francesc Guasch committed
136
137
        next if $user->name() eq $USER_DAEMON_NAME;

138
139
        $USER_DAEMON->grant_user_permissions($user);
        $USER_DAEMON->grant_admin_permissions($user)    if $user->is_admin;
140
141
142
143
    }
    $sth->finish;
}

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
sub _update_isos {
    my $self = shift;
    my $table = 'iso_images';
    my $field = 'name';
    my %data = (
        zesty => {
                    name => 'Ubuntu Zesty Zapus'
            ,description => 'Ubuntu 17.04 Zesty Zapus 64 bits'
                   ,arch => 'amd64'
                    ,xml => 'yakkety64-amd64.xml'
             ,xml_volume => 'yakkety64-volume.xml'
                    ,url => 'http://releases.ubuntu.com/17.04/'
                ,file_re => ,'ubuntu-17.04.*desktop-amd64.iso'
                ,md5_url => ,'http://releases.ubuntu.com/17.04/MD5SUMS'
        }
Francesc Guasch's avatar
Francesc Guasch committed
159
160
161
162
163
164
165
166
167
168
169
170
        ,serena64 => {
            name => 'Mint 18.1 Mate 64 bits'
    ,description => 'Mint Serena 18.1 with Mate Desktop based on Ubuntu Xenial 64 bits'
           ,arch => 'amd64'
            ,xml => 'xenial64-amd64.xml'
     ,xml_volume => 'xenial64-volume.xml'
            ,url => 'http://mirrors.evowise.com/linuxmint/stable/18.1/'
        ,file_re => 'linuxmint-18.1-mate-64bit.iso'
        ,md5_url => ''
            ,md5 => 'c5cf5c5d568e2dfeaf705cfa82996d93'

        }
Francesc Guasch's avatar
Francesc Guasch committed
171
172
173
        ,fedora => {
            name => 'Fedora 25'
            ,description => 'RedHat Fedora 25 Workstation 64 bits'
Francesc Guasch's avatar
Francesc Guasch committed
174
            ,url => 'http://ftp.halifax.rwth-aachen.de/fedora/linux/releases/25/Workstation/x86_64/iso/Fedora-Workstation-netinst-x86_64-25-.*\.iso'
Francesc Guasch's avatar
Francesc Guasch committed
175
176
177
178
179
            ,arch => 'amd64'
            ,xml => 'xenial64-amd64.xml'
            ,xml_volume => 'xenial64-volume.xml'
            ,sha256_url => 'http://fedora.mirrors.ovh.net/linux/releases/25/Workstation/x86_64/iso/Fedora-Workstation-25-.*-x86_64-CHECKSUM'
        }
Francesc Guasch's avatar
Francesc Guasch committed
180

181
182
183
184
185
186
187
188
    );

    my $sth_search = $CONNECTOR->dbh->prepare("SELECT id FROM $table WHERE $field = ?");
    for my $name (keys %data) {
        my $row = $data{$name};
        $sth_search->execute($row->{$field});
        my ($id) = $sth_search->fetchrow;
        next if $id;
Francesc Guasch's avatar
Francesc Guasch committed
189
        warn("INFO: updating $table : $row->{$field}\n")    if $0 !~ /\.t$/;
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

        my $sql =
            "INSERT INTO iso_images "
            ."("
            .join(" , ", sort keys %{$data{$name}})
            .")"
            ." VALUES ( "
            .join(" , ", map { "?" } keys %{$data{$name}})
            ." )"
        ;
        my $sth = $CONNECTOR->dbh->prepare($sql);
        $sth->execute(map { $data{$name}->{$_} } sort keys %{$data{$name}});
        $sth->finish;
    }
}

sub _update_data {
    my $self = shift;
208

209
    $self->_update_isos();
210
    $self->_update_user_grants();
211
212
}

213
214
215
216
217
218
219
220
221
222
sub _upgrade_table {
    my $self = shift;
    my ($table, $field, $definition) = @_;
    my $dbh = $CONNECTOR->dbh;

    my $sth = $dbh->column_info(undef,undef,$table,$field);
    my $row = $sth->fetchrow_hashref;
    $sth->finish;
    return if $row;

Francesc Guasch's avatar
Francesc Guasch committed
223
    warn "INFO: adding $field $definition to $table\n"  if $0 !~ /\.t$/;
224
    $dbh->do("alter table $table add $field $definition");
225
    return 1;
226
227
}

228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
sub _create_table {
    my $self = shift;
    my $table = shift;

    my $sth = $CONNECTOR->dbh->table_info('%',undef,$table,'TABLE');
    my $info = $sth->fetchrow_hashref();
    $sth->finish;
    return if keys %$info;

    warn "INFO: creating table $table\n";
    my $file_sql = "$DIR_SQL/$table.sql";
    open my $in,'<',$file_sql or die "$! $file_sql";
    my $sql = join " ",<$in>;
    close $in;

    $CONNECTOR->dbh->do($sql);
    return 1;
}

sub _insert_data {
    my $self = shift;
    my $table = shift;

    my $file_sql =  "$DIR_SQL/../data/insert_$table.sql";
    return if ! -e $file_sql;

    warn "INFO: inserting data for $table\n";
    open my $in,'<',$file_sql or die "$! $file_sql";
    my $sql = '';
    while (my $line = <$in>) {
        $sql .= $line;
        next if $sql !~ /\w/ || $sql !~ /;\s*$/;
        $CONNECTOR->dbh->do($sql);
        $sql = '';
    }
    close $in;

}

sub _create_tables {
    my $self = shift;
269
270
    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;

271
272
273
274
275
276
277
278
279
    opendir my $ls,$DIR_SQL or die "$! $DIR_SQL";
    while (my $file = readdir $ls) {
        my ($table) = $file =~ m{(.*)\.sql$};
        next if !$table;
        $self->_insert_data($table)     if $self->_create_table($table);
    }
    closedir $ls;
}

280
281
sub _upgrade_tables {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
282
#    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;
283

284
    $self->_upgrade_table('file_base_images','target','varchar(64) DEFAULT NULL');
285

286
    $self->_upgrade_table('vms','vm_type',"char(20) NOT NULL DEFAULT 'KVM'");
287
288
    $self->_upgrade_table('vms','connection_args',"text DEFAULT NULL");

289
    $self->_upgrade_table('requests','at_time','int(11) DEFAULT NULL');
Francesc Guasch's avatar
Francesc Guasch committed
290

291
    $self->_upgrade_table('iso_images','md5_url','varchar(255)');
Francesc Guasch's avatar
Francesc Guasch committed
292
293
    $self->_upgrade_table('iso_images','sha256','varchar(255)');
    $self->_upgrade_table('iso_images','sha256_url','varchar(255)');
294
    $self->_upgrade_table('iso_images','file_re','char(64)');
295
    $self->_upgrade_table('iso_images','device','varchar(255)');
296
297

    $self->_upgrade_table('users','language','char(3) DEFAULT NULL');
298
299
300
301
302
303
    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'"
        );
        $sth->execute;
    }
Francesc Guasch's avatar
Francesc Guasch committed
304

305
    $self->_upgrade_table('networks','requires_password','int(11)');
306
307
    $self->_upgrade_table('networks','n_order','int(11) not null default 0');

308
    $self->_upgrade_table('domains','spice_password','varchar(20) DEFAULT NULL');
309
310
}

311

312
313
314
315
sub _connect_dbh {
    my $driver= ($CONFIG->{db}->{driver} or 'mysql');;
    my $db_user = ($CONFIG->{db}->{user} or getpwnam($>));;
    my $db_pass = ($CONFIG->{db}->{password} or undef);
Francesc Guasch's avatar
Francesc Guasch committed
316
317
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
318
319
320
321
322
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

323
=head2 display_ip
324

325
Returns the default display IP read from the config file
326

327
=cut
328

329
sub display_ip {
330

331
    my $ip = $CONFIG->{display_ip};
joansp's avatar
joansp committed
332

333
    return $ip if $ip;
334
335
}

336
337
sub _init_config {
    my $file = shift;
338
339

    my $connector = shift;
340
    confess "Deprecated connector" if $connector;
341

342
    $CONFIG = YAML::LoadFile($file);
343
344
345

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
346
#    $CONNECTOR = ( $connector or _connect_dbh());
347
348
}

349
sub _create_vm_kvm {
350
    my $self = shift;
351

352
353
354
355
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

    return(undef,"ERROR: Missing qemu-img") if !$cmd_qemu_img;
356
357

    my $vm_kvm;
358

359
360
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
361
362
363
364

    my ($internal_vm , $storage);
    eval {
        $storage = $vm_kvm->dir_img();
365
        $internal_vm = $vm_kvm->vm;
366
367
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
368
369
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
370
371
}

372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
=head2 disconnect_vm

Disconnect all the Virtual Managers connections.

=cut


sub disconnect_vm {
    my $self = shift;
    $self->_disconnect_vm();
}

sub _disconnect_vm{
    my $self = shift;
    return $self->_connect_vm(0);
}

sub _connect_vm {
390
    my $self = shift;
391
392
393
394

    my $connect = shift;
    $connect = 1 if !defined $connect;

395
396
    my @vms;
    eval { @vms = $self->vm };
397
    warn $@ if $@ && $self->warn_error;
398
399
400
401
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
402
403
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
404
405
406

        if (!$connect) {
            $vm->disconnect();
407
408
        } else {
            $vm->connect();
409
        }
410
411
412
    }
}

413
414
415
416
417
418
sub _create_vm {
    my $self = shift;

    my @vms = ();

    my ($vm_kvm, $err_kvm) = $self->_create_vm_kvm();
419
    warn $err_kvm if $err_kvm && $0 !~ /\.t$/;
420

421
422
    my $err = $err_kvm;

423
424
425
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
426
427
428
429
430
431
    if ($CAN_LXC) {
        eval { $vm_lxc = Ravada::VM::LXC->new( connector => ( $self->connector or $CONNECTOR )) };
        push @vms,($vm_lxc) if $vm_lxc;
        my $err_lxc = $@;
        $err .= "\n$err_lxc" if $err_lxc;
    }
432
    if (!@vms) {
433
        warn "No VMs found: $err\n" if $self->warn_error;
434
435
436
    }
    return \@vms;

437
438
}

439
sub _check_vms {
440
441
    my $self = shift;

442
443
    my @vm;
    eval { @vm = @{$self->vm} };
444
445
446
447
448
449
450
451
452
453
    for my $n ( 0 .. $#vm ) {
        if ($vm[$n] && ref $vm[$n] =~ /KVM/i) {
            if (!$vm[$n]->is_alive) {
                warn "$vm[$n] dead" if $DEBUG;
                $vm[$n] = $self->_create_vm_kvm();
            }
        }
    }
}

Francesc Guasch's avatar
Francesc Guasch committed
454
455
456
457
=head2 create_domain

Creates a new domain based on an ISO image or another domain.

joansp's avatar
joansp committed
458
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
459
460
461
462
463
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
464
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
465
466
467
468
469
470
471
472
         name => $name
    , id_base => 3
  );


=cut


473
sub create_domain {
474
475
    my $self = shift;

476
477
    my %args = @_;

478
479
480
    croak "Argument id_owner required "
        if !$args{id_owner};

481
482
    my $vm_name = $args{vm};
    delete $args{vm};
483

484
    my $request = ( $args{request} or undef);
Francesc Guasch's avatar
Francesc Guasch committed
485

486
    my $vm;
487
488
489
490
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
491
    $vm = $self->vm->[0]               if !$vm;
492

493
494
    confess "No vm found"   if !$vm;

495
496
    carp "WARNING: no VM defined, we will use ".$vm->name
        if !$vm_name;
Francesc Guasch's avatar
Francesc Guasch committed
497

498
    confess "I can't find any vm ".Dumper($self->vm) if !$vm;
Francesc Guasch's avatar
Francesc Guasch committed
499

500
    return $vm->create_domain(@_);
501
502
}

Francesc Guasch's avatar
Francesc Guasch committed
503
504
505
506
507
508
509
510
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

511
512
sub remove_domain {
    my $self = shift;
513
514
    my %arg = @_;

515
    confess "Argument name required "
516
517
        if !$arg{name};

518
519
    confess "Argument uid required "
        if !$arg{uid};
520
521
522
523

    lock_hash(%arg);

    my $domain = $self->search_domain($arg{name}, 1)
524
        or die "ERROR: I can't find domain '$arg{name}', maybe already removed.";
525

526
527
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
528
529
}

Francesc Guasch's avatar
Francesc Guasch committed
530
531
532
533
534
535
=head2 search_domain

  my $domain = $ravada->search_domain($name);

=cut

536
537
538
sub search_domain {
    my $self = shift;
    my $name = shift;
539
    my $import = shift;
540

541
542
543
544
545
546
547
548
549
550
551
552
    my $vm = $self->search_vm('Void');
    warn "No Void VM" if !$vm;
    return if !$vm;

    my $domain = $vm->search_domain($name, $import);
    return $domain if $domain;

    my @vms;
    eval { @vms = $self->vm };
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

553
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
554
        my $domain = $vm->search_domain($name, $import);
555
        next if !$domain;
556
        next if !$domain->_select_domain_db && !$import;
557
558
559
        my $id;
        eval { $id = $domain->id };
        # TODO import the domain in the database with an _insert_db or something
Francesc Guasch's avatar
Francesc Guasch committed
560
        warn $@ if $@   && $DEBUG;
561
        return $domain if $id || $import;
562
    }
563
564


565
    return;
566
}
567

Francesc Guasch's avatar
Francesc Guasch committed
568
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
569

Francesc Guasch's avatar
Francesc Guasch committed
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
  my $domain = $ravada->search_domain_by_id($id);

=cut

sub search_domain_by_id {
    my $self = shift;
    my $id = shift  or confess "ERROR: missing argument id";

    my $sth = $CONNECTOR->dbh->prepare("SELECT name FROM domains WHERE id=?");
    $sth->execute($id);
    my ($name) = $sth->fetchrow;
    confess "Unknown domain id=$id" if !$name;

    return $self->search_domain($name);
}
Francesc Guasch's avatar
Francesc Guasch committed
585

586
587
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
588
List all created domains
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604

  my @list = $ravada->list_domains();

=cut

sub list_domains {
    my $self = shift;
    my @domains;
    for my $vm (@{$self->vm}) {
        for my $domain ($vm->list_domains) {
            push @domains,($domain);
        }
    }
    return @domains;
}

605
606
607
608
609
610
611
612
613
614
615
616
617
=head2 list_domains_data

List all domains in raw format. Return a list of id => { name , id , is_active , is_base }

   my $list = $ravada->list_domains_data();

   $c->render(json => $list);

=cut

sub list_domains_data {
    my $self = shift;
    my @domains;
618
619
620
621
622
623
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
624
    }
625
    $sth->finish;
626
    return \@domains;
627
628
}

629
630
631
632
633
634
635
# sub list_domains_data {
#     my $self = shift;
#     my @domains;
#     for my $domain ($self->list_domains()) {
#         eval { $domain->id };
#         warn $@ if $@;
#         next if $@;
joansp's avatar
joansp committed
636
#         push @domains, {                id => $domain->id
637
638
639
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
640

641
642
643
644
645
#                            }
#     }
#     return \@domains;
# }

646

Francesc Guasch's avatar
Francesc Guasch committed
647
648
649
650
651
652
653
654
655
656
657
658
659
660
=head2 list_bases

List all base domains

  my @list = $ravada->list_domains();


=cut

sub list_bases {
    my $self = shift;
    my @domains;
    for my $vm (@{$self->vm}) {
        for my $domain ($vm->list_domains) {
661
662
663
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
664
665
666
667
668
669
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
=head2 list_bases_data

List information about the bases

=cut

sub list_bases_data {
    my $self = shift;
    my @data;
    for ($self->list_bases ) {
        push @data,{ id => $_->id , name => $_->name };
    }
    return \@data;
}

Francesc Guasch's avatar
Francesc Guasch committed
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
=head2 list_images

List all ISO images

=cut

sub list_images {
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM iso_images ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
=head2 list_images_data

List information about the images

=cut

sub list_images_data {
    my $self = shift;
    my @data;
    for ($self->list_images ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

Francesc Guasch's avatar
Francesc Guasch committed
720

721
722
723
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
724
725
726
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
727
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
728
729
730
731
732
733
734
735
736
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

737
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
738
739
740
741
742
743
744
745
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

746
=cut
fv3rdugo's avatar
fv3rdugo committed
747

Francesc Guasch's avatar
Francesc Guasch committed
748
749
750
751
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
752

Francesc Guasch's avatar
Francesc Guasch committed
753
754
=cut

755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
sub remove_volume {
    my $self = shift;

    my $file = shift;
    my ($name) = $file =~ m{.*/(.*)};

    my $removed = 0;
    for my $vm (@{$self->vm}) {
        my $vol = $vm->search_volume($name);
        next if !$vol;

        $vol->delete();
        $removed++;
    }
    if (!$removed && -e $file ) {
        warn "volume $file not found. removing file $file.\n";
        unlink $file or die "$! $file";
    }

}
775

776
777
778
779
780
781
782
783
784
=head2 clean_killed_requests

Before processing requests, old killed requests must be cleaned.

=cut

sub clean_killed_requests {
    my $self = shift;
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
785
        ." WHERE status <> 'done' AND STATUS <> 'requested'"
786
787
788
789
    );
    $sth->execute;
    while (my ($id) = $sth->fetchrow) {
        my $req = Ravada::Request->open($id);
790
        $req->status("done","Killed ".$req->command." before completion");
791
792
793
794
    }

}

Francesc Guasch's avatar
Francesc Guasch committed
795
796
797
798
799
800
801
802
=head2 process_requests

This is run in the ravada backend. It processes the commands requested by the fronted

  $ravada->process_requests();

=cut

803
804
sub process_requests {
    my $self = shift;
805
    my $debug = shift;
806
    my $dont_fork = shift;
807
808
    my $long_commands = (shift or 0);
    my $short_commands = (shift or 0);
809

810
811
    $self->_wait_pids_nohang();

812
    my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
813
814
815
        ." WHERE "
        ."    ( status='requested' OR status like 'retry %' OR status='waiting')"
        ."   AND ( at_time IS NULL  OR at_time = 0 OR at_time<=?) "
816
817
        ." ORDER BY date_req"
    );
818
819
820
821
822
823
824
    $sth->execute(time);

    my $debug_type = '';
    $debug_type = 'long' if $long_commands;
    $debug_type = 'short' if $short_commands || !$long_commands;
    $debug_type = 'all' if $long_commands && $short_commands;

825
826
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
827
828
829
830
831
832
833
834
835

        if ( ($long_commands && 
                (!$short_commands && !$LONG_COMMAND{$req->command}))
            ||(!$long_commands && $LONG_COMMAND{$req->command})
        ) {
            warn "[$debug_type,$long_commands,$short_commands] $$ skipping request "
                .$req->command  if $DEBUG;
            next;
        }
836
837
        next if $req->command !~ /shutdown/i
            && $self->_domain_working($id_domain, $id_request);
838

839
840
        warn "[$debug_type] $$ executing request ".$req->id." ".$req->status()." "
            .$req->command
841
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
842
843
844

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
845
846
847
        my $err = $self->_execute($req, $dont_fork);
        $req->error($err)   if $err;
        if ($err && $err =~ /libvirt error code: 38/) {
Francesc Guasch's avatar
Francesc Guasch committed
848
            if ( $n_retry < 3) {
849
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
850
                $req->status("retry ".++$n_retry)
851
            }
852
        }
853
854
855
        next if !$DEBUG && !$debug;

        sleep 1;
856
        warn "req ".$req->id." , command: ".$req->command." , status: ".$req->status()
857
            ." , error: '".($req->error or 'NONE')."'\n"  if $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
858

859
860
    }
    $sth->finish;
861
862
863

}

Francesc Guasch's avatar
Francesc Guasch committed
864
=head2 process_long_requests
865
866
867
868
869
870
871
872
873
874
875

Process requests that take log time. It will fork on each one

=cut

sub process_long_requests {
    my $self = shift;
    my ($debug,$dont_fork) = @_;

    $self->_disconnect_vm();
    return $self->process_requests($debug, $dont_fork, 1);
876
877
}

878
879
880
881
882
883
884
885
886
887
888
889
890
=head2 process_all_requests

Process all the requests, long and short

=cut

sub process_all_requests {

    my $self = shift;
    my ($debug,$dont_fork) = @_;

    $self->process_requests($debug, $dont_fork,1,1);

891
892
}

893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
sub _domain_working {
    my $self = shift;
    my ($id_domain, $id_request) = @_;

    confess "Missing id_request" if !defined$id_request;

    if (!$id_domain) {
        my $req = Ravada::Request->open($id_request);
        $id_domain = $req->defined_arg('id_base');
        if (!$id_domain) {
            my $domain_name = $req->defined_arg('name');
            return if !$domain_name;
            my $domain = $self->search_domain($domain_name) or return;
            $id_domain = $domain->id;
            if (!$id_domain) {
                warn Dumper($req);
                return;
            }
        }
    }
    my $sth = $CONNECTOR->dbh->prepare("SELECT id, status FROM requests "
        ." WHERE id <> ? AND id_domain=? AND (status <> 'requested' AND status <> 'done')");
    $sth->execute($id_request, $id_domain);
    my ($id, $status) = $sth->fetchrow;
#    warn "CHECKING DOMAIN WORKING "
#        ."[$id_request] id_domain $id_domain working in request ".($id or '<NULL>')
#            ." status: ".($status or '<UNDEF>');
    return $id;
}

923
924
925
926
927
928
929
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

    return $self->process_requests($debug,1, 1, 1);
}

930
931
sub _process_requests_dont_fork {
    my $self = shift;
932
    my $debug = shift;
933
    return $self->process_requests($debug, 1);
934
}
Francesc Guasch's avatar
Francesc Guasch committed
935

936
937
938
939
940
941
942
943
=head2 list_vm_types

Returnsa list ofthe types of Virtual Machines available on this system

=cut

sub list_vm_types {
    my $self = shift;
joansp's avatar
joansp committed
944

945
946
947
948
949
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
950
    return keys %type;
951
952
}

953
954
955
sub _execute {
    my $self = shift;
    my $request = shift;
956
    my $dont_fork = shift;
957

Francesc Guasch's avatar
Francesc Guasch committed
958
959
    my $sub = $self->_req_method($request->command);

960
961
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
962

963
    if ($dont_fork || !$CAN_FORK || !$LONG_COMMAND{$request->command}) {
Francesc Guasch's avatar
Francesc Guasch committed
964

965
966
967
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
968
        $request->status('done') if $request->status() ne 'done';
969
970
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
971

972
973
974
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

975
    $request->status('working');
976
977
    my $pid = fork();
    die "I can't fork" if !defined $pid;
978
979
980
981
982
    if ( $pid == 0 ) {
        $self->_do_execute_command($sub, $request) 
    } else {
        $self->_add_pid($pid, $request->id);
    }
983
#    $self->_connect_vm_kvm();
984
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
985
986
}

987
988
989
990
991
992
993
994
995
996
997
998
999
1000
sub _do_execute_command {
    my $self = shift;
    my ($sub, $request) = @_;

#    if ($DEBUG ) {
#        mkdir 'log' if ! -e 'log';
#        open my $f_out ,'>', "log/fork_$$.out";
#        open my $f_err ,'>', "log/fork_$$.err";
#        $| = 1;
#        local *STDOUT = $f_out;
#        local *STDERR = $f_err;
#    }

    eval {
For faster browsing, not all history is shown. View entire blame