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

use warnings;
use strict;

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

14
15
16
use Socket qw( inet_aton inet_ntoa );
use Sys::Hostname;

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

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

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

34
35
36
37
38
39
40

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

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

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

our %FAT_COMMAND =  map { $_ => 1 } qw(start create prepare_base remove);
47
48
49
50
51
52
53
54
55

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

has 'connector' => (
56
57
58
59
60
61
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
62
63
);

Francesc Guasch's avatar
Francesc Guasch committed
64
65
66
67
68
69
70
=head2 BUILD

Internal constructor

=cut


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

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

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

}

99
=head2 display_ip
100

101
Returns the default display IP read from the config file
102

103
=cut
104

105
106
sub display_ip {
    my $ip = $CONFIG->{display_ip};
joansp's avatar
joansp committed
107

108
    return $ip if $ip;
109
110
}

111
112
sub _init_config {
    my $file = shift;
113
114

    my $connector = shift;
115
    confess "Deprecated connector" if $connector;
116

117
    $CONFIG = YAML::LoadFile($file);
118
119
120

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
121
#    $CONNECTOR = ( $connector or _connect_dbh());
122
123
}

124
sub _create_vm_kvm {
125
    my $self = shift;
126

127
128
129
130
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
133

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

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

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

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

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

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

        if (!$connect) {
            $vm->disconnect();
182
183
        } else {
            $vm->connect();
184
        }
185
186
187
    }
}

188
189
190
191
192
193
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

196
197
    my $err = $err_kvm;

198
199
200
    push @vms,($vm_kvm) if $vm_kvm;

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

212
213
}

214
sub _check_vms {
215
216
    my $self = shift;

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

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

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


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


=cut


248
sub create_domain {
249
250
    my $self = shift;

251
252
    my %args = @_;

253
254
255
    croak "Argument id_owner required "
        if !$args{id_owner};

256
257
    my $vm_name = $args{vm};
    delete $args{vm};
258

Francesc Guasch's avatar
Francesc Guasch committed
259
260
    my $request = $args{request}            if $args{request};

261
    my $vm;
262
    $vm = $self->search_vm($vm_name)   if $vm_name;
263
    $vm = $self->vm->[0]               if !$vm;
264

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

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

270
    return $vm->create_domain(@_);
271
272
}

Francesc Guasch's avatar
Francesc Guasch committed
273
274
275
276
277
278
279
280
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

281
282
sub remove_domain {
    my $self = shift;
283
284
    my %arg = @_;

285
    confess "Argument name required "
286
287
        if !$arg{name};

288
289
    confess "Argument uid required "
        if !$arg{uid};
290
291
292
293

    lock_hash(%arg);

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

296
297
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
298
299
}

Francesc Guasch's avatar
Francesc Guasch committed
300
301
302
303
304
305
=head2 search_domain

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

=cut

306
307
308
sub search_domain {
    my $self = shift;
    my $name = shift;
309
    my $import = shift;
310

311
312
313
314
315
316
317
318
319
320
321
322
    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 $@;

323
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
324
        my $domain = $vm->search_domain($name, $import);
325
        next if !$domain;
326
        next if !$domain->_select_domain_db && !$import;
327
328
329
        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
330
        warn $@ if $@   && $DEBUG;
331
        return $domain if $id || $import;
332
    }
333
334


335
    return;
336
}
337

Francesc Guasch's avatar
Francesc Guasch committed
338
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
339

Francesc Guasch's avatar
Francesc Guasch committed
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
  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
355

356
357
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
358
List all created domains
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374

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

375
376
377
378
379
380
381
382
383
384
385
386
387
=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;
388
389
390
391
392
393
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
394
    }
395
    $sth->finish;
396
    return \@domains;
397
398
}

399
400
401
402
403
404
405
# 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
406
#         push @domains, {                id => $domain->id
407
408
409
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
410

411
412
413
414
415
#                            }
#     }
#     return \@domains;
# }

416

Francesc Guasch's avatar
Francesc Guasch committed
417
418
419
420
421
422
423
424
425
426
427
428
429
430
=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) {
431
432
433
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
434
435
436
437
438
439
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
=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
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
=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;
}

475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
=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
490

491
492
493
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
494
495
496
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
497
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
498
499
500
501
502
503
504
505
506
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

507
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
508
509
510
511
512
513
514
515
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

516
=cut
fv3rdugo's avatar
fv3rdugo committed
517

Francesc Guasch's avatar
Francesc Guasch committed
518
519
520
521
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
522

Francesc Guasch's avatar
Francesc Guasch committed
523
524
=cut

525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
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";
    }

}
545

Francesc Guasch's avatar
Francesc Guasch committed
546
547
548
549
550
551
552
553
=head2 process_requests

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

  $ravada->process_requests();

=cut

554
555
sub process_requests {
    my $self = shift;
556
    my $debug = shift;
557
    my $dont_fork = shift;
558

559
    $self->_wait_pids_nohang();
560
    $self->_check_vms();
561

562
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
Francesc Guasch's avatar
Francesc Guasch committed
563
        ." WHERE status='requested' OR status like 'retry %'");
564
565
    $sth->execute;
    while (my ($id)= $sth->fetchrow) {
566
        $self->_wait_pids_nohang();
Francesc Guasch's avatar
Francesc Guasch committed
567
        my $req = Ravada::Request->open($id);
568
569
        warn "executing request ".$req->id." ".$req->status()." ".$req->command
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
570
571
572

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
573
        $req->status('working');
574
575
576
        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
577
            if ( $n_retry < 3) {
578
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
579
                $req->status("retry ".++$n_retry)
580
            }
581
        }
582
        warn "req ".$req->id." , command: ".$req->command." , status: ".$req->status()
joansp's avatar
joansp committed
583
            ." , error: '".($req->error or 'NONE')."'"
584
                if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
585

586
587
588
589
    }
    $sth->finish;
}

590
591
sub _process_requests_dont_fork {
    my $self = shift;
592
    my $debug = shift;
593
    return $self->process_requests($debug, 1);
594
}
Francesc Guasch's avatar
Francesc Guasch committed
595

596
597
598
599
600
601
602
603
=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
604

605
606
607
608
609
610
611
612
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
    return sort keys %type;
}

613
614
615
sub _execute {
    my $self = shift;
    my $request = shift;
616
    my $dont_fork = shift;
617

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

620
621
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
622

623
624
    $self->_disconnect_vm();

625
    if ($dont_fork || !$CAN_FORK ) {
joansp's avatar
joansp committed
626

Francesc Guasch's avatar
Francesc Guasch committed
627
628
        $self->_connect_vm();

629
630
631
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
632
        $request->status('done') if $request->status() ne 'done';
633
634
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
635

636
    $self->_wait_children($request) if $FAT_COMMAND{$request->command};
637
638
639
640
    my $pid = fork();
    die "I can't fork" if !defined $pid;
    if ($pid == 0) {
        $request->status("forked $$");
joansp's avatar
joansp committed
641
        eval {
642
            $self->_connect_vm();
643
            $sub->($self,$request);
644
            $self->_disconnect_vm();
645
646
647
        };
        my $err = ( $@ or '');
        $request->error($err);
648
        $request->status('done') if $request->status() ne 'done';
649
650
651
        exit;
    }
    $self->_add_pid($pid, $request->id);
652
#    $self->_connect_vm_kvm();
653
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
654
655
}

656
657
658
659
660
661
662
663
664
sub _cmd_domdisplay {
    my $self = shift;
    my $request = shift;

    $request->status('working');

    my $name = $request->args('name');
    confess "Unknown name for request ".Dumper($request)  if!$name;
    my $domain = $self->search_domain($request->args->{name});
665
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
666
    $request->error('');
667
    my $display = $domain->display($user);
668
669
670
    $request->result({display => $display});

    $request->status('done');
671
672
}

673
674
675
676
677
678
679
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);
    $request->error('');
680
    my $bytes = 0;
681
    if (!$domain->can_screenshot) {
682
        die "I can't take a screenshot of the domain ".$domain->name;
683
    } else {
684
685
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
686
    }
687
    $request->error("No data received") if !$bytes;
688
689
690
691
692
    $request->status('done');

}


693
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
694
695
696
    my $self = shift;
    my $request = shift;

697
    $request->status('creating domain');
698
    warn "$$ creating domain"   if $DEBUG;
699
    my $domain;
700

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

703
    my $msg = '';
704

705
    if ($domain) {
706
       $msg = 'Domain '
707
708
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
709
            ." created."
710
711
712
713
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
714
715
716

}

717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
sub _wait_children {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $try = 0;
    for (;;) {
        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;

        return if $n_pids <= $LIMIT_PROCESS;

        $self->_wait_pids_nohang();
        sleep 1;
        $req->error($msg)
            if !$try++;

    }
}

737
738
739
740
741
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

    my $kid = waitpid(-1 , WNOHANG);
Francesc Guasch's avatar
Francesc Guasch committed
742
    return if !$kid || $kid == -1;
743

744
    $self->_set_req_done($kid);
745
    delete $self->{pids}->{$kid};
746
747
748
749
750
751
752
753
754
755
756
757

}

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

Francesc Guasch's avatar
Francesc Guasch committed
760
761
762
763
sub _wait_pids {
    my $self = shift;
    my $request = shift;

Francesc Guasch's avatar
Francesc Guasch committed
764
765
    $request->status('waiting for other tasks')     if $request;

Francesc Guasch's avatar
Francesc Guasch committed
766
    for my $pid ( keys %{$self->{pids}}) {
767
768
769
        $request->status("waiting for pid $pid")    if $request;

#        warn "Checking for pid '$pid' created at ".localtime($self->{pids}->{$pid});
Francesc Guasch's avatar
Francesc Guasch committed
770
        my $kid = waitpid($pid,0);
771
#        warn "Found $kid";
772
773
774
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
775
776
777
778
779
780
781
        return if $kid  == $pid;
    }
}

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

784
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
785
786
}

787
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
788
789
790
791
    my $self = shift;
    my $request = shift;

    $request->status('working');
792
793
794
795
    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
796

797
}
Francesc Guasch's avatar
Francesc Guasch committed
798

799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
sub _cmd_pause {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    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;

    $request->status('working');
    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->resume($user);

    $request->status('done');

}


Francesc Guasch's avatar
Francesc Guasch committed
836
837
838
839
sub _cmd_start {
    my $self = shift;
    my $request = shift;

840
    $request->status("working $$");
Francesc Guasch's avatar
Francesc Guasch committed
841
    my $name = $request->args('name');
842

843
844
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
845
846
847
848

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

849
    $domain->start(user => $user, remote_ip => $request->args('remote_ip'));
850
851
852
    my $msg = 'Domain '
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
853
            ." started"
854
855
        ;
    $request->status('done', $msg);
Francesc Guasch's avatar
Francesc Guasch committed
856
857
858

}

Francesc Guasch's avatar
Francesc Guasch committed
859
860
861
862
863
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
Francesc Guasch's avatar
Francesc Guasch committed
864
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
865
866
867
868
    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
869
    my $domain = $self->search_domain_by_id($id_domain);
870

Francesc Guasch's avatar
Francesc Guasch committed
871
    die "Unknown domain id '$id_domain'\n" if !$domain;
872
873

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
874
875
876

}

877
878
879
880
881
882
883
884
885
886
887
888
889
890
sub _cmd_remove_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    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;

891
892
    $domain->_vm->disconnect();
    $self->_disconnect_vm();
893
894
895
896
897
    $domain->remove_base($user);

}


Francesc Guasch's avatar
Francesc Guasch committed
898

Francesc Guasch's avatar
Francesc Guasch committed
899
900
901
902
903
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
904
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
905
    my $name = $request->args('name');
906
    my $timeout = ($request->args('timeout') or 60);
907

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

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

914
915
    $domain->shutdown(timeout => $timeout, name => $name, user => $user
                    , request => $request);
Francesc Guasch's avatar
Francesc Guasch committed
916
917
918

}

919
920
921
922
923
sub _cmd_list_vm_types {
    my $self = shift;
    my $request = shift;
    $request->status('working');
    my @list_types = $self->list_vm_types();
Francesc Guasch's avatar
Francesc Guasch committed
924
    $request->result(\@list_types);
925
926
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
927

928
929
930
931
932
933
934
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
936
937
938
939
940
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
942
          start => \&_cmd_start
943
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
944
945
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
946
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
947
      ,shutdown => \&_cmd_shutdown
948
    ,domdisplay => \&_cmd_domdisplay
949
    ,screenshot => \&_cmd_screenshot
950
   ,remove_base => \&_cmd_remove_base
951
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
952
  ,prepare_base => \&_cmd_prepare_base
953
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
954
955
956
957
    );
    return $methods{$cmd};
}

958
959
960
961
962
963
964
965
966
967
968
969
970
=head2 open_vm

Opens a VM of a given type


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

=cut

sub open_vm {
    return search_vm(@_);
}

971
972
973
974
975
976
977
978
979
980
981
982
=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;

983
984
    confess "Missing VM type"   if !$type;

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

987
    if ($type =~ /Void/i) {
988
989
990
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
991
992
    my @vms;
    eval { @vms = @{$self->vm} };
993
994
995
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
996
    for my $vm (@vms) {
997
998
999
1000
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
1001

1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
=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);
}

1033

Francesc Guasch's avatar
Francesc Guasch committed
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

1044
1;