Ravada.pm 17.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;

Francesc Guasch's avatar
Francesc Guasch committed
14
use Ravada::Auth;
15
use Ravada::Request;
16
use Ravada::VM::KVM;
17
use Ravada::VM::Void;
18

Francesc Guasch's avatar
Francesc Guasch committed
19
20
21
22
23
24
25
26
27
28
29
30
=head1 NAME

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

31
32
33
34
35
36
37

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

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

our $CONNECTOR;
our $CONFIG = {};
38
our $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
39
our $CAN_FORK = 0;
40
41
42
43
44
45
46
47
48
49


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

has 'connector' => (
50
51
52
53
54
55
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
56
57
);

Francesc Guasch's avatar
Francesc Guasch committed
58
59
60
61
62
63
64
=head2 BUILD

Internal constructor

=cut


65
66
sub BUILD {
    my $self = shift;
67
    if ($self->config()) {
68
        _init_config($self->config);
69
    } else {
Francesc Guasch's avatar
Francesc Guasch committed
70
        _init_config($FILE_CONFIG) if -e $FILE_CONFIG;
71
    }
72

Francesc Guasch's avatar
Francesc Guasch committed
73
74
75
76
    if ( $self->connector ) {
        $CONNECTOR = $self->connector 
    } else {
        $CONNECTOR = $self->_connect_dbh();
77
        $self->connector($CONNECTOR);
Francesc Guasch's avatar
Francesc Guasch committed
78
    }
Francesc Guasch's avatar
Francesc Guasch committed
79
    Ravada::Auth::init($CONFIG);
80
81
82
83
84
85
}

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
86
87
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
88
89
90
91
92
93
94
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

sub _init_config {
    my $file = shift;
95
96

    my $connector = shift;
97
    confess "Deprecated connector" if $connector;
98

99
    $CONFIG = YAML::LoadFile($file);
100
#    $CONNECTOR = ( $connector or _connect_dbh());
101
102
}

103
sub _create_vm_kvm {
104
    my $self = shift;
105

106
107
108
109
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
112

113
114
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
115
    return (undef, $err_kvm)    if !$vm_kvm;
116
117
118
119
120
121
122
123
124

    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
125
126
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
127
128
}

129
130
sub _refresh_vm_kvm {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
131
    sleep 1;
132
133
134
135
136
137
    my @vms;
    eval { @vms = $self->vm };
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
138
139
140
141
142
143
144
145
146
147
    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;
    }
}

148
149
150
151
152
153
sub _create_vm {
    my $self = shift;

    my @vms = ();

    my ($vm_kvm, $err_kvm) = $self->_create_vm_kvm();
Francesc Guasch's avatar
Francesc Guasch committed
154
    warn $err_kvm if $err_kvm;
155

156
157
158
159
160
161
162
163
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
    eval { $vm_lxc = Ravada::VM::LXC->new( connector => ( $self->connector or $CONNECTOR )) };
    push @vms,($vm_lxc) if $vm_lxc;
    my $err_lxc = $@;

    if (!@vms) {
Francesc Guasch's avatar
Francesc Guasch committed
164
        confess "No VMs found: $err_lxc\n$err_kvm\n";
165
166
167
    }
    return \@vms;

168
169
}

170
sub _check_vms {
171
172
    my $self = shift;

173
174
    my @vm;
    eval { @vm = @{$self->vm} };
175
176
177
178
179
180
181
182
183
184
    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
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
=head2 create_domain

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

  my $domain = $ravada->create_domain( 
         name => $name
    , id_iso => 1
  );


  my $domain = $ravada->create_domain( 
         name => $name
    , id_base => 3
  );


=cut


204
sub create_domain {
205
206
    my $self = shift;

207
208
    my %args = @_;

209
210
211
    croak "Argument id_owner required "
        if !$args{id_owner};

212
213
    my $vm_name = $args{vm};
    delete $args{vm};
214

Francesc Guasch's avatar
Francesc Guasch committed
215
216
217
    my $request = $args{request}            if $args{request};

    $request->status("Searching for VM")    if $request;
Francesc Guasch's avatar
Francesc Guasch committed
218

219
    my $vm;
220
    $vm = $self->search_vm($vm_name)   if $vm_name;
221
    $vm = $self->vm->[0]               if !$vm;
222

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

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

228
    $request->status("creating domain in ".ref($vm))    if $request;
229
    return $vm->create_domain(@_);
230
231
}

Francesc Guasch's avatar
Francesc Guasch committed
232
233
234
235
236
237
238
239
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

240
241
sub remove_domain {
    my $self = shift;
242
243
    my %arg = @_;

244
    confess "Argument name required "
245
246
        if !$arg{name};

247
248
    confess "Argument uid required "
        if !$arg{uid};
249
250
251
252

    lock_hash(%arg);

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

255
256
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
257
258
}

Francesc Guasch's avatar
Francesc Guasch committed
259
260
261
262
263
264
=head2 search_domain

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

=cut

265
266
267
sub search_domain {
    my $self = shift;
    my $name = shift;
268
    my $import = shift;
269

270
271
272
273
274
275
276
277
278
279
280
281
    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 $@;

282
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
283
        my $domain = $vm->search_domain($name, $import);
284
        next if !$domain;
285
        next if !$domain->_select_domain_db && !$import;
286
287
288
        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
289
        warn $@ if $@   && $DEBUG;
290
        return $domain if $id || $import;
291
    }
292
293


294
    return;
295
}
296

Francesc Guasch's avatar
Francesc Guasch committed
297
298


299
300
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
301
List all created domains
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317

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

318
319
320
321
322
323
324
325
326
327
328
329
330
=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;
331
332
333
334
335
336
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
337
    }
338
    $sth->finish;
339
    return \@domains;
340
341
}

342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
# sub list_domains_data {
#     my $self = shift;
#     my @domains;
#     for my $domain ($self->list_domains()) {
#         eval { $domain->id };
#         warn $@ if $@;
#         next if $@;
#         push @domains, {                id => $domain->id 
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
                               
#                            }
#     }
#     return \@domains;
# }

359

Francesc Guasch's avatar
Francesc Guasch committed
360
361
362
363
364
365
366
367
368
369
370
371
372
373
=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) {
374
375
376
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
377
378
379
380
381
382
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
=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
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
=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;
}

418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
=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
433

434
435
436
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
437
438
439
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
440
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
441
442
443
444
445
446
447
448
449
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

450
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
451
452
453
454
455
456
457
458
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

459
=cut
fv3rdugo's avatar
fv3rdugo committed
460

Francesc Guasch's avatar
Francesc Guasch committed
461
462
463
464
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
465

Francesc Guasch's avatar
Francesc Guasch committed
466
467
=cut

468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
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";
    }

}
488

Francesc Guasch's avatar
Francesc Guasch committed
489
490
491
492
493
494
495
496
=head2 process_requests

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

  $ravada->process_requests();

=cut

497
498
sub process_requests {
    my $self = shift;
499
    my $debug = shift;
500
    my $dont_fork = shift;
Francesc Guasch's avatar
Francesc Guasch committed
501
    $dont_fork = 1 if !$CAN_FORK;
502

503
    $self->_wait_pids_nohang();
504
    $self->_check_vms();
505

506
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
Francesc Guasch's avatar
Francesc Guasch committed
507
        ." WHERE status='requested' OR status like 'retry %'");
508
509
    $sth->execute;
    while (my ($id)= $sth->fetchrow) {
510
        $self->_wait_pids_nohang();
Francesc Guasch's avatar
Francesc Guasch committed
511
        my $req = Ravada::Request->open($id);
512
513
        warn "executing request ".$req->id." ".$req->status()." ".$req->command
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
514
515
516

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
517
        $req->status('working');
518
        eval { $self->_execute($req, $dont_fork) };
519
        my $err = $@;
520
        $req->error($err or '');
521
        if ($err =~ /libvirt error code: 38/) {
Francesc Guasch's avatar
Francesc Guasch committed
522
            if ( $n_retry < 3) {
523
                warn $req->id." ".$req->command." to retry" if $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
524
                $req->status("retry ".++$n_retry)   
525
526
527
            }
            $self->_refresh_vm_kvm();
        } else {
528
            $req->status('done');
529
        }
530
531
532
        warn "req ".$req->id." , command: ".$req->command." , status: ".$req->status()
            ." , error: '".($req->error or 'NONE')."'" 
                if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
533
534

        $self->_refresh_vm_kvm() if $req->command =~ /create|remove/i;
535
536
537
538
    }
    $sth->finish;
}

539
540
sub _process_requests_dont_fork {
    my $self = shift;
541
    my $debug = shift;
542
    return $self->process_requests($debug, 1);
543
}
Francesc Guasch's avatar
Francesc Guasch committed
544

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
=head2 list_vm_types

Returnsa list ofthe types of Virtual Machines available on this system

=cut

sub list_vm_types {
    my $self = shift;
    
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
    return sort keys %type;
}

562
563
564
sub _execute {
    my $self = shift;
    my $request = shift;
565
    my $dont_fork = shift;
566

Francesc Guasch's avatar
Francesc Guasch committed
567
568
569
570
571
    my $sub = $self->_req_method($request->command);

    die "Unknown command ".$request->command
        if !$sub;

572
    return $sub->($self,$request, $dont_fork);
Francesc Guasch's avatar
Francesc Guasch committed
573
574
575

}

576
577
578
579
580
581
582
583
584
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});
585
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
586
    $request->error('');
587
    my $display = $domain->display($user);
588
589
590
591
    $request->result({display => $display});

    $request->status('done');

592
593
}

594
sub _do_cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
595
596
597
    my $self = shift;
    my $request = shift;

598
    $request->status('creating domain');
599
    warn "$$ creating domain"   if $DEBUG;
600
    my $domain;
601
    $domain = $self->create_domain(%{$request->args},request => $request);
602

Francesc Guasch's avatar
Francesc Guasch committed
603
604
605
606
    $request->status('done');

}

607
608
609
610
611
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

614
    warn "Kid $kid finished"    if $DEBUG;
615
616
617
    delete $self->{pids}->{$kid};
}

Francesc Guasch's avatar
Francesc Guasch committed
618
619
620
621
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
624
    for my $pid ( keys %{$self->{pids}}) {
625
626
627
        $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
628
629
        my $kid = waitpid($pid,0);

630
#        warn "Found $kid";
Francesc Guasch's avatar
Francesc Guasch committed
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
        return if $kid  == $pid;
    }
}

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

    $self->{pids}->{$pid} = time;
}

sub _cmd_create {

    my $self = shift;
    my $request = shift;
646
647
648
649
    my $dont_fork = shift;

    return $self->_do_cmd_create($request)
        if $dont_fork;
Francesc Guasch's avatar
Francesc Guasch committed
650
651
652
653
654
655
656
657
658
659
660
661


    $self->_wait_pids($request);

    $request->status('forking');
    my $pid = fork();
    if (!defined $pid) {
        $request->status('done');
        $request->error("I can't fork");
        return;
    }
    if ($pid == 0 ) {
662
        $self->_do_cmd_create($request);
Francesc Guasch's avatar
Francesc Guasch committed
663
664
665
        exit;
    }
    $self->_add_pid($pid);
666

Francesc Guasch's avatar
Francesc Guasch committed
667
668
669
    return;
}

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

    $request->status('working');
675
676
677
678
    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
679

680
}
Francesc Guasch's avatar
Francesc Guasch committed
681

Francesc Guasch's avatar
Francesc Guasch committed
682
683
684
685
686
687
sub _cmd_remove {
    my $self = shift;
    my $request = shift;
    my $dont_fork = shift;

    return $self->_do_cmd_remove($request)
688
        if $dont_fork || !$CAN_FORK;
Francesc Guasch's avatar
Francesc Guasch committed
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707

    $self->_wait_pids($request);

    $request->status('forking');
    my $pid = fork();
    if (!defined $pid) {
        $request->status('done');
        $request->error("I can't fork");
        return;
    }
    if ($pid == 0 ) {
        $self->_do_cmd_remove($request);
        exit;
    }
    $self->_add_pid($pid);

    return;
}

708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
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
745
746
747
748
749
750
sub _cmd_start {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $name = $request->args('name');
751
752
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
753
754
755
756
757

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

    $domain->start($user);
758

Francesc Guasch's avatar
Francesc Guasch committed
759
760
761
762
    $request->status('done');

}

Francesc Guasch's avatar
Francesc Guasch committed
763
764
765
766
767
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
768
769
770
771
772
773
774
775
776
777
    my $name = $request->args('name')   or confess "Missing argument name";
    my $uid = $request->args('uid')     or confess "Missing argument uid";

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

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

    die "Unknown domain '$name'\n" if !$domain;

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
778
779
780
781

}


Francesc Guasch's avatar
Francesc Guasch committed
782
783
784
785
786
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
787
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
788
    my $name = $request->args('name');
789
    my $timeout = ($request->args('timeout') or 60);
790

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

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

    $domain->shutdown(timeout => $timeout, name => $name, user => $user);
Francesc Guasch's avatar
Francesc Guasch committed
798
799
800

}

801
802
803
804
805
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
806
    $request->result(\@list_types);
807
808
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
809

810
811
812
813
814
815
816
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
818
819
820
821
822
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
824
          start => \&_cmd_start
825
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
826
827
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
828
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
829
      ,shutdown => \&_cmd_shutdown
830
    ,domdisplay => \&_cmd_domdisplay
831
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
832
  ,prepare_base => \&_cmd_prepare_base
833
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
834
835
836
837
    );
    return $methods{$cmd};
}

838
839
840
841
842
843
844
845
846
847
848
849
=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;

850
851
    confess "Missing VM type"   if !$type;

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

854
    if ($type =~ /Void/i) {
855
856
857
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
858
859
    my @vms;
    eval { @vms = @{$self->vm} };
860
861
862
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
863
    for my $vm (@vms) {
864
865
866
867
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
868

Francesc Guasch's avatar
Francesc Guasch committed
869
870
871
872
873
874
875
876
877
878
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

879
1;