Request.pm 14 KB
Newer Older
1
2
3
4
5
6
package Ravada::Request;

use strict;
use warnings;

use Carp qw(confess);
7
use Data::Dumper;
8
use JSON::XS;
9
use Hash::Util;
10
use Ravada;
11
use Ravada::Front;
12
13
14
15
16
17
18
19
20
21

use vars qw($AUTOLOAD);

=pod

Request a command to the ravada backend

=cut

our %FIELD = map { $_ => 1 } qw(error);
22
our %FIELD_RO = map { $_ => 1 } qw(id name);
23

24
our $args_manage = { name => 1 , uid => 1 };
Francesc Guasch's avatar
Francesc Guasch committed
25
our $args_prepare = { id_domain => 1 , uid => 1 };
26
our $args_remove_base = { domain => 1 , uid => 1 };
27
our $args_manage_ip = {%$args_manage, remote_ip => 1};
28

29
our %VALID_ARG = (
joansp's avatar
joansp committed
30
    create_domain => {
31
32
              vm => 1
           ,name => 1
33
         ,id_iso => 1
34
        ,id_base => 1
35
       ,id_owner => 1
36
    ,id_template => 1
37
38
         ,memory => 2
           ,disk => 2
39
        ,network => 2
40
    }
41
    ,open_iptables => $args_manage_ip
42
      ,remove_base => $args_remove_base
Francesc Guasch's avatar
Francesc Guasch committed
43
44
     ,prepare_base => $args_prepare
     ,pause_domain => $args_manage
45
    ,resume_domain => {%$args_manage, remote_ip => 1 }
46
47
    ,remove_domain => $args_manage
    ,shutdown_domain => { name => 1, uid => 1, timeout => 2 }
48
    ,screenshot_domain => { id_domain => 1, filename => 2 }
49
    ,start_domain => {%$args_manage, remote_ip => 1 }
50
51
);

52
our $CONNECTOR;
53

54
55
56
57
58
59
sub _init_connector {
    $CONNECTOR = \$Ravada::CONNECTOR;
    $CONNECTOR = \$Ravada::Front::CONNECTOR   if !$$CONNECTOR;

}

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

    Internal object builder, do not call

=Cut

66
67
68
sub BUILD {
    _init_connector();
}
69

Francesc Guasch's avatar
Francesc Guasch committed
70
sub _request {
71
72
73
74
75
76
77
78
    my $proto = shift;
    my $class=ref($proto) || $proto;

    my $self = {};
    bless ($self, $class);
    return $self;
}

Francesc Guasch's avatar
Francesc Guasch committed
79
80
81
82
83
84
85
86
=head2 open

Opens the information of a previous request by id

  my $req = Ravada::Request->open($id);

=cut

87
88
89
90
91
92
sub open {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my $id = shift or confess "Missing request id";

93
94
    _init_connector()   if !$CONNECTOR || !$$CONNECTOR;

95
    my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM requests "
96
97
98
99
100
101
102
103
104
105
106
107
        ." WHERE id=?");
    $sth->execute($id);
    my $row = $sth->fetchrow_hashref;

    confess "I can't find id=$id " if !defined $row;
    $sth->finish;

    my $args = decode_json($row->{args}) if $row->{args};
    $args = {} if !$args;

    $row->{args} = $args;

108
    bless ($row, $class);
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
    return $row;
}

=head2 create_domain

    my $req = Ravada::Request->create_domain( name => 'bla'
                    , id_iso => 1
    );


=cut

sub create_domain {
    my $proto = shift;
    my $class=ref($proto) || $proto;

    my %args = @_;

    confess "Missing domain name "
        if !$args{name};

130
131
132
    for (keys %args) {
        confess "Invalid argument $_" if !$VALID_ARG{'create_domain'}->{$_};
    }
133
    my $self = {};
134
135
136
    if ($args{network}) {
        $args{network} = JSON::XS->new->convert_blessed->encode($args{network});
    }
137
138
139
140
141
142
143

    bless($self,$class);
    return $self->_new_request(command => 'create' , args => encode_json(\%args));
}

=head2 remove_domain

144
145
    my $req = Ravada::Request->remove_domain( name => 'bla'
                    , uid => $user->id
146
147
148
149
150
151
152
153
154
155
    );


=cut


sub remove_domain {
    my $proto = shift;
    my $class=ref($proto) || $proto;

156
157
158
159
    my %args = @_;
    confess "Missing domain name"   if !$args{name};
    confess "Name is not scalar"    if ref($args{name});
    confess "Missing uid"           if !$args{uid};
160

161
162
163
    for (keys %args) {
        confess "Invalid argument $_" if !$VALID_ARG{'remove_domain'}->{$_};
    }
164
165
166

    my $self = {};
    bless($self,$class);
167
168

    return $self->_new_request(command => 'remove' , args => encode_json(\%args));
169
170
171

}

Francesc Guasch's avatar
Francesc Guasch committed
172
173
174
175
=head2 start_domain

Requests to start a domain

176
  my $req = Ravada::Request->start_domain( name => 'name', uid => $user->id );
Francesc Guasch's avatar
Francesc Guasch committed
177
178
179
180
181
182
183

=cut

sub start_domain {
    my $proto = shift;
    my $class=ref($proto) || $proto;

184
    my $args = _check_args('start_domain', @_);
Francesc Guasch's avatar
Francesc Guasch committed
185
186
187

    my $self = {};
    bless($self,$class);
188
189

    return $self->_new_request(command => 'start' , args => encode_json($args));
Francesc Guasch's avatar
Francesc Guasch committed
190
191
}

192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
=head2 pause_domain

Requests to pause a domain

  my $req = Ravada::Request->pause_domain( name => 'name', uid => $user->id );

=cut

sub pause_domain {
    my $proto = shift;
    my $class=ref($proto) || $proto;

    my $args = _check_args('pause_domain', @_);

    my $self = {};
    bless($self,$class);

    return $self->_new_request(command => 'pause' , args => encode_json($args));
}

212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
=head2 resume_domain

Requests to pause a domain

  my $req = Ravada::Request->resume_domain( name => 'name', uid => $user->id );

=cut

sub resume_domain {
    my $proto = shift;
    my $class=ref($proto) || $proto;

    my $args = _check_args('pause_domain', @_);

    my $self = {};
    bless($self,$class);

    return $self->_new_request(command => 'resume' , args => encode_json($args));
}


233

234
235
236
237
sub _check_args {
    my $sub = shift;
    my $args = { @_ };

238
    my $valid_args = $VALID_ARG{$sub};
239
    for (keys %{$args}) {
joansp's avatar
joansp committed
240
        confess "Invalid argument $_ , valid args ".Dumper($valid_args)
241
            if !$valid_args->{$_};
242
243
244
245
246
247
248
249
250
251
    }

    for (keys %{$VALID_ARG{$sub}}) {
        next if $VALID_ARG{$sub}->{$_} == 2; # optional arg
        confess "Missing argument $_"   if !exists $args->{$_};
    }

    return $args;
}

Francesc Guasch's avatar
Francesc Guasch committed
252
253
254
255
=head2 shutdown_domain

Requests to stop a domain

256
  my $req = Ravada::Request->shutdown_domain( name => 'name' , uid => $user->id );
joansp's avatar
joansp committed
257
  my $req = Ravada::Request->shutdown_domain( name => 'name' , uid => $user->id
258
                                            ,timeout => $timeout );
Francesc Guasch's avatar
Francesc Guasch committed
259
260
261
262
263
264
265

=cut

sub shutdown_domain {
    my $proto = shift;
    my $class=ref($proto) || $proto;

266
    my $args = _check_args('shutdown_domain', @_ );
267

268
    $args->{timeout} = 10 if !exists $args->{timeout};
Francesc Guasch's avatar
Francesc Guasch committed
269
270
271

    my $self = {};
    bless($self,$class);
272
273

    return $self->_new_request(command => 'shutdown' , args => encode_json($args));
Francesc Guasch's avatar
Francesc Guasch committed
274
275
}

Francesc Guasch's avatar
Francesc Guasch committed
276
=head2 prepare_base
Francesc Guasch's avatar
Francesc Guasch committed
277

Francesc Guasch's avatar
Francesc Guasch committed
278
279
280
281
282
283
284
285
286
287
Returns a new request for preparing a domain base

  my $req = Ravada::Request->prepare_base( $name );

=cut

sub prepare_base {
    my $proto = shift;
    my $class=ref($proto) || $proto;

288
289
    my %args = @_;
    confess "Missing uid"           if !$args{uid};
Francesc Guasch's avatar
Francesc Guasch committed
290

Francesc Guasch's avatar
Francesc Guasch committed
291
    my $args = _check_args('prepare_base', @_);
Francesc Guasch's avatar
Francesc Guasch committed
292
293
294

    my $self = {};
    bless($self,$class);
Francesc Guasch's avatar
Francesc Guasch committed
295

joansp's avatar
joansp committed
296
    return $self->_new_request(command => 'prepare_base'
Francesc Guasch's avatar
Francesc Guasch committed
297
298
        , id_domain => $args{id_domain}
        , args => encode_json( $args ));
Francesc Guasch's avatar
Francesc Guasch committed
299
300

}
Francesc Guasch's avatar
Francesc Guasch committed
301

302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
=head2 remove_base

Returns a new request for making a base regular domain. It marks it
as 'non base' and removes the files.

It must have not clones. All clones must be removed before calling
this method.

  my $req = Ravada::Request->remove_base( $name );

=cut

sub remove_base {
    my $proto = shift;
    my $class=ref($proto) || $proto;

318
319
    my %_args = @_;
    confess "Missing uid"           if !$_args{uid};
320
321
322
323
324
325

    my $args = _check_args('remove_base', @_);

    my $self = {};
    bless($self,$class);

326
327
328
329
330
331
332
    my $domain = $args->{domain};

    $args->{id_domain} = $domain->id;
    delete $args->{domain};

    my $req = $self->_new_request(command => 'remove_base'
        , id_domain => $domain->id
333
334
        , args => encode_json( $args ));

335
336
337
338
339
340
    if ($domain->has_clones()) {
        $req->status('done');
        $req->error("Domain ".$domain->name." can't be removed."
                    ."It has ".$domain->has_clones." clones");
    }
    return $req;
341
342
343
}


Francesc Guasch's avatar
Francesc Guasch committed
344
345
346
347
348
349
350
351
352
353
354
355
=head2 ping_backend

Returns wether the backend is alive or not

=cut

sub ping_backend {
    my $proto = shift;
    my $class=ref($proto) || $proto;

    my $self = {};
    bless ($self, $class);
356
    return $self->_new_request( command => 'ping_backend' );
357
358
}

Francesc Guasch's avatar
Francesc Guasch committed
359

360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
=head2 domdisplay

Returns the domdisplay of a domain

Arguments:

* domain name

=cut

sub domdisplay {
   my $proto = shift;
    my $class=ref($proto) || $proto;

    my $name = shift;
375
    my $uid = shift;
376
377
378

    my $self = {};
    bless ($self, $class);
379
380
    return $self->_new_request( command => 'domdisplay'
        ,args => { name => $name, uid => $uid });
381
382
}

383
384
385
386
387
388
389
390
391
392
sub _new_request {
    my $self = shift;
    my %args = @_;

    $args{status} = 'requested';

    if ($args{name}) {
        $args{domain_name} = $args{name};
        delete $args{name};
    }
393
    if ( ref $args{args} ) {
394
395
        $args{args}->{uid} = $args{args}->{id_owner}
            if !exists $args{args}->{uid};
396
397
        $args{args} = encode_json($args{args});
    }
398
    _init_connector()   if !$CONNECTOR || !$$CONNECTOR;
399

400
    my $sth = $$CONNECTOR->dbh->prepare(
401
402
403
404
405
406
407
408
        "INSERT INTO requests (".join(",",sort keys %args).")"
        ."  VALUES ( "
                .join(",", map { '?' } keys %args)
                ." )"
    );
    $sth->execute(map { $args{$_} } sort keys %args);
    $sth->finish;

Francesc Guasch's avatar
Francesc Guasch committed
409
    $self->{id} = $self->_last_insert_id();
410
411
412
413

    return $self->open($self->{id});
}

Francesc Guasch's avatar
Francesc Guasch committed
414
sub _last_insert_id {
415
    my $driver = $$CONNECTOR->dbh->{Driver}->{Name};
416
417
418
419
420
421
422
423
424
425
426
427

    if ( $driver =~ /sqlite/i ) {
        return _last_insert_id_sqlite(@_);
    } elsif ( $driver =~ /mysql/i ) {
        return _last_insert_id_mysql(@_);
    } else {
        confess "I don't know how to get last_insert_id for $driver";
    }
}

sub _last_insert_id_mysql {
    my $self = shift;
428
    my $sth = $$CONNECTOR->dbh->prepare("SELECT last_insert_id()");
429
430
431
432
433
434
435
436
    $sth->execute;
    my ($id) = $sth->fetchrow;
    $sth->finish;
    return $id;

}

sub _last_insert_id_sqlite {
437
438
    my $self = shift;

439
    my $sth = $$CONNECTOR->dbh->prepare("SELECT last_insert_rowid()");
440
441
442
443
444
445
    $sth->execute;
    my ($id) = $sth->fetchrow;
    $sth->finish;
    return $id;
}

Francesc Guasch's avatar
Francesc Guasch committed
446
447
448
449
450
451
452
453
454
=head2 status

Returns or sets the status of a request

  $req->status('done');

  my $status = $req->status();

=cut
455
456
457
458

sub status {
    my $self = shift;
    my $status = shift;
459
    my $message = shift;
460
461

    if (!defined $status) {
462
        my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM requests "
463
464
465
466
467
468
469
470
            ." WHERE id=?");
        $sth->execute($self->{id});
        my $row = $sth->fetchrow_hashref;
        $sth->finish;

        return ($row->{status} or 'unknown');
    }

471
    my $sth = $$CONNECTOR->dbh->prepare("UPDATE requests set status=? "
472
            ." WHERE id=?");
473
    $sth->execute($status, $self->{id});
474
    $sth->finish;
475

476
    $self->_send_message($status, $message)   if $self->command ne 'domdisplay';
477
478
479
    return $status;
}

480
481
482
sub _send_message {
    my $self = shift;
    my $status = shift;
483
    my $message = ( shift or $self->error );
484
485
486

    my $uid;

487
488
    $uid = $self->args('id_owner') if $self->defined_arg('id_owner');
    $uid = $self->args('uid')      if !$uid && $self->defined_arg('uid');
489
490
    return if !$uid;

491
    my $domain_name = $self->defined_arg('name');
492
493
494
495
496
497
498
499
500
501
    $domain_name = ''               if !$domain_name;
    $domain_name = "$domain_name "  if length $domain_name;

    $self->_remove_unnecessary_messages() if $self->status eq 'done';

    my $sth = $$CONNECTOR->dbh->prepare(
        "INSERT INTO messages ( id_user, id_request, subject, message ) "
        ." VALUES ( ?,?,?,?)"
    );
    $sth->execute($uid, $self->id,"Command ".$self->command." $domain_name".$self->status
502
        ,$message);
503
504
505
506
507
508
509
    $sth->finish;
}

sub _remove_unnecessary_messages {
    my $self = shift;

    my $uid;
510
511
    $uid = $self->defined_arg('id_owner');
    $uid = $self->defined_arg('uid')        if !$uid;
512
    return if !$uid;
513
    
514
515

    my $sth = $$CONNECTOR->dbh->prepare(
516
517
        "DELETE FROM messages WHERE id_user=? AND id_request=? "
        ." AND (message='' OR message IS NULL)"
518
519
520
521
522
523
524
525
    );

    $sth->execute($uid, $self->id);
    $sth->finish;

}


526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
=head2 result

  Returns the result of the request if any

  my $result = $req->result;

=cut

sub result {
    my $self = shift;

    my $value = shift;

    if (defined $value ) {
        my $sth = $$CONNECTOR->dbh->prepare("UPDATE requests set result=? "
            ." WHERE id=?");
Francesc Guasch's avatar
Francesc Guasch committed
542
        $sth->execute(encode_json($value), $self->{id});
543
544
545
546
547
548
        $sth->finish;

    } else {
        my $sth = $$CONNECTOR->dbh->prepare("SELECT result FROM requests where id=? ");
        $sth->execute($self->{id});
        ($value) = $sth->fetchrow;
549
        $value = decode_json($value)    if defined $value;
550
551
552
553
554
555
556
        $sth->finish;

    }

    return $value;
}

Francesc Guasch's avatar
Francesc Guasch committed
557
558
559
560
561
562
=head2 command

Returns the requested command

=cut

563
564
565
566
567
sub command {
    my $self = shift;
    return $self->{command};
}

Francesc Guasch's avatar
Francesc Guasch committed
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
=head2 args

Returns the requested command

  my $command = $req->command;

=cut


=head2 args

Returns the arguments of a request or the value of one argument field

  my $args = $request->args();
  print $args->{name};

  print $request->args('name');

=cut


589
590
591
592
593
sub args {
    my $self = shift;
    my $name = shift;
    return $self->{args}    if !$name;

594
595
    confess "Unknown argument $name ".Dumper($self->{args})
        if !exists $self->{args}->{$name};
596
597
598
    return $self->{args}->{$name};
}

599
600
601
602
603
604
605
606
607
608
609
610
611
=head2 defined_arg

Returns if an argument is defined

=cut

sub defined_arg {
    my $self = shift;
    my $name = shift;
    confess "ERROR: missing arg name" if !defined $name;
    return $self->{args}->{$name};
}

Francesc Guasch's avatar
Francesc Guasch committed
612
613
614
615
616
617
618
619
620
621
622
623
=head2 screenshot_domain

Request the screenshot of a domain.

Arguments:

- optional filename , defaults to "storage_path/$id_domain.png"

Returns a Ravada::Request;

=cut

624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
sub screenshot_domain {
    my $proto = shift;
    my $class=ref($proto) || $proto;

    my $args = _check_args('screenshot_domain', @_ );

    $args->{filename} = '' if !exists $args->{filename};

    my $self = {};
    bless($self,$class);

    return $self->_new_request(command => 'screenshot' , id_domain => $args->{id_domain}
        ,args => encode_json($args));

}

640
641
642
sub AUTOLOAD {
    my $self = shift;

Francesc Guasch's avatar
Francesc Guasch committed
643

644
645
    my $name = $AUTOLOAD;
    $name =~ s/.*://;
Francesc Guasch's avatar
Francesc Guasch committed
646
647
648
649
650

    confess "Can't locate object method $name via package $self"
        if !ref($self);

    my $value = shift;
651
652
653
    $name =~ tr/[a-z]/_/c;

    confess "ERROR: Unknown field $name "
654
        if !exists $self->{$name} && !exists $FIELD{$name} && !exists $FIELD_RO{$name};
655
    if (!defined $value) {
656
        my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM requests "
657
658
659
660
661
662
663
664
665
666
667
            ." WHERE id=?");
        $sth->execute($self->{id});
        my $row = $sth->fetchrow_hashref;
        $sth->finish;

        return $row->{$name};
    }

    confess "ERROR: field $name is read only"
        if $FIELD_RO{$name};

668
    my $sth = $$CONNECTOR->dbh->prepare("UPDATE requests set $name=? "
669
            ." WHERE id=?");
joansp's avatar
joansp committed
670
    eval {
671
672
673
674
        $sth->execute($value, $self->{id});
        $sth->finish;
    };
    warn "$name=$value\n$@" if $@;
675
676
677
678
679
    return $value;

}

1;