Ravada.pm 18.7 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
our $CAN_LXC = 0;
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();
156
    warn $err_kvm if $err_kvm && $0 !~ /\.t$/;
157

158
159
    my $err = $err_kvm;

160
161
162
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
163
164
165
166
167
168
    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;
    }
169
    if (!@vms) {
170
        confess "No VMs found: $err\n";
171
172
173
    }
    return \@vms;

174
175
}

176
sub _check_vms {
177
178
    my $self = shift;

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


210
sub create_domain {
211
212
    my $self = shift;

213
214
    my %args = @_;

215
216
217
    croak "Argument id_owner required "
        if !$args{id_owner};

218
219
    my $vm_name = $args{vm};
    delete $args{vm};
220

Francesc Guasch's avatar
Francesc Guasch committed
221
222
    my $request = $args{request}            if $args{request};

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

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

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

232
    return $vm->create_domain(@_);
233
234
}

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

Removes a domain

  $ravada->remove_domain($name);

=cut

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

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

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

    lock_hash(%arg);

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

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

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

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

=cut

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

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

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


297
    return;
298
}
299

Francesc Guasch's avatar
Francesc Guasch committed
300
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
301

Francesc Guasch's avatar
Francesc Guasch committed
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
  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
317

318
319
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
320
List all created domains
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336

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

337
338
339
340
341
342
343
344
345
346
347
348
349
=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;
350
351
352
353
354
355
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
356
    }
357
    $sth->finish;
358
    return \@domains;
359
360
}

361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
# 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;
# }

378

Francesc Guasch's avatar
Francesc Guasch committed
379
380
381
382
383
384
385
386
387
388
389
390
391
392
=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) {
393
394
395
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
396
397
398
399
400
401
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
=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
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
=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;
}

437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
=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
452

453
454
455
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
456
457
458
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
459
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
460
461
462
463
464
465
466
467
468
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

469
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
470
471
472
473
474
475
476
477
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

478
=cut
fv3rdugo's avatar
fv3rdugo committed
479

Francesc Guasch's avatar
Francesc Guasch committed
480
481
482
483
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
484

Francesc Guasch's avatar
Francesc Guasch committed
485
486
=cut

487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
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";
    }

}
507

Francesc Guasch's avatar
Francesc Guasch committed
508
509
510
511
512
513
514
515
=head2 process_requests

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

  $ravada->process_requests();

=cut

516
517
sub process_requests {
    my $self = shift;
518
    my $debug = shift;
519
    my $dont_fork = shift;
520

521
    $self->_wait_pids_nohang();
522
    $self->_check_vms();
523

524
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
Francesc Guasch's avatar
Francesc Guasch committed
525
        ." WHERE status='requested' OR status like 'retry %'");
526
527
    $sth->execute;
    while (my ($id)= $sth->fetchrow) {
528
        $self->_wait_pids_nohang();
Francesc Guasch's avatar
Francesc Guasch committed
529
        my $req = Ravada::Request->open($id);
530
531
        warn "executing request ".$req->id." ".$req->status()." ".$req->command
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
532
533
534

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
535
        $req->status('working');
536
537
538
        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
539
            if ( $n_retry < 3) {
540
                warn $req->id." ".$req->command." to retry" if $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
541
                $req->status("retry ".++$n_retry)   
542
            }
543
        }
544
545
546
        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
547

548
549
550
551
    }
    $sth->finish;
}

552
553
sub _process_requests_dont_fork {
    my $self = shift;
554
    my $debug = shift;
555
    return $self->process_requests($debug, 1);
556
}
Francesc Guasch's avatar
Francesc Guasch committed
557

558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
=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;
}

575
576
577
sub _execute {
    my $self = shift;
    my $request = shift;
578
    my $dont_fork = shift;
579

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

582
583
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
584

585
586
587
588
589
590
591
592
    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
593

594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
    my $pid = fork();
    die "I can't fork" if !defined $pid;
    if ($pid == 0) {
        $request->status("forked $$");
        eval { 
            $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
609
610
}

611
612
613
614
615
616
617
618
619
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});
620
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
621
    $request->error('');
622
    my $display = $domain->display($user);
623
624
625
626
    $request->result({display => $display});

    $request->status('done');

627
628
}

629
630
631
632
633
634
635
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('');
636
    my $bytes = 0;
637
    if (!$domain->can_screenshot) {
638
        die "I can't take a screenshot of the domain ".$domain->name;
639
    } else {
640
641
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
642
    }
643
    $request->error("No data received") if !$bytes;
644
645
646
647
648
    $request->status('done');

}


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

653
    $request->status('creating domain');
654
    warn "$$ creating domain"   if $DEBUG;
655
    my $domain;
656
    $domain = $self->create_domain(%{$request->args},request => $request);
657

658
659
660
661
662
663
664
665
    my $msg = '';
    if ($domain) {
        $msg = 'Domain '.$request->args('name')." created. "
            ."<a href=\"/machine/view/".$domain->id.".html>Start</a>";
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
666
667
668

}

669
670
671
672
673
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

676
    $self->_set_req_done($kid);
677
    delete $self->{pids}->{$kid};
678
679
680
681
682
683
684
685
686
687
688
689

}

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

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

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

Francesc Guasch's avatar
Francesc Guasch committed
698
    for my $pid ( keys %{$self->{pids}}) {
699
700
701
        $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
702
        my $kid = waitpid($pid,0);
703
#        warn "Found $kid";
704
705
706
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
707
708
709
710
711
712
713
        return if $kid  == $pid;
    }
}

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

716
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
717
718
}

719
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
720
721
722
723
    my $self = shift;
    my $request = shift;

    $request->status('working');
724
725
726
727
    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
728

729
}
Francesc Guasch's avatar
Francesc Guasch committed
730

731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
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
768
769
770
771
sub _cmd_start {
    my $self = shift;
    my $request = shift;

772
    $request->status("working $$");
Francesc Guasch's avatar
Francesc Guasch committed
773
    my $name = $request->args('name');
774

775
776
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
777
778
779
780
781

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

    $domain->start($user);
782

Francesc Guasch's avatar
Francesc Guasch committed
783
784
785
786
    $request->status('done');

}

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

    $request->status('working');
Francesc Guasch's avatar
Francesc Guasch committed
792
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
793
794
795
796
    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
797
    my $domain = $self->search_domain_by_id($id_domain);
798

Francesc Guasch's avatar
Francesc Guasch committed
799
    die "Unknown domain id '$id_domain'\n" if !$domain;
800
801

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
802
803
804
805

}


Francesc Guasch's avatar
Francesc Guasch committed
806
807
808
809
810
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
811
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
812
    my $name = $request->args('name');
813
    my $timeout = ($request->args('timeout') or 60);
814

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

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

    $domain->shutdown(timeout => $timeout, name => $name, user => $user);
Francesc Guasch's avatar
Francesc Guasch committed
822
823
824

}

825
826
827
828
829
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
830
    $request->result(\@list_types);
831
832
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
833

834
835
836
837
838
839
840
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
842
843
844
845
846
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
848
          start => \&_cmd_start
849
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
850
851
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
852
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
853
      ,shutdown => \&_cmd_shutdown
854
    ,domdisplay => \&_cmd_domdisplay
855
    ,screenshot => \&_cmd_screenshot
856
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
857
  ,prepare_base => \&_cmd_prepare_base
858
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
859
860
861
862
    );
    return $methods{$cmd};
}

863
864
865
866
867
868
869
870
871
872
873
874
=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;

875
876
    confess "Missing VM type"   if !$type;

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

879
    if ($type =~ /Void/i) {
880
881
882
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
883
884
    my @vms;
    eval { @vms = @{$self->vm} };
885
886
887
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
888
    for my $vm (@vms) {
889
890
891
892
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
893

Francesc Guasch's avatar
Francesc Guasch committed
894
895
896
897
898
899
900
901
902
903
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

904
1;