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

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