Ravada.pm 20.5 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
    return (undef, $err_kvm)    if !$vm_kvm;
137
    return ($vm_kvm,$err_kvm);
138
139
140
141
142
143
144
145
146

    my ($internal_vm , $storage);
    eval {
        $internal_vm = $vm_kvm->vm;
        $internal_vm->list_all_domains();

        $storage = $vm_kvm->dir_img();
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
147
148
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
149
150
}

151
152
sub _refresh_vm_kvm {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
153
    sleep 1;
154
155
    my @vms;
    eval { @vms = $self->vm };
156
    warn $@ if $@;
157
158
159
160
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
161
162
163
164
165
166
167
168
169
170
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
        next if ref $vm !~ /KVM/i;
        warn "Refreshing VM $n $vm" if $DEBUG;
        my ($vm2, $err) = $self->_create_vm_kvm();
        $self->vm->[$n] = $vm2;
        warn $err if $err;
    }
}

171
172
173
174
175
176
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

179
180
    my $err = $err_kvm;

181
182
183
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
184
185
186
187
188
189
    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;
    }
190
    if (!@vms) {
191
        confess "No VMs found: $err\n";
192
193
194
    }
    return \@vms;

195
196
}

197
sub _check_vms {
198
199
    my $self = shift;

200
201
    my @vm;
    eval { @vm = @{$self->vm} };
202
203
204
205
206
207
208
209
210
211
    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
212
213
214
215
=head2 create_domain

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

joansp's avatar
joansp committed
216
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
217
218
219
220
221
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
222
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
223
224
225
226
227
228
229
230
         name => $name
    , id_base => 3
  );


=cut


231
sub create_domain {
232
233
    my $self = shift;

234
235
    my %args = @_;

236
237
238
    croak "Argument id_owner required "
        if !$args{id_owner};

239
240
    my $vm_name = $args{vm};
    delete $args{vm};
241

Francesc Guasch's avatar
Francesc Guasch committed
242
243
    my $request = $args{request}            if $args{request};

244
    my $vm;
245
    $vm = $self->search_vm($vm_name)   if $vm_name;
246
    $vm = $self->vm->[0]               if !$vm;
247

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

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

253
    return $vm->create_domain(@_);
254
255
}

Francesc Guasch's avatar
Francesc Guasch committed
256
257
258
259
260
261
262
263
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

264
265
sub remove_domain {
    my $self = shift;
266
267
    my %arg = @_;

268
    confess "Argument name required "
269
270
        if !$arg{name};

271
272
    confess "Argument uid required "
        if !$arg{uid};
273
274
275
276

    lock_hash(%arg);

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

279
280
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
281
282
}

Francesc Guasch's avatar
Francesc Guasch committed
283
284
285
286
287
288
=head2 search_domain

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

=cut

289
290
291
sub search_domain {
    my $self = shift;
    my $name = shift;
292
    my $import = shift;
293

294
295
296
297
298
299
300
301
302
303
304
305
    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 $@;

306
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
307
        my $domain = $vm->search_domain($name, $import);
308
        next if !$domain;
309
        next if !$domain->_select_domain_db && !$import;
310
311
312
        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
313
        warn $@ if $@   && $DEBUG;
314
        return $domain if $id || $import;
315
    }
316
317


318
    return;
319
}
320

Francesc Guasch's avatar
Francesc Guasch committed
321
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
322

Francesc Guasch's avatar
Francesc Guasch committed
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
  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
338

339
340
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
341
List all created domains
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357

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

358
359
360
361
362
363
364
365
366
367
368
369
370
=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;
371
372
373
374
375
376
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
377
    }
378
    $sth->finish;
379
    return \@domains;
380
381
}

382
383
384
385
386
387
388
# 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
389
#         push @domains, {                id => $domain->id
390
391
392
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
393

394
395
396
397
398
#                            }
#     }
#     return \@domains;
# }

399

Francesc Guasch's avatar
Francesc Guasch committed
400
401
402
403
404
405
406
407
408
409
410
411
412
413
=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) {
414
415
416
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
417
418
419
420
421
422
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
=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
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
=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;
}

458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
=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
473

474
475
476
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
477
478
479
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
480
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
481
482
483
484
485
486
487
488
489
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

490
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
491
492
493
494
495
496
497
498
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

499
=cut
fv3rdugo's avatar
fv3rdugo committed
500

Francesc Guasch's avatar
Francesc Guasch committed
501
502
503
504
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
505

Francesc Guasch's avatar
Francesc Guasch committed
506
507
=cut

508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
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";
    }

}
528

Francesc Guasch's avatar
Francesc Guasch committed
529
530
531
532
533
534
535
536
=head2 process_requests

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

  $ravada->process_requests();

=cut

537
538
sub process_requests {
    my $self = shift;
539
    my $debug = shift;
540
    my $dont_fork = shift;
541

542
    $self->_wait_pids_nohang();
543
    $self->_check_vms();
544

545
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
Francesc Guasch's avatar
Francesc Guasch committed
546
        ." WHERE status='requested' OR status like 'retry %'");
547
548
    $sth->execute;
    while (my ($id)= $sth->fetchrow) {
549
        $self->_wait_pids_nohang();
Francesc Guasch's avatar
Francesc Guasch committed
550
        my $req = Ravada::Request->open($id);
551
552
        warn "executing request ".$req->id." ".$req->status()." ".$req->command
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
553
554
555

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
556
        $req->status('working');
557
558
559
        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
560
            if ( $n_retry < 3) {
561
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
562
                $req->status("retry ".++$n_retry)
563
            }
564
        }
565
        warn "req ".$req->id." , command: ".$req->command." , status: ".$req->status()
joansp's avatar
joansp committed
566
            ." , error: '".($req->error or 'NONE')."'"
567
                if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
568

569
570
571
572
    }
    $sth->finish;
}

573
574
sub _process_requests_dont_fork {
    my $self = shift;
575
    my $debug = shift;
576
    return $self->process_requests($debug, 1);
577
}
Francesc Guasch's avatar
Francesc Guasch committed
578

579
580
581
582
583
584
585
586
=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
587

588
589
590
591
592
593
594
595
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
    return sort keys %type;
}

596
597
598
sub _execute {
    my $self = shift;
    my $request = shift;
599
    my $dont_fork = shift;
600

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

603
604
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
605

606
    if ($dont_fork || !$CAN_FORK ) {
joansp's avatar
joansp committed
607

608
609
610
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
611
        $request->status('done') if $request->status() ne 'done';
612
613
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
614

615
    $self->_wait_children($request) if $FAT_COMMAND{$request->command};
616
617
618
619
    my $pid = fork();
    die "I can't fork" if !defined $pid;
    if ($pid == 0) {
        $request->status("forked $$");
joansp's avatar
joansp committed
620
        eval {
621
622
623
624
            $sub->($self,$request);
        };
        my $err = ( $@ or '');
        $request->error($err);
625
        $request->status('done') if $request->status() ne 'done';
626
627
628
629
630
        exit;
    }
    $self->_add_pid($pid, $request->id);
    $self->_refresh_vm_kvm();
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
631
632
}

633
634
635
636
637
638
639
640
641
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});
642
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
643
    $request->error('');
644
    my $display = $domain->display($user);
645
646
647
648
    $request->result({display => $display});

    $request->status('done');

649
650
}

651
652
653
654
655
656
657
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('');
658
    my $bytes = 0;
659
    if (!$domain->can_screenshot) {
660
        die "I can't take a screenshot of the domain ".$domain->name;
661
    } else {
662
663
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
664
    }
665
    $request->error("No data received") if !$bytes;
666
667
668
669
670
    $request->status('done');

}


671
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
672
673
674
    my $self = shift;
    my $request = shift;

675
    $request->status('creating domain');
676
    warn "$$ creating domain"   if $DEBUG;
677
    my $domain;
678

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

681
    my $msg = '';
682

683
    if ($domain) {
684
       $msg = 'Domain '
685
686
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
687
            ." created."
688
689
690
691
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
692
693
694

}

695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
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++;

    }
}

715
716
717
718
719
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

722
    $self->_set_req_done($kid);
723
    delete $self->{pids}->{$kid};
724
725
726
727
728
729
730
731
732
733
734
735

}

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

Francesc Guasch's avatar
Francesc Guasch committed
738
739
740
741
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
744
    for my $pid ( keys %{$self->{pids}}) {
745
746
747
        $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
748
        my $kid = waitpid($pid,0);
749
#        warn "Found $kid";
750
751
752
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
753
754
755
756
757
758
759
        return if $kid  == $pid;
    }
}

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

762
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
763
764
}

765
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
766
767
768
769
    my $self = shift;
    my $request = shift;

    $request->status('working');
770
771
772
773
    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
774

775
}
Francesc Guasch's avatar
Francesc Guasch committed
776

777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
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
814
815
816
817
sub _cmd_start {
    my $self = shift;
    my $request = shift;

818
    $request->status("working $$");
Francesc Guasch's avatar
Francesc Guasch committed
819
    my $name = $request->args('name');
820

821
822
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
823
824
825
826
827

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

    $domain->start($user);
828
829
830
    my $msg = 'Domain '
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
831
            ." started"
832
833
        ;
    $request->status('done', $msg);
Francesc Guasch's avatar
Francesc Guasch committed
834
835
836

}

Francesc Guasch's avatar
Francesc Guasch committed
837
838
839
840
841
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
Francesc Guasch's avatar
Francesc Guasch committed
842
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
843
844
845
846
    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
847
    my $domain = $self->search_domain_by_id($id_domain);
848

Francesc Guasch's avatar
Francesc Guasch committed
849
    die "Unknown domain id '$id_domain'\n" if !$domain;
850
851

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
852
853
854

}

855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
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;

    $domain->remove_base($user);

}


Francesc Guasch's avatar
Francesc Guasch committed
874

Francesc Guasch's avatar
Francesc Guasch committed
875
876
877
878
879
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
880
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
881
    my $name = $request->args('name');
882
    my $timeout = ($request->args('timeout') or 60);
883

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

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

    $domain->shutdown(timeout => $timeout, name => $name, user => $user);
Francesc Guasch's avatar
Francesc Guasch committed
891
892
893

}

894
895
896
897
898
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
899
    $request->result(\@list_types);
900
901
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
902

903
904
905
906
907
908
909
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
911
912
913
914
915
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
917
          start => \&_cmd_start
918
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
919
920
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
921
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
922
      ,shutdown => \&_cmd_shutdown
923
    ,domdisplay => \&_cmd_domdisplay
924
    ,screenshot => \&_cmd_screenshot
925
   ,remove_base => \&_cmd_remove_base
926
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
927
  ,prepare_base => \&_cmd_prepare_base
928
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
929
930
931
932
    );
    return $methods{$cmd};
}

933
934
935
936
937
938
939
940
941
942
943
944
945
=head2 open_vm

Opens a VM of a given type


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

=cut

sub open_vm {
    return search_vm(@_);
}

946
947
948
949
950
951
952
953
954
955
956
957
=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;

958
959
    confess "Missing VM type"   if !$type;

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

962
    if ($type =~ /Void/i) {
963
964
965
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
966
967
    my @vms;
    eval { @vms = @{$self->vm} };
968
969
970
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
971
    for my $vm (@vms) {
972
973
974
975
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
976

Francesc Guasch's avatar
Francesc Guasch committed
977
978
979
980
981
982
983
984
985
986
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

987
1;