Void.pm 8.14 KB
Newer Older
Francesc Guasch's avatar
Francesc Guasch committed
1
2
3
4
5
6
7
package Ravada::Domain::Void;

use warnings;
use strict;

use Carp qw(cluck croak);
use Data::Dumper;
8
use File::Copy;
9
use Hash::Util qw(lock_keys);
Francesc Guasch's avatar
Francesc Guasch committed
10
11
use IPC::Run3 qw(run3);
use Moose;
12
use YAML qw(LoadFile DumpFile);
Francesc Guasch's avatar
Francesc Guasch committed
13
14
15

with 'Ravada::Domain';

16
has 'domain' => (
17
    is => 'rw'
18
19
20
21
    ,isa => 'Str'
    ,required => 1
);

22
23
24
25
26
27
has '_ip' => (
    is => 'rw'
    ,isa => 'Str'
    ,default => sub { return '1.1.1.'.int rand(255)}
);

28
our $DIR_TMP = "/var/tmp/rvd_void";
Francesc Guasch's avatar
Francesc Guasch committed
29

30
#######################################3
Francesc Guasch's avatar
Francesc Guasch committed
31

Francesc Guasch's avatar
Francesc Guasch committed
32
33
sub BUILD {
    my $self = shift;
34
35

    my $args = $_[0];
36

37
38
    mkdir $DIR_TMP or die "$! when mkdir $DIR_TMP"
        if ! -e $DIR_TMP;
Francesc Guasch's avatar
Francesc Guasch committed
39

40
41
    
    return if $args->{id_base} || $args->{is_readonly};
42

43
44
    my ($file_img) = $self->disk_device;
    return if $file_img && -e $file_img;
45

46
47
    $self->add_volume(name => 'void-diska' , size => ( $args->{disk} or 1)
                        , path => $file_img
48
49
50
                        , type => 'file'
                        , target => 'vda'
    );
51

52
    $self->_set_default_info();
53
    $self->set_memory($args->{memory}) if $args->{memory};
Francesc Guasch's avatar
Francesc Guasch committed
54
55
}

56
sub name { 
Francesc Guasch's avatar
Francesc Guasch committed
57
58
    my $self = shift;
    return $self->domain;
59
60
};

61
sub display {
62
63
    my $self = shift;

64
    my $ip = $self->_vm->ip();
65
    return "void://$ip:5990/";
66
67
}

68
69
70
71
72
sub is_active {
    my $self = shift;

    return $self->_value('is_active');
}
Francesc Guasch's avatar
Francesc Guasch committed
73

74
75
sub pause {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
76
    $self->_store(is_paused => 1);
77
}
Francesc Guasch's avatar
Francesc Guasch committed
78
79
80
81
82
83

sub resume {
    my $self = shift;
    return $self->_store(is_paused => 0 );
}

84
85
sub remove {
    my $self = shift;
86

Francesc Guasch's avatar
Francesc Guasch committed
87
    $self->remove_disks();
88
89
}

90
91
sub is_hibernated { return 0 }

Francesc Guasch's avatar
Francesc Guasch committed
92
93
94
95
96
97
sub is_paused {
    my $self = shift;

    return $self->_value('is_paused');
}

98
99
100
101
102
103
sub _store {
    my $self = shift;

    my ($var, $value) = @_;

    my $data = {};
104

105
    my $disk = $self->_config_file();
106
107
    $data = LoadFile($disk)   if -e $disk;

108
    $data->{$var} = $value;
109
110

    DumpFile($disk, $data);
111

112
}
113
114
115
116
117
118

sub _value{
    my $self = shift;

    my ($var) = @_;

119
    my ($disk) = $self->_config_file();
120
121
122

    my $data = {} ;
    $data = LoadFile($disk) if -e $disk;
123
124
125
126
127
128
129
130
131
132
133
    
    return $data->{$var};

}


sub shutdown {
    my $self = shift;
    $self->_store(is_active => 0);
}

134
135
136
137
sub force_shutdown {
    return shutdown_now(@_);
}

Francesc Guasch's avatar
Francesc Guasch committed
138
139
140
141
142
sub _do_force_shutdown {
    my $self = shift;
    return $self->_store(is_active => 0);
}

143
144
sub shutdown_now {
    my $self = shift;
145
146
    my $user = shift;
    return $self->shutdown(user => $user);
147
}
148

149
150
151
152
153
sub start {
    my $self = shift;
    $self->_store(is_active => 1);
}

Francesc Guasch's avatar
Francesc Guasch committed
154
155
156
sub prepare_base {
    my $self = shift;

157
    for my $file_qcow ($self->list_volumes) {;
158
        my $file_base = $file_qcow.".qcow";
Francesc Guasch's avatar
Francesc Guasch committed
159

160
        if ( $file_qcow =~ /.SWAP.img$/ ) {
161
162
            $file_base = $file_qcow;
            $file_base =~ s/(\.SWAP.img$)/base-$1/;
163
        }
164
        open my $out,'>',$file_base or die "$! $file_base";
165
166
        print $out "$file_qcow\n";
        close $out;
167
        $self->_prepare_base_db($file_base);
168
    }
Francesc Guasch's avatar
Francesc Guasch committed
169
170
}

171
sub _config_file {
Francesc Guasch's avatar
Francesc Guasch committed
172
    my $self = shift;
173
    return "$DIR_TMP/".$self->name.".yml";
Francesc Guasch's avatar
Francesc Guasch committed
174
175
176
177
178
179
180
}

sub list_disks {
    return disk_device(@_);
}

sub _vol_remove {
181
182
183
184
    my $self = shift;
    my $file = shift;
    unlink $file or die "$! $file"
        if -e $file;
Francesc Guasch's avatar
Francesc Guasch committed
185
186
187
188
}

sub remove_disks {
    my $self = shift;
189
190
    my @files = $self->list_disks;
    for my $file (@files) {
191
        next if ! -e $file;
Francesc Guasch's avatar
Francesc Guasch committed
192
193
194
195
196
197
198
        $self->_vol_remove($file);
        if ( -e $file ) {
            unlink $file or die "$! $file";
        }
    }

}
Francesc Guasch's avatar
Francesc Guasch committed
199

200
201
202
203
204
sub remove_disk {
    my $self = shift;
    return $self->_vol_remove(@_);
}

205
206
207
208
=head2 add_volume

Adds a new volume to the domain

209
    $domain->add_volume(size => $size);
210
211
212
213

=cut

sub add_volume {
214
    my $self = shift;
215
    confess "Wrong arguments " if scalar@_ % 1;
216
217
    my %args = @_;

218
    my $suffix = ".img";
219
    $suffix = '.SWAP.img' if $args{swap};
220
    $args{path} = "$DIR_TMP/".$self->name.".$args{name}$suffix"
221
222
        if !$args{path};

223
224
225
    confess "Volume path must be absolute , it is '$args{path}'"
        if $args{path} !~ m{^/};

226

227
228
    return if -e $args{path};

229
    my %valid_arg = map { $_ => 1 } ( qw( name size path vm type swap target));
230
231
232
233
234
235
236
237
238

    for my $arg_name (keys %args) {
        confess "Unknown arg $arg_name"
            if !$valid_arg{$arg_name};
    }
    confess "Missing name " if !$args{name};
#    TODO
#    confess "Missing size " if !$args{size};

239
240
241
    $args{type} = 'file' if !$args{type};
    delete $args{vm}   if defined $args{vm};

242
    my $data = { };
243
    $data = LoadFile($self->_config_file) if -e $self->_config_file;
244
    $args{target} = _new_target($data);
245
246

    $data->{device}->{$args{name}} = \%args;
247
    DumpFile($self->_config_file, $data);
248

249
    open my $out,'>>',$args{path} or die "$! $args{path}";
250
    print $out Dumper($data->{device}->{$args{name}});
251
252
    close $out;

253
254
}

255
256
257
258
259
260
261
262
263
264
265
266
267
268
sub _new_target {
    my $data = shift;
    return 'vda'    if !$data or !keys %$data;
    my %targets;
    for my $dev ( keys %{$data->{device}}) {
        $targets{$data->{device}->{$dev}->{target}}++
    }
    return 'vda'    if !keys %targets;

    my @targets = sort keys %targets;
    my ($prefix,$a) = $targets[-1] =~ /(.*)(.)/;
    return $prefix.chr(ord($a)+1);
}

269
270
271
272
273
274
275
276
277
278
279
sub create_swap_disk {
    my $self = shift;
    my $path = shift;

    return if -e $path;

    open my $out,'>>',$path or die "$! $path";
    close $out;

}

280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
sub _rename_path {
    my $self = shift;
    my $path = shift;

    my $new_name = $self->name;

    my $cnt = 0;
    my ($dir,$ext) = $path =~ m{(.*)/.*?\.(.*)};
    for (;;) {
        my $new_path = "$dir/$new_name.$ext";
        return $new_path if ! -e $new_path;

        $new_name = $self->name."-$cnt";
    }
}

sub disk_device {
    return list_volumes(@_);
298
299
}

300
sub list_volumes {
301
    my $self = shift;
302
303
    my $data;
    $data = LoadFile($self->_config_file) if -e $self->_config_file;
304

305
    return () if !exists $data->{device};
306
307
    my @vol;
    for my $dev (keys %{$data->{device}}) {
308
309
310
        push @vol,($data->{device}->{$dev}->{path})
            if ! exists $data->{device}->{$dev}->{type}
                || $data->{device}->{$dev}->{type} ne 'base';
311
312
    }
    return @vol;
313
}
314

315
sub list_volumes_target {
316
317
318
    my $self = shift;
    my $data;
    $data = LoadFile($self->_config_file) if -e $self->_config_file;
319
320
321
322

    return () if !exists $data->{device};
    my @vol;
    for my $dev (keys %{$data->{device}}) {
323
324
        my $vol;
        $vol = ($data->{device}->{$dev}->{path})
325
326
327
328
329
330
331
332
333
            if ! exists $data->{device}->{$dev}->{type}
                || $data->{device}->{$dev}->{type} ne 'base';
        next if !$vol;
        push @vol,[$vol, $data->{device}->{$dev}->{target}];
    }
    return @vol;

}

334
sub screenshot {}
Francesc Guasch's avatar
Francesc Guasch committed
335

336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
sub get_info {
    my $self = shift;
    my $info = $self->_value('info');
    lock_keys(%$info);
    return $info;
}

sub _set_default_info {
    my $self = shift;
    my $info = {
            max_mem => 512*1024
            ,memory => 512*1024,
            ,cpu_time => 1
            ,n_virt_cpu => 1
            ,state => 'UNKNOWN'
    };
    $self->_store(info => $info);

}

sub set_max_memory {
    my $self = shift;
    my $value = shift;

    $self->_set_info(max_mem => $value);

}

sub set_memory {
    my $self = shift;
    my $value = shift;
    
    $self->_set_info(memory => $value );
}

sub set_max_mem {
    $_[0]->_set_info(max_mem => $_[1]);
}

sub _set_info {
    my $self = shift;
    my ($field, $value) = @_;
    my $info = $self->get_info();
    confess "Unknown field $field" if !exists $info->{$field};

    $info->{$field} = $value;
    $self->_store(info => $info);
}
384
385
386
387
388
389
390
391

=head2 rename

    $domain->rename("new_name");

=cut

sub rename {
392
393
394
395
    my $self = shift;
    my %args = @_;
    my $new_name = $args{name};

396
    my $file_yml = $self->_config_file();
397

398
399
400
    my $file_yml_new = "$DIR_TMP/$new_name.yml";
    copy($file_yml, $file_yml_new) or die "$! $file_yml -> $file_yml_new";
    unlink($file_yml);
401

402
    $self->domain($new_name);
403
404
}

405
406
407
408
409
410
sub disk_size {
    my $self = shift;
    my ($disk) = $self->list_volumes();
    return -s $disk;
}

411
412
413
sub spinoff_volumes {
    return;
}
414
415
416
417
418

sub ip {
    my $self = shift;
    return $self->_ip;
}
419
420
421
422
423
424
425
426
427
428

sub clean_swap_volumes {
    my $self = shift;
    for my $file ($self->list_volumes) {
        next if $file !~ /SWAP.img$/;
        open my $out,'>',$file or die "$! $file";
        close $out;
    }
}

429
sub hybernate { confess "Not supported"; }
Francesc Guasch's avatar
Francesc Guasch committed
430
1;