Request.pm 11.7 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

27
28
our %VALID_ARG = (
    create_domain => { 
29
30
              vm => 1
           ,name => 1
31
         ,id_iso => 1
32
        ,id_base => 1
33
       ,id_owner => 1
34
    ,id_template => 1
35
    }
Francesc Guasch's avatar
Francesc Guasch committed
36
37
     ,prepare_base => $args_prepare
     ,pause_domain => $args_manage
38
    ,resume_domain => $args_manage
39
40
41
    ,remove_domain => $args_manage
    ,shutdown_domain => { name => 1, uid => 1, timeout => 2 }
    ,start_domain => $args_manage
42
43
);

44
our $CONNECTOR;
45

46
47
48
49
50
51
sub _init_connector {
    $CONNECTOR = \$Ravada::CONNECTOR;
    $CONNECTOR = \$Ravada::Front::CONNECTOR   if !$$CONNECTOR;

}

Francesc Guasch's avatar
Francesc Guasch committed
52
53
54
55
56
57
=head2 BUILD

    Internal object builder, do not call

=Cut

58
59
60
sub BUILD {
    _init_connector();
}
61

Francesc Guasch's avatar
Francesc Guasch committed
62
sub _request {
63
64
65
66
67
68
69
70
    my $proto = shift;
    my $class=ref($proto) || $proto;

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

Francesc Guasch's avatar
Francesc Guasch committed
71
72
73
74
75
76
77
78
=head2 open

Opens the information of a previous request by id

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

=cut

79
80
81
82
83
84
sub open {
    my $proto = shift;
    my $class = ref($proto) || $proto;

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

85
86
    _init_connector()   if !$CONNECTOR || !$$CONNECTOR;

87
    my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM requests "
88
89
90
91
92
93
94
95
96
97
98
99
        ." 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;

100
    bless ($row, $class);
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
    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};

122
123
124
    for (keys %args) {
        confess "Invalid argument $_" if !$VALID_ARG{'create_domain'}->{$_};
    }
125
126
127
128
129
130
131
132
    my $self = {};

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

=head2 remove_domain

133
134
    my $req = Ravada::Request->remove_domain( name => 'bla'
                    , uid => $user->id
135
136
137
138
139
140
141
142
143
144
    );


=cut


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

145
146
147
148
    my %args = @_;
    confess "Missing domain name"   if !$args{name};
    confess "Name is not scalar"    if ref($args{name});
    confess "Missing uid"           if !$args{uid};
149

150
151
152
    for (keys %args) {
        confess "Invalid argument $_" if !$VALID_ARG{'remove_domain'}->{$_};
    }
153
154
155

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

    return $self->_new_request(command => 'remove' , args => encode_json(\%args));
158
159
160

}

Francesc Guasch's avatar
Francesc Guasch committed
161
162
163
164
=head2 start_domain

Requests to start a domain

165
  my $req = Ravada::Request->start_domain( name => 'name', uid => $user->id );
Francesc Guasch's avatar
Francesc Guasch committed
166
167
168
169
170
171
172

=cut

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

173
    my $args = _check_args('start_domain', @_);
Francesc Guasch's avatar
Francesc Guasch committed
174
175
176

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

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

181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
=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));
}

201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
=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));
}


222

223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
sub _check_args {
    my $sub = shift;
    my $args = { @_ };

    for (keys %{$args}) {
        confess "Invalid argument $_" if !$VALID_ARG{$sub}->{$_};
    }

    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
239
240
241
242
=head2 shutdown_domain

Requests to stop a domain

243
244
245
  my $req = Ravada::Request->shutdown_domain( name => 'name' , uid => $user->id );
  my $req = Ravada::Request->shutdown_domain( name => 'name' , uid => $user->id 
                                            ,timeout => $timeout );
Francesc Guasch's avatar
Francesc Guasch committed
246
247
248
249
250
251
252

=cut

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

253
    my $args = _check_args('shutdown_domain', @_ );
254

255
    $args->{timeout} = 10 if !exists $args->{timeout};
Francesc Guasch's avatar
Francesc Guasch committed
256
257
258

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

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

Francesc Guasch's avatar
Francesc Guasch committed
263
=head2 prepare_base
Francesc Guasch's avatar
Francesc Guasch committed
264

Francesc Guasch's avatar
Francesc Guasch committed
265
266
267
268
269
270
271
272
273
274
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;

275
276
    my %args = @_;
    confess "Missing uid"           if !$args{uid};
Francesc Guasch's avatar
Francesc Guasch committed
277

Francesc Guasch's avatar
Francesc Guasch committed
278
    my $args = _check_args('prepare_base', @_);
Francesc Guasch's avatar
Francesc Guasch committed
279
280
281

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

Francesc Guasch's avatar
Francesc Guasch committed
283
    return $self->_new_request(command => 'prepare_base' 
Francesc Guasch's avatar
Francesc Guasch committed
284
285
        , id_domain => $args{id_domain}
        , args => encode_json( $args ));
Francesc Guasch's avatar
Francesc Guasch committed
286
287

}
Francesc Guasch's avatar
Francesc Guasch committed
288

Francesc Guasch's avatar
Francesc Guasch committed
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
=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);
    return $self->_new_request( command => 'ping_backend' );
}

304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
=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;
319
    my $uid = shift;
320
321
322

    my $self = {};
    bless ($self, $class);
323
324
    return $self->_new_request( command => 'domdisplay'
        ,args => { name => $name, uid => $uid });
325
326
}

327
328
329
330
331
332
333
334
335
336
sub _new_request {
    my $self = shift;
    my %args = @_;

    $args{status} = 'requested';

    if ($args{name}) {
        $args{domain_name} = $args{name};
        delete $args{name};
    }
337
    if ( ref $args{args} ) {
338
339
        $args{args}->{uid} = $args{args}->{id_owner}
            if !exists $args{args}->{uid};
340
341
        $args{args} = encode_json($args{args});
    }
342
    _init_connector()   if !$CONNECTOR || !$$CONNECTOR;
343

344
    my $sth = $$CONNECTOR->dbh->prepare(
345
346
347
348
349
350
351
352
        "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
353
    $self->{id} = $self->_last_insert_id();
354
355
356
357

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

Francesc Guasch's avatar
Francesc Guasch committed
358
sub _last_insert_id {
359
    my $driver = $$CONNECTOR->dbh->{Driver}->{Name};
360
361
362
363
364
365
366
367
368
369
370
371

    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;
372
    my $sth = $$CONNECTOR->dbh->prepare("SELECT last_insert_id()");
373
374
375
376
377
378
379
380
    $sth->execute;
    my ($id) = $sth->fetchrow;
    $sth->finish;
    return $id;

}

sub _last_insert_id_sqlite {
381
382
    my $self = shift;

383
    my $sth = $$CONNECTOR->dbh->prepare("SELECT last_insert_rowid()");
384
385
386
387
388
389
    $sth->execute;
    my ($id) = $sth->fetchrow;
    $sth->finish;
    return $id;
}

Francesc Guasch's avatar
Francesc Guasch committed
390
391
392
393
394
395
396
397
398
=head2 status

Returns or sets the status of a request

  $req->status('done');

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

=cut
399
400
401
402
403
404

sub status {
    my $self = shift;
    my $status = shift;

    if (!defined $status) {
405
        my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM requests "
406
407
408
409
410
411
412
413
            ." WHERE id=?");
        $sth->execute($self->{id});
        my $row = $sth->fetchrow_hashref;
        $sth->finish;

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

414
    my $sth = $$CONNECTOR->dbh->prepare("UPDATE requests set status=? "
415
            ." WHERE id=?");
416
    $sth->execute($status, $self->{id});
417
    $sth->finish;
418

419
    $self->_send_message($status)   if $self->command ne 'domdisplay';
420
421
422
    return $status;
}

423
424
425
426
427
428
429
sub _send_message {
    my $self = shift;
    my $status = shift;

    my $uid;

    eval { $uid = $self->args('id_owner') };
430
    eval { $uid = $self->args('uid') }  if !$uid;
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
    return if !$uid;

    my $domain_name;
    eval { $domain_name = $self->args('name') };
    $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
        ,$self->error);
    $sth->finish;
}

sub _remove_unnecessary_messages {
    my $self = shift;

    my $uid;
    eval { $uid = $self->args('id_owner') };
454
    eval { $uid = $self->args('uid') }      if !$uid;
455
456
457
458
459
460
461
462
463
464
465
466
    return if !$uid;

    my $sth = $$CONNECTOR->dbh->prepare(
        "DELETE FROM messages WHERE id_user=? AND id_request=?"
    );

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

}


467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
=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
483
        $sth->execute(encode_json($value), $self->{id});
484
485
486
487
488
489
        $sth->finish;

    } else {
        my $sth = $$CONNECTOR->dbh->prepare("SELECT result FROM requests where id=? ");
        $sth->execute($self->{id});
        ($value) = $sth->fetchrow;
490
        $value = decode_json($value)    if defined $value;
491
492
493
494
495
496
497
        $sth->finish;

    }

    return $value;
}

Francesc Guasch's avatar
Francesc Guasch committed
498
499
500
501
502
503
=head2 command

Returns the requested command

=cut

504
505
506
507
508
sub command {
    my $self = shift;
    return $self->{command};
}

Francesc Guasch's avatar
Francesc Guasch committed
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
=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


530
531
532
533
534
sub args {
    my $self = shift;
    my $name = shift;
    return $self->{args}    if !$name;

535
536
    confess "Unknown argument $name ".Dumper($self->{args})
        if !exists $self->{args}->{$name};
537
538
539
540
541
542
    return $self->{args}->{$name};
}

sub AUTOLOAD {
    my $self = shift;

Francesc Guasch's avatar
Francesc Guasch committed
543

544
545
    my $name = $AUTOLOAD;
    $name =~ s/.*://;
Francesc Guasch's avatar
Francesc Guasch committed
546
547
548
549
550

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

    my $value = shift;
551
552
553
    $name =~ tr/[a-z]/_/c;

    confess "ERROR: Unknown field $name "
554
        if !exists $self->{$name} && !exists $FIELD{$name} && !exists $FIELD_RO{$name};
555
    if (!defined $value) {
556
        my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM requests "
557
558
559
560
561
562
563
564
565
566
567
            ." 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};

568
    my $sth = $$CONNECTOR->dbh->prepare("UPDATE requests set $name=? "
569
            ." WHERE id=?");
570
571
572
573
574
    eval { 
        $sth->execute($value, $self->{id});
        $sth->finish;
    };
    warn "$name=$value\n$@" if $@;
575
576
577
578
579
    return $value;

}

1;