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
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
    my $request = $args{request}            if $args{request};

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
    return $vm->create_domain(@_);
229
230
}

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

Removes a domain

  $ravada->remove_domain($name);

=cut

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

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

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

    lock_hash(%arg);

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

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

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

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

=cut

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

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

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


293
    return;
294
}
295

Francesc Guasch's avatar
Francesc Guasch committed
296
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
297

Francesc Guasch's avatar
Francesc Guasch committed
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
  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
313

314
315
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
316
List all created domains
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

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

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

357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
# 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;
# }

374

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

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

433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
=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
448

449
450
451
=pod

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

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

474
=cut
fv3rdugo's avatar
fv3rdugo committed
475

Francesc Guasch's avatar
Francesc Guasch committed
476
477
478
479
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
480

Francesc Guasch's avatar
Francesc Guasch committed
481
482
=cut

483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
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";
    }

}
503

Francesc Guasch's avatar
Francesc Guasch committed
504
505
506
507
508
509
510
511
=head2 process_requests

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

  $ravada->process_requests();

=cut

512
513
sub process_requests {
    my $self = shift;
514
    my $debug = shift;
515
    my $dont_fork = shift;
516

517
    $self->_wait_pids_nohang();
518
    $self->_check_vms();
519

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

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

544
545
546
547
    }
    $sth->finish;
}

548
549
sub _process_requests_dont_fork {
    my $self = shift;
550
    my $debug = shift;
551
    return $self->process_requests($debug, 1);
552
}
Francesc Guasch's avatar
Francesc Guasch committed
553

554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
=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;
}

571
572
573
sub _execute {
    my $self = shift;
    my $request = shift;
574
    my $dont_fork = shift;
575

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

578
579
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
580

581
582
583
584
585
586
587
588
    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
589

590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
    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
605
606
}

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

    $request->status('done');

623
624
}

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

}


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

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

656
657
658
659
660
661
662
663
    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
664
665
666

}

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

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

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

}

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

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

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

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

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

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

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

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

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

727
}
Francesc Guasch's avatar
Francesc Guasch committed
728

729
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
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
766
767
768
769
sub _cmd_start {
    my $self = shift;
    my $request = shift;

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

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

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

    $domain->start($user);
780

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

}

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

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

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

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

}


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

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

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

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

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

}

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

832
833
834
835
836
837
838
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

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

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

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

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

873
874
    confess "Missing VM type"   if !$type;

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

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

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

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

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

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

=head1 SEE ALSO

Sys::Virt

=cut

902
1;