Ravada.pm 19.4 KB
Newer Older
1
2
3
4
5
package Ravada;

use warnings;
use strict;

6
use Carp qw(carp croak);
7
use Data::Dumper;
8
use DBIx::Connector;
9
use Hash::Util qw(lock_hash);
10
use Moose;
Francesc Guasch's avatar
Francesc Guasch committed
11
use POSIX qw(WNOHANG);
12
13
use YAML;

14
15
16
use Socket qw( inet_aton inet_ntoa );
use Sys::Hostname;

Francesc Guasch's avatar
Francesc Guasch committed
17
use Ravada::Auth;
18
use Ravada::Request;
19
use Ravada::VM::KVM;
20
use Ravada::VM::Void;
21

Francesc Guasch's avatar
Francesc Guasch committed
22
23
24
25
26
27
28
29
30
31
32
33
=head1 NAME

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

34
35
36
37
38
39
40

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

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

our $CONNECTOR;
our $CONFIG = {};
41
our $DEBUG;
42
our $CAN_FORK = 1;
43
our $CAN_LXC = 0;
44
45
46
47
48
49
50
51
52

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

has 'connector' => (
53
54
55
56
57
58
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
59
60
);

Francesc Guasch's avatar
Francesc Guasch committed
61
62
63
64
65
66
67
=head2 BUILD

Internal constructor

=cut


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

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

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

}

96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
sub display_ip {
    my $ip = $CONFIG->{display_ip};
    return $ip if $ip;

    my $name = hostname() or die "CRITICAL: I can't find the hostname.\n";
    $ip = inet_ntoa(inet_aton($name)) 
        or die "CRITICAL: I can't find IP of $name in the DNS.\n";

    if (!$ip || $ip =~ /^127./) {
        #TODO Net:DNS
        $ip= `host $name`;
        chomp $ip;
        $ip =~ s/.*?address (\d+)/$1/;
    }
    if ( !$ip || $ip =~ /^127./ || $ip !~ /^\d+\..*\.\d+$/) {
        warn "WARNING: I can't find IP with hostname $name ( $ip )"
            .", using localhost\n";
        $ip='127.0.0.1';
    }

    return $ip;

}

120
121
sub _init_config {
    my $file = shift;
122
123

    my $connector = shift;
124
    confess "Deprecated connector" if $connector;
125

126
    $CONFIG = YAML::LoadFile($file);
127
#    $CONNECTOR = ( $connector or _connect_dbh());
128
129
}

130
sub _create_vm_kvm {
131
    my $self = shift;
132

133
134
135
136
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
139

140
141
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
142
    return (undef, $err_kvm)    if !$vm_kvm;
143
    return ($vm_kvm,$err_kvm);
144
145
146
147
148
149
150
151
152

    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
153
154
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
155
156
}

157
158
sub _refresh_vm_kvm {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
159
    sleep 1;
160
161
    my @vms;
    eval { @vms = $self->vm };
162
    warn $@ if $@;
163
164
165
166
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
167
168
169
170
171
172
173
174
175
176
    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;
    }
}

177
178
179
180
181
182
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

185
186
    my $err = $err_kvm;

187
188
189
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
190
191
192
193
194
195
    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;
    }
196
    if (!@vms) {
197
        confess "No VMs found: $err\n";
198
199
200
    }
    return \@vms;

201
202
}

203
sub _check_vms {
204
205
    my $self = shift;

206
207
    my @vm;
    eval { @vm = @{$self->vm} };
208
209
210
211
212
213
214
215
216
217
    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
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
=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


237
sub create_domain {
238
239
    my $self = shift;

240
241
    my %args = @_;

242
243
244
    croak "Argument id_owner required "
        if !$args{id_owner};

245
246
    my $vm_name = $args{vm};
    delete $args{vm};
247

Francesc Guasch's avatar
Francesc Guasch committed
248
249
    my $request = $args{request}            if $args{request};

250
    my $vm;
251
    $vm = $self->search_vm($vm_name)   if $vm_name;
252
    $vm = $self->vm->[0]               if !$vm;
253

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

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

259
    return $vm->create_domain(@_);
260
261
}

Francesc Guasch's avatar
Francesc Guasch committed
262
263
264
265
266
267
268
269
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

270
271
sub remove_domain {
    my $self = shift;
272
273
    my %arg = @_;

274
    confess "Argument name required "
275
276
        if !$arg{name};

277
278
    confess "Argument uid required "
        if !$arg{uid};
279
280
281
282

    lock_hash(%arg);

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

285
286
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
287
288
}

Francesc Guasch's avatar
Francesc Guasch committed
289
290
291
292
293
294
=head2 search_domain

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

=cut

295
296
297
sub search_domain {
    my $self = shift;
    my $name = shift;
298
    my $import = shift;
299

300
301
302
303
304
305
306
307
308
309
310
311
    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 $@;

312
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
313
        my $domain = $vm->search_domain($name, $import);
314
        next if !$domain;
315
        next if !$domain->_select_domain_db && !$import;
316
317
318
        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
319
        warn $@ if $@   && $DEBUG;
320
        return $domain if $id || $import;
321
    }
322
323


324
    return;
325
}
326

Francesc Guasch's avatar
Francesc Guasch committed
327
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
328

Francesc Guasch's avatar
Francesc Guasch committed
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
  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
344

345
346
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
347
List all created domains
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363

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

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

388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
# 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;
# }

405

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

429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
=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
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
=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;
}

464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
=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
479

480
481
482
=pod

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

496
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
497
498
499
500
501
502
503
504
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

505
=cut
fv3rdugo's avatar
fv3rdugo committed
506

Francesc Guasch's avatar
Francesc Guasch committed
507
508
509
510
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
511

Francesc Guasch's avatar
Francesc Guasch committed
512
513
=cut

514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
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";
    }

}
534

Francesc Guasch's avatar
Francesc Guasch committed
535
536
537
538
539
540
541
542
=head2 process_requests

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

  $ravada->process_requests();

=cut

543
544
sub process_requests {
    my $self = shift;
545
    my $debug = shift;
546
    my $dont_fork = shift;
547

548
    $self->_wait_pids_nohang();
549
    $self->_check_vms();
550

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

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
562
        $req->status('working');
563
564
565
        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
566
            if ( $n_retry < 3) {
567
                warn $req->id." ".$req->command." to retry" if $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
568
                $req->status("retry ".++$n_retry)   
569
            }
570
        }
571
572
573
        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
574

575
576
577
578
    }
    $sth->finish;
}

579
580
sub _process_requests_dont_fork {
    my $self = shift;
581
    my $debug = shift;
582
    return $self->process_requests($debug, 1);
583
}
Francesc Guasch's avatar
Francesc Guasch committed
584

585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
=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;
}

602
603
604
sub _execute {
    my $self = shift;
    my $request = shift;
605
    my $dont_fork = shift;
606

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

609
610
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
611

612
613
614
615
616
617
618
619
    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
620

621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
    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
636
637
}

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

    $request->status('done');

654
655
}

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

}


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

680
    $request->status('creating domain');
681
    warn "$$ creating domain"   if $DEBUG;
682
    my $domain;
683
    $domain = $self->create_domain(%{$request->args},request => $request);
684

685
686
687
688
689
690
691
692
    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
693
694
695

}

696
697
698
699
700
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

703
    $self->_set_req_done($kid);
704
    delete $self->{pids}->{$kid};
705
706
707
708
709
710
711
712
713
714
715
716

}

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

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

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

Francesc Guasch's avatar
Francesc Guasch committed
725
    for my $pid ( keys %{$self->{pids}}) {
726
727
728
        $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
729
        my $kid = waitpid($pid,0);
730
#        warn "Found $kid";
731
732
733
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
734
735
736
737
738
739
740
        return if $kid  == $pid;
    }
}

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

743
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
744
745
}

746
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
747
748
749
750
    my $self = shift;
    my $request = shift;

    $request->status('working');
751
752
753
754
    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
755

756
}
Francesc Guasch's avatar
Francesc Guasch committed
757

758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
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
795
796
797
798
sub _cmd_start {
    my $self = shift;
    my $request = shift;

799
    $request->status("working $$");
Francesc Guasch's avatar
Francesc Guasch committed
800
    my $name = $request->args('name');
801

802
803
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
804
805
806
807
808

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

    $domain->start($user);
809

Francesc Guasch's avatar
Francesc Guasch committed
810
811
812
813
    $request->status('done');

}

Francesc Guasch's avatar
Francesc Guasch committed
814
815
816
817
818
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
Francesc Guasch's avatar
Francesc Guasch committed
819
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
820
821
822
823
    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
824
    my $domain = $self->search_domain_by_id($id_domain);
825

Francesc Guasch's avatar
Francesc Guasch committed
826
    die "Unknown domain id '$id_domain'\n" if !$domain;
827
828

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
829
830
831
832

}


Francesc Guasch's avatar
Francesc Guasch committed
833
834
835
836
837
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
838
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
839
    my $name = $request->args('name');
840
    my $timeout = ($request->args('timeout') or 60);
841

842
    my $domain;
843
844
845
    $domain = $self->search_domain($name);
    die "Unknown domain '$name'\n" if !$domain;

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

    $domain->shutdown(timeout => $timeout, name => $name, user => $user);
Francesc Guasch's avatar
Francesc Guasch committed
849
850
851

}

852
853
854
855
856
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
857
    $request->result(\@list_types);
858
859
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
860

861
862
863
864
865
866
867
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
869
870
871
872
873
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
875
          start => \&_cmd_start
876
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
877
878
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
879
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
880
      ,shutdown => \&_cmd_shutdown
881
    ,domdisplay => \&_cmd_domdisplay
882
    ,screenshot => \&_cmd_screenshot
883
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
884
  ,prepare_base => \&_cmd_prepare_base
885
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
886
887
888
889
    );
    return $methods{$cmd};
}

890
891
892
893
894
895
896
897
898
899
900
901
=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;

902
903
    confess "Missing VM type"   if !$type;

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

906
    if ($type =~ /Void/i) {
907
908
909
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
910
911
    my @vms;
    eval { @vms = @{$self->vm} };
912
913
914
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
915
    for my $vm (@vms) {
916
917
918
919
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
920

Francesc Guasch's avatar
Francesc Guasch committed
921
922
923
924
925
926
927
928
929
930
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

931
1;