VM.pm 4.86 KB
Newer Older
1
2
3
4
5
use warnings;
use strict;

package Ravada::VM;

6
use Carp qw(croak);
7
use Data::Dumper;
8
use Socket qw( inet_aton inet_ntoa );
9
use Moose::Role;
10
use Net::DNS;
11
12
use IO::Socket;
use IO::Interface;
13
use Net::Domain qw(hostfqdn);
14
15
16
17
18

requires 'connect';

# global DB Connection

fv3rdugo's avatar
fv3rdugo committed
19
our $CONNECTOR = \$Ravada::CONNECTOR;
20
our $CONFIG = \$Ravada::CONFIG;
21

22
23
our $MIN_MEMORY_MB = 128 * 1024;

24
# domain
25
26
requires 'create_domain';
requires 'search_domain';
27

28
29
requires 'list_domains';

30
# storage volume
31
requires 'create_volume';
32

33
34
35
requires 'connect';
requires 'disconnect';

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
############################################################

has 'host' => (
          isa => 'Str'
         , is => 'ro',
    , default => 'localhost'
);

has 'storage_pool' => (
     isa => 'Object'
    , is => 'ro'
);

has 'default_dir_img' => (
      isa => 'String'
     , is => 'ro'
);

54
55
56
57
58
has 'readonly' => (
    isa => 'Str'
    , is => 'ro'
    ,default => 0
);
59
60
############################################################
#
61
# Method Modifiers definition
62
63
# 
#
64
around 'create_domain' => \&_around_create_domain;
65

66
67
68
69
70
71
72
73
before 'search_domain' => \&_connect;

before 'create_volume' => \&_connect;

#############################################################
#
# method modifiers
#
74
75
76
77
78
79
sub _check_readonly {
    my $self = shift;
    confess "ERROR: You can't create domains in read-only mode "
        if $self->readonly 

}
80

81
82
83
84
85
86
87
88
89
90
sub _connect {
    my $self = shift;
    $self->connect();
}

sub _pre_create_domain {
    _check_create_domain(@_);
    _connect(@_);
}

91
92
93
94
95
96
97
98
99
100
101
sub _around_create_domain {
    my $orig = shift;
    my $self = shift;
    my %args = @_;

    $self->_pre_create_domain(@_);
    my $domain = $self->$orig(@_);
    $domain->add_volume_swap( size => $args{swap})  if $args{swap};
    return $domain;
}

102
103
############################################################
#
104
sub _domain_remove_db {
105
106
    my $self = shift;
    my $name = shift;
fv3rdugo's avatar
fv3rdugo committed
107
    my $sth = $$CONNECTOR->dbh->prepare("DELETE FROM domains WHERE name=?");
108
109
110
111
    $sth->execute($name);
    $sth->finish;
}

112
113
114
115
116
117
118
=head2 domain_remove

Remove the domain. Returns nothing.

=cut


119
120
121
sub domain_remove {
    my $self = shift;
    $self->domain_remove_vm();
122
    $self->_domain_remove_bd();
123
124
}

Francesc Guasch's avatar
Francesc Guasch committed
125
126
127
128
129
130
131
132
=head2 name

Returns the name of this Virtual Machine Manager

    my $name = $vm->name();

=cut

Francesc Guasch's avatar
Francesc Guasch committed
133
134
135
136
137
138
139
140
sub name {
    my $self = shift;

    my ($ref) = ref($self) =~ /.*::(.*)/;

    return ($ref or ref($self));
}

141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
=head2 search_domain_by_id

Returns a domain searching by its id

    $domain = $vm->search_domain_by_id($id);

=cut

sub search_domain_by_id {
    my $self = shift;
      my $id = shift;

    my $sth = $$CONNECTOR->dbh->prepare("SELECT name FROM domains "
        ." WHERE id=?");
    $sth->execute($id);
    my ($name) = $sth->fetchrow;
    return if !$name;

    return $self->search_domain($name);
}

162
163
164
165
166
167
168
169
170
=head2 ip

Returns the external IP this for this VM

=cut

sub ip {
    my $self = shift;

171
    my $name = $self->host() or confess "this vm has no host name";
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
    my $ip = inet_ntoa(inet_aton($name)) ;

    return $ip if $ip && $ip !~ /^127\./;

    $name = Ravada::display_ip();

    if ($name) {
        if ($name =~ /^\d+\.\d+\.\d+\.\d+$/) {
            $ip = $name;
        } else {
            $ip = inet_ntoa(inet_aton($name));
        }
    }
    return $ip if $ip && $ip !~ /^127\./;

187
    $ip = _ip_from_hostname();
188
189
    return $ip if $ip && $ip !~ /^127\./;

190
191
192
    $ip = $self->_interface_ip();
    return $ip if $ip && $ip !~ /^127/ && $ip =~ /^\d+\.\d+\.\d+\.\d+$/;

193
    warn "WARNING: I can't find the IP of host ".$self->host.", using localhost."
194
195
196
197
        ." This virtual machine won't be available from the network.";

    return '127.0.0.1';
}
198

199
200
sub _ip_from_hostname {
    my $res = Net::DNS::Resolver->new();
201
202
203

    my $name = hostfqdn();
    my $reply = $res->search($name);
204
205
206
207
208
209
210
    return if !$reply;

    for my $rr ($reply->answer) {
        return $rr->address if $rr->type eq 'A';
    }
}

211
212
213
214
215
sub _interface_ip {
    my $s = IO::Socket::INET->new(Proto => 'tcp');

    for my $if ( $s->if_list) {
        my $addr = $s->if_addr($if);
216
        return $addr if $addr && $addr !~ /^127\./;
217
218
219
220
    }
    return;
}

221
222
223
224
225
sub _check_memory {
    my $self = shift;
    my %args = @_;
    return if !exists $args{memory};

226
    die "ERROR: Low memory '$args{memory}' required ".int($MIN_MEMORY_MB/1024)." MB " if $args{memory} < $MIN_MEMORY_MB;
227
228
229
230
231
232
233
234
235
236
237
238
239
240
}

sub _check_disk {
    my $self = shift;
    my %args = @_;
    return if !exists $args{disk};

    die "ERROR: Low Disk '$args{disk}' required 1 Gb " if $args{disk} < 1024*1024;
}


sub _check_create_domain {
    my $self = shift;

241
242
    my %args = @_;

243
    $self->_check_readonly(@_);
244
245

    $self->_check_require_base(@_);
246
247
248
249
250
    $self->_check_memory(@_);
    $self->_check_disk(@_);

}

251
252
253
254
255
256
257
258
259
260
261
262
sub _check_require_base {
    my $self = shift;

    my %args = @_;
    return if !$args{id_base};

    my $base = $self->search_domain_by_id($args{id_base});
    die "ERROR: Domain ".$self->name." is not base"
            if !$base->is_base();

}

263
1;