Ravada.pm 19.8 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
    if ($dont_fork || !$CAN_FORK ) {
        
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
605
        $request->status('done') if $request->status() ne 'done';
606
607
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
608

609
610
611
612
613
614
615
616
617
    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);
618
        $request->status('done') if $request->status() ne 'done';
619
620
621
622
623
        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
    my $msg = '';
675

676
    if ($domain) {
677
       $msg = 'Domain '
678
679
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
680
            ." created."
681
682
683
684
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
685
686
687

}

688
689
690
691
692
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

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

}

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

Francesc Guasch's avatar
Francesc Guasch committed
711
712
713
714
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

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

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

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

735
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
736
737
}

738
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
739
740
741
742
    my $self = shift;
    my $request = shift;

    $request->status('working');
743
744
745
746
    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
747

748
}
Francesc Guasch's avatar
Francesc Guasch committed
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
784
785
786
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
787
788
789
790
sub _cmd_start {
    my $self = shift;
    my $request = shift;

791
    $request->status("working $$");
Francesc Guasch's avatar
Francesc Guasch committed
792
    my $name = $request->args('name');
793

794
795
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
796
797
798
799
800

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

    $domain->start($user);
801
802
803
    my $msg = 'Domain '
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
804
            ." started"
805
806
        ;
    $request->status('done', $msg);
Francesc Guasch's avatar
Francesc Guasch committed
807
808
809

}

Francesc Guasch's avatar
Francesc Guasch committed
810
811
812
813
814
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
822
    die "Unknown domain id '$id_domain'\n" if !$domain;
823
824

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
825
826
827

}

828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
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
847

Francesc Guasch's avatar
Francesc Guasch committed
848
849
850
851
852
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
853
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
854
    my $name = $request->args('name');
855
    my $timeout = ($request->args('timeout') or 60);
856

857
    my $domain;
858
859
860
    $domain = $self->search_domain($name);
    die "Unknown domain '$name'\n" if !$domain;

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

    $domain->shutdown(timeout => $timeout, name => $name, user => $user);
Francesc Guasch's avatar
Francesc Guasch committed
864
865
866

}

867
868
869
870
871
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
872
    $request->result(\@list_types);
873
874
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
875

876
877
878
879
880
881
882
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
884
885
886
887
888
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
890
          start => \&_cmd_start
891
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
892
893
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
894
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
895
      ,shutdown => \&_cmd_shutdown
896
    ,domdisplay => \&_cmd_domdisplay
897
    ,screenshot => \&_cmd_screenshot
898
   ,remove_base => \&_cmd_remove_base
899
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
900
  ,prepare_base => \&_cmd_prepare_base
901
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
902
903
904
905
    );
    return $methods{$cmd};
}

906
907
908
909
910
911
912
913
914
915
916
917
918
=head2 open_vm

Opens a VM of a given type


  my $vm = $ravada->open_vm('KVM');

=cut

sub open_vm {
    return search_vm(@_);
}

919
920
921
922
923
924
925
926
927
928
929
930
=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;

931
932
    confess "Missing VM type"   if !$type;

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

935
    if ($type =~ /Void/i) {
936
937
938
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
939
940
    my @vms;
    eval { @vms = @{$self->vm} };
941
942
943
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
944
    for my $vm (@vms) {
945
946
947
948
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
949

Francesc Guasch's avatar
Francesc Guasch committed
950
951
952
953
954
955
956
957
958
959
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

960
1;