source: repository/lib/Metabrik/System/Virtualbox.pm

Last change on this file was 969:50c217684c90, checked in by GomoR <gomor@…>, 5 weeks ago
  • new: api::onyphe: new API Commands
  • bugfix: client::elasticsearch: catch bulk_helper and index_bulk errors
  • update: client::elasticsearch: switch some info messages to verbose
  • update: client::kafka: randomize broker on create_connection Command
  • bugfix: crypto::x509: added to check when PubKeyAlg returns undef
  • update: file::write: on setting unbuffered Attribute
  • bugfix: system::virtualbox: restart_vboxnet is really named reset_vboxnet
File size: 11.6 KB
Line 
1#
2# $Id$
3#
4# system::virtualbox Brik
5#
6package Metabrik::System::Virtualbox;
7use strict;
8use warnings;
9
10use base qw(Metabrik::Shell::Command Metabrik::System::Package);
11
12sub brik_properties {
13   return {
14      revision => '$Revision$',
15      tags => [ qw(unstable) ],
16      author => 'GomoR <GomoR[at]metabrik.org>',
17      license => 'http://opensource.org/licenses/BSD-3-Clause',
18      attributes => {
19         datadir => [ qw(datadir) ],
20         capture_mode => [ qw(0|1) ],
21         type => [ qw(gui|sdl|headless) ],
22      },
23      attributes_default => {
24         capture_mode => 1,
25         type => 'gui',
26      },
27      commands => {
28         install => [ ], # Inherited
29         command => [ qw(command) ],
30         list => [ ],
31         start => [ qw(name type|OPTIONAL) ],
32         restore => [ qw(name type|OPTIONAL) ], # Alias for start
33         stop => [ qw(name) ],
34         save => [ qw(name) ],
35         pause => [ qw(name) ],
36         resume => [ qw(resume) ],
37         snapshot_list => [ qw(name) ],
38         snapshot_live => [ qw(name snapshot_name description|OPTIONAL) ],
39         snapshot_delete => [ qw(name snapshot_name) ],
40         snapshot_restore => [ qw(name snapshot_name) ],
41         screenshot => [ qw(name output.png|OPTIONAL) ],
42         dumpguestcore => [ qw(name output.elf|OPTIONAL) ],
43         dumpvmcore => [ qw(name output.elf|OPTIONAL) ],
44         extract_memdump_from_dumpguestcore => [ qw(input output.vol|OPTIONAL) ],
45         restart => [ qw(name type|OPTIONAL) ],
46         info => [ qw(name) ],
47         is_started => [ qw(name) ],
48         is_stopped => [ qw(name) ],
49         get_current_snapshot_id => [ qw(name) ],
50         reset_vboxnet => [ qw(device) ],
51      },
52      require_modules => {
53         'Data::Dumper' => [ ],
54         'Metabrik::File::Raw' => [ ],
55         'Metabrik::File::Read' => [ ],
56         'Metabrik::File::Readelf' => [ ],
57         'Metabrik::System::File' => [ ],
58      },
59      require_binaries => {
60         vboxmanage => [ ],
61      },
62      need_packages => {
63         ubuntu => [ qw(virtualbox) ],
64         debian => [ qw(virtualbox) ],
65      },
66   };
67}
68
69sub command {
70   my $self = shift;
71   my ($command) = @_;
72
73   $self->brik_help_run_undef_arg('command', $command) or return;
74
75   return $self->execute("vboxmanage $command");
76}
77
78sub list {
79   my $self = shift;
80
81   my %vms = ();
82   my $lines = $self->command('list vms') or return;
83   for my $line (@$lines) {
84      my ($name, $uuid) = $line =~ m/^\s*"([^"]+)"\s+{([^}]+)}\s*$/;
85      $vms{$uuid} = { uuid => $uuid, name => $name };
86   }
87
88   return \%vms;
89}
90
91sub start {
92   my $self = shift;
93   my ($name, $type) = @_;
94
95   $type ||= $self->type;
96   $self->brik_help_run_undef_arg('start', $name) or return;
97   $self->brik_help_run_undef_arg('start', $type) or return;
98
99   if ($self->is_started($name)) {
100      return $self->log->info("start: VM with name [$name] already started");
101   }
102
103   return $self->command("startvm \"$name\" --type $type");
104}
105
106sub restore {
107   my $self = shift;
108
109   return $self->start(@_);
110}
111
112sub stop {
113   my $self = shift;
114   my ($name) = @_;
115
116   $self->brik_help_run_undef_arg('stop', $name) or return;
117
118   if ($self->is_stopped($name)) {
119      return $self->log->info("start: VM with name [$name] already stopped");
120   }
121
122   return $self->command("controlvm \"$name\" poweroff");
123}
124
125sub save {
126   my $self = shift;
127   my ($name) = @_;
128
129   $self->brik_help_run_undef_arg('save', $name) or return;
130
131   return $self->command("controlvm \"$name\" savestate");
132}
133
134sub pause {
135   my $self = shift;
136   my ($name) = @_;
137
138   $self->brik_help_run_undef_arg('pause', $name) or return;
139
140   return $self->command("controlvm \"$name\" pause");
141}
142
143sub resume {
144   my $self = shift;
145   my ($name) = @_;
146
147   $self->brik_help_run_undef_arg('resume', $name) or return;
148
149   return $self->command("controlvm \"$name\" resume");
150}
151
152sub snapshot_list {
153   my $self = shift;
154   my ($name) = @_;
155
156   $self->brik_help_run_undef_arg('snapshot_list', $name) or return;
157
158   my $lines = $self->command("snapshot \"$name\" list");
159
160   if ($self->log->level > 1) {
161      print Dumper($lines)."\n";
162   }
163
164   # No snapshot: error code 256
165   if ($? != 0) {
166      return $self->log->error("snapshot_list: no snapshot found?");
167   }
168
169   my @list = ();
170   for my $line (@$lines) {
171      if ($line =~ m{^\s*Name:}) {
172         my ($descr, $id) = $line =~ m{^\s*Name:\s+([^\(]+)\(UUID:\s+([^\)]+)\)};
173         if (defined($descr) && defined($id)) {
174            my $current = 0;
175            if ($line =~ m{\*$}) {
176               $current = 1;
177            }
178            $descr =~ s{\s*$}{};
179            push @list, {
180               name => $descr,
181               uuid => $id,
182               current => $current,
183            };
184         }
185      }
186   }
187
188   return \@list;
189}
190
191sub snapshot_live {
192   my $self = shift;
193   my ($name, $snapshot_name, $description) = @_;
194
195   $description ||= 'snapshot';
196   $self->brik_help_run_undef_arg('snapshot_live', $name) or return;
197   $self->brik_help_run_undef_arg('snapshot_live', $snapshot_name) or return;
198
199   my $lines = $self->command("snapshot \"$name\" take \"$snapshot_name\" --description \"$description\" --live");
200
201   if ($self->log->level > 1) {
202      print Dumper($lines)."\n";
203   }
204
205   if ($? != 0) {
206      return $self->log->error("snapshot_live: snapshot failed");
207   }
208
209   return $self->log->info("snapshot_live: snapshot complete");
210}
211
212sub snapshot_delete {
213   my $self = shift;
214   my ($name, $snapshot_name) = @_;
215
216   $self->brik_help_run_undef_arg('snapshot_delete', $name) or return;
217   $self->brik_help_run_undef_arg('snapshot_delete', $snapshot_name) or return;
218
219   my $lines = $self->command("snapshot \"$name\" delete \"$snapshot_name\"");
220
221   # code 256: This machine does not have any snapshots
222   if ($? != 0) {
223      return $self->log->error("snapshot_delete: unable to delete snapshot [$snapshot_name] for vm [$name]");
224   }
225
226   return $self->log->info("snapshot_delete: snapshot [$snapshot_name] deleted successfully for vm [$name]");
227}
228
229sub snapshot_restore {
230   my $self = shift;
231   my ($name, $snapshot_name) = @_;
232
233   $self->brik_help_run_undef_arg('snapshot_restore', $name) or return;
234   $self->brik_help_run_undef_arg('snapshot_restore', $snapshot_name) or return;
235
236   return $self->command("snapshot \"$name\" restore \"$snapshot_name\"");
237}
238
239sub screenshot {
240   my $self = shift;
241   my ($name, $output) = @_;
242
243   $output ||= $self->datadir."/screenshot.png";
244   $self->brik_help_run_undef_arg('screenshot', $name) or return;
245
246   $self->command("controlvm \"$name\" screenshotpng \"$output\"") or return;
247
248   return $output;
249}
250
251#
252# Dump guestcore
253#
254sub dumpguestcore {
255   my $self = shift;
256   my ($name, $output) = @_;
257
258   $output ||= $self->datadir.'/output.elf';
259   $self->brik_help_run_undef_arg('dumpguestcore', $name) or return;
260
261   if (-f $output) {
262      my $sf = Metabrik::System::File->new_from_brik_init($self) or return;
263      $sf->remove($output) or return;
264   }
265
266   $self->command("debugvm \"$name\" dumpguestcore --filename \"$output\"") or return;
267
268   return $output;
269}
270
271#
272# Dump vmcore, same as dump guestcore but for newer versions of VirtualBox which renamed
273# the function
274#
275sub dumpvmcore {
276   my $self = shift;
277   my ($name, $output) = @_;
278
279   $output ||= $self->datadir.'/output.elf';
280   $self->brik_help_run_undef_arg('dumpvmcore', $name) or return;
281
282   if (-f $output) {
283      my $sf = Metabrik::System::File->new_from_brik_init($self) or return;
284      $sf->remove($output) or return;
285   }
286
287   $self->command("debugvm \"$name\" dumpvmcore --filename \"$output\"") or return;
288
289   return $output;
290}
291
292#
293# By taking information from:
294# http://wiki.yobi.be/wiki/RAM_analysis#RAM_dump_with_VirtualBox:_via_ELF64_coredump
295#
296sub extract_memdump_from_dumpguestcore {
297   my $self = shift;
298   my ($input, $output) = @_;
299
300   $output ||= $self->datadir.'/output.vol';
301   $self->brik_help_run_undef_arg('extract_memdump_from_dumpguestcore', $input) or return;
302
303   my $fraw = Metabrik::File::Raw->new_from_brik_init($self) or return;
304   my $fread = Metabrik::File::Read->new_from_brik_init($self) or return;
305   my $felf = Metabrik::File::Readelf->new_from_brik_init($self) or return;
306
307   my $headers = $felf->program_headers($input) or return;
308
309   my $offset = 0;
310   my $size = 0;
311   for my $section (@{$headers->{sections}}) {
312      if ($section->{type} eq 'LOAD') {
313         $offset = hex($section->{offset});
314         $size = hex($section->{filesiz});
315         last;
316      }
317   }
318   if (! $offset || ! $size) {
319      return $self->log->error("extract_memdump_from_dumpguestcore: unable to find memdump");
320   }
321
322   $self->log->verbose("extract_memdump_from_dumpguestcore: offset[$offset] size[$size]");
323
324   $fread->encoding('ascii');  # Raw mode
325   my $fdin = $fread->open($input) or return;
326   $fread->seek($offset) or return;
327
328   if (-f $output) {
329      my $sf = Metabrik::System::File->new_from_brik_init($self) or return;
330      $sf->remove($output) or return;
331   }
332
333   my $written = 0;
334   my $fdout = $fraw->open($output) or return;
335   while (<$fdin>) {
336      my $this = length($_);
337      if (($written + $this) <= $size) {
338         print $fdout $_;
339         $written += $this;
340      }
341      else {
342         my $rest = $size - $written;
343         if ($rest < 0) {
344            $self->log->warning("extract_memdump_from_dumpguestcore: error while reading input");
345            last;
346         }
347         my $tail = substr($_, 0, $rest);
348         print $fdout $tail;
349         last;
350      }
351   }
352   $fraw->close;
353   $fread->close;
354
355   return $output;
356}
357
358sub restart {
359   my $self = shift;
360   my ($name, $type) = @_;
361
362   $self->brik_help_run_undef_arg('restart', $name) or return;
363
364   $self->stop($name) or return;
365   sleep(2);
366   return $self->start($name, $type);
367}
368
369sub info {
370   my $self = shift;
371   my ($name) = @_;
372
373   $self->brik_help_run_undef_arg('info', $name) or return;
374
375   my $lines = $self->command("showvminfo \"$name\"") or return;
376
377   my $info = {};
378   if (@$lines > 0) {
379      for my $line (@$lines) {
380         my @t = split(/:/, $line, 2);
381         my $k = $t[0];
382         my $v = $t[1];
383         next unless defined($v);
384         $k =~ s{^\s*}{};
385         $k =~ s{\s*$}{};
386         $v =~ s{^\s*}{};
387         $v =~ s{\s*$}{};
388         if (length($k) && length($v)) {
389            $k =~ s{ }{_}g;
390            $k =~ s{(\(|\))}{}g;
391            $info->{lc($k)} = $v;
392         }
393      }
394   }
395
396   return $info;
397
398}
399
400sub is_started {
401   my $self = shift;
402   my ($name) = @_;
403
404   $self->brik_help_run_undef_arg('is_started', $name) or return;
405
406   my $info = $self->info($name) or return;
407   my $state = $info->{state} || 'undef';
408   if ($state =~ m{running}) {
409      return 1;
410   }
411
412   return 0;
413}
414
415sub is_stopped {
416   my $self = shift;
417   my ($name) = @_;
418
419   $self->brik_help_run_undef_arg('is_stopped', $name) or return;
420
421   return ! $self->is_started($name);
422}
423
424sub get_current_snapshot_id {
425   my $self = shift;
426   my ($name) = @_;
427
428   $self->brik_help_run_undef_arg('get_current_snapshot_id', $name) or return;
429
430   my $list = $self->snapshot_list($name) or return;
431
432   for my $this (@$list) {
433      if ($this->{current}) {
434         return $this->{uuid};
435      }
436   }
437
438   return 0;
439}
440
441sub reset_vboxnet {
442   my $self = shift;
443   my ($device) = @_;
444
445   $self->brik_help_run_undef_arg('reset_vboxnet', $device) or return;
446
447   my $lines1 = $self->command("hostonlyif remove $device") or return;
448   my $lines2 = $self->command("hostonlyif create") or return;
449
450   return [ $lines1, $lines2 ];
451}
452
4531;
454
455__END__
456
457=head1 NAME
458
459Metabrik::System::Virtualbox - system::virtualbox Brik
460
461=head1 COPYRIGHT AND LICENSE
462
463Copyright (c) 2014-2018, Patrice E<lt>GomoRE<gt> Auffret
464
465You may distribute this module under the terms of The BSD 3-Clause License.
466See LICENSE file in the source distribution archive.
467
468=head1 AUTHOR
469
470Patrice E<lt>GomoRE<gt> Auffret
471
472=cut
Note: See TracBrowser for help on using the repository browser.