Ravada.pm 14.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
9
use DBIx::Connector;
use Moose;
Francesc Guasch's avatar
Francesc Guasch committed
10
use POSIX qw(WNOHANG);
11
12
use YAML;

Francesc Guasch's avatar
Francesc Guasch committed
13
use Ravada::Auth;
14
use Ravada::Request;
15
use Ravada::VM::KVM;
16
use Ravada::VM::LXC;
17

Francesc Guasch's avatar
Francesc Guasch committed
18
19
20
21
22
23
24
25
26
27
28
29
=head1 NAME

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

30
31
32
33
34
35
36

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

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

our $CONNECTOR;
our $CONFIG = {};
37
38
our $DEBUG;

39
40
41
42
43
44
45
46
47
48


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

has 'connector' => (
49
50
51
52
53
54
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
55
56
);

Francesc Guasch's avatar
Francesc Guasch committed
57
58
59
60
61
62
63
=head2 BUILD

Internal constructor

=cut


64
65
sub BUILD {
    my $self = shift;
66
    if ($self->config()) {
67
        _init_config($self->config);
68
    } else {
Francesc Guasch's avatar
Francesc Guasch committed
69
        _init_config($FILE_CONFIG) if -e $FILE_CONFIG;
70
    }
71

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

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

}

sub _init_config {
    my $file = shift;
94
95

    my $connector = shift;
96
    confess "Deprecated connector" if $connector;
97

98
    $CONFIG = YAML::LoadFile($file);
99
#    $CONNECTOR = ( $connector or _connect_dbh());
100
101
}

102
sub _create_vm_kvm {
103
    my $self = shift;
104

105
106
107
108
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
111

112
113
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
114
    return (undef, $err_kvm)    if !$vm_kvm;
115
116
117
118
119
120
121
122
123

    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
124
125
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
126
127
128
129
130
131
132
133
134
}

sub _create_vm {
    my $self = shift;

    my @vms = ();

    my ($vm_kvm, $err_kvm) = $self->_create_vm_kvm();

135
136
137
138
139
140
141
142
    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
143
        confess "No VMs found: $err_lxc\n$err_kvm\n";
144
145
146
    }
    return \@vms;

147
148
}

Francesc Guasch's avatar
Francesc Guasch committed
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
=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


168
sub create_domain {
169
170
    my $self = shift;

171
172
    my %args = @_;

173
174
175
    croak "Argument id_owner required "
        if !$args{id_owner};

176
177
    my $vm_name = $args{vm};
    delete $args{vm};
178

Francesc Guasch's avatar
Francesc Guasch committed
179
180
181
182
    my $request = $args{request}            if $args{request};

    $request->status("Searching for VM")    if $request;
    sleep 5;
Francesc Guasch's avatar
Francesc Guasch committed
183

184
    my $vm = $self->vm->[0];
185
    $vm = $self->search_vm($vm_name)   if $vm_name;
186

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

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

192
    $request->status("creating domain in ".ref($vm))    if $request;
193
    return $vm->create_domain(@_);
194
195
}

Francesc Guasch's avatar
Francesc Guasch committed
196
197
198
199
200
201
202
203
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

204
205
sub remove_domain {
    my $self = shift;
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
    my %arg = @_;

    croak "Argument name required "
        if !$arg{name};

    croak "Argument id_user required "
        if !$arg{id_user};

    lock_hash(%arg);

    my $domain = $self->search_domain($arg{name}, 1)
        or confess "ERROR: I can't find domain $arg{name}";

#    TODO allow if user is admin
#    my $user = ...
    confess "ERROR: Access denied. User ".$arg{id_user}." is not owner of domain $arg{name}"
        if $domain->id_owner != $arg{id_user};
#            || $user->is_admin();
224
225
226
227

    $domain->remove();
}

Francesc Guasch's avatar
Francesc Guasch committed
228
229
230
231
232
233
=head2 search_domain

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

=cut

234
235
236
sub search_domain {
    my $self = shift;
    my $name = shift;
237
    my $import = shift;
238
239

    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
240
        my $domain = $vm->search_domain($name, $import);
241
        next if !$domain;
242
        next if !$domain->_select_domain_db && !$import;
243
244
245
        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
246
        warn $@ if $@   && $DEBUG;
247
        return $domain if $id || $import;
248
    }
249
250
251
252
253
254
255
256

    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;

257
    return;
258
}
259

Francesc Guasch's avatar
Francesc Guasch committed
260
261


262
263
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
264
List all created domains
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280

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

281
282
283
284
285
286
287
288
289
290
291
292
293
=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;
294
295
296
297
298
299
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
300
    }
301
    $sth->finish;
302
    return \@domains;
303
304
}

305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
# 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;
# }

322

Francesc Guasch's avatar
Francesc Guasch committed
323
324
325
326
327
328
329
330
331
332
333
334
335
336
=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) {
337
338
339
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
340
341
342
343
344
345
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
=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
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
=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;
}

381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
=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
396

fv3rdugo's avatar
fv3rdugo committed
397
398
399
400
sub list_images_lxc {
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
401
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

=head2 list_images_data

List information about the images

=cut

sub list_images_data_lxc {
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}



Francesc Guasch's avatar
Francesc Guasch committed
428
429
430
431
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
432

Francesc Guasch's avatar
Francesc Guasch committed
433
434
=cut

435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
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";
    }

}
455

Francesc Guasch's avatar
Francesc Guasch committed
456
457
458
459
460
461
462
463
=head2 process_requests

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

  $ravada->process_requests();

=cut

464
465
sub process_requests {
    my $self = shift;
466
    my $debug = shift;
467
    my $dont_fork = shift;
468

469
470
    $self->_wait_pids_nohang();

471
472
473
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests WHERE status='requested'");
    $sth->execute;
    while (my ($id)= $sth->fetchrow) {
Francesc Guasch's avatar
Francesc Guasch committed
474
        my $req = Ravada::Request->open($id);
475
        warn "executing request ".$req." ".Dumper($req) if $DEBUG || $debug;
476
        eval { $self->_execute($req, $dont_fork) };
477
478
        if ($@) {
            $req->error($@);
479
            $req->status('done');
480
        }
481
482
483
        warn "req ".$req->id." , command: ".$req->command." , status: ".$req->status()
            ." , error: '".($req->error or 'NONE')."'" 
                if $DEBUG || $debug;
484
485
486
487
    }
    $sth->finish;
}

488
489
sub _process_requests_dont_fork {
    my $self = shift;
490
491
    my $debug = shift;
    return $self->process_requests($debug,1);
492
}
Francesc Guasch's avatar
Francesc Guasch committed
493

494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
=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;
}

511
512
513
sub _execute {
    my $self = shift;
    my $request = shift;
514
    my $dont_fork = shift;
515

Francesc Guasch's avatar
Francesc Guasch committed
516
517
518
519
520
    my $sub = $self->_req_method($request->command);

    die "Unknown command ".$request->command
        if !$sub;

521
    return $sub->($self,$request, $dont_fork);
Francesc Guasch's avatar
Francesc Guasch committed
522
523
524

}

525
526
527
528
529
530
531
532
533
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});
534
535
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
    my $display = $domain->display($user);
536
537
538
539
    $request->result({display => $display});

    $request->status('done');

540
541
}

542
sub _do_cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
543
544
545
    my $self = shift;
    my $request = shift;

546
    $request->status('creating domain');
547
    warn "$$ creating domain"   if $DEBUG;
548
    my $domain;
549
    $domain = $self->create_domain(%{$request->args},request => $request);
Francesc Guasch's avatar
Francesc Guasch committed
550
    warn $@ if $@;
551

Francesc Guasch's avatar
Francesc Guasch committed
552
553
554
555
556
    $request->status('done');
    $request->error($@);

}

557
558
559
560
561
562
563
564
565
566
567
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

    my $kid = waitpid(-1 , WNOHANG);
    return if !$kid;

    warn "Kid $kid finished";
    delete $self->{pids}->{$kid};
}

Francesc Guasch's avatar
Francesc Guasch committed
568
569
570
571
572
sub _wait_pids {
    my $self = shift;
    my $request = shift;

    for my $pid ( keys %{$self->{pids}}) {
573
574
575
        $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
576
577
        my $kid = waitpid($pid,0);

578
#        warn "Found $kid";
Francesc Guasch's avatar
Francesc Guasch committed
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
        return if $kid  == $pid;
    }
}

sub _add_pid {
    my $self = shift;
    my $pid = shift;

    $self->{pids}->{$pid} = time;
}

sub _cmd_create {

    my $self = shift;
    my $request = shift;
594
595
596
597
    my $dont_fork = shift;

    return $self->_do_cmd_create($request)
        if $dont_fork;
Francesc Guasch's avatar
Francesc Guasch committed
598
599
600
601
602
603
604
605
606
607
608
609
610

    $request->status('waiting for other tasks');

    $self->_wait_pids($request);

    $request->status('forking');
    my $pid = fork();
    if (!defined $pid) {
        $request->status('done');
        $request->error("I can't fork");
        return;
    }
    if ($pid == 0 ) {
611
        $self->_do_cmd_create($request);
Francesc Guasch's avatar
Francesc Guasch committed
612
613
614
615
616
617
        exit;
    }
    $self->_add_pid($pid);
    return;
}

Francesc Guasch's avatar
Francesc Guasch committed
618
619
620
621
622
623
624
625
sub _cmd_remove {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    eval { $self->remove_domain($request->args('name')) };
    $request->status('done');
    $request->error($@);
Francesc Guasch's avatar
Francesc Guasch committed
626

627
}
Francesc Guasch's avatar
Francesc Guasch committed
628

Francesc Guasch's avatar
Francesc Guasch committed
629
630
631
632
633
634
sub _cmd_start {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $name = $request->args('name');
635
636
637
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
    $domain->start();
638

Francesc Guasch's avatar
Francesc Guasch committed
639
    $request->status('done');
640
    $request->error($@ or '');
Francesc Guasch's avatar
Francesc Guasch committed
641
642
643

}

Francesc Guasch's avatar
Francesc Guasch committed
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $name = $request->args('name');
    eval { 
        my $domain = $self->search_domain($name);
        die "Unknown domain '$name'\n" if !$domain;
        $domain->prepare_base();
    };
    $request->status('done');
    $request->error($@);

}


Francesc Guasch's avatar
Francesc Guasch committed
661
662
663
664
665
666
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $name = $request->args('name');
667
668
    my $timeout = ($request->args('timeout') or 60);
    my $domain;
Francesc Guasch's avatar
Francesc Guasch committed
669
    eval { 
670
        $domain = $self->search_domain($name);
Francesc Guasch's avatar
Francesc Guasch committed
671
        die "Unknown domain '$name'\n" if !$domain;
672
        $domain->shutdown(timeout => $timeout);
Francesc Guasch's avatar
Francesc Guasch committed
673
674
675
676
677
678
    };
    $request->status('done');
    $request->error($@);

}

679
680
681
682
683
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
684
    $request->result(\@list_types);
685
686
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
687

688
689
690
691
692
693
694
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
696
697
698
699
700
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
702
703
704
          start => \&_cmd_start
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
Francesc Guasch's avatar
Francesc Guasch committed
705
      ,shutdown => \&_cmd_shutdown
706
    ,domdisplay => \&_cmd_domdisplay
707
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
708
  ,prepare_base => \&_cmd_prepare_base
709
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
710
711
712
713
    );
    return $methods{$cmd};
}

714
715
716
717
718
719
720
721
722
723
724
725
=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;

726
727
    confess "Missing VM type"   if !$type;

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

730
    if ($type =~ /Void/i) {
731
732
733
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
734
735
736
    my @vms;
    eval { @vms = @{$self->vm} };
    for my $vm (@vms) {
737
738
739
740
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
741

Francesc Guasch's avatar
Francesc Guasch committed
742
743
744
745
746
747
748
749
750
751
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

752
1;