Ravada.pm 19.5 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
=head2 display_ip
97

98
Returns the default display IP read from the config file
99

100
=cut
101

102
103
104
105
sub display_ip {
    my $ip = $CONFIG->{display_ip};
    
    return $ip if $ip;
106
107
}

108
109
sub _init_config {
    my $file = shift;
110
111

    my $connector = shift;
112
    confess "Deprecated connector" if $connector;
113

114
    $CONFIG = YAML::LoadFile($file);
115
#    $CONNECTOR = ( $connector or _connect_dbh());
116
117
}

118
sub _create_vm_kvm {
119
    my $self = shift;
120

121
122
123
124
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
127

128
129
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
130
    return (undef, $err_kvm)    if !$vm_kvm;
131
    return ($vm_kvm,$err_kvm);
132
133
134
135
136
137
138
139
140

    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
141
142
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
143
144
}

145
146
sub _refresh_vm_kvm {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
147
    sleep 1;
148
149
    my @vms;
    eval { @vms = $self->vm };
150
    warn $@ if $@;
151
152
153
154
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
155
156
157
158
159
160
161
162
163
164
    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;
    }
}

165
166
167
168
169
170
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

173
174
    my $err = $err_kvm;

175
176
177
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
178
179
180
181
182
183
    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;
    }
184
    if (!@vms) {
185
        confess "No VMs found: $err\n";
186
187
188
    }
    return \@vms;

189
190
}

191
sub _check_vms {
192
193
    my $self = shift;

194
195
    my @vm;
    eval { @vm = @{$self->vm} };
196
197
198
199
200
201
202
203
204
205
    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
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
=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


225
sub create_domain {
226
227
    my $self = shift;

228
229
    my %args = @_;

230
231
232
    croak "Argument id_owner required "
        if !$args{id_owner};

233
234
    my $vm_name = $args{vm};
    delete $args{vm};
235

Francesc Guasch's avatar
Francesc Guasch committed
236
237
    my $request = $args{request}            if $args{request};

238
    my $vm;
239
    $vm = $self->search_vm($vm_name)   if $vm_name;
240
    $vm = $self->vm->[0]               if !$vm;
241

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

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

247
    return $vm->create_domain(@_);
248
249
}

Francesc Guasch's avatar
Francesc Guasch committed
250
251
252
253
254
255
256
257
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

258
259
sub remove_domain {
    my $self = shift;
260
261
    my %arg = @_;

262
    confess "Argument name required "
263
264
        if !$arg{name};

265
266
    confess "Argument uid required "
        if !$arg{uid};
267
268
269
270

    lock_hash(%arg);

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

273
274
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
275
276
}

Francesc Guasch's avatar
Francesc Guasch committed
277
278
279
280
281
282
=head2 search_domain

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

=cut

283
284
285
sub search_domain {
    my $self = shift;
    my $name = shift;
286
    my $import = shift;
287

288
289
290
291
292
293
294
295
296
297
298
299
    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 $@;

300
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
301
        my $domain = $vm->search_domain($name, $import);
302
        next if !$domain;
303
        next if !$domain->_select_domain_db && !$import;
304
305
306
        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
307
        warn $@ if $@   && $DEBUG;
308
        return $domain if $id || $import;
309
    }
310
311


312
    return;
313
}
314

Francesc Guasch's avatar
Francesc Guasch committed
315
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
316

Francesc Guasch's avatar
Francesc Guasch committed
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
  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
332

333
334
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
335
List all created domains
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351

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

352
353
354
355
356
357
358
359
360
361
362
363
364
=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;
365
366
367
368
369
370
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
371
    }
372
    $sth->finish;
373
    return \@domains;
374
375
}

376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
# 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;
# }

393

Francesc Guasch's avatar
Francesc Guasch committed
394
395
396
397
398
399
400
401
402
403
404
405
406
407
=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) {
408
409
410
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
411
412
413
414
415
416
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
=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
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
=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;
}

452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
=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
467

468
469
470
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
471
472
473
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
474
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
475
476
477
478
479
480
481
482
483
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

484
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
485
486
487
488
489
490
491
492
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

493
=cut
fv3rdugo's avatar
fv3rdugo committed
494

Francesc Guasch's avatar
Francesc Guasch committed
495
496
497
498
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
499

Francesc Guasch's avatar
Francesc Guasch committed
500
501
=cut

502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
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";
    }

}
522

Francesc Guasch's avatar
Francesc Guasch committed
523
524
525
526
527
528
529
530
=head2 process_requests

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

  $ravada->process_requests();

=cut

531
532
sub process_requests {
    my $self = shift;
533
    my $debug = shift;
534
    my $dont_fork = shift;
535

536
    $self->_wait_pids_nohang();
537
    $self->_check_vms();
538

539
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
Francesc Guasch's avatar
Francesc Guasch committed
540
        ." WHERE status='requested' OR status like 'retry %'");
541
542
    $sth->execute;
    while (my ($id)= $sth->fetchrow) {
543
        $self->_wait_pids_nohang();
Francesc Guasch's avatar
Francesc Guasch committed
544
        my $req = Ravada::Request->open($id);
545
546
        warn "executing request ".$req->id." ".$req->status()." ".$req->command
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
547
548
549

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
550
        $req->status('working');
551
552
553
        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
554
            if ( $n_retry < 3) {
555
                warn $req->id." ".$req->command." to retry" if $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
556
                $req->status("retry ".++$n_retry)   
557
            }
558
        }
559
560
561
        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
562

563
564
565
566
    }
    $sth->finish;
}

567
568
sub _process_requests_dont_fork {
    my $self = shift;
569
    my $debug = shift;
570
    return $self->process_requests($debug, 1);
571
}
Francesc Guasch's avatar
Francesc Guasch committed
572

573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
=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;
}

590
591
592
sub _execute {
    my $self = shift;
    my $request = shift;
593
    my $dont_fork = shift;
594

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

597
598
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
599

600
601
602
603
604
605
606
607
    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
608

609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
    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
624
625
}

626
627
628
629
630
631
632
633
634
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});
635
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
636
    $request->error('');
637
    my $display = $domain->display($user);
638
639
640
641
    $request->result({display => $display});

    $request->status('done');

642
643
}

644
645
646
647
648
649
650
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('');
651
    my $bytes = 0;
652
    if (!$domain->can_screenshot) {
653
        die "I can't take a screenshot of the domain ".$domain->name;
654
    } else {
655
656
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
657
    }
658
    $request->error("No data received") if !$bytes;
659
660
661
662
663
    $request->status('done');

}


664
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
665
666
667
    my $self = shift;
    my $request = shift;

668
    $request->status('creating domain');
669
    warn "$$ creating domain"   if $DEBUG;
670
    my $domain;
671

672
    $domain = $self->create_domain(%{$request->args},request => $request);
673

674
675
676
677
678
679
680
681
    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
682
683
684

}

685
686
687
688
689
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

692
    $self->_set_req_done($kid);
693
    delete $self->{pids}->{$kid};
694
695
696
697
698
699
700
701
702
703
704
705

}

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

Francesc Guasch's avatar
Francesc Guasch committed
708
709
710
711
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
714
    for my $pid ( keys %{$self->{pids}}) {
715
716
717
        $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
718
        my $kid = waitpid($pid,0);
719
#        warn "Found $kid";
720
721
722
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
723
724
725
726
727
728
729
        return if $kid  == $pid;
    }
}

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

732
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
733
734
}

735
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
736
737
738
739
    my $self = shift;
    my $request = shift;

    $request->status('working');
740
741
742
743
    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
744

745
}
Francesc Guasch's avatar
Francesc Guasch committed
746

747
748
749
750
751
752
753
754
755
756
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
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
784
785
786
787
sub _cmd_start {
    my $self = shift;
    my $request = shift;

788
    $request->status("working $$");
Francesc Guasch's avatar
Francesc Guasch committed
789
    my $name = $request->args('name');
790

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

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

    $domain->start($user);
798

Francesc Guasch's avatar
Francesc Guasch committed
799
800
801
802
    $request->status('done');

}

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

    $request->status('working');
Francesc Guasch's avatar
Francesc Guasch committed
808
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
809
810
811
812
    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
813
    my $domain = $self->search_domain_by_id($id_domain);
814

Francesc Guasch's avatar
Francesc Guasch committed
815
    die "Unknown domain id '$id_domain'\n" if !$domain;
816
817

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
818
819
820

}

821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
sub _cmd_remove_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $id_domain = $request->id_domain or confess "Missing request id_domain";
    my $uid = $request->args('uid')     or confess "Missing argument uid";

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

    my $domain = $self->search_domain_by_id($id_domain);

    die "Unknown domain id '$id_domain'\n" if !$domain;

    $domain->remove_base($user);

}


Francesc Guasch's avatar
Francesc Guasch committed
840

Francesc Guasch's avatar
Francesc Guasch committed
841
842
843
844
845
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
846
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
847
    my $name = $request->args('name');
848
    my $timeout = ($request->args('timeout') or 60);
849

850
    my $domain;
851
852
853
    $domain = $self->search_domain($name);
    die "Unknown domain '$name'\n" if !$domain;

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

    $domain->shutdown(timeout => $timeout, name => $name, user => $user);
Francesc Guasch's avatar
Francesc Guasch committed
857
858
859

}

860
861
862
863
864
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
865
    $request->result(\@list_types);
866
867
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
868

869
870
871
872
873
874
875
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
877
878
879
880
881
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
883
          start => \&_cmd_start
884
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
885
886
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
887
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
888
      ,shutdown => \&_cmd_shutdown
889
    ,domdisplay => \&_cmd_domdisplay
890
    ,screenshot => \&_cmd_screenshot
891
   ,remove_base => \&_cmd_remove_base
892
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
893
  ,prepare_base => \&_cmd_prepare_base
894
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
895
896
897
898
    );
    return $methods{$cmd};
}

899
900
901
902
903
904
905
906
907
908
909
910
=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;

911
912
    confess "Missing VM type"   if !$type;

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

915
    if ($type =~ /Void/i) {
916
917
918
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
919
920
    my @vms;
    eval { @vms = @{$self->vm} };
921
922
923
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
924
    for my $vm (@vms) {
925
926
927
928
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
929

Francesc Guasch's avatar
Francesc Guasch committed
930
931
932
933
934
935
936
937
938
939
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

940
1;