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

use warnings;
use strict;

6
our $VERSION = '0.1.1';
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
18
use Socket qw( inet_aton inet_ntoa );
use Sys::Hostname;

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

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

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

36
37
38
39
40
41
42

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

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

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

48
# LONG commands take long
Francesc Guasch's avatar
Francesc Guasch committed
49
our %LONG_COMMAND =  map { $_ => 1 } qw(prepare_base remove_base screenshot);
50
51
52
53
54
55
56
57
58

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

has 'connector' => (
59
60
61
62
63
64
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
65
66
);

Francesc Guasch's avatar
Francesc Guasch committed
67
68
69
70
71
72
73
=head2 BUILD

Internal constructor

=cut


74
75
sub BUILD {
    my $self = shift;
76
    if ($self->config()) {
77
        _init_config($self->config);
78
    } else {
Francesc Guasch's avatar
Francesc Guasch committed
79
        _init_config($FILE_CONFIG) if -e $FILE_CONFIG;
80
    }
81

Francesc Guasch's avatar
Francesc Guasch committed
82
    if ( $self->connector ) {
joansp's avatar
joansp committed
83
        $CONNECTOR = $self->connector
Francesc Guasch's avatar
Francesc Guasch committed
84
85
    } else {
        $CONNECTOR = $self->_connect_dbh();
86
        $self->connector($CONNECTOR);
Francesc Guasch's avatar
Francesc Guasch committed
87
    }
Francesc Guasch's avatar
Francesc Guasch committed
88
    Ravada::Auth::init($CONFIG);
89
90
91
92
93
94
}

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
95
96
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
97
98
99
100
101
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

102
=head2 display_ip
103

104
Returns the default display IP read from the config file
105

106
=cut
107

108
109
sub display_ip {
    my $ip = $CONFIG->{display_ip};
joansp's avatar
joansp committed
110

111
    return $ip if $ip;
112
113
}

114
115
sub _init_config {
    my $file = shift;
116
117

    my $connector = shift;
118
    confess "Deprecated connector" if $connector;
119

120
    $CONFIG = YAML::LoadFile($file);
121
122
123

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
124
#    $CONNECTOR = ( $connector or _connect_dbh());
125
126
}

127
sub _create_vm_kvm {
128
    my $self = shift;
129

130
131
132
133
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
136

137
138
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
139
140
141
142

    my ($internal_vm , $storage);
    eval {
        $storage = $vm_kvm->dir_img();
143
        $internal_vm = $vm_kvm->vm;
144
145
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
146
147
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
148
149
}

150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
=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 {
168
    my $self = shift;
169
170
171
172

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

173
174
    my @vms;
    eval { @vms = $self->vm };
175
    warn $@ if $@;
176
177
178
179
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
180
181
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
182
183
184

        if (!$connect) {
            $vm->disconnect();
185
186
        } else {
            $vm->connect();
187
        }
188
189
190
    }
}

191
192
193
194
195
196
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

199
200
    my $err = $err_kvm;

201
202
203
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
204
205
206
207
208
209
    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;
    }
210
    if (!@vms) {
211
        warn "No VMs found: $err\n";
212
213
214
    }
    return \@vms;

215
216
}

217
sub _check_vms {
218
219
    my $self = shift;

220
221
    my @vm;
    eval { @vm = @{$self->vm} };
222
223
224
225
226
227
228
229
230
231
    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
232
233
234
235
=head2 create_domain

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

joansp's avatar
joansp committed
236
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
237
238
239
240
241
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
242
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
243
244
245
246
247
248
249
250
         name => $name
    , id_base => 3
  );


=cut


251
sub create_domain {
252
253
    my $self = shift;

254
255
    my %args = @_;

256
257
258
    croak "Argument id_owner required "
        if !$args{id_owner};

259
260
    my $vm_name = $args{vm};
    delete $args{vm};
261

Francesc Guasch's avatar
Francesc Guasch committed
262
263
    my $request = $args{request}            if $args{request};

264
    my $vm;
265
266
267
268
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
269
    $vm = $self->vm->[0]               if !$vm;
270

271
272
    confess "No vm found"   if !$vm;

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

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

278
    return $vm->create_domain(@_);
279
280
}

Francesc Guasch's avatar
Francesc Guasch committed
281
282
283
284
285
286
287
288
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

289
290
sub remove_domain {
    my $self = shift;
291
292
    my %arg = @_;

293
    confess "Argument name required "
294
295
        if !$arg{name};

296
297
    confess "Argument uid required "
        if !$arg{uid};
298
299
300
301

    lock_hash(%arg);

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

304
305
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
306
307
}

Francesc Guasch's avatar
Francesc Guasch committed
308
309
310
311
312
313
=head2 search_domain

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

=cut

314
315
316
sub search_domain {
    my $self = shift;
    my $name = shift;
317
    my $import = shift;
318

319
320
321
322
323
324
325
326
327
328
329
330
    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 $@;

331
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
332
        my $domain = $vm->search_domain($name, $import);
333
        next if !$domain;
334
        next if !$domain->_select_domain_db && !$import;
335
336
337
        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
338
        warn $@ if $@   && $DEBUG;
339
        return $domain if $id || $import;
340
    }
341
342


343
    return;
344
}
345

Francesc Guasch's avatar
Francesc Guasch committed
346
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
347

Francesc Guasch's avatar
Francesc Guasch committed
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
  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
363

364
365
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
366
List all created domains
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382

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

383
384
385
386
387
388
389
390
391
392
393
394
395
=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;
396
397
398
399
400
401
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
402
    }
403
    $sth->finish;
404
    return \@domains;
405
406
}

407
408
409
410
411
412
413
# 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
414
#         push @domains, {                id => $domain->id
415
416
417
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
418

419
420
421
422
423
#                            }
#     }
#     return \@domains;
# }

424

Francesc Guasch's avatar
Francesc Guasch committed
425
426
427
428
429
430
431
432
433
434
435
436
437
438
=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) {
439
440
441
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
442
443
444
445
446
447
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
=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
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
=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;
}

483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
=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
498

499
500
501
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
502
503
504
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
505
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
506
507
508
509
510
511
512
513
514
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

515
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
516
517
518
519
520
521
522
523
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

524
=cut
fv3rdugo's avatar
fv3rdugo committed
525

Francesc Guasch's avatar
Francesc Guasch committed
526
527
528
529
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
530

Francesc Guasch's avatar
Francesc Guasch committed
531
532
=cut

533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
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";
    }

}
553

554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
=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 "
        ." WHERE status='working' "
    );
    $sth->execute;
    while (my ($id) = $sth->fetchrow) {
        my $req = Ravada::Request->open($id);
        $req->status("done","Killed before completion");
    }

}

Francesc Guasch's avatar
Francesc Guasch committed
573
574
575
576
577
578
579
580
=head2 process_requests

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

  $ravada->process_requests();

=cut

581
582
sub process_requests {
    my $self = shift;
583
    my $debug = shift;
584
    my $dont_fork = shift;
585
586
    my $long_commands = shift;
    my $short_commands = shift;
587

588
589
    $self->_wait_pids_nohang();

590
    my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
591
592
593
        ." WHERE "
        ."    ( status='requested' OR status like 'retry %' OR status='waiting')"
        ."   AND ( at_time IS NULL  OR at_time = 0 OR at_time<=?) "
594
595
        ." ORDER BY date_req"
    );
596
597
598
599
600
601
602
    $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;

603
604
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
605
606
607
608
609
610
611
612
613

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

617
618
        warn "[$debug_type] $$ executing request ".$req->id." ".$req->status()." "
            .$req->command
619
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
620
621
622

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
623
624
625
        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
626
            if ( $n_retry < 3) {
627
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
628
                $req->status("retry ".++$n_retry)
629
            }
630
        }
631
632
633
        next if !$DEBUG && !$debug;

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

637
638
    }
    $sth->finish;
639
640
641

}

Francesc Guasch's avatar
Francesc Guasch committed
642
=head2 process_long_requests
643
644
645
646
647
648
649
650
651
652
653

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);
654
655
}

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

686
687
688
689
690
691
692
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

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

693
694
sub _process_requests_dont_fork {
    my $self = shift;
695
    my $debug = shift;
696
    return $self->process_requests($debug, 1);
697
}
Francesc Guasch's avatar
Francesc Guasch committed
698

699
700
701
702
703
704
705
706
=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
707

708
709
710
711
712
713
714
715
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
    return sort keys %type;
}

716
717
718
sub _execute {
    my $self = shift;
    my $request = shift;
719
    my $dont_fork = shift;
720

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

723
724
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
725

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

728
729
730
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
731
        $request->status('done') if $request->status() ne 'done';
732
733
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
734

735
736
737
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

738
    $request->status('working');
739
740
    my $pid = fork();
    die "I can't fork" if !defined $pid;
741
    $self->_do_execute_command($sub, $request) if $pid == 0;
742
    $self->_add_pid($pid, $request->id);
743
#    $self->_connect_vm_kvm();
744
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
745
746
}

747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
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;

}

772
773
774
775
776
777
778
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});
779
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
780
    $request->error('');
781
    my $display = $domain->display($user);
782
783
    $request->result({display => $display});

784
785
}

786
787
788
789
790
791
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);
792
    my $bytes = 0;
793
    if (!$domain->can_screenshot) {
794
        die "I can't take a screenshot of the domain ".$domain->name;
795
    } else {
796
797
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
798
    }
799
    $request->error("No data received") if !$bytes;
800
801
802
}


803
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
804
805
806
    my $self = shift;
    my $request = shift;

807
    $request->status('creating domain');
808
    warn "$$ creating domain"   if $DEBUG;
809
    my $domain;
810

811
    $domain = $self->create_domain(%{$request->args},request => $request);
812

813
    my $msg = '';
814

815
    if ($domain) {
816
       $msg = 'Domain '
817
818
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
819
            ." created."
820
821
822
823
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
824
825
826

}

827
828
829
830
831
sub _wait_children {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $try = 0;
832
    for ( 1 .. 10 ) {
833
834
835
836
        my $n_pids = scalar keys %{$self->{pids}};
        my $msg = $req->id." ".$req->command." waiting for processes to finish $n_pids of $LIMIT_PROCESS running";
        warn $msg if $DEBUG;

837
        return if $n_pids < $LIMIT_PROCESS;
838
839
840
841

        $self->_wait_pids_nohang();
        sleep 1;

842
843
844
        next if $try++;

        $req->error($msg);
845
        $req->status('waiting') if $req->status() !~ 'waiting';
846
    }
847
    return scalar keys %{$self->{pids}};
848
849
}

850
851
852
853
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

Francesc Guasch's avatar
Francesc Guasch committed
854
855
856
857
858
859
    for my $pid ( keys %{$self->{pids}}) {
        my $kid = waitpid($pid , WNOHANG);
        next if !$kid || $kid == -1;
        $self->_set_req_done($kid);
        delete $self->{pids}->{$kid};
    }
860
861
862
863
864
865
866
867
868
869
870
871

}

sub _set_req_done {
    my $self = shift;
    my $pid = shift;

    my $id_request = $self->{pids}->{$pid};
    return if !$id_request;

    my $req = Ravada::Request->open($id_request);
    $req->status('done')    if $req->status =~ /working/i;
872
873
}

Francesc Guasch's avatar
Francesc Guasch committed
874
875
876
877
sub _wait_pids {
    my $self = shift;
    my $request = shift;

878
879
    $request->status('waiting for other tasks')
        if $request && $request->status !~ /waiting/i;
Francesc Guasch's avatar
Francesc Guasch committed
880

Francesc Guasch's avatar
Francesc Guasch committed
881
    for my $pid ( keys %{$self->{pids}}) {
882
883
        $request->status("waiting for pid $pid")
            if $request && $request->status !~ /waiting/i;
884
885

#        warn "Checking for pid '$pid' created at ".localtime($self->{pids}->{$pid});
Francesc Guasch's avatar
Francesc Guasch committed
886
        my $kid = waitpid($pid,0);
887
#        warn "Found $kid";
888
889
890
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
891
892
893
894
895
896
897
        return if $kid  == $pid;
    }
}

sub _add_pid {
    my $self = shift;
    my $pid = shift;
898
    my $id_req = shift;
Francesc Guasch's avatar
Francesc Guasch committed
899

900
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
901
902
}

903
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
904
905
906
    my $self = shift;
    my $request = shift;

907
908
909
910
    confess "Unknown user id ".$request->args->{uid}
        if !defined $request->args->{uid};

    $self->remove_domain(name => $request->args('name'), uid => $request->args('uid'));
Francesc Guasch's avatar
Francesc Guasch committed
911

912
}
Francesc Guasch's avatar
Francesc Guasch committed
913

914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
sub _cmd_pause {
    my $self = shift;
    my $request = shift;

    my $name = $request->args('name');
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;

    my $uid = $request->args('uid');
    my $user = Ravada::Auth::SQL->search_by_id($uid);

    $domain->pause($user);

    $request->status('done');

}

sub _cmd_resume {
    my $self = shift;
    my $request = shift;

    my $name = $request->args('name');
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;

    my $uid = $request->args('uid');
    my $user = Ravada::Auth::SQL->search_by_id($uid);

942
943
    $domain->resume(
        remote_ip => $request->args('remote_ip')
944
        ,user => $user
945
    );
946
947
948
949
950
951

    $request->status('done');

}


952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
sub _cmd_open_iptables {
    my $self = shift;
    my $request = shift;

    my $uid = $request->args('uid');
    my $user = Ravada::Auth::SQL->search_by_id($uid);

    my $domain = $self->search_domain_by_id($request->args('id_domain'));
    die "Unknown domain" if !$domain;

    $domain->open_iptables(
        remote_ip => $request->args('remote_ip')
        ,uid => $user->id
    );
}

Francesc Guasch's avatar
Francesc Guasch committed
968
969
970
971
972
sub _cmd_start {
    my $self = shift;
    my $request = shift;

    my $name = $request->args('name');
973

974
975
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
976
977
978
979

    my $uid = $request->args('uid');
    my $user = Ravada::Auth::SQL->search_by_id($uid);

980
    $domain->start(user => $user, remote_ip => $request->args('remote_ip'));
981
982
983
    my $msg = 'Domain '
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
984
            ." started"
985
986
        ;
    $request->status('done', $msg);
Francesc Guasch's avatar
Francesc Guasch committed
987
988
989

}

Francesc Guasch's avatar
Francesc Guasch committed
990
991
992
993
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

Francesc Guasch's avatar
Francesc Guasch committed
994
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
995
996
997
998
    my $uid = $request->args('uid')     or confess "Missing argument uid";

    my $user = Ravada::Auth::SQL->search_by_id( $uid);

Francesc Guasch's avatar
Francesc Guasch committed
999
    my $domain = $self->search_domain_by_id($id_domain);
1000

Francesc Guasch's avatar
Francesc Guasch committed
1001
    die "Unknown domain id '$id_domain'\n" if !$domain;
1002
1003

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
1004
1005
1006

}

1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
sub _cmd_remove_base {
    my $self = shift;
    my $request = shift;

    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;

1020
1021
    $domain->_vm->disconnect();
    $self->_disconnect_vm();
1022
1023
1024
1025
1026
    $domain->remove_base($user);

}


Francesc Guasch's avatar
Francesc Guasch committed
1027
1028
1029
1030
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

1031
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
1032
    my $name = $request->args('name');
1033
    my $timeout = ($request->args('timeout') or 60);
1034

1035
    my $domain;
1036
1037
1038
    $domain = $self->search_domain($name);
    die "Unknown domain '$name'\n" if !$domain;

1039
1040
    my $user = Ravada::Auth::SQL->search_by_id( $uid);

1041
1042
    $domain->shutdown(timeout => $timeout, name => $name, user => $user
                    , request => $request);
Francesc Guasch's avatar
Francesc Guasch committed
1043
1044
1045

}

1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
sub _cmd_force_shutdown {
    my $self = shift;
    my $request = shift;

    my $uid = $request->args('uid');
    my $name = $request->args('name');

    my $domain;
    $domain = $self->search_domain($name);
    die "Unknown domain '$name'\n" if !$domain;

    my $user = Ravada::Auth::SQL->search_by_id( $uid);

    $domain->force_shutdown($user,$request);

}

1063
1064
1065
1066
sub _cmd_list_vm_types {
    my $self = shift;
    my $request = shift;
    my @list_types = $self->list_vm_types();
Francesc Guasch's avatar
Francesc Guasch committed
1067
    $request->result(\@list_types);
1068
1069
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
1070

1071
1072
1073
1074
1075
1076
1077
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

    $request->status('done');
    return 1;
}
Francesc Guasch's avatar
Francesc Guasch committed
1078

1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
sub _cmd_rename_domain {
    my $self = shift;
    my $request = shift;

    my $uid = $request->args('uid');
    my $name = $request->args('name');
    my $id_domain = $request->args('id_domain') or die "ERROR: Missing id_domain";

    my $user = Ravada::Auth::SQL->search_by_id($uid);
    my $domain = $self->search_domain_by_id($id_domain);

    confess "Unkown domain ".Dumper($request)   if !$domain;

    $domain->rename(user => $user, name => $name);

}

Francesc Guasch's avatar
Francesc Guasch committed
1096
1097
1098
1099
1100
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

    my %methods = (
Francesc Guasch's avatar
Francesc Guasch committed
1101

Francesc Guasch's avatar
Francesc Guasch committed
1102
          start => \&_cmd_start
1103
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
1104
1105
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
1106
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
1107
      ,shutdown => \&_cmd_shutdown
1108
    ,domdisplay => \&_cmd_domdisplay
1109
    ,screenshot => \&_cmd_screenshot
1110
   ,remove_base => \&_cmd_remove_base
1111
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
1112
  ,prepare_base => \&_cmd_prepare_base
1113
 ,rename_domain => \&_cmd_rename_domain
1114
 ,open_iptables => \&_cmd_open_iptables
1115
 ,list_vm_types => \&_cmd_list_vm_types
1116
,force_shutdown => \&_cmd_force_shutdown
Francesc Guasch's avatar
Francesc Guasch committed
1117
1118
1119
1120
    );
    return $methods{$cmd};
}

1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
=head2 open_vm

Opens a VM of a given type


  my $vm = $ravada->open_vm('KVM');

=cut

sub open_vm {
    return search_vm(@_);
}

1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
=head2 search_vm

Searches for a VM of a given type

  my $vm = $ravada->search_vm('kvm');

=cut

sub search_vm {
    my $self = shift;
    my $type = shift;

1146
1147
    confess "Missing VM type"   if !$type;

1148
    my $class = 'Ravada::VM::'.uc($type);
Francesc Guasch's avatar
Francesc Guasch committed
1149

1150
    if ($type =~ /Void/i) {
1151
1152
1153
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
1154
1155
    my @vms;
    eval { @vms = @{$self->vm} };
1156
1157
1158
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
1159
    for my $vm (@vms) {
1160
1161
1162
1163
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
1164

1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
=head2 import_domain

Imports a domain in Ravada

    my $domain = $ravada->import_domain(
                            vm => 'KVM'
                            ,name => $name
                            ,user => $user_name
    );

=cut

sub import_domain {
    my $self = shift;
    my %args = @_;

    my $vm_name = $args{vm} or die "ERROR: mandatory argument vm required";
    my $name = $args{name} or die "ERROR: mandatory argument domain name required";
    my $user_name = $args{user} or die "ERROR: mandatory argument user required";

    my $vm = $self->search_vm($vm_name) or die "ERROR: unknown VM '$vm_name'";
    my $user = Ravada::Auth::SQL->new(name => $user_name);
    die "ERROR: unknown user '$user_name'" if !$user || !$user->id;
    
    my $domain;
    eval { $domain = $self->search_domain($name) };
    die "ERROR: Domain '$name' already in RVD"  if $domain;

    return $vm->import_domain($name, $user);
}

Francesc Guasch's avatar
Francesc Guasch committed
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
=head2 version

Returns the version of the module

=cut

sub version {
    return $VERSION;
}

1206

Francesc Guasch's avatar
Francesc Guasch committed
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
=head1 AUTHOR

Francesc Guasch-Ortiz	, frankie@telecos.upc.edu

=head1 SEE ALSO

Sys::Virt

=cut

1217
1;