Front.pm 26.4 KB
Newer Older
1
2
3
4
5
package Ravada::Front;

use strict;
use warnings;

6
7
8
9
10
11
=head1 NAME

Ravada::Front - Web Frontend library for Ravada

=cut

12
use Carp qw(carp);
Francesc Guasch's avatar
Francesc Guasch committed
13
use DateTime;
14
use Hash::Util qw(lock_hash);
Francesc Guasch's avatar
Francesc Guasch committed
15
use IPC::Run3 qw(run3);
16
17
18
use JSON::XS;
use Moose;
use Ravada;
19
use Ravada::Auth::LDAP;
20
use Ravada::Front::Domain;
21
use Ravada::Front::Domain::KVM;
22
23
use Ravada::Network;

Francesc Guasch's avatar
Francesc Guasch committed
24
25
26
use feature qw(signatures);
no warnings "experimental::signatures";

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
use Data::Dumper;

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
);
has 'connector' => (
        is => 'rw'
);
has 'backend' => (
    is => 'ro',
    isa => 'Ravada'

);

has 'fork' => (
    is => 'rw'
    ,isa => 'Int'
    ,default => 1
);

our $CONNECTOR;# = \$Ravada::CONNECTOR;
our $TIMEOUT = 20;
our @VM_TYPES = ('KVM');
our $DIR_SCREENSHOTS = "/var/www/img/screenshots";

our %VM;
54
our %VM_ID;
55
our $PID_FILE_BACKEND = '/var/run/rvd_back.pid';
56

Francesc Guasch's avatar
Francesc Guasch committed
57
our $LOCAL_TZ = DateTime::TimeZone->new(name => 'local');
Francesc Guasch's avatar
Francesc Guasch committed
58
59
60
61
62
63
64
###########################################################################
#
# method modifiers
#

around 'list_machines' => \&_around_list_machines;

65
66
67
68
69
70
71
72
73
74
75
=head2 BUILD

Internal constructor

=cut

sub BUILD {
    my $self = shift;
    if ($self->connector) {
        $CONNECTOR = $self->connector;
    } else {
76
        Ravada::_init_config($self->config()) if $self->config;
77
78
        $CONNECTOR = Ravada::_connect_dbh();
    }
79
80
    Ravada::_init_config($self->config()) if $self->config;
    Ravada::Auth::init($Ravada::CONFIG);
81
82
83
84
85
86
87
88
89
90
91
    $CONNECTOR->dbh();
}

=head2 list_bases

Returns a list of the base domains as a listref

    my $bases = $rvd_front->list_bases();

=cut

92
93
sub list_bases($self, %args) {
    $args{is_base} = 1;
Francesc Guasch's avatar
Francesc Guasch committed
94
    my $query = "SELECT name, id, is_base, id_owner FROM domains "
95
96
97
98
99
100
        ._where(%args)
        ." ORDER BY name";

    my $sth = $CONNECTOR->dbh->prepare($query);
    $sth->execute(map { $args{$_} } sort keys %args);

101
102
103
104
105
106
    my @bases = ();
    while ( my $row = $sth->fetchrow_hashref) {
        my $domain;
        eval { $domain   = $self->search_domain($row->{name}) };
        next if !$domain;
        $row->{has_clones} = $domain->has_clones;
Francesc Guasch's avatar
Francesc Guasch committed
107
        $row->{is_locked} = 0 if !exists $row->{is_locked};
108
        delete $row->{spice_password};
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
        push @bases, ($row);
    }
    $sth->finish;

    return \@bases;
}

=head2 list_machines_user

Returns a list of machines available to the user

If the user has ever clone the base, it shows this information. It show the
base data if not.

Arguments: user

Returns: listref of machines

=cut

sub list_machines_user {
    my $self = shift;
    my $user = shift;

    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT id,name,is_public, file_screenshot"
        ." FROM domains "
        ." WHERE is_base=1"
        ." ORDER BY name "
    );
    my ($id, $name, $is_public, $screenshot);
    $sth->execute;
141
    $sth->bind_columns(\($id, $name, $is_public, $screenshot ));
142
143
144

    my @list;
    while ( $sth->fetch ) {
Francesc Guasch's avatar
Francesc Guasch committed
145
        next if !$is_public && !$user->is_admin;
146
        next if !$user->allowed_access($id);
147
148
149
150
151
152
        my $is_active = 0;
        my $clone = $self->search_clone(
            id_owner =>$user->id
            ,id_base => $id
        );
        my %base = ( id => $id, name => $name
153
            , is_public => ($is_public or 0)
154
155
156
157
158
            , screenshot => ($screenshot or '')
            , is_active => 0
            , id_clone => undef
            , name_clone => undef
            , is_locked => undef
159
            , can_hibernate => 0
160
161
162
163
        );

        if ($clone) {
            $base{is_locked} = $clone->is_locked;
Francesc Guasch's avatar
Francesc Guasch committed
164
            if ($clone->is_active && !$clone->is_locked && $user->can_screenshot) {
165
166
167
168
169
170
171
172
173
                my $req = Ravada::Request->screenshot_domain(
                id_domain => $clone->id
                ,filename => "$DIR_SCREENSHOTS/".$clone->id.".png"
                );
            }
            $base{name_clone} = $clone->name;
            $base{screenshot} = ( $clone->_data('file_screenshot') 
                                or $base{screenshot});
            $base{is_active} = $clone->is_active;
Francesc Guasch's avatar
Francesc Guasch committed
174
175
176
            $base{id_clone} = $clone->id;
            $base{can_remove} = 0;
            $base{can_remove} = 1 if $user->can_remove && $clone->id_owner == $user->id;
177
            $base{can_hibernate} = 1 if $clone->is_active && !$clone->is_volatile;
178
179
180
181
182
183
184
185
186
        }
        $base{screenshot} =~ s{^/var/www}{};
        lock_hash(%base);
        push @list,(\%base);
    }
    $sth->finish;
    return \@list;
}

187

serk's avatar
serk committed
188
sub list_machines($self, $user) {
serk's avatar
serk committed
189
190
    return $self->list_domains() if $user->can_list_machines();

Francesc Guasch's avatar
Francesc Guasch committed
191
    my @list = ();
serk's avatar
serk committed
192
    push @list,(@{filter_base_without_clones($self->list_domains())}) if $user->can_list_clones();
serk's avatar
serk committed
193
194
195
    push @list,(@{$self->list_own_clones($user)}) if $user->can_list_clones_from_own_base();
    push @list,(@{$self->list_own($user)}) if $user->can_list_own_machines();
    
Francesc Guasch's avatar
Francesc Guasch committed
196
197
198
199
    return [@list] if scalar @list < 2;

    my %uniq = map { $_->{name} => $_ } @list;
    return [sort { $a->{name} cmp $b->{name} } values %uniq];
200
201
}

Francesc Guasch's avatar
Francesc Guasch committed
202
203
204
sub _around_list_machines($orig, $self, $user) {
    my $machines = $self->$orig($user);
    for my $m (@$machines) {
Francesc Guasch's avatar
Francesc Guasch committed
205
        $m->{can_shutdown} = $user->can_shutdown($m->{id});
Francesc Guasch's avatar
Francesc Guasch committed
206
207
208
209
210
211

        $m->{can_start} = 0;
        $m->{can_start} = 1 if $m->{id_owner} == $user->id || $user->is_admin;

        $m->{can_view} = 0;
        $m->{can_view} = 1 if $m->{id_owner} == $user->id || $user->is_admin;
Francesc Guasch's avatar
Francesc Guasch committed
212
213
214

        $m->{can_manage} = ( $user->can_manage_machine($m->{id}) or 0);
        $m->{can_change_settings} = ( $user->can_change_settings($m->{id}) or 0);
215
216
217

        $m->{can_hibernate} = 0;
        $m->{can_hibernate} = 1 if $user->can_shutdown($m->{id})
218
219
220
        && !$m->{is_volatile};

        $m->{id_base} = undef if !exists $m->{id_base};
221
        lock_hash(%$m);
Francesc Guasch's avatar
Francesc Guasch committed
222
223
224
225
    }
    return $machines;
}

226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
=pod

sub search_clone_data {
    my $self = shift;
    my %args = @_;
    my $query = "SELECT * FROM domains WHERE "
        .(join(" AND ", map { "$_ = ? " } sort keys %args));

    my $sth = $CONNECTOR->dbh->prepare($query);
    $sth->execute( map { $args{$_} } sort keys %args );
    my $row = $sth->fetchrow_hashref;
    return ( $row or {});
        
}

=cut

=head2 list_domains

Returns a list of the domains as a listref

    my $bases = $rvd_front->list_domains();

=cut

251
sub list_domains($self, %args) {
252

253
    my $query = "SELECT d.name, d.id, id_base, is_base, id_vm, status, is_public "
Francesc Guasch's avatar
Francesc Guasch committed
254
        ."      ,vms.name as node , is_volatile, client_status, id_owner "
255
256
        ." FROM domains d LEFT JOIN vms "
        ."  ON d.id_vm = vms.id ";
257
258
259
260

    my $where = '';
    for my $field ( sort keys %args ) {
        $where .= " AND " if $where;
261
        $where .= " d.$field=?"
262
263
264
    }
    $where = "WHERE $where" if $where;

265
    my $sth = $CONNECTOR->dbh->prepare("$query $where ORDER BY d.id");
266
267
268
269
    $sth->execute(map { $args{$_} } sort keys %args);
    
    my @domains = ();
    while ( my $row = $sth->fetchrow_hashref) {
Francesc Guasch's avatar
Francesc Guasch committed
270
        for (qw(is_locked is_hibernated is_paused
271
272
273
                has_clones )) {
            $row->{$_} = 0;
        }
274
        my $domain ;
275
        my $t0 = time;
276
        eval { $domain   = $self->search_domain($row->{name}) };
277
        warn $@ if $@;
Francesc Guasch's avatar
Francesc Guasch committed
278
        $row->{remote_ip} = undef;
279
280
281
282
        if ( $row->{is_volatile} && !$domain ) {
            $self->_remove_domain_db($row->{id});
            next;
        }
283
284
        $row->{has_clones} = 0 if !exists $row->{has_clones};
        $row->{is_locked} = 0 if !exists $row->{is_locked};
Francesc Guasch's avatar
Francesc Guasch committed
285
286
        $row->{is_active} = 0;
        $row->{remote_ip} = undef;
287
288
        if ( $domain ) {
            $row->{is_locked} = $domain->is_locked;
Francesc Guasch's avatar
Francesc Guasch committed
289
            $row->{is_hibernated} = ( $domain->is_hibernated or 0);
290
            $row->{is_paused} = 1 if $domain->is_paused;
291
            $row->{is_active} = 1 if $row->{status} eq 'active';
292
            $row->{has_clones} = $domain->has_clones;
293
294
295
#            $row->{disk_size} = ( $domain->disk_size or 0);
#            $row->{disk_size} /= (1024*1024*1024);
#            $row->{disk_size} = 1 if $row->{disk_size} < 1;
296
            $row->{remote_ip} = $domain->remote_ip if $row->{is_active};
297
            $row->{node} = $domain->_vm->name if $domain->_vm;
298
299
            $row->{remote_ip} = $domain->client_status
                if $domain->client_status && $domain->client_status ne 'connected';
300
            $row->{autostart} = $domain->autostart;
Francesc Guasch's avatar
Francesc Guasch committed
301
302
303
304
305
306
307
308
309
            if (!$row->{status} ) {
                if ($row->{is_active}) {
                    $row->{status} = 'active';
                } elsif ($row->{is_hibernated}) {
                    $row->{status} = 'hibernated';
                } else {
                    $row->{status} = 'down';
                }
            }
310
        }
311
        delete $row->{spice_password};
312
313
314
315
316
317
        push @domains, ($row);
    }
    $sth->finish;

    return \@domains;
}
serk's avatar
serk committed
318

serk's avatar
serk committed
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
=head2 filter_base_without_clones

filters the list of domains and drops all machines that are unacessible and 
bases with 0 machines accessible

=cut

sub filter_base_without_clones($domains) {
    my @list;
    my $size_domains = scalar(@$domains);
    for (my $i = 0; $i < $size_domains; ++$i) {
        if (@$domains[$i]->{is_base}) {
            for (my $j = 0; $j < $size_domains; ++$j) {
                if ($j != $i && !(@$domains[$j]->{is_base}) && (@$domains[$j]->{id_base} eq @$domains[$i]->{id})) {
                    push @list, (@$domains[$i]);
                    last;
                }
            }
        }
        else {
            push @list, (@$domains[$i]);
        }
    }
    return \@list;
}

serk's avatar
serk committed
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
sub list_own_clones($self, $user) {
    my $machines = $self->list_bases( id_owner => $user->id );
    for my $base (@$machines) {
        confess "ERROR: BAse without id ".Dumper($base) if !$base->{id};
        push @$machines,@{$self->list_domains( id_base => $base->{id} )};
    }
    return $machines;
}

sub list_own($self, $user) {
    my $machines = $self->list_domains(id_owner => $user->id);
    for my $clone (@$machines) {
        next if !$clone->{id_base};
        push @$machines,@{$self->list_domains( id => $clone->{id_base} )};
    }
    return $machines;
}


364
365
366
367
368
369
370
371
372
sub _where(%args) {
    my $where = '';
    for my $field ( sort keys %args ) {
        $where .= " AND " if $where;
        $where .= " $field=?"
    }
    $where = "WHERE $where" if $where;
    return $where;
}
373

374
375
376
377
378
379
380
381
382
383
=head2 list_clones
  Returns a list of the domains that are clones as a listref

      my $clones = $rvd_front->list_clones();
=cut

sub list_clones {
  my $self = shift;
  my %args = @_;
  
384
  my $domains = $self->list_domains();
385
386
387
388
389
390
  my @clones;
  for (@$domains ) {
    if($_->{id_base}) { push @clones, ($_); }
  }
  return \@clones;
}
391
392
393
394
395
396
sub _remove_domain_db($self, $id) {
    my $sth = $CONNECTOR->dbh->prepare("DELETE FROM domains WHERE id=?");
    $sth->execute($id);
    $sth->finish;
}

397
398
399
400
401
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
428
=head2 domain_info

Returns information of a domain

    my $info = $rvd_front->domain_info( id => $id);
    my $info = $rvd_front->domain_info( name => $name);

=cut

sub domain_info {
    my $self = shift;

    my $domains = $self->list_domains(@_);
    return $domains->[0];
}

=head2 domain_exists

Returns true if the domain name exists

    if ($rvd->domain_exists('domain_name')) {
        ...
    }

=cut

sub domain_exists {
    my $self = shift;
    my $name = shift;

    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT id FROM domains "
429
430
431
432
        ." WHERE name=? "
        ."    AND ( is_volatile = 0 "
        ."          OR is_volatile=1 AND status = 'active' "
        ."         ) "
433
434
435
436
437
438
439
440
    );
    $sth->execute($name);
    my ($id) = $sth->fetchrow;
    $sth->finish;
    return 0 if !defined $id;
    return 1;
}

441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465

=head2 node_exists

Returns true if the node name exists

    if ($rvd->node('node_name')) {
        ...
    }

=cut

sub node_exists {
    my $self = shift;
    my $name = shift;

    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT id FROM vms"
        ." WHERE name=? "
    );
    $sth->execute($name);
    my ($id) = $sth->fetchrow;
    $sth->finish;
    return 0 if !defined $id;
    return 1;
}
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
=head2 list_vm_types

Returns a reference to a list of Virtual Machine Managers known by the system

=cut

sub list_vm_types {
    my $self = shift;

    return $self->{cache}->{vm_types} if $self->{cache}->{vm_types};

    my $result = [@VM_TYPES];

    $self->{cache}->{vm_types} = $result if $result->[0];

    return $result;
}

Francesc Guasch's avatar
Francesc Guasch committed
484
485
486
487
488
489
=head2 list_vms

Returns a list of Virtual Managers

=cut

490
sub list_vms($self, $type=undef) {
Francesc Guasch's avatar
Francesc Guasch committed
491

492
    my $sql = "SELECT id,name,hostname,is_active, vm_type, enabled FROM vms ";
Francesc Guasch's avatar
Francesc Guasch committed
493

494
495
496
497
498
499
    my @args = ();
    if ($type) {
        $sql .= "WHERE (vm_type=? or vm_type=?)";
        my $type2 = $type;
        $type2 = 'qemu' if $type eq 'KVM';
        @args = ( $type, $type2);
Francesc Guasch's avatar
Francesc Guasch committed
500
    }
501
    my $sth = $CONNECTOR->dbh->prepare($sql." ORDER BY vm_type,name");
502
    $sth->execute(@args);
Francesc Guasch's avatar
Francesc Guasch committed
503

Francesc Guasch's avatar
Francesc Guasch committed
504
505
    my @list;
    while (my $row = $sth->fetchrow_hashref) {
506
507
        $row->{bases}= $self->_list_bases_vm($row->{id});
        $row->{machines}= $self->_list_machines_vm($row->{id});
Francesc Guasch's avatar
Francesc Guasch committed
508
        $row->{type} = $row->{vm_type};
Carlos Juan's avatar
Carlos Juan committed
509
        $row->{action_remove} = 'disabled' if length defined $row->{machines}[0];
Carlos Juan's avatar
Carlos Juan committed
510
        $row->{action_remove} = 'disabled' if $row->{hostname} eq 'localhost';
Carlos Juan's avatar
Carlos Juan committed
511
        $row->{action_remove} = 'disabled' if length defined $row->{bases}[0];
Francesc Guasch's avatar
Francesc Guasch committed
512
513
        $row->{is_local} = 0;
        $row->{is_local} = 1  if $row->{hostname} =~ /^(localhost|127)/;
Francesc Guasch's avatar
Francesc Guasch committed
514
        delete $row->{vm_type};
Francesc Guasch's avatar
Francesc Guasch committed
515
516
517
518
        lock_hash(%$row);
        push @list,($row);
    }
    $sth->finish;
519
    return @list;
Francesc Guasch's avatar
Francesc Guasch committed
520
521
}

522
sub _list_bases_vm($self, $id_node) {
Francesc Guasch's avatar
Francesc Guasch committed
523
524
525
526
527
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT d.id FROM domains d,bases_vm bv"
        ." WHERE d.is_base=1"
        ."  AND d.id = bv.id_domain "
        ."  AND bv.id_vm=?"
528
        ."  AND bv.enabled=1"
Francesc Guasch's avatar
Francesc Guasch committed
529
    );
530
531
    my @bases;
    $sth->execute($id_node);
Francesc Guasch's avatar
Francesc Guasch committed
532
    while ( my ($id_domain) = $sth->fetchrow ) {
533
        push @bases,($id_domain);
Francesc Guasch's avatar
Francesc Guasch committed
534
535
    }
    $sth->finish;
536
    return \@bases;
Francesc Guasch's avatar
Francesc Guasch committed
537
538
}

539
540
sub _list_machines_vm($self, $id_node) {
    my $sth = $CONNECTOR->dbh->prepare(
541
        "SELECT d.id, name FROM domains d"
542
543
544
545
546
        ." WHERE d.status='active'"
        ."  AND d.id_vm=?"
    );
    my @bases;
    $sth->execute($id_node);
547
548
    while ( my ($id_domain, $name) = $sth->fetchrow ) {
        push @bases,({ id => $id_domain, name => $name });
549
550
551
552
    }
    $sth->finish;
    return \@bases;
}
553
554
555
556
557
558
559
560
=head2 list_iso_images

Returns a reference to a list of the ISO images known by the system

=cut

sub list_iso_images {
    my $self = shift;
561
562
563
    my $vm_name = shift;

    my $vm;
564
565
566
567
568
569
570
571
572
573
574
575
576

    my @iso;
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM iso_images ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @iso,($row);
    }
    $sth->finish;
    return \@iso;
}

577
=head2 iso_file
joelalju's avatar
joelalju committed
578
579
580
581
582

Returns a reference to a list of the ISOs known by the system

=cut

583
sub iso_file {
joelalju's avatar
joelalju committed
584
585
    my $self = shift;
    my $vm = $self->search_vm('KVM');
JanFontanet's avatar
JanFontanet committed
586
    my @isos = sort { "\L$a" cmp "\L$b" } $vm->search_volume_path_re(qr(.*\.iso$));
587
    #TODO remove path from device
joelalju's avatar
joelalju committed
588
589
590
    return \@isos;
}

591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
=head2 list_lxc_templates

Returns a reference to a list of the LXC templates known by the system

=cut


sub list_lxc_templates {
    my $self = shift;

    my @template;
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM lxc_templates ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @template,($row);
    }
    $sth->finish;
    return \@template;

}

=head2 list_users

Returns a reference to a list of the users

=cut

620
sub list_users($self,$name=undef) {
621
    my $sth = $CONNECTOR->dbh->prepare("SELECT id, name FROM users ");
622
623
624
625
    $sth->execute();
    
    my @users = ();
    while ( my $row = $sth->fetchrow_hashref) {
626
        next if defined $name && $row->{name} !~ /$name/;
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
        push @users, ($row);
    }
    $sth->finish;

    return \@users;
}

=head2 create_domain

Request the creation of a new domain or virtual machine

    # TODO: document the args here
    my $req = $rvd_front->create_domain( ... );

=cut

sub create_domain {
    my $self = shift;
    return Ravada::Request->create_domain(@_);
}

=head2 wait_request

Waits for a request for some seconds.

=head3 Arguments

=over 

=item * request

=item * timeout (optional defaults to $Ravada::Front::TIMEOUT

=back

Returns: the request

=cut

sub wait_request {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $timeout = ( shift or $TIMEOUT );

    if ( $self->backend ) {
        if ($self->fork ) {
            $self->backend->process_requests();
        } else {
            $self->backend->_process_requests_dont_fork();
        }
    }

    for ( 1 .. $timeout ) {
        last if $req->status eq 'done';
        sleep 1;
    }
    $req->status("timeout")
        if $req->status eq 'working';
    return $req;

}

=head2 ping_backend

Checks if the backend is alive.

Return true if alive, false otherwise.

=cut

sub ping_backend {
    my $self = shift;

    return 1 if $self->_ping_backend_localhost();

    my $req = Ravada::Request->ping_backend();
    $self->wait_request($req, 2);

    return 1 if $req->status() eq 'done';
    return 0;
}

sub _ping_backend_localhost {
    my $self = shift;
    return 1 if -e $PID_FILE_BACKEND;
    # TODO check the process with pid $PID_FILE_BACKEND is really alive
    return;
}

=head2 open_vm

Connects to a Virtual Machine Manager ( or VMM ( or VM )).
Returns a read-only connection to the VM.

joelalju's avatar
joelalju committed
722
723
  my $vm = $front->open_vm('KVM');

724
725
726
727
728
729
730
=cut

sub open_vm {
    my $self = shift;
    my $type = shift or confess "I need vm type";
    my $class = "Ravada::VM::$type";

731
    if (my $vm = $VM{$type}) {
732
        if (!$vm->ping || !$vm->is_alive) {
733
734
735
736
737
            $vm->disconnect();
            $vm->connect();
        } else {
            return $vm;
        }
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
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
795
796
797
    }

    my $proto = {};
    bless $proto,$class;

    my $vm = $proto->new(readonly => 1);
    eval { $vm->vm };
    warn $@ if $@;
    return if $@;
    return $vm if $0 =~ /\.t$/;

    $VM{$type} = $vm;
    return $vm;
}

=head2 search_vm

Calls to open_vm

=cut

sub search_vm {
    return open_vm(@_);
}

=head2 search_clone

Search for a clone of a domain owned by an user.

    my $domain_clone = $rvd_front->(id_base => $domain_base->id , id_owner => $user->id);

=head3 arguments

=over

=item id_base : The id of the base domain

=item id_user

=back

Returns the domain

=cut

sub search_clone {
    my $self = shift;
    my %args = @_;
    confess "Missing id_owner " if !$args{id_owner};
    confess "Missing id_base" if !$args{id_base};

    my ($id_base , $id_owner) = ($args{id_base} , $args{id_owner} );

    delete $args{id_base};
    delete $args{id_owner};

    confess "Unknown arguments ".Dumper(\%args) if keys %args;

    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT id,name FROM domains "
798
        ." WHERE id_base=? AND id_owner=? AND (is_base=0 OR is_base=NULL)"
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
    );
    $sth->execute($id_base, $id_owner);

    my ($id_domain, $name) = $sth->fetchrow;
    $sth->finish;

    return if !$id_domain;

    return $self->search_domain($name);

}

=head2 search_domain

Searches a domain by name

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

Returns a Ravada::Domain object

=cut

sub search_domain {
    my $self = shift;

    my $name = shift;

826
    my $sth = $CONNECTOR->dbh->prepare("SELECT id, vm FROM domains WHERE name=?");
827
    $sth->execute($name);
828
    my ($id, $tipo) = $sth->fetchrow or return;
829

Francesc Guasch's avatar
Francesc Guasch committed
830
    return Ravada::Front::Domain->open($id);
831
832
833
834
835
836
837
838
}

=head2 list_requests

Returns a list of ruquests : ( id , domain_name, status, error )

=cut

839
sub list_requests($self, $id_domain_req=undef, $seconds=60) {
840

Francesc Guasch's avatar
Francesc Guasch committed
841
    my @now = localtime(time-$seconds);
842
843
844
845
846
    $now[4]++;
    for (0 .. 4) {
        $now[$_] = "0".$now[$_] if length($now[$_])<2;
    }
    my $time_recent = ($now[5]+=1900)."-".$now[4]."-".$now[3]
Francesc Guasch's avatar
Francesc Guasch committed
847
        ." ".$now[2].":".$now[1].":".$now[0];
848
    my $sth = $CONNECTOR->dbh->prepare(
849
        "SELECT requests.id, command, args, date_changed, requests.status"
850
851
852
853
854
            ." ,requests.error, id_domain ,domains.name as domain"
            ." ,date_changed "
        ." FROM requests left join domains "
        ."  ON requests.id_domain = domains.id"
        ." WHERE "
855
        ."    requests.status <> 'done' "
Francesc Guasch's avatar
Francesc Guasch committed
856
        ."  OR ( date_changed >= ?) "
857
        ." ORDER BY date_changed "
858
    );
859
    $sth->execute($time_recent);
860
    my @reqs;
861
    my ($id_request, $command, $j_args, $date_changed, $status
862
        , $error, $id_domain, $domain, $date);
863
    $sth->bind_columns(\($id_request, $command, $j_args, $date_changed, $status
864
        , $error, $id_domain, $domain, $date));
865
866

    while ( $sth->fetch) {
Francesc Guasch's avatar
Francesc Guasch committed
867
868
869
870
871
872
873
874
875
876
        my $epoch_date_changed;
        if ($date_changed) {
            my ($y,$m,$d,$hh,$mm,$ss) = $date_changed =~ /(\d{4})-(\d\d)-(\d\d) (\d+):(\d+):(\d+)/;
            if ($y)  {
                $epoch_date_changed = DateTime->new(year => $y, month => $m, day => $d
                    ,hour => $hh, minute => $mm, second => $ss
                    ,time_zone => $LOCAL_TZ
                )->epoch;
            }
        }
877
878
879
        next if $command eq 'enforce_limits'
                || $command eq 'refresh_vms'
                || $command eq 'refresh_storage'
880
                || $command eq 'refresh_machine'
881
                || $command eq 'ping_backend'
882
                || $command eq 'cleanup'
Francesc Guasch's avatar
Francesc Guasch committed
883
                || $command eq 'screenshot'
Francesc Guasch's avatar
Francesc Guasch committed
884
                || $command eq 'connect_node'
885
                || $command eq 'post_login'
Francesc Guasch's avatar
Francesc Guasch committed
886
                || $command eq 'list_network_interfaces'
887
                ;
Francesc Guasch's avatar
Francesc Guasch committed
888
        next if ( $command eq 'force_shutdown'
889
890
                || $command eq 'start'
                || $command eq 'shutdown'
891
                || $command eq 'hibernate'
892
                )
Francesc Guasch's avatar
Francesc Guasch committed
893
894
895
                && time - $epoch_date_changed > 5
                && $status eq 'done'
                && !$error;
896
        next if $id_domain_req && defined $id_domain && $id_domain != $id_domain_req;
897
898
        my $args;
        $args = decode_json($j_args) if $j_args;
899

900
901
902
903
        if (!$domain && $args->{id_domain}) {
            $domain = $args->{id_domain};
        }
        $domain = $args->{name} if !$domain && $args->{name};
904
905
906
907
908

        my $message = ( $self->_last_message($id_request) or $error or '');
        $message =~ s/^$command\s+$status(.*)/$1/i;

        push @reqs,{ id => $id_request,  command => $command, date_changed => $date_changed, status => $status, name => $args->{name}
909
910
            ,domain => $domain
            ,date => $date
911
            ,message => $message
Francesc Guasch's avatar
Francesc Guasch committed
912
            ,error => $error
913
        };
914
915
916
917
918
    }
    $sth->finish;
    return \@reqs;
}

919
920
921
922
sub _last_message {
    my $self = shift;
    my $id_request = shift;
    my $sth = $CONNECTOR->dbh->prepare(
923
        "SELECT subject , message FROM messages WHERE id_request=? ORDER BY date_send DESC,id DESC");
924
925
926
927
928
    $sth->execute($id_request);
    my ($subject, $message) = $sth->fetchrow;

    return '' if !$subject;

929
    $subject = '' if $message && $message =~ /^$subject/;
930
931
932
933
934
    return "$subject ".($message or '');
    $sth->finish;

}

935
936
937
938
939
940
941
942
943
944
=head2 search_domain_by_id

  my $domain = $ravada->search_domain_by_id($id);

=cut

sub search_domain_by_id {
    my $self = shift;
      my $id = shift;

945
    my $sth = $CONNECTOR->dbh->prepare("SELECT name, id, id_base, is_base FROM domains WHERE id=?");
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
    $sth->execute($id);

    my $row = $sth->fetchrow_hashref;

    return if !keys %$row;

    lock_hash(%$row);

    return $self->search_domain($row->{name});
}

=head2 start_domain

Request to start a domain.

=head3 arguments

=over

=item user => $user : a Ravada::Auth::SQL user

=item name => $name : the domain name

=item remote_ip => $remote_ip: a Ravada::Auth::SQL user

971
=back
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000

Returns an object: Ravada::Request.

    my $req = $rvd_front->start_domain(
               user => $user
              ,name => 'mydomain'
        , remote_ip => '192.168.1.1');

=cut

sub start_domain {
    my $self = shift;
    confess "ERROR: Must call start_domain with user=>\$user, name => \$name, remote_ip => \$ip"
        if scalar @_ % 2;

    my %args = @_;

    # TODO check for user argument
    $args{uid} = $args{user}->id    if $args{user};
    delete $args{user};

    return Ravada::Request->start_domain( %args );
}

=head2 list_bases_anonymous

List the available bases for anonymous user in a remote IP

    my $list = $rvd_front->list_bases_anonymous($remote_ip);
For faster browsing, not all history is shown. View entire blame