Ravada.pm 17.6 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;
39
our $CAN_FORK = 1;
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
    return ($vm_kvm,$err_kvm);
117
118
119
120
121
122
123
124
125

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

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

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

150
151
152
153
154
155
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

158
159
160
161
162
163
164
165
    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
166
        confess "No VMs found: $err_lxc\n$err_kvm\n";
167
168
169
    }
    return \@vms;

170
171
}

172
sub _check_vms {
173
174
    my $self = shift;

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


206
sub create_domain {
207
208
    my $self = shift;

209
210
    my %args = @_;

211
212
213
    croak "Argument id_owner required "
        if !$args{id_owner};

214
215
    my $vm_name = $args{vm};
    delete $args{vm};
216

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

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

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

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

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

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

Francesc Guasch's avatar
Francesc Guasch committed
234
235
236
237
238
239
240
241
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

242
243
sub remove_domain {
    my $self = shift;
244
245
    my %arg = @_;

246
    confess "Argument name required "
247
248
        if !$arg{name};

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

    lock_hash(%arg);

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

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

Francesc Guasch's avatar
Francesc Guasch committed
261
262
263
264
265
266
=head2 search_domain

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

=cut

267
268
269
sub search_domain {
    my $self = shift;
    my $name = shift;
270
    my $import = shift;
271

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

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


296
    return;
297
}
298

Francesc Guasch's avatar
Francesc Guasch committed
299
300


301
302
=head2 list_domains

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

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

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

344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
# 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;
# }

361

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

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

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

436
437
438
=pod

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

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

461
=cut
fv3rdugo's avatar
fv3rdugo committed
462

Francesc Guasch's avatar
Francesc Guasch committed
463
464
465
466
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
467

Francesc Guasch's avatar
Francesc Guasch committed
468
469
=cut

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

}
490

Francesc Guasch's avatar
Francesc Guasch committed
491
492
493
494
495
496
497
498
=head2 process_requests

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

  $ravada->process_requests();

=cut

499
500
sub process_requests {
    my $self = shift;
501
    my $debug = shift;
502
    my $dont_fork = shift;
503

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

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

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
518
        $req->status('working');
519
520
521
        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
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
528
529
        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
530

531
532
533
534
    }
    $sth->finish;
}

535
536
sub _process_requests_dont_fork {
    my $self = shift;
537
    my $debug = shift;
538
    return $self->process_requests($debug, 1);
539
}
Francesc Guasch's avatar
Francesc Guasch committed
540

541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
=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;
}

558
559
560
sub _execute {
    my $self = shift;
    my $request = shift;
561
    my $dont_fork = shift;
562

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

565
566
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
567

568
569
570
571
572
573
574
575
    if ($dont_fork || !$CAN_FORK ) {
        
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
        $request->status('done');
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
576

577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
    my $pid = fork();
    die "I can't fork" if !defined $pid;
    if ($pid == 0) {
        $request->status("forked $$");
        eval { 
            $request->status("calling ".$request->command);
            $sub->($self,$request);
        };
        my $err = ( $@ or '');
        $request->error($err);
        $request->status('done');
        exit;
    }
    $self->_add_pid($pid, $request->id);
    $self->_refresh_vm_kvm();
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
593
594
}

595
596
597
598
599
600
601
602
603
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});
604
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
605
    $request->error('');
606
    my $display = $domain->display($user);
607
608
609
610
    $request->result({display => $display});

    $request->status('done');

611
612
}

613
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
614
615
616
    my $self = shift;
    my $request = shift;

617
    $request->status('creating domain');
618
    warn "$$ creating domain"   if $DEBUG;
619
    my $domain;
620
    $domain = $self->create_domain(%{$request->args},request => $request);
621

Francesc Guasch's avatar
Francesc Guasch committed
622
623
624
625
    $request->status('done');

}

626
627
628
629
630
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

633
    $self->_set_req_done($kid);
634
    delete $self->{pids}->{$kid};
635
636
637
638
639
640
641
642
643
644
645
646

}

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

Francesc Guasch's avatar
Francesc Guasch committed
649
650
651
652
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
655
    for my $pid ( keys %{$self->{pids}}) {
656
657
658
        $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
659
        my $kid = waitpid($pid,0);
660
#        warn "Found $kid";
661
662
663
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
664
665
666
667
668
669
670
        return if $kid  == $pid;
    }
}

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

673
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
674
675
}

676
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
677
678
679
680
    my $self = shift;
    my $request = shift;

    $request->status('working');
681
682
683
684
    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
685

686
}
Francesc Guasch's avatar
Francesc Guasch committed
687

688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
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
725
726
727
728
sub _cmd_start {
    my $self = shift;
    my $request = shift;

729
    $request->status("working $$");
Francesc Guasch's avatar
Francesc Guasch committed
730
    my $name = $request->args('name');
731

732
733
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
734
735
736
737
738

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

    $domain->start($user);
739

Francesc Guasch's avatar
Francesc Guasch committed
740
741
742
743
    $request->status('done');

}

Francesc Guasch's avatar
Francesc Guasch committed
744
745
746
747
748
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
749
750
751
752
753
754
755
756
757
758
    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
759
760
761
762

}


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

    $request->status('working');
768
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
769
    my $name = $request->args('name');
770
    my $timeout = ($request->args('timeout') or 60);
771

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

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

    $domain->shutdown(timeout => $timeout, name => $name, user => $user);
Francesc Guasch's avatar
Francesc Guasch committed
779
780
781

}

782
783
784
785
786
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
787
    $request->result(\@list_types);
788
789
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
790

791
792
793
794
795
796
797
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
799
800
801
802
803
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
805
          start => \&_cmd_start
806
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
807
808
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
809
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
810
      ,shutdown => \&_cmd_shutdown
811
    ,domdisplay => \&_cmd_domdisplay
812
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
813
  ,prepare_base => \&_cmd_prepare_base
814
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
815
816
817
818
    );
    return $methods{$cmd};
}

819
820
821
822
823
824
825
826
827
828
829
830
=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;

831
832
    confess "Missing VM type"   if !$type;

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

835
    if ($type =~ /Void/i) {
836
837
838
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
839
840
    my @vms;
    eval { @vms = @{$self->vm} };
841
842
843
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
844
    for my $vm (@vms) {
845
846
847
848
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
849

Francesc Guasch's avatar
Francesc Guasch committed
850
851
852
853
854
855
856
857
858
859
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

860
1;