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

use warnings;
use strict;

Francesc Guasch's avatar
Francesc Guasch committed
6
our $VERSION = '0.2.5';
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->_init_user_daemon();
108
    $self->_create_tables();
109
    $self->_upgrade_tables();
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
129
130
131
132
133
134
sub _update_user_grants {
    my $self = shift;
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM users");
    my $id;
    $sth->bind_columns(\$id);
    $sth->execute;
    while ($sth->fetch) {
        my $user = Ravada::Auth::SQL->search_by_id($id);
135
136
137
        warn $user->name;
        $USER_DAEMON->grant_user_permissions($user);
        $USER_DAEMON->grant_admin_permissions($user)    if $user->is_admin;
138
139
140
141
    }
    $sth->finish;
}

142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
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
157
158
159
160
161
162
163
164
165
166
167
168
169
        ,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'

        }

170
171
172
173
174
175
176
177
    );

    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
178
        warn("INFO: updating $table : $row->{$field}\n")    if $0 !~ /\.t$/;
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196

        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;
197

198
    $self->_update_isos();
199
    $self->_update_user_grants();
200
201
}

202
203
204
205
206
207
208
209
210
211
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
212
    warn "INFO: adding $field $definition to $table\n"  if $0 !~ /\.t$/;
213
    $dbh->do("alter table $table add $field $definition");
214
    return 1;
215
216
}

217
218
219
220
221
222
223
224
225
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
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;
258
259
    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;

260
261
262
263
264
265
266
267
268
    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;
}

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

273
    $self->_upgrade_table('file_base_images','target','varchar(64) DEFAULT NULL');
274
275
    $self->_upgrade_table('vms','vm_type',"char(20) NOT NULL DEFAULT 'KVM'");
    $self->_upgrade_table('requests','at_time','int(11) DEFAULT NULL');
Francesc Guasch's avatar
Francesc Guasch committed
276

277
278
    $self->_upgrade_table('iso_images','md5_url','varchar(255)');
    $self->_upgrade_table('iso_images','file_re','char(64)');
279
    $self->_upgrade_table('iso_images','device','varchar(255)');
280
281

    $self->_upgrade_table('users','language','char(3) DEFAULT NULL');
282
283
284
285
286
287
    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
288

289
    $self->_upgrade_table('networks','requires_password','int(11)');
290
291
    $self->_upgrade_table('networks','n_order','int(11) not null default 0');

292
    $self->_upgrade_table('domains','spice_password','varchar(20) DEFAULT NULL');
293
294
}

295

296
297
298
299
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
300
301
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
302
303
304
305
306
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

307
=head2 display_ip
308

309
Returns the default display IP read from the config file
310

311
=cut
312

313
sub display_ip {
314

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

317
    return $ip if $ip;
318
319
}

320
321
sub _init_config {
    my $file = shift;
322
323

    my $connector = shift;
324
    confess "Deprecated connector" if $connector;
325

326
    $CONFIG = YAML::LoadFile($file);
327
328
329

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
330
#    $CONNECTOR = ( $connector or _connect_dbh());
331
332
}

333
sub _create_vm_kvm {
334
    my $self = shift;
335

336
337
338
339
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
342

343
344
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
345
346
347
348

    my ($internal_vm , $storage);
    eval {
        $storage = $vm_kvm->dir_img();
349
        $internal_vm = $vm_kvm->vm;
350
351
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
352
353
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
354
355
}

356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
=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 {
374
    my $self = shift;
375
376
377
378

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

379
380
    my @vms;
    eval { @vms = $self->vm };
381
    warn $@ if $@ && $self->warn_error;
382
383
384
385
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
386
387
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
388
389
390

        if (!$connect) {
            $vm->disconnect();
391
392
        } else {
            $vm->connect();
393
        }
394
395
396
    }
}

397
398
399
400
401
402
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

405
406
    my $err = $err_kvm;

407
408
409
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
410
411
412
413
414
415
    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;
    }
416
    if (!@vms) {
417
        warn "No VMs found: $err\n" if $self->warn_error;
418
419
420
    }
    return \@vms;

421
422
}

423
sub _check_vms {
424
425
    my $self = shift;

426
427
    my @vm;
    eval { @vm = @{$self->vm} };
428
429
430
431
432
433
434
435
436
437
    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
438
439
440
441
=head2 create_domain

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

joansp's avatar
joansp committed
442
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
443
444
445
446
447
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
448
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
449
450
451
452
453
454
455
456
         name => $name
    , id_base => 3
  );


=cut


457
sub create_domain {
458
459
    my $self = shift;

460
461
    my %args = @_;

462
463
464
    croak "Argument id_owner required "
        if !$args{id_owner};

465
466
    my $vm_name = $args{vm};
    delete $args{vm};
467

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

470
    my $vm;
471
472
473
474
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
475
    $vm = $self->vm->[0]               if !$vm;
476

477
478
    confess "No vm found"   if !$vm;

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

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

484
    return $vm->create_domain(@_);
485
486
}

Francesc Guasch's avatar
Francesc Guasch committed
487
488
489
490
491
492
493
494
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

495
496
sub remove_domain {
    my $self = shift;
497
498
    my %arg = @_;

499
    confess "Argument name required "
500
501
        if !$arg{name};

502
503
    confess "Argument uid required "
        if !$arg{uid};
504
505
506
507

    lock_hash(%arg);

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

510
511
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
512
513
}

Francesc Guasch's avatar
Francesc Guasch committed
514
515
516
517
518
519
=head2 search_domain

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

=cut

520
521
522
sub search_domain {
    my $self = shift;
    my $name = shift;
523
    my $import = shift;
524

525
526
527
528
529
530
531
532
533
534
535
536
    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 $@;

537
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
538
        my $domain = $vm->search_domain($name, $import);
539
        next if !$domain;
540
        next if !$domain->_select_domain_db && !$import;
541
542
543
        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
544
        warn $@ if $@   && $DEBUG;
545
        return $domain if $id || $import;
546
    }
547
548


549
    return;
550
}
551

Francesc Guasch's avatar
Francesc Guasch committed
552
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
553

Francesc Guasch's avatar
Francesc Guasch committed
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
  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
569

570
571
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
572
List all created domains
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588

  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;
}

589
590
591
592
593
594
595
596
597
598
599
600
601
=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;
602
603
604
605
606
607
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
608
    }
609
    $sth->finish;
610
    return \@domains;
611
612
}

613
614
615
616
617
618
619
# 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
620
#         push @domains, {                id => $domain->id
621
622
623
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
624

625
626
627
628
629
#                            }
#     }
#     return \@domains;
# }

630

Francesc Guasch's avatar
Francesc Guasch committed
631
632
633
634
635
636
637
638
639
640
641
642
643
644
=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) {
645
646
647
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
648
649
650
651
652
653
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
=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
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
=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;
}

689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
=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
704

705
706
707
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
708
709
710
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
711
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
712
713
714
715
716
717
718
719
720
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

721
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
722
723
724
725
726
727
728
729
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

730
=cut
fv3rdugo's avatar
fv3rdugo committed
731

Francesc Guasch's avatar
Francesc Guasch committed
732
733
734
735
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
736

Francesc Guasch's avatar
Francesc Guasch committed
737
738
=cut

739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
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";
    }

}
759

760
761
762
763
764
765
766
767
768
=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 "
769
        ." WHERE status <> 'done' AND STATUS <> 'requested'"
770
771
772
773
    );
    $sth->execute;
    while (my ($id) = $sth->fetchrow) {
        my $req = Ravada::Request->open($id);
774
        $req->status("done","Killed ".$req->command." before completion");
775
776
777
778
    }

}

Francesc Guasch's avatar
Francesc Guasch committed
779
780
781
782
783
784
785
786
=head2 process_requests

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

  $ravada->process_requests();

=cut

787
788
sub process_requests {
    my $self = shift;
789
    my $debug = shift;
790
    my $dont_fork = shift;
791
792
    my $long_commands = (shift or 0);
    my $short_commands = (shift or 0);
793

794
795
    $self->_wait_pids_nohang();

796
    my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
797
798
799
        ." WHERE "
        ."    ( status='requested' OR status like 'retry %' OR status='waiting')"
        ."   AND ( at_time IS NULL  OR at_time = 0 OR at_time<=?) "
800
801
        ." ORDER BY date_req"
    );
802
803
804
805
806
807
808
    $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;

809
810
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
811
812
813
814
815
816
817
818
819

        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;
        }
820
821
        next if $req->command !~ /shutdown/i
            && $self->_domain_working($id_domain, $id_request);
822

823
824
        warn "[$debug_type] $$ executing request ".$req->id." ".$req->status()." "
            .$req->command
825
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
826
827
828

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
829
830
831
        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
832
            if ( $n_retry < 3) {
833
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
834
                $req->status("retry ".++$n_retry)
835
            }
836
        }
837
838
839
        next if !$DEBUG && !$debug;

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

843
844
    }
    $sth->finish;
845
846
847

}

Francesc Guasch's avatar
Francesc Guasch committed
848
=head2 process_long_requests
849
850
851
852
853
854
855
856
857
858
859

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);
860
861
}

862
863
864
865
866
867
868
869
870
871
872
873
874
=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);

875
876
}

877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
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;
}

907
908
909
910
911
912
913
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

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

914
915
sub _process_requests_dont_fork {
    my $self = shift;
916
    my $debug = shift;
917
    return $self->process_requests($debug, 1);
918
}
Francesc Guasch's avatar
Francesc Guasch committed
919

920
921
922
923
924
925
926
927
=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
928

929
930
931
932
933
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
934
    return keys %type;
935
936
}

937
938
939
sub _execute {
    my $self = shift;
    my $request = shift;
940
    my $dont_fork = shift;
941

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

944
945
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
946

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

949
950
951
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
952
        $request->status('done') if $request->status() ne 'done';
953
954
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
955

956
957
958
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

959
    $request->status('working');
960
961
    my $pid = fork();
    die "I can't fork" if !defined $pid;
962
963
964
965
966
    if ( $pid == 0 ) {
        $self->_do_execute_command($sub, $request) 
    } else {
        $self->_add_pid($pid, $request->id);
    }
967
#    $self->_connect_vm_kvm();
968
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
969
970
}

971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
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 {
        $self->_connect_vm();
        $sub->($self,$request);
        $self->_disconnect_vm();
    };
    my $err = ( $@ or '');
    $request->error($err);
    $request->status('done') if $request->status() ne 'done';
    exit;

}

996
997
998
999
1000
sub _cmd_domdisplay {
    my $self = shift;
    my $request = shift;

    my $name = $request->args('name');
For faster browsing, not all history is shown. View entire blame