Ravada.pm 34.5 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
62
63
64
65
66

has 'vm' => (
          is => 'ro'
        ,isa => 'ArrayRef'
       ,lazy => 1
     , builder => '_create_vm'
);

has 'connector' => (
67
68
69
70
71
72
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
73
74
);

75
76
77
78
79
80
has 'warn_error' => (
    is => 'rw'
    ,isa => 'Bool'
    ,default => sub { 1 }
);

Francesc Guasch's avatar
Francesc Guasch committed
81
82
83
84
85
86
87
=head2 BUILD

Internal constructor

=cut


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

Francesc Guasch's avatar
Francesc Guasch committed
96
    if ( $self->connector ) {
joansp's avatar
joansp committed
97
        $CONNECTOR = $self->connector
Francesc Guasch's avatar
Francesc Guasch committed
98
99
    } else {
        $CONNECTOR = $self->_connect_dbh();
100
        $self->connector($CONNECTOR);
Francesc Guasch's avatar
Francesc Guasch committed
101
    }
Francesc Guasch's avatar
Francesc Guasch committed
102
    Ravada::Auth::init($CONFIG);
103
    $self->_create_tables();
104
    $self->_upgrade_tables();
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
    $self->_update_data();
}

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
123
124
125
126
127
128
129
130
131
132
133
134
        ,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
135
136
137
138
139
140
141
142
143
        ,fedora => {
            name => 'Fedora 25'
            ,description => 'RedHat Fedora 25 Workstation 64 bits'
            ,url => 'https://download.fedoraproject.org/pub/fedora/linux/releases/25/Workstation/x86_64/iso/Fedora-Workstation-netinst-x86_64-25-.*\.iso'
            ,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
144

145
146
147
148
149
150
151
152
    );

    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
153
        warn("INFO: updating $table : $row->{$field}\n")    if $0 !~ /\.t$/;
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172

        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;
    $self->_update_isos();
173
174
}

175
176
177
178
179
180
181
182
183
184
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
185
    warn "INFO: adding $field $definition to $table\n"  if $0 !~ /\.t$/;
186
    $dbh->do("alter table $table add $field $definition");
187
    return 1;
188
189
}

190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
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;
231
232
    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;

233
234
235
236
237
238
239
240
241
    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;
}

242
243
sub _upgrade_tables {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
244
#    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;
245

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

248
    $self->_upgrade_table('vms','vm_type',"char(20) NOT NULL DEFAULT 'KVM'");
249
250
    $self->_upgrade_table('vms','connection_args',"text DEFAULT NULL");

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

253
    $self->_upgrade_table('iso_images','md5_url','varchar(255)');
Francesc Guasch's avatar
Francesc Guasch committed
254
255
    $self->_upgrade_table('iso_images','sha256','varchar(255)');
    $self->_upgrade_table('iso_images','sha256_url','varchar(255)');
256
    $self->_upgrade_table('iso_images','file_re','char(64)');
257
    $self->_upgrade_table('iso_images','device','varchar(255)');
258
259

    $self->_upgrade_table('users','language','char(3) DEFAULT NULL');
260
261
262
263
264
265
    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
266

267
    $self->_upgrade_table('networks','requires_password','int(11)');
268
269
    $self->_upgrade_table('networks','n_order','int(11) not null default 0');

270
    $self->_upgrade_table('domains','spice_password','varchar(20) DEFAULT NULL');
271
272
}

273

274
275
276
277
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
278
279
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
280
281
282
283
284
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

285
=head2 display_ip
286

287
Returns the default display IP read from the config file
288

289
=cut
290

291
sub display_ip {
292

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

295
    return $ip if $ip;
296
297
}

298
299
sub _init_config {
    my $file = shift;
300
301

    my $connector = shift;
302
    confess "Deprecated connector" if $connector;
303

304
    $CONFIG = YAML::LoadFile($file);
305
306
307

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
308
#    $CONNECTOR = ( $connector or _connect_dbh());
309
310
}

311
sub _create_vm_kvm {
312
    my $self = shift;
313

314
315
316
317
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
320

321
322
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
323
324
325
326

    my ($internal_vm , $storage);
    eval {
        $storage = $vm_kvm->dir_img();
327
        $internal_vm = $vm_kvm->vm;
328
329
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
330
331
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
332
333
}

334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
=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 {
352
    my $self = shift;
353
354
355
356

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

357
358
    my @vms;
    eval { @vms = $self->vm };
359
    warn $@ if $@ && $self->warn_error;
360
361
362
363
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
364
365
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
366
367
368

        if (!$connect) {
            $vm->disconnect();
369
370
        } else {
            $vm->connect();
371
        }
372
373
374
    }
}

375
376
377
378
379
380
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

383
384
    my $err = $err_kvm;

385
386
387
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
388
389
390
391
392
393
    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;
    }
394
    if (!@vms) {
395
        warn "No VMs found: $err\n" if $self->warn_error;
396
397
398
    }
    return \@vms;

399
400
}

401
sub _check_vms {
402
403
    my $self = shift;

404
405
    my @vm;
    eval { @vm = @{$self->vm} };
406
407
408
409
410
411
412
413
414
415
    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
416
417
418
419
=head2 create_domain

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

joansp's avatar
joansp committed
420
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
421
422
423
424
425
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
426
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
427
428
429
430
431
432
433
434
         name => $name
    , id_base => 3
  );


=cut


435
sub create_domain {
436
437
    my $self = shift;

438
439
    my %args = @_;

440
441
442
    croak "Argument id_owner required "
        if !$args{id_owner};

443
444
    my $vm_name = $args{vm};
    delete $args{vm};
445

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

448
    my $vm;
449
450
451
452
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
453
    $vm = $self->vm->[0]               if !$vm;
454

455
456
    confess "No vm found"   if !$vm;

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

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

462
    return $vm->create_domain(@_);
463
464
}

Francesc Guasch's avatar
Francesc Guasch committed
465
466
467
468
469
470
471
472
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

473
474
sub remove_domain {
    my $self = shift;
475
476
    my %arg = @_;

477
    confess "Argument name required "
478
479
        if !$arg{name};

480
481
    confess "Argument uid required "
        if !$arg{uid};
482
483
484
485

    lock_hash(%arg);

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

488
489
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
490
491
}

Francesc Guasch's avatar
Francesc Guasch committed
492
493
494
495
496
497
=head2 search_domain

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

=cut

498
499
500
sub search_domain {
    my $self = shift;
    my $name = shift;
501
    my $import = shift;
502

503
504
505
506
507
508
509
510
511
512
513
514
    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 $@;

515
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
516
        my $domain = $vm->search_domain($name, $import);
517
        next if !$domain;
518
        next if !$domain->_select_domain_db && !$import;
519
520
521
        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
522
        warn $@ if $@   && $DEBUG;
523
        return $domain if $id || $import;
524
    }
525
526


527
    return;
528
}
529

Francesc Guasch's avatar
Francesc Guasch committed
530
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
531

Francesc Guasch's avatar
Francesc Guasch committed
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
  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
547

548
549
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
550
List all created domains
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566

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

567
568
569
570
571
572
573
574
575
576
577
578
579
=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;
580
581
582
583
584
585
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
586
    }
587
    $sth->finish;
588
    return \@domains;
589
590
}

591
592
593
594
595
596
597
# 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
598
#         push @domains, {                id => $domain->id
599
600
601
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
602

603
604
605
606
607
#                            }
#     }
#     return \@domains;
# }

608

Francesc Guasch's avatar
Francesc Guasch committed
609
610
611
612
613
614
615
616
617
618
619
620
621
622
=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) {
623
624
625
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
626
627
628
629
630
631
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
=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
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
=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;
}

667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
=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
682

683
684
685
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
686
687
688
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
689
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
690
691
692
693
694
695
696
697
698
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

699
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
700
701
702
703
704
705
706
707
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

708
=cut
fv3rdugo's avatar
fv3rdugo committed
709

Francesc Guasch's avatar
Francesc Guasch committed
710
711
712
713
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
714

Francesc Guasch's avatar
Francesc Guasch committed
715
716
=cut

717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
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";
    }

}
737

738
739
740
741
742
743
744
745
746
=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 "
747
        ." WHERE status <> 'done' AND STATUS <> 'requested'"
748
749
750
751
    );
    $sth->execute;
    while (my ($id) = $sth->fetchrow) {
        my $req = Ravada::Request->open($id);
752
        $req->status("done","Killed ".$req->command." before completion");
753
754
755
756
    }

}

Francesc Guasch's avatar
Francesc Guasch committed
757
758
759
760
761
762
763
764
=head2 process_requests

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

  $ravada->process_requests();

=cut

765
766
sub process_requests {
    my $self = shift;
767
    my $debug = shift;
768
    my $dont_fork = shift;
769
770
    my $long_commands = (shift or 0);
    my $short_commands = (shift or 0);
771

772
773
    $self->_wait_pids_nohang();

774
    my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
775
776
777
        ." WHERE "
        ."    ( status='requested' OR status like 'retry %' OR status='waiting')"
        ."   AND ( at_time IS NULL  OR at_time = 0 OR at_time<=?) "
778
779
        ." ORDER BY date_req"
    );
780
781
782
783
784
785
786
    $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;

787
788
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
789
790
791
792
793
794
795
796
797

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

801
802
        warn "[$debug_type] $$ executing request ".$req->id." ".$req->status()." "
            .$req->command
803
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
804
805
806

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
807
808
809
        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
810
            if ( $n_retry < 3) {
811
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
812
                $req->status("retry ".++$n_retry)
813
            }
814
        }
815
816
817
        next if !$DEBUG && !$debug;

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

821
822
    }
    $sth->finish;
823
824
825

}

Francesc Guasch's avatar
Francesc Guasch committed
826
=head2 process_long_requests
827
828
829
830
831
832
833
834
835
836
837

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);
838
839
}

840
841
842
843
844
845
846
847
848
849
850
851
852
=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);

853
854
}

855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
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;
}

885
886
887
888
889
890
891
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

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

892
893
sub _process_requests_dont_fork {
    my $self = shift;
894
    my $debug = shift;
895
    return $self->process_requests($debug, 1);
896
}
Francesc Guasch's avatar
Francesc Guasch committed
897

898
899
900
901
902
903
904
905
=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
906

907
908
909
910
911
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
912
    return keys %type;
913
914
}

915
916
917
sub _execute {
    my $self = shift;
    my $request = shift;
918
    my $dont_fork = shift;
919

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

922
923
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
924

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

927
928
929
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
930
        $request->status('done') if $request->status() ne 'done';
931
932
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
933

934
935
936
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

937
    $request->status('working');
938
939
    my $pid = fork();
    die "I can't fork" if !defined $pid;
940
941
942
943
944
    if ( $pid == 0 ) {
        $self->_do_execute_command($sub, $request) 
    } else {
        $self->_add_pid($pid, $request->id);
    }
945
#    $self->_connect_vm_kvm();
946
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
947
948
}

949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
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;

}

974
975
976
977
978
979
980
sub _cmd_domdisplay {
    my $self = shift;
    my $request = shift;

    my $name = $request->args('name');
    confess "Unknown name for request ".Dumper($request)  if!$name;
    my $domain = $self->search_domain($request->args->{name});
981
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
982
    $request->error('');
983
    my $display = $domain->display($user);
984
985
    $request->result({display => $display});

986
987
}

988
989
990
991
992
993
sub _cmd_screenshot {
    my $self = shift;
    my $request = shift;

    my $id_domain = $request->args('id_domain');
    my $domain = $self->search_domain_by_id($id_domain);
994
    my $bytes = 0;
995
    if (!$domain->can_screenshot) {
996
        die "I can't take a screenshot of the domain ".$domain->name;
997
    } else {
998
999
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
1000
    }
For faster browsing, not all history is shown. View entire blame