Project

General

Profile

Download (120 KB) Statistics
| Branch: | Revision:
1
#!/usr/bin/perl
2

    
3
# All rights reserved and Copyright (c) 2020 Origo Systems ApS.
4
# This file is provided with no warranty, and is subject to the terms and conditions defined in the license file LICENSE.md.
5
# The license file is part of this source code package and its content is also available at:
6
# https://www.origo.io/info/stabiledocs/licensing/stabile-open-source-license
7

    
8
package Stabile::Servers;
9

    
10
use Error qw(:try);
11
use Data::UUID;
12
use Proc::Daemon;
13
use File::Basename;
14
use lib dirname (__FILE__);
15
use File::Basename;
16
use lib dirname (__FILE__);
17
use Stabile;
18
#use Encode::Escape;
19

    
20
$\ = ''; # Some of the above seems to set this to \n, resulting in every print appending a line feed
21

    
22
$cpuovercommision = $Stabile::config->get('CPU_OVERCOMMISION') || 1;
23
$dpolicy = $Stabile::config->get('DISTRIBUTION_POLICY') || 'disperse'; #"disperse" or "pack"
24
$amtpasswd = $Stabile::config->get('AMT_PASSWD') || "";
25
$brutalsleep = $Stabile::config->get('BRUTAL_SLEEP') || "";
26
$sshcmd = $sshcmd || $Stabile::sshcmd;
27

    
28
my %ahash; # A hash of accounts and associated privileges current user has access to
29

    
30
#my %options=();
31
#Getopt::Std::getopts("a:hfu:m:k:", \%options); # -a action -h help -f full-list (all users) -u uuid -m match pattern -k keywords
32

    
33
try {
34
    Init(); # Perform various initalization tasks
35
    process() if ($package);
36

    
37
    if ($action || %params) {
38
    	untie %register;
39
    	untie %networkreg;
40
        untie %nodereg;
41
        untie %xmlreg;
42
    }
43

    
44
} catch Error with {
45
	my $ex = shift;
46
    print $Stabile::q->header('text/html', '500 Internal Server Error') unless ($console);
47
	if ($ex->{-text}) {
48
        print "Got error: ", $ex->{-text}, " on line ", $ex->{-line}, "\n";
49
	} else {
50
	    print "Status=ERROR\n";
51
	}
52
} finally {
53
};
54

    
55
1;
56

    
57
sub getObj {
58
    my %h = %{@_[0]};
59
    $console = 1 if $h{"console"};
60
    $api = 1 if $h{"api"};
61
    my $uuid = $h{"uuid"};
62
    $uuid = $curuuid if ($uuid eq 'this');
63
    my $obj;
64
    $action = $action || $h{'action'};
65

    
66
    if ($h{'action'} eq 'destroy' || $action eq 'destroy' || $action eq 'destroyuserservers' || $action eq 'attach' || $action eq 'detach' || $action =~ /changepassword|sshaccess/) {
67
        $obj = \%h;
68
        return $obj;
69
    }
70

    
71
    # Allow specifying nicmac1 instead of uuid if known
72
    if (!$uuid) {
73
        $uuid = nicmac1ToUuid($h{"nicmac1"});
74
    }
75
    my $status = 'new';
76
    $status = $register{$uuid}->{'status'} if ($register{$uuid});
77

    
78
    my $objaction = lc $h{"action"};
79
    $objaction = "" if ($status eq "new");
80

    
81
    if ((!$uuid) && $status eq 'new') {
82
        my $ug = new Data::UUID;
83
        $uuid = $ug->create_str();
84
        if ($uripath =~ /servers(\.cgi)?\/(.+)/) {
85
            my $huuid = $2;
86
            if ($ug->to_string($ug->from_string($huuid)) eq $huuid) { # Check for valid uuid
87
                $uuid = $huuid;
88
            }
89
        }
90
    };
91
    unless ($uuid && length $uuid == 36) {
92
        $posterror .= "Status=Error Invalid uuid.\n";
93
        return;
94
    }
95

    
96
    my $dbobj = $register{$uuid} || {};
97

    
98
    my $name = $h{"name"} || $dbobj->{'name'};
99
    utf8::decode($name);
100
    my $memory = $h{"memory"} || $dbobj->{'memory'};
101
    my $vcpu = $h{"vcpu"} || $dbobj->{'vcpu'};
102
    my $boot = $h{"boot"} || $dbobj->{'boot'};
103
    my $loader = $h{"loader"} || $dbobj->{'loader'};
104
    my $image = $h{"image"} || $dbobj->{'image'};
105
    my $imagename = $h{"imagename"} || $dbobj->{'imagename'};
106
    if ($image && $image ne '--' && !($image =~ /^\//)) { # Image is registered by uuid - we find the path
107
        unless ( tie(%imagereg2,'Tie::DBI', Hash::Merge::merge({table=>'images', CLOBBER=>1}, $Stabile::dbopts)) ) {$posterror = "Unable to access image uuid register"; return;};
108
        $image = $imagereg2{$image}->{'path'};
109
        $imagename = $imagereg2{$image}->{'name'};
110
        untie %imagereg2;
111
        return unless ($image);
112
    }
113
    my $image2 = $h{"image2"} || $dbobj->{'image2'};
114
    my $image3 = $h{"image3"} || $dbobj->{'image3'};
115
    my $image4 = $h{"image4"} || $dbobj->{'image4'};
116
    my $image2name = $h{"image2name"} || $dbobj->{'image2name'};
117
    my $image3name = $h{"image3name"} || $dbobj->{'image3name'};
118
    my $image4name = $h{"image4name"} || $dbobj->{'image4name'};
119
    if ($image2 && $image2 ne '--' && !($image2 =~ /^\//)) { # Image2 is registered by uuid - we find the path
120
        unless ( tie(%imagereg2,'Tie::DBI', Hash::Merge::merge({table=>'images', CLOBBER=>1}, $Stabile::dbopts)) ) {$postreply = "Unable to access image uuid register"; return $postreply;};
121
        $image2 = $imagereg2{$image2}->{'path'};
122
        $image2name = $imagereg2{$image2}->{'name'};
123
        untie %imagereg2;
124
    }
125
    my $diskbus = $h{"diskbus"} || $dbobj->{'diskbus'};
126
    my $diskdev = "vda";
127
    my $diskdev2 = "vdb";
128
    my $diskdev3 = "vdc";
129
    my $diskdev4 = "vdd";
130
    if ($diskbus eq "ide") {$diskdev = "hda"; $diskdev2 = "hdb"; $diskdev3 = "hdc"; $diskdev4 = "hdd"};
131
    my $cdrom = $h{"cdrom"} || $dbobj->{'cdrom'};
132
    if ($cdrom && $cdrom ne '--' && !($cdrom =~ /^\//) && $cdrom ne 'virtio') {
133
        unless ( tie(%imagereg2,'Tie::DBI', Hash::Merge::merge({table=>'images', CLOBBER=>1}, $Stabile::dbopts)) ) {$postreply = "Unable to access image uuid register"; return $postreply;};
134
        $cdrom = $imagereg2{$cdrom}->{'path'};
135
        untie %imagereg2;
136
    }
137

    
138
    my $networkuuid1 = $h{"networkuuid1"} || $dbobj->{'networkuuid1'};
139
    if ($h{"networkuuid1"} eq "0") {$networkuuid1 = "0"}; #Stupid perl... :-)
140
    my $networkid1 = $h{"networkid1"} || $dbobj->{'networkid1'};
141
    my $networkname1 = $h{"networkname1"} || $dbobj->{'networkname1'};
142
    my $nicmodel1 = $h{"nicmodel1"} || $dbobj->{'nicmodel1'};
143
    my $nicmac1 = $h{"nicmac1"} || $dbobj->{'nicmac1'};
144
    if (!$nicmac1 || $nicmac1 eq "--") {$nicmac1 = randomMac();}
145

    
146
    my $networkuuid2 = $h{"networkuuid2"} || $dbobj->{'networkuuid2'};
147
    if ($h{"networkuuid2"} eq "0") {$networkuuid2 = "0"};
148
    my $networkid2 = $h{"networkid2"} || $dbobj->{'networkid2'};
149
    my $networkname2 = $h{"networkname2"} || $dbobj->{'networkname2'};
150
    my $nicmac2 = $h{"nicmac2"} || $dbobj->{'nicmac2'};
151
    if (!$nicmac2 || $nicmac2 eq "--") {$nicmac2 = randomMac();}
152

    
153
    my $networkuuid3 = $h{"networkuuid3"} || $dbobj->{'networkuuid3'};
154
    if ($h{"networkuuid3"} eq "0") {$networkuuid3 = "0"};
155
    my $networkid3 = $h{"networkid3"} || $dbobj->{'networkid3'};
156
    my $networkname3 = $h{"networkname3"} || $dbobj->{'networkname3'};
157
    my $nicmac3 = $h{"nicmac3"} || $dbobj->{'nicmac3'};
158
    if (!$nicmac3 || $nicmac3 eq "--") {$nicmac3 = randomMac();}
159

    
160
    my $action = $h{"action"};
161
    my $notes = $h{"notes"};
162
    $notes = $dbobj->{'notes'} if (!$notes || $notes eq '--');
163
    my $reguser = $dbobj->{'user'};
164
    my $autostart = ($h{"autostart"} ."") || $dbobj->{'autostart'};
165
    if ($autostart && $autostart ne "false") {$autostart = "true";}
166
    my $locktonode = ($h{"locktonode"} ."") || $dbobj->{'locktonode'};
167
    if ($locktonode && $locktonode ne "false") {$locktonode = "true";}
168
    my $mac;
169
    $mac = $dbobj->{'mac'} unless ($objaction eq 'start');
170
#    $mac = $h{"mac"} if ($isadmin && $locktonode eq 'true' && $h{"mac"});
171
    $mac = $h{"mac"} if ($isadmin && $h{"mac"});
172
    my $domuser = $h{"user"} || $user; # Set if user is trying to move server to another account
173

    
174
    # Sanity checks
175
    if (
176
        ($name && length $name > 255)
177
            || ($networkuuid1<0)
178
            || ($networkuuid2<0)
179
            || ($networkuuid3<0)
180
            || ($networkuuid1>1 && length $networkuuid1 != 36)
181
            || ($networkuuid2>1 && length $networkuuid2 != 36)
182
            || ($networkuuid3>1 && length $networkuuid3 != 36)
183
            || ($image && length $image > 255)
184
            || ($imagename && length $imagename > 255)
185
            || ($image2 && length $image2 > 255)
186
            || ($image3 && length $image3 > 255)
187
            || ($image4 && length $image4 > 255)
188
            || ($image2name && length $image2name > 255)
189
            || ($image3name && length $image3name > 255)
190
            || ($image4name && length $image4name > 255)
191
            || ($cdrom && length $cdrom > 255)
192
            || ($memory && ($memory<64 || $memory >1024*64))
193
    ) {
194
        $postreply .= "Status=ERROR Invalid server data: $name\n";
195
        return 0;
196
    }
197

    
198
    # Security check
199
    if ($status eq 'new' && (($action && $action ne '--' && $action ne 'save') || !$image || $image eq '--')) {
200
        $postreply .= "Status=ERROR Bad server data: $name\n";
201
        $postmsg = "Bad server data";
202
        return 0;
203
    }
204
    if (!$reguser && $status ne 'new'
205
        && !($name && $memory && $vcpu && $boot && $image && $diskbus && $networkuuid1 && $nicmodel1)) {
206
        $posterror .= "Status=ERROR Insufficient data: $name\n";
207
        return 0;
208
    }
209
    if (!$isadmin) {
210
        if (($networkuuid1>1 && $networkreg{$networkuuid1}->{'user'} ne $user)
211
            || ($networkuuid2>1 && $networkreg{$networkuuid2}->{'user'} ne $user)
212
            || ($networkuuid3>1 && $networkreg{$networkuuid3}->{'user'} ne $user)
213
        )
214
        {
215
            $postreply .= "Status=ERROR No privileges: $networkname1 $networkname2\n";
216
            return 0;
217
        }
218
        if ( ($reguser && ($user ne $reguser) && $action ) || ($reguser && $status eq "new"))
219
        {
220
            $postreply .= "Status=ERROR No privileges: $name\n";
221
            return 0;
222
        }
223
        if (!($image =~ /\/$user\//)
224
            || ($image2 && $image2 ne "--" && !($image2 =~ /\/$user\//))
225
            || ($image3 && $image3 ne "--" && !($image3 =~ /\/$user\//))
226
            || ($image4 && $image4 ne "--" && !($image4 =~ /\/$user\//))
227
        )
228
        {
229
            $postreply .= "Status=ERROR No image privileges: $name\n";
230
            return 0;
231
        }
232
    }
233

    
234
    # No action - regular save of domain properties
235
    $cdrom = '--' if ($cdrom eq 'virtio' && $action ne 'mountcd');
236

    
237
    $obj = {
238
        uuid => $uuid,
239
        status => $status,
240
        name => $name,
241
        memory => $memory,
242
        vcpu => $vcpu,
243
        image => $image,
244
        imagename => $imagename,
245
        image2 => $image2,
246
        image2name => $image2name,
247
        image3 => $image3,
248
        image3name => $image3name,
249
        image4 => $image4,
250
        image4name => $image4name,
251
        diskbus => $diskbus,
252
        cdrom => $cdrom,
253
        boot => $boot,
254
        loader=> $loader,
255
        networkuuid1 => $networkuuid1,
256
        networkid1 => $networkid1,
257
        networkname1 => $networkname1,
258
        nicmodel1 => $nicmodel1,
259
        nicmac1 => $nicmac1,
260
        networkuuid2 => $networkuuid2,
261
        networkid2 => $networkid2,
262
        networkname2 => $networkname2,
263
        nicmac2 => $nicmac2,
264
        networkuuid3 => $networkuuid3,
265
        networkid3 => $networkid3,
266
        networkname3 => $networkname3,
267
        nicmac3 => $nicmac3,
268
        notes => $notes,
269
        autostart => $autostart,
270
        locktonode => $locktonode,
271
        mac => $mac,
272
        user => $domuser
273
    };
274
    return $obj;
275
}
276

    
277
sub Init {
278
    # Tie database tables to hashes
279
    unless ( tie(%register,'Tie::DBI', Hash::Merge::merge({table=>'domains'}, $Stabile::dbopts)) ) {return "Unable to access image register"};
280
    unless ( tie(%networkreg,'Tie::DBI', Hash::Merge::merge({table=>'networks'}, $Stabile::dbopts)) ) {return "Unable to access network register"};
281
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac'}, $Stabile::dbopts)) ) {return "Unable to access nodes register"};
282
    unless ( tie(%xmlreg,'Tie::DBI', Hash::Merge::merge({table=>'domainxml'}, $Stabile::dbopts)) ) {return "Unable to access domainxml register"};
283

    
284
    # simplify globals initialized in Stabile.pm
285
    $tktuser = $tktuser || $Stabile::tktuser;
286
    $user = $user || $Stabile::user;
287
    $isadmin = $isadmin || $Stabile::isadmin;
288
    $privileges = $privileges || $Stabile::privileges;
289

    
290
    # Create aliases of functions
291
    *header = \&CGI::header;
292
    *to_json = \&JSON::to_json;
293

    
294
    *Showautostart = \&Autostartall;
295

    
296
    *do_save = \&Save;
297
    *do_tablelist = \&do_list;
298
    *do_jsonlist = \&do_list;
299
    *do_showautostart = \&action;
300
    *do_autostartall = \&privileged_action;
301
    *do_help = \&action;
302

    
303
    *do_start = \&privileged_action;
304
    *do_destroy = \&action;
305
    *do_shutdown = \&action;
306
    *do_suspend = \&action;
307
    *do_resume = \&action;
308
    *do_remove = \&privileged_action;
309
    *do_move = \&action;
310
    *do_mountcd = \&action;
311
    *do_changepassword = \&privileged_action;
312
    *do_sshaccess = \&privileged_action;
313

    
314
    *do_gear_start = \&do_gear_action;
315
    *do_gear_autostart = \&do_gear_action;
316
    *do_gear_showautostart = \&do_gear_action;
317
    *do_gear_autostartall = \&do_gear_action;
318
    *do_gear_remove = \&do_gear_action;
319
    *do_gear_changepassword = \&do_gear_action;
320
    *do_gear_sshaccess = \&do_gear_action;
321

    
322
}
323

    
324
sub do_list {
325
    my ($uuid, $action) = @_;
326
    if ($help) {
327
        return <<END
328
GET:uuid:
329
List servers current user has access to.
330
END
331
    }
332

    
333
    my $res;
334
    my $filter;
335
    my $statusfilter;
336
    my $uuidfilter;
337
    my $curserv = $register{$curuuid};
338
    if ($curuuid && ($isadmin || $curserv->{'user'} eq $user) && $uripath =~ /servers(\.cgi)?\/(\?|)(this)/) {
339
        $uuidfilter = $curuuid;
340
    } elsif ($uripath =~ /servers(\.cgi)?\/(\?|)(name|status)/) {
341
        $filter = $3 if ($uripath =~ /servers(\.cgi)?\/\??name(:|=)(.+)/);
342
        $filter = $1 if ($filter =~ /(.*)\*$/);
343
        $statusfilter = $4 if ($uripath =~ /servers(\.cgi)?\/\??(.+ AND )?status(:|=)(\w+)/);
344
    } elsif ($uripath =~ /servers(\.cgi)?\/(\w{8}-\w{4}-\w{4}-\w{4}-\w{12})/) {
345
        $uuidfilter = $2;
346
    }
347
    $filter = $1 if ($filter =~ /(.*)\*/);
348

    
349
    my $sysuuid;
350
    if ($params{'system'}) {
351
        $sysuuid = $params{'system'};
352
        $sysuuid = $cursysuuid || $curuuid if ($params{'system'} eq 'this');
353
    }
354
    my @curregvalues;
355
    my @regkeys;
356
    if ($fulllist && $isadmin) {
357
        @regkeys = keys %register;
358
    } elsif ($uuidfilter && $isadmin) {
359
        @regkeys = (tied %register)->select_where("uuid = '$uuidfilter'");
360
    } elsif ($sysuuid) {
361
        @regkeys = (tied %register)->select_where("system = '$sysuuid' OR uuid = '$sysuuid'");
362
    } else {
363
        @regkeys = (tied %register)->select_where("user = '$user'");
364
    }
365

    
366
    unless (tie(%sysreg,'Tie::DBI', Hash::Merge::merge({table=>'systems'}, $Stabile::dbopts)) ) {$res .= qq|{"status": "Error": "message": "Unable to access systems register"}|; return $res;};
367
    unless (tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {$res .= qq|{"status": "Error": "message": "Unable to access images register"}|; return $res;};
368

    
369
    foreach my $k (@regkeys) {
370
        $valref = $register{$k};
371
        # Only include VM's belonging to current user (or all users if specified and user is admin)
372
        if ($user eq $valref->{'user'} || $fulllist || ($uuidfilter && $isadmin)) {
373
            next unless (!$sysuuid || $valref->{'system'} eq $sysuuid || $valref->{'uuid'} eq $sysuuid);
374

    
375
            my $validatedref = validateItem($valref);
376
            my %val = %{$validatedref}; # Deference and assign to new ass array, effectively cloning object
377
            $val{'memory'} += 0;
378
            $val{'vcpu'} += 0;
379
            $val{'nodetype'} = 'parent';
380
            $val{'internalip'} = $networkreg{$val{'networkuuid1'}}->{'internalip'};
381
            $val{'self'} = 1 if ($curuuid && $curuuid eq $val{'uuid'});
382
            if ($action eq 'treelist') {
383
                if ($val{'system'} && $val{'system'} ne '') {
384
                    my $sysuuid = $val{'system'};
385
                    my $sysname = $sysreg{$sysuuid}->{'name'};
386
                    if (!$sysname) {
387
                        $sysname = $1 if ($sysname =~ /(.+)\..*/);
388
                        $sysname = $val{'name'};
389
                        $sysname =~ s/server/System/i;
390
                    }
391
                    $sysreg{$sysuuid} = {
392
                        uuid => $sysuuid,
393
                        name => $sysname,
394
                        user => 'irigo'
395
                    };
396

    
397
                    my %pval = %{$sysreg{$sysuuid}};
398
                    $pval{'nodetype'} = 'parent';
399
                    $pval{'status'} = '--';
400
                    $val{'nodetype'} = 'child';
401

    
402
                    my @children;
403
                    push @children,\%val;
404
                    $pval{'children'} = \@children;
405
                    push @curregvalues,\%pval;
406
                } else {
407
                    push @curregvalues,\%val;
408
                }
409
            } elsif ($filter || $statusfilter || $uuidfilter) { # List filtered servers
410
                my $fmatch;
411
                my $smatch;
412
                my $umatch;
413
                $fmatch = 1 if (!$filter || $val{'name'}=~/$filter/i);
414
                $smatch = 1 if (!$statusfilter || $statusfilter eq 'all'
415
                    || $statusfilter eq $val{'status'}
416
                );
417
                $umatch = 1 if ($val{'uuid'} eq $uuidfilter);
418
                if ($fmatch && $smatch && !$uuidfilter) {
419
                    push @curregvalues,\%val;
420
                } elsif ($umatch) {
421
                    push @curregvalues,\%val;
422
                    last;
423
                }
424
            } else {
425
                push @curregvalues,\%val;
426
            }
427
        }
428
    }
429
    tied(%sysreg)->commit;
430
    untie(%sysreg);
431
    untie %imagereg;
432
    @curregvalues = (sort {$a->{'status'} cmp $b->{'status'}} @curregvalues); # Sort by status
433

    
434
    # Sort @curregvalues
435
    @curregvalues = (sort {$b->{'name'} <=> $a->{'name'}} @curregvalues); # Always sort by name first
436
    my $sort = 'status';
437
    $sort = $2 if ($uripath =~ /sort\((\+|\-)(\S+)\)/);
438
    my $reverse;
439
    $reverse = 1 if ($1 eq '-');
440
    if ($reverse) { # sort reverse
441
        if ($sort =~ /memory|vcpu/) {
442
            @curregvalues = (sort {$b->{$sort} <=> $a->{$sort}} @curregvalues); # Sort as number
443
        } else {
444
            @curregvalues = (sort {$b->{$sort} cmp $a->{$sort}} @curregvalues); # Sort as string
445
        }
446
    } else {
447
        if ($sort =~ /memory|vcpu/) {
448
            @curregvalues = (sort {$a->{$sort} <=> $b->{$sort}} @curregvalues); # Sort as number
449
        } else {
450
            @curregvalues = (sort {$a->{$sort} cmp $b->{$sort}} @curregvalues); # Sort as string
451
        }
452
    }
453

    
454
    if ($action eq 'tablelist') {
455
        my $t2;
456

    
457
        if ($isadmin) {
458
            $t2 = Text::SimpleTable->new(36,20,20,10,10,12,7);
459
            $t2->row('uuid', 'name', 'imagename', 'memory', 'user', 'mac', 'status');
460
        } else {
461
            $t2 = Text::SimpleTable->new(36,20,20,10,10,7);
462
            $t2->row('uuid', 'name', 'imagename', 'memory', 'user', 'status');
463
        }
464
        $t2->hr;
465
        my $pattern = $options{m};
466
        foreach $rowref (@curregvalues){
467
            if ($pattern) {
468
                my $rowtext = $rowref->{'uuid'} . " " . $rowref->{'name'} . " " . $rowref->{'imagename'} . " " . $rowref->{'memory'}
469
                    . " " .  $rowref->{'user'} . " " . $rowref->{'status'};
470
                $rowtext .= " " . $rowref->{'mac'} if ($isadmin);
471
                next unless ($rowtext =~ /$pattern/i);
472
            }
473
            if ($isadmin) {
474
                $t2->row($rowref->{'uuid'}, $rowref->{'name'}, $rowref->{'imagename'}, $rowref->{'memory'},
475
                    $rowref->{'user'}, $rowref->{'mac'}, $rowref->{'status'});
476
            } else {
477
                $t2->row($rowref->{'uuid'}, $rowref->{'name'}, $rowref->{'imagename'}, $rowref->{'memory'},
478
                    $rowref->{'user'}, $rowref->{'status'});
479
            }
480
        }
481
        $res .= $t2->draw;
482
    } elsif ($console) {
483
        $res .= Dumper(\@curregvalues);
484
    } else {
485
        my $json_text;
486
        if ($uuidfilter && @curregvalues) {
487
            $json_text = to_json($curregvalues[0], {pretty => 1});
488
        } else {
489
            $json_text = to_json(\@curregvalues, {pretty => 1});
490
        }
491

    
492
        $json_text =~ s/\x/ /g;
493
        $json_text =~ s/\"\"/"--"/g;
494
        $json_text =~ s/null/"--"/g;
495
        $json_text =~ s/"autostart"\s?:\s?"true"/"autostart": true/g;
496
        $json_text =~ s/"autostart"\s?:\s?"--"/"autostart": false/g;
497
        $json_text =~ s/"locktonode"\s?:\s?"true"/"locktonode": true/g;
498
        $json_text =~ s/"locktonode"\s?:\s?"--"/"locktonode": false/g;
499
        $json_text =~ s/"loader"\s?:\s?"--"/"loader": "bios"/g;
500
        if ($action eq 'jsonlist' || $action eq 'list' || !$action) {
501
            $res .= $json_text;
502
        } else {
503
            $res .= qq|{"action": "$action", "identifier": "uuid", "label": "uuid", "items" : $json_text}|;
504
        }
505
    }
506
    return $res;
507
}
508

    
509
sub do_uuidshow {
510
    my ($uuid, $action) = @_;
511
    if ($help) {
512
        return <<END
513
GET:uuid:
514
Simple action for showing a single server.
515
END
516
    }
517
    my $res;
518
    $res .= $Stabile::q->header('text/plain') unless $console;
519
    my $u = $uuid || $options{u};
520
    if ($u || $u eq '0') {
521
        foreach my $uuid (keys %register) {
522
            if (($register{$uuid}->{'user'} eq $user || $register{$uuid}->{'user'} eq 'common' || $isadmin)
523
                && $uuid =~ /^$u/) {
524
                my %hash = %{$register{$uuid}};
525
                delete $hash{'action'};
526
                my $dump = Dumper(\%hash);
527
                $dump =~ s/undef/"--"/g;
528
                $res .= $dump;
529
                last;
530
            }
531
        }
532
    }
533
    return $res;
534
}
535

    
536
sub do_uuidlookup {
537
    if ($help) {
538
        return <<END
539
GET:uuid:
540
Simple action for looking up a uuid or part of a uuid and returning the complete uuid.
541
END
542
    }
543
    my $res;
544
    $res .= header('text/plain') unless $console;
545
    my $u = $options{u};
546
    $u = $curuuid unless ($u || $u eq '0');
547
    my $ruuid;
548
    if ($u || $u eq '0') {
549
        my $match;
550
        foreach my $uuid (keys %register) {
551
            if ($uuid =~ /^$u/) {
552
                $ruuid = $uuid if ($register{$uuid}->{'user'} eq $user || index($privileges,"a")!=-1);
553
                $match = 1;
554
                last;
555
            }
556
        }
557
        if (!$match && $isadmin) { # If no match and user is admin, do comprehensive lookup
558
            foreach my $uuid (keys %register) {
559
                if ($uuid =~ /^$u/ || $register{$uuid}->{'name'} =~ /^$u/) {
560
                    $ruuid = $uuid;
561
                    last;
562
                }
563
            }
564
        }
565
    }
566
    $res .= "$ruuid\n" if ($ruuid);
567
    return $res;
568
}
569

    
570
sub do_destroyuserservers {
571
    my ($uuid, $action, $obj) = @_;
572
    if ($help) {
573
        return <<END
574
GET:username:
575
Simple action for destroying all servers belonging to a user
576
END
577
    }
578
    $username = $obj->{username};
579
    my $res;
580
    $res .= $Stabile::q->header('text/plain') unless $console;
581

    
582
    destroyUserServers($username);
583
    $res .= $postreply;
584
    return $res;
585
}
586

    
587
sub do_removeuserservers {
588
    if ($help) {
589
        return <<END
590
GET::
591
Simple action for removing all servers belonging to a user
592
END
593
    }
594
    my $res;
595
    $res .= $Stabile::q->header('text/plain') unless $console;
596
    removeUserServers($user);
597
    $res .= $postreply;
598
    return $res;
599
}
600

    
601
sub do_getappid {
602
    my ($uuid, $action) = @_;
603
    if ($help) {
604
        return <<END
605
GET:uuid:
606
Simple action for getting the app id
607
END
608
    }
609
    my $res;
610
    $res .= $Stabile::q->header('text/plain') unless $console;
611
    $uuid = $uuid || $options{u};
612
    $uuid = $curuuid unless ($uuid);
613
    if ($uuid && $register{$uuid}) {
614
        unless ( tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {return "Unable to access image register"};
615
        $res .= "appid: ". $imagereg{$register{$uuid}->{image}}->{appid}, "\n";
616
        untie %imagereg;
617
    }
618
    return $res;
619
}
620

    
621
sub do_setrunning {
622
    my ($uuid, $action) = @_;
623
    if ($help) {
624
        return <<END
625
GET:uuid:
626
Simple action for setting status back to running after e.g. an upgrade
627
END
628
    }
629
    my $res;
630
    $res .= $Stabile::q->header('text/plain') unless $console;
631
    $uuid = $uuid || $options{u};
632
    $uuid = $curuuid unless ($uuid);
633
    if ($uuid && $register{$uuid}) {
634
        $register{$uuid}->{'status'} = 'running';
635
        $main::updateUI->({ tab => 'servers',
636
            user                => $user,
637
            uuid                => $uuid,
638
            status              => 'running' })
639

    
640
    };
641
    $res .= "Status=OK Set status of $register{$uuid}->{'name'} to running\n";
642
    return $res;
643
}
644

    
645
sub do_getappinfo {
646
    my ($uuid, $action) = @_;
647
    if ($help) {
648
        return <<END
649
GET:uuid:
650
Simple action for getting the apps basic info
651
END
652
    }
653
    my $res;
654
    $res .= $Stabile::q->header('application/json') unless $console;
655
    $uuid = $uuid || $options{u};
656
    $uuid = $curuuid unless ($uuid);
657
    my %appinfo;
658
    if ($uuid && $register{$uuid}) {
659
        unless ( tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {return "Unable to access image register"};
660
        $appinfo{'appid'} = $imagereg{$register{$uuid}->{image}}->{appid} || '';
661
        $appinfo{'managementlink'} = $imagereg{$register{$uuid}->{image}}->{managementlink} || '';
662
        $appinfo{'managementlink'} =~ s/{uuid}/$register{$uuid}->{networkuuid1}/;
663

    
664
        my $termlink = $imagereg{$register{$uuid}->{image}}->{terminallink} || '';
665
        $termlink =~ s/{uuid}/$register{$uuid}->{networkuuid1}/;
666
        my $burl = $baseurl;
667
        $burl = $1 if ($termlink =~ /\/stabile/ && $baseurl =~ /(.+)\/stabile/); # Unpretty, but works for now
668
        # $termlink = $1 if ($termlink =~ /\/(.+)/);
669
        # $termlink = "$burl/$termlink" unless ($termlink =~ /^http/ || !$termlink); # || $termlink =~ /^\//
670
        $appinfo{'terminallink'} = $termlink;
671

    
672
        $appinfo{'upgradelink'} = $imagereg{$register{$uuid}->{image}}->{upgradelink} || '';
673
        $appinfo{'upgradelink'} =~ s/{uuid}/$register{$uuid}->{networkuuid1}/;
674
        $appinfo{'version'} = $imagereg{$register{$uuid}->{image}}->{version} || '';
675
        $appinfo{'status'} = $register{$uuid}->{status} || '';
676
        $appinfo{'name'} = $register{$uuid}->{name} || '';
677
        $appinfo{'system'} = $register{$uuid}->{system} || '';
678

    
679
        if ($appinfo{'system'}) {
680
            unless (tie(%sysreg,'Tie::DBI', Hash::Merge::merge({table=>'systems'}, $Stabile::dbopts)) ) {$res .= qq|{"status": "Error": "message": "Unable to access systems register"}|; return $res;};
681
            $appinfo{'systemname'} = $sysreg{$appinfo{'system'}}->{name} || '';
682
            untie(%sysreg);
683
        } else {
684
            $appinfo{'systemname'} = $appinfo{'name'};
685
        }
686

    
687

    
688
        if ($appinfo{'appid'}) {
689
            my @regkeys = (tied %imagereg)->select_where("appid = '$appinfo{appid}'");
690
            foreach my $k (@regkeys) {
691
                my $imgref = $imagereg{$k};
692
                if ($imgref->{'path'} =~ /\.master\.qcow2$/ && $imgref->{'appid'} eq $appinfo{'appid'}
693
                     && $imgref->{'installable'} && $imgref->{'installable'} ne 'false'
694
                ) {
695
                    if ($imgref->{'version'} > $appinfo{'currentversion'}) {
696
                        $appinfo{'currentversion'} = $imgref->{'version'};
697
                        $appinfo{'appname'} = $imgref->{'name'};
698
                    }
699
                }
700
            }
701
        }
702

    
703
        untie %imagereg;
704
    }
705
    $appinfo{'appstoreurl'} = $appstoreurl;
706
    $appinfo{'dnsdomain'} = ($enginelinked)?$dnsdomain:'';
707
    $appinfo{'dnssubdomain'} = ($enginelinked)?substr($engineid, 0, 8):'';
708
    $appinfo{'uuid'} = $uuid;
709
    $appinfo{'user'} = $user;
710
    $appinfo{'remoteip'} = $remoteip;
711
    $res .= to_json(\%appinfo, { pretty => 1 });
712
    return $res;
713
}
714

    
715
sub do_removeserver {
716
    if ($help) {
717
        return <<END
718
GET:uuid:
719
Simple action for destroying and removing a single server
720
END
721
    }
722
    my $res;
723
    $res .= $Stabile::q->header('text/plain') unless $console;
724
    if ($curuuid) {
725
        removeUserServers($user, $curuuid, 1);
726
    }
727
    else {
728
        $postreply .= "Status=Error Unable to uninstall\n";
729
    }
730
    $res .= $postreply;
731
    return $res;
732
}
733

    
734
sub do_updateregister {
735
    if ($help) {
736
        return <<END
737
GET::
738
Update server register
739
END
740
    }
741
    my $res;
742
    $res .= $Stabile::q->header('text/plain') unless $console;
743
    return unless $isadmin;
744
    updateRegister();
745
    $res .= "Status=OK Updated server registry for all users\n";
746
    return $res;
747
}
748

    
749
sub Autostartall {
750
    my ($uuid, $action) = @_;
751
    if ($help) {
752
        return <<END
753
GET::
754
Start all servers marked for autostart. When called as showautostart only shows which would be started.
755
END
756
    }
757
    my $res;
758
    $res .= $Stabile::q->header('text/plain') unless $console;
759
    my $mes;
760
    return $res if ($isreadonly);
761

    
762
    # Wait for all pistons to be online
763
    my $nodedown;
764
    my $nodecount;
765
    for (my $i = 0; $i < 10; $i++) {
766
        $nodedown = 0;
767
        foreach my $node (values %nodereg) {
768
            if ($node->{'status'} ne 'running' && $node->{'status'} ne 'maintenance') {
769
                $nodedown = 1;
770
            }
771
            else {
772
                $nodecount++ unless ($node->{'status'} eq 'maintenance');
773
            }
774
        }
775
        if ($nodedown) {
776
            # Wait and see if nodes come online
777
            $mes = "Waiting for nodes...(" . (10 - $i) . ")\n";
778
            print $mes if ($console);
779
            $res .= $mes;
780
            sleep 5;
781
        }
782
        else {
783
            last;
784
        }
785
    }
786

    
787
    if (!%nodereg || $nodedown || !$nodecount) {
788
        $mes = "Not autostarting servers - not all nodes ready!\n";
789
        print $mes if ($console);
790
        $res .= $mes;
791
    }
792
    else {
793
        $mes = "$nodecount nodes ready - autostarting servers...\n";
794
        print $mes if ($console);
795
        $res .= $mes;
796
        if ($action eq "showautostart") {
797
            $mes = "Only showing which servers would be starting!\n";
798
            print $mes if ($console);
799
            $res .= $mes;
800
        }
801

    
802
        $Stabile::Networks::user = $user;
803
        require "$Stabile::basedir/cgi/networks.cgi";
804
        $Stabile::Networks::console = 1;
805

    
806
        foreach my $dom (values %register) {
807
            if ($dom->{'autostart'} eq '1' || $dom->{'autostart'} eq 'true') {
808
                $res .= "Checking if $dom->{'name'} ($dom->{'user'}, $dom->{'uuid'}) should be started\n";
809
                my $networkstatus1 = $networkreg{$dom->{'networkuuid1'}}->{status};
810
                my $networkstatus2 = ($networkreg{$dom->{'networkuuid2'}})?$networkreg{$dom->{'networkuuid2'}}->{status}:'';
811
                my $networkstatus3 = ($networkreg{$dom->{'networkuuid3'}})?$networkreg{$dom->{'networkuuid3'}}->{status}:'';
812
                my @dnets;
813
                push @dnets, $dom->{'networkuuid1'} if ($dom->{'networkuuid1'} && $dom->{'networkuuid1'} ne '--' && $networkstatus1 ne 'up');
814
                push @dnets, $dom->{'networkuuid2'} if ($dom->{'networkuuid2'} && $dom->{'networkuuid2'} ne '--' && $networkstatus2 ne 'up');
815
                push @dnets, $dom->{'networkuuid3'} if ($dom->{'networkuuid3'} && $dom->{'networkuuid3'} ne '--' && $networkstatus3 ne 'up');
816
                my $i;
817
                for ($i=0; $i<5; $i++) { # wait for status newer than 10 secs
818
                    validateItem($dom);
819
                    last if (time() - $dom->{timestamp} < 10);
820
                    $mes = "Waiting for newer timestamp, current is " . (time() - $dom->{timestamp}) . " old\n";
821
                    print $mes if ($console);
822
                    $res .= $mes;
823
                    sleep 2;
824
                }
825
                if (
826
                    $dom->{'status'} eq 'shutoff' || $dom->{'status'} eq 'inactive'
827
                ) {
828
                    if ($action eq "showautostart") { # Dry run
829
                        $mes = "Starting $dom->{'name'} ($dom->{'user'}, $dom->{'uuid'})\n";
830
                        print $mes if ($console);
831
                        $res .= $mes;
832
                    }
833
                    else {
834
                        $mes = "Starting $dom->{'name'} ($dom->{'user'}, $dom->{'uuid'})\n";
835
                        print $mes if ($console);
836
                        $res .= $mes;
837
                        $postreply = Start($dom->{'uuid'});
838
                        print $postreply if ($console);
839
                        $res .= $postreply;
840
#                        $mes = `REMOTE_USER=$dom->{'user'} $base/cgi/servers.cgi -a start -u $dom->{'uuid'}`;
841
                        print $mes if ($console);
842
                        $res .= $mes;
843
                        sleep 1;
844
                    }
845
                }
846
                elsif (@dnets) {
847
                    if ($action eq "showautostart") { # Dry run
848
                        foreach my $networkuuid (@dnets) {
849
                            $mes = "Would bring network $networkreg{$networkuuid}->{name} up for $dom->{'name'} ($dom->{'user'}, $dom->{'uuid'})\n";
850
                            print $mes if ($console);
851
                            $res .= $mes;
852
                        }
853
                    }
854
                    else {
855
                        foreach my $networkuuid (@dnets) {
856
                            $mes = "Bringing network $networkreg{$networkuuid}->{name} up for $dom->{'name'} ($dom->{'user'}, $dom->{'uuid'})\n";
857
                            print $mes if ($console);
858
                            $res .= $mes;
859
                            $mes = Stabile::Networks::Activate($networkuuid, 'activate');
860
                            print $mes if ($console);
861
                            $res .= $mes;
862
                            sleep 1;
863
                        }
864
                    }
865
                }
866
            } else {
867
                $res .= "Not marked for autostart $dom->{'name'} ($dom->{'user'}, $dom->{'uuid'})\n";
868
            }
869
        }
870
    }
871
    return $res;
872
}
873

    
874
sub do_listnodeavailability {
875
    if ($help) {
876
        return <<END
877
GET::
878
Utility call - only informational. Shows availability of nodes for starting servers.
879
END
880
    }
881
    my $res;
882
    $res .= $Stabile::q->header('application/json') unless ($console);
883
    my ($temp1, $temp2, $temp3, $temp4, $ahashref) = locateTargetNode();
884
    my @avalues = values %$ahashref;
885
    my @sorted_values = (sort {$b->{'index'} <=> $a->{'index'}} @avalues);
886
    $res .= to_json(\@sorted_values, { pretty => 1 });
887
    return $res;
888
}
889

    
890
sub do_listbillingdata {
891
    if ($help) {
892
        return <<END
893
GET::
894
List current billing data.
895
END
896
    }
897
    my $res;
898
    $res .= $Stabile::q->header('application/json') unless ($console);
899
    my $buser = URI::Escape::uri_unescape($params{'user'}) || $user;
900
    my %b;
901
    my @bmonths;
902
    if ($isadmin || $buser eq $user) {
903
        my $bmonth = URI::Escape::uri_unescape($params{'month'}) || $month;
904
        my $byear = URI::Escape::uri_unescape($params{'year'}) || $year;
905
        if ($bmonth eq "all") {
906
            @bmonths = ("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12");
907
        }
908
        else {
909
            @bmonths = ($bmonth);
910
        }
911

    
912
        unless ( tie(%billingreg,'Tie::DBI', Hash::Merge::merge({table=>'billing_domains', key=>'usernodetime'}, $Stabile::dbopts)) ) {return "Unable to access billing register"};
913

    
914
        my @nkeys = keys %nodereg;
915
        foreach my $bm (@bmonths) {
916
            my $vcpuavg = 0;
917
            my $memoryavg = 0;
918
            foreach my $nmac (@nkeys) {
919
                $vcpuavg += $billingreg{"$buser-$nmac-$byear-$bm"}->{'vcpuavg'};
920
                $memoryavg += $billingreg{"$buser-$nmac-$byear-$bm"}->{'memoryavg'};
921
            }
922
            $b{"$buser-$byear-$bm"} = {
923
                id        => "$buser-$byear-$bm",
924
                vcpuavg   => $vcpuavg,
925
                memoryavg => $memoryavg,
926
                month     => $bm + 0,
927
                year      => $byear + 0
928
            }
929
        }
930
        untie %billingreg;
931
    }
932
    my @bvalues = values %b;
933
    $res .= "{\"identifier\": \"id\", \"label\": \"id\", \"items\":" . to_json(\@bvalues) . "}";
934
    return $res;
935
}
936

    
937
# Print list of available actions on objects
938
sub do_plainhelp {
939
    my $res;
940
    $res .= $Stabile::q->header('text/plain') unless $console;
941
    $res .= <<END
942
new [name="name"]
943
* start: Starts a server
944
* destroy: Destroys a server, i.e. terminates the VM, equivalent of turning the power off a physical computer
945
* shutdown: Asks the operating system of a server to shut down via ACPI
946
* suspend: Suspends the VM, effectively putting the server to sleep
947
* resume: Resumes a suspended VM, effectively waking the server from sleep
948
* move [mac="mac"]: Moves a server to specified node. If no node is specified, moves to other node with highest availability
949
index
950
* delete: Deletes a server. Image and network are not deleted, only information about the server. Server cannot be
951
runing
952
* mountcd [cdrom="path"]: Mounts a cd rom
953
END
954
    ;
955
    return $res;
956
}
957

    
958
# Helper function
959
sub recurse($) {
960
	my($path) = @_;
961
	my @files;
962
	## append a trailing / if it's not there
963
	$path .= '/' if($path !~ /\/$/);
964
	## loop through the files contained in the directory
965
	for my $eachFile (glob($path.'*')) {
966
		## if the file is a directory
967
		if( -d $eachFile) {
968
			## pass the directory to the routine ( recursion )
969
			push(@files,recurse($eachFile));
970
		} else {
971
			push(@files,$eachFile);
972
		}
973
	}
974
	return @files;
975
}
976

    
977
sub Start {
978
    my ($uuid, $action, $obj) = @_;
979
    $dmac = $obj->{mac};
980
    $buildsystem = $obj->{buildsystem};
981
    $uistatus = $obj->{uistatus};
982
    if ($help) {
983
        return <<END
984
GET:uuid,mac:
985
Start a server. Supply mac for starting on specific node.
986
END
987
    }
988
    $dmac = $dmac || $params{'mac'};
989
    return "Status=ERROR No uuid\n" unless ($register{$uuid});
990
    my $serv = $register{$uuid};
991
    $postreply = '' if ($buildsystem);
992

    
993
    my $name = $serv->{'name'};
994
    utf8::decode($name);
995
    my $image = $serv->{'image'};
996
    my $image2 = $serv->{'image2'};
997
    my $image3 = $serv->{'image3'};
998
    my $image4 = $serv->{'image4'};
999
    my $memory = $serv->{'memory'};
1000
    my $vcpu = $serv->{'vcpu'};
1001
    my $vgpu = $serv->{'vgpu'};
1002
    my $dbstatus = $serv->{'status'};
1003
    my $mac = $serv->{'mac'};
1004
    my $macname = $serv->{'macname'};
1005
    my $networkuuid1 = $serv->{'networkuuid1'};
1006
    my $networkuuid2 = $serv->{'networkuuid2'};
1007
    my $networkuuid3 = $serv->{'networkuuid3'};
1008
    my $nicmodel1 = $serv->{'nicmodel1'};
1009
    my $nicmac1 = $serv->{'nicmac1'};
1010
    my $nicmac2 = $serv->{'nicmac2'};
1011
    my $nicmac3 = $serv->{'nicmac3'};
1012
    my $boot = $serv->{'boot'};
1013
    my $loader = $serv->{'loader'};
1014
    my $diskbus = $serv->{'diskbus'};
1015
    my $cdrom = $serv->{'cdrom'};
1016
    my $diskdev = "vda";
1017
    my $diskdev2 = "vdb";
1018
    my $diskdev3 = "vdc";
1019
    my $diskdev4 = "vdd";
1020
    if ($diskbus eq "ide") {$diskdev = "hda"; $diskdev2 = "hdb"; $diskdev3 = "hdc"; $diskdev4 = "hdd"};
1021

    
1022
    my $mem = $memory * 1024;
1023

    
1024
    unless ( tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {return "Unable to access image register"};
1025

    
1026
    my $img = $imagereg{$image};
1027
    my $imagename = $img->{'name'};
1028
    my $imagestatus = $img->{'status'};
1029
    my $img2 = $imagereg{$image2};
1030
    my $image2status = $img2->{'status'};
1031
    my $img3 = $imagereg{$image3};
1032
    my $image3status = $img3->{'status'};
1033
    my $img4 = $imagereg{$image4};
1034
    my $image4status = $img4->{'status'};
1035

    
1036
    if (!$imagereg{$image}) {
1037
        $postreply .= "Status=Error Image $image not found - please select a new image for your server, not starting $name\n";
1038
        untie %imagereg;
1039
        return $postreply;
1040
    }
1041
    untie %imagereg;
1042

    
1043
    if ($imagestatus ne "used" && $imagestatus ne "cloning") {
1044
        $postreply .= "Status=ERROR Image $imagename $image is $imagestatus, not starting $name\n";
1045
    } elsif ($image2 && $image2 ne '--' && $image2status ne "used" && $image2status ne "cloning") {
1046
        $postreply .= "Status=ERROR Image2 is $image2status, not starting $name\n";
1047
    } elsif ($image3 && $image3 ne '--' && $image3status ne "used" && $image3status ne "cloning") {
1048
        $postreply .= "Status=ERROR Image3 is $image3status, not starting $name\n";
1049
    } elsif ($image4 && $image4 ne '--' && $image4status ne "used" && $image4status ne "cloning") {
1050
        $postreply .= "Status=ERROR Image4 is $image4status, not starting $name\n";
1051
    } elsif (overQuotas($memory,$vcpu)) {
1052
        $main::syslogit->($user, "info", "Over quota starting a $dbstatus domain: $uuid");
1053
        $postreply .= "Status=ERROR Over quota - not starting $name\n";
1054
    # Status inactive is typically caused by a movepiston having problems. We should not start inactive servers since
1055
    # they could possibly be running even if movepiston is down. Movepiston on the node should be brought up to update
1056
    # the status, or the node should be removed from the stabile.
1057
    # We now allow to force start of inactive server when dmac is specified
1058
    } elsif ((!$dmac || $dmac eq $mac) && $dbstatus eq 'inactive' && $nodereg{$mac} && ($nodereg{$mac}->{'status'} eq 'inactive' || $nodereg{$mac}->{'status'} eq 'shutdown')) {
1059
        $main::syslogit->($user, "info", "Not starting inactive domain: $uuid (last seen on $mac)");
1060
        $postreply .= "Status=ERROR Not starting $name - Please bring up node $macname\n";
1061
    } elsif ($dbstatus eq 'inactive' || $dbstatus eq 'shutdown' || $dbstatus eq 'shutoff' || $dbstatus eq 'new') {
1062
        unless ($dmac && $isadmin) {
1063
            $dmac = $mac if ($dbstatus eq 'inactive'); # If movepiston crashed while shutting down, allow server to start on same node
1064
        }
1065
        $uistatus = "starting" unless ($uistatus);
1066
        my $hypervisor = getHypervisor($image);
1067
        my ($targetmac, $targetname, $targetip, $port) = locateTargetNode($uuid, $dmac, $mem, $vcpu, $image, $image2 ,$image3, $image4, $hypervisor);
1068

    
1069
        # Build XML for starting domain
1070
        my $graphics = "vnc";
1071
        $graphics = "rdp" if ($hypervisor eq "vbox");
1072
        my $net1 = $networkreg{$networkuuid1};
1073
        my $networkid1 = $net1->{'id'}; # Get the current vlan id of the network
1074
        my $net2 = $networkreg{$networkuuid2};
1075
        my $networkid2 = $net2->{'id'}; # Get the current vlan id of the network
1076
        my $net3 = $networkreg{$networkuuid2};
1077
        my $networkid3 = $net3->{'id'}; # Get the current vlan id of the network
1078
        my $networkid1ip = $net1->{'internalip'};
1079
        $networkid1ip = $net1->{'externalip'} if ($net1->{'type'} eq 'externalip');
1080

    
1081
        my $uname = $name . substr($uuid,0,8); # We don't enforce unique names, so we make them
1082
        $uname =~ s/[^[:ascii:]]/_/g; # Get rid of funny chars - they mess up Guacamole
1083
        $uname =~ s/\W/_/g;
1084

    
1085
        my $driver1;
1086
        my $driver2;
1087
        if ($hypervisor eq 'kvm') {
1088
            my $fmt1 = ($image =~ /\.qcow2$/)?'qcow2':'raw';
1089
            my $fmt2 = ($image2 =~ /\.qcow2$/)?'qcow2':'raw';
1090
            my $fmt3 = ($image3 =~ /\.qcow2$/)?'qcow2':'raw';
1091
            my $fmt4 = ($image4 =~ /\.qcow2$/)?'qcow2':'raw';
1092
            my $cache1 = ($image =~ /\/node\//)?'default':'writeback';
1093
            my $cache2 = ($image2 =~ /\/node\//)?'default':'writeback';
1094
            my $cache3 = ($image3 =~ /\/node\//)?'default':'writeback';
1095
            my $cache4 = ($image4 =~ /\/node\//)?'default':'writeback';
1096
            $driver1 = "\n      <driver name='qemu' type='$fmt1' cache='$cache1'/>";
1097
            $driver2 = "\n      <driver name='qemu' type='$fmt2' cache='$cache2'/>";
1098
            $driver3 = "\n      <driver name='qemu' type='$fmt3' cache='$cache3'/>";
1099
            $driver4 = "\n      <driver name='qemu' type='$fmt4' cache='$cache4'/>";
1100
        }
1101

    
1102
        my $networktype1 = "user";
1103
        my $networksource1 = "default";
1104
        my $networkforward1 = "bridge";
1105
        my $networkisolated1 = "no";
1106
        $networksource1 = "vboxnet0" if ($hypervisor eq "vbox");
1107
        if ($networkid1 eq '0') {
1108
            $networktype1 = "user";
1109
            $networkforward1 = "nat";
1110
            $networkisolated1 = "yes"
1111
        } elsif ($networkid1 == 1) {
1112
            $networktype1 = "network" ;
1113
            $networkforward1 = "nat";
1114
            $networkisolated1 = "yes"
1115
        } elsif ($networkid1 > 1) {
1116
            $networktype1 = "bridge";
1117
            $networksource1 = "br$networkid1";
1118
        }
1119
        my $networktype2 = "user";
1120
        my $networksource2 = "default";
1121
        my $networkforward2 = "bridge";
1122
        my $networkisolated2 = "no";
1123
        $networksource2 = "vboxnet0" if ($hypervisor eq "vbox");
1124
        if ($networkid2 eq '0') {
1125
            $networktype2 = "user";
1126
            $networkforward2 = "nat";
1127
            $networkisolated2 = "yes"
1128
        } elsif ($networkid2 == 1) {
1129
            $networktype2 = "network" ;
1130
            $networkforward2 = "nat";
1131
            $networkisolated2 = "yes"
1132
        } elsif ($networkid2 > 1) {
1133
            $networktype2 = "bridge";
1134
            $networksource2 = "br$networkid2";
1135
        }
1136
        my $networktype3 = "user";
1137
        my $networksource3 = "default";
1138
        my $networkforward3 = "bridge";
1139
        my $networkisolated3 = "no";
1140
        $networksource3 = "vboxnet0" if ($hypervisor eq "vbox");
1141
        if ($networkid3 eq '0') {
1142
            $networktype3 = "user";
1143
            $networkforward3 = "nat";
1144
            $networkisolated3 = "yes"
1145
        } elsif ($networkid3 == 1) {
1146
            $networktype3 = "network" ;
1147
            $networkforward3 = "nat";
1148
            $networkisolated3 = "yes"
1149
        } elsif ($networkid3 > 1) {
1150
            $networktype3 = "bridge";
1151
            $networksource3 = "br$networkid3";
1152
        }
1153

    
1154
        my $xml = "<domain type='$hypervisor' xmlns:qemu='http://libvirt.org/schemas/domain/qemu/1.0'>\n";
1155
#        if ($vgpu && $vgpu ne "--") {
1156
#            $xml .= <<ENDXML2
1157
#  <qemu:commandline>
1158
#    <qemu:arg value='-device'/>
1159
#    <qemu:arg value='vfio-pci,host=01:00.0,x-vga=on'/>
1160
#    <qemu:arg value='-device'/>
1161
#    <qemu:arg value='vfio-pci,host=02:00.0,x-vga=on'/>
1162
#  </qemu:commandline>
1163
#ENDXML2
1164
#            ;
1165
#        }
1166

    
1167
#    <qemu:arg value='-set'/>
1168
#    <qemu:arg value='device.hostdev1.x-vga=on'/>
1169
#    <qemu:arg value='-cpu'/>
1170
#	<qemu:arg value='host,kvm=off'/>
1171
#    <qemu:arg value='-device'/>
1172
#	<qemu:arg value='pci-assign,host=01:00.0,id=hostdev0,configfd=20,bus=pci.0,addr=0x6,x-pci-vendor-id=0x10DE,x-pci-device-id=0x11BA,x-pci-sub-vendor-id=0x10DE,x-pci-sub-device-id=0x0965'/>
1173

    
1174
#  <cpu mode='host-model'>
1175
#    <vendor>Intel</vendor>
1176
#    <model>core2duo</model>
1177
#  </cpu>
1178

    
1179
#    <loader readonly='yes' type='pflash'>/usr/share/OVMF/OVMF_CODE.fd</loader>
1180
#    <nvram template='/usr/share/OVMF/OVMF_VARS.fd'/>
1181
        my $loader_xml = <<ENDXML
1182
    <bootmenu enable='yes' timeout='200'/>
1183
    <smbios mode='sysinfo'/>
1184
ENDXML
1185
        ;
1186
if ($loader eq 'uefi') {
1187
    $loader_xml = <<ENDXML
1188
  <loader readonly='yes' secure='no' type='pflash'>/usr/share/ovmf/OVMF.fd</loader>
1189
  <nvram template='/usr/share/OVMF/OVMF_VARS.fd'>/tmp/guest_VARS.fd</nvram>
1190
ENDXML
1191
    ;
1192
}
1193

    
1194
        if ($vgpu && $vgpu ne "--") {
1195
            $xml .= <<ENDXML
1196
  <cpu mode='host-passthrough'>
1197
    <feature policy='disable' name='hypervisor'/>
1198
  </cpu>
1199
ENDXML
1200
;
1201
        } else {
1202
            $xml .= <<ENDXML
1203
  <cpu mode='host-model'>
1204
  </cpu>
1205
ENDXML
1206
            ;
1207
        }
1208
        $xml .=  <<ENDXML
1209
  <name>$uname</name>
1210
  <uuid>$uuid</uuid>
1211
  <memory>$mem</memory>
1212
  <vcpu>$vcpu</vcpu>
1213
  <os>
1214
    <type arch='x86_64' machine='pc'>hvm</type>
1215
    <boot dev='$boot'/>
1216
$loader_xml
1217
  </os>
1218
  <sysinfo type='smbios'>
1219
    <bios>
1220
      <entry name='vendor'>Origo</entry>
1221
    </bios>
1222
    <system>
1223
      <entry name='manufacturer'>Origo</entry>
1224
      <entry name='sku'>$networkid1ip</entry>
1225
    </system>
1226
  </sysinfo>
1227
  <features>
1228
ENDXML
1229
;
1230
        if ($vgpu && $vgpu ne "--") { $xml .= <<ENDXML
1231
    <kvm>
1232
      <hidden state='on'/>
1233
    </kvm>
1234
ENDXML
1235
;
1236
        }
1237
        $xml .= <<ENDXML
1238
    <pae/>
1239
    <acpi/>
1240
    <apic/>
1241
  </features>
1242
  <clock offset='localtime'>
1243
    <timer name='rtc' tickpolicy='catchup' track='guest'/>
1244
    <timer name='pit' tickpolicy='delay'/>
1245
    <timer name='hpet' present='no'/>
1246
  </clock>
1247
  <on_poweroff>destroy</on_poweroff>
1248
  <on_reboot>restart</on_reboot>½
1249
  <on_crash>restart</on_crash>
1250
  <devices>
1251
  <sound model='ich6'/>
1252
ENDXML
1253
;
1254
#        if ($vgpu && $vgpu ne "--") {
1255
#            $xml .= <<ENDXML2
1256
#  <hostdev mode='subsystem' type='pci' managed='yes'>
1257
#    <source>
1258
#      <address domain='0x0000' bus='0x01' slot='0x00' function='0x0' multifunction='on'/>
1259
#    </source>
1260
#  </hostdev>
1261
#  <hostdev mode='subsystem' type='pci' managed='yes'>
1262
#    <source>
1263
#      <address domain='0x0000' bus='0x02' slot='0x00' function='0x0' multifunction='on'/>
1264
#    </source>
1265
#  </hostdev>
1266
#ENDXML2
1267
#;
1268
#        }
1269
        if ($image && $image ne "" && $image ne "--") {
1270
						$xml .= <<ENDXML2
1271
    <disk type='file' device='disk'>
1272
      <source file='$image'/>$driver1
1273
      <target dev='$diskdev' bus='$diskbus'/>
1274
    </disk>
1275
ENDXML2
1276
;
1277
        };
1278

    
1279
        if ($image2 && $image2 ne "" && $image2 ne "--") {
1280
						$xml .= <<ENDXML2
1281
    <disk type='file' device='disk'>$driver2
1282
      <source file='$image2'/>
1283
      <target dev='$diskdev2' bus='$diskbus'/>
1284
    </disk>
1285
ENDXML2
1286
;
1287
        };
1288
        if ($image3 && $image3 ne "" && $image3 ne "--") {
1289
						$xml .= <<ENDXML2
1290
    <disk type='file' device='disk'>$driver3
1291
      <source file='$image3'/>
1292
      <target dev='$diskdev3' bus='$diskbus'/>
1293
    </disk>
1294
ENDXML2
1295
;
1296
        };
1297
        if ($image4 && $image4 ne "" && $image4 ne "--") {
1298
						$xml .= <<ENDXML2
1299
    <disk type='file' device='disk'>$driver4
1300
      <source file='$image4'/>
1301
      <target dev='$diskdev4' bus='$diskbus'/>
1302
    </disk>
1303
ENDXML2
1304
;
1305
        };
1306

    
1307
        unless ($image4 && $image4 ne '--' && $diskbus eq 'ide') {
1308
            if ($cdrom && $cdrom ne "" && $cdrom ne "--") {
1309
						$xml .= <<ENDXML3
1310
    <disk type='file' device='cdrom'>
1311
      <source file='$cdrom'/>
1312
      <target dev='hdd' bus='ide'/>
1313
      <readonly/>
1314
    </disk>
1315
ENDXML3
1316
;
1317
            } elsif ($hypervisor ne "vbox") {
1318
						$xml .= <<ENDXML3
1319
    <disk type='file' device='cdrom'>
1320
      <target dev='hdd' bus='ide'/>
1321
      <readonly/>
1322
    </disk>
1323
ENDXML3
1324
;
1325
            }
1326
        }
1327

    
1328
        $xml .= <<ENDXML4
1329
    <interface type='$networktype1'>
1330
      <source $networktype1='$networksource1'/>
1331
      <forward mode='$networkforward1'/>
1332
      <port isolated='$networkisolated1'/>
1333
      <model type='$nicmodel1'/>
1334
      <mac address='$nicmac1'/>
1335
    </interface>
1336
ENDXML4
1337
;
1338

    
1339
        if (($networkuuid2 && $networkuuid2 ne '--') || $networkuuid2 eq '0') {
1340
            $xml .= <<ENDXML5
1341
    <interface type='$networktype2'>
1342
      <source $networktype2='$networksource2'/>
1343
      <forward mode='$networkforward2'/>
1344
      <port isolated='$networkisolated2'/>
1345
      <model type='$nicmodel1'/>
1346
      <mac address='$nicmac2'/>
1347
    </interface>
1348
ENDXML5
1349
;
1350
        }
1351
        if (($networkuuid3 && $networkuuid3 ne '--') || $networkuuid3 eq '0') {
1352
            $xml .= <<ENDXML5
1353
    <interface type='$networktype3'>
1354
      <source $networktype3='$networksource3'/>
1355
      <forward mode='$networkforward3'/>
1356
      <port isolated='$networkisolated3'/>
1357
      <model type='$nicmodel1'/>
1358
      <mac address='$nicmac3'/>
1359
    </interface>
1360
ENDXML5
1361
;
1362
        }
1363
        $xml .= <<ENDXML6
1364
     <serial type='pty'>
1365
       <source path='/dev/pts/0'/>
1366
       <target port='0'/>
1367
     </serial>
1368
    <input type='tablet' bus='usb'/>
1369
    <graphics type='$graphics' port='$port'/>
1370
  </devices>
1371
</domain>
1372
ENDXML6
1373
;
1374

    
1375

    
1376
#    <graphics type='$graphics' port='$port' keymap='en-us'/>
1377
#     <console type='pty' tty='/dev/pts/0'>
1378
#       <source path='/dev/pts/0'/>
1379
#       <target port='0'/>
1380
#     </console>
1381
#     <graphics type='$graphics' port='-1' autoport='yes'/>
1382

    
1383
        $xmlreg{$uuid} = {
1384
            xml=>URI::Escape::uri_escape($xml)
1385
        };
1386

    
1387
        # Actually ask node to start domain
1388
        if ($targetmac) {
1389
            $register{$uuid}->{'mac'} = $targetmac;
1390
            $register{$uuid}->{'macname'} = $targetname;
1391
            $register{$uuid}->{'macip'} = $targetip;
1392

    
1393
            my $tasks = $nodereg{$targetmac}->{'tasks'};
1394
            $tasks .= "START $uuid $user\n";
1395
    # Also update allowed port forwards - obsolete
1396
    #        $tasks .= "PERMITOPEN $user\n";
1397
            $nodereg{$targetmac}->{'tasks'} = $tasks;
1398
            tied(%nodereg)->commit;
1399
            $uiuuid = $uuid;
1400
            $uidisplayip = $targetip;
1401
            $uidisplayport = $port;
1402
            $register{$uuid}->{'status'} = $uistatus;
1403
            $register{$uuid}->{'statustime'} = $current_time;
1404
            tied(%register)->commit;
1405

    
1406
            # Activate networks
1407
            require "$Stabile::basedir/cgi/networks.cgi";
1408
            Stabile::Networks::Activate($networkuuid1, 'activate');
1409
            Stabile::Networks::Activate($networkuuid2, 'activate') if ($networkuuid2 && $networkuuid2 ne '--');
1410
            Stabile::Networks::Activate($networkuuid3, 'activate') if ($networkuuid3 && $networkuuid3 ne '--');
1411

    
1412
            $main::syslogit->($user, "info", "Marked $name ($uuid) for ". $serv->{'status'} . " on $targetname ($targetmac)");
1413
            $postreply .= "Status=starting OK $uistatus ". $serv->{'name'} . "\n";
1414
        } else {
1415
            $main::syslogit->($user, "info", "Could not find $hypervisor target for creating $uuid ($image)");
1416
            $postreply .= "Status=ERROR problem $uistatus ". $serv->{'name'} . " (unable to locate target node)\n";
1417
        };
1418
    } else {
1419
        $main::syslogit->($user, "info", "Problem $uistatus a $dbstatus domain: $uuid");
1420
        $postreply .= "Status=ERROR problem $uistatus ". $serv->{'name'} . "\n";
1421
    }
1422
    #return ($uiuuid, $uidisplayip, $uidisplayport, $postreply, $targetmac);
1423
    return $postreply;
1424
}
1425

    
1426
sub do_attach {
1427
    my ($uuid, $action, $obj) = @_;
1428
    if ($help) {
1429
        return <<END
1430
GET:uuid,image:
1431
Attaches an image to a server as a disk device. Image must not be in use.
1432
END
1433
    }
1434
    my $dev = '';
1435
    my $imagenum = 0;
1436
    my $serv = $register{$uuid};
1437

    
1438
    if (!$serv->{'uuid'} || ($serv->{'status'} ne 'running' && $serv->{'status'} ne 'paused')) {
1439
        return "Status=Error Server must exist and be running\n";
1440
    }
1441
    my $macip = $serv->{macip};
1442
    my $image = $obj->{image} || $obj->{path};
1443
    if ($image && !($image =~ /^\//)) { # We have a uuid
1444
        unless ( tie(%imagereg2,'Tie::DBI', Hash::Merge::merge({table=>'images', CLOBBER=>1}, $Stabile::dbopts)) ) {return "Status=Error Unable to access images register\n"};
1445
        $image = $imagereg2{$image}->{'path'} if ($imagereg2{$image});
1446
        untie %imagereg2;
1447
    }
1448
    unless (tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {$postreply .= "Status=Error Unable to access images register\n"; return $postreply;};
1449
    unless ($macip && $imagereg{$image} && $imagereg{$image}->{'user'} eq $user && $serv->{'user'} eq $user)  {$postreply .= "Status=Error Invalid image or server\n"; return $postreply;};
1450
    if ($imagereg{$image}->{'status'} ne 'unused') {return "Status=Error Image $image is already in use ($imagereg{$image}->{'status'})\n"};
1451

    
1452
    my $cmd = qq|$sshcmd $macip "LIBVIRT_DEFAULT_URI=qemu:///system virsh domblklist $uuid"|;
1453
    my $res = `$cmd`;
1454
    unless ($res =~ /vdb\s+.+/) {$dev = 'vdb'; $imagenum = 2};
1455
    unless ($dev || $res =~ /vdc\s+.+/)  {$dev = 'vdc'; $imagenum = 3};
1456
    unless ($dev || $res =~ /vdd\s+.+/)  {$dev = 'vdd'; $imagenum = 4};
1457
    if (!$dev) {
1458
        $postreply = "Status=Error No more images can be attached\n";
1459
    } else {
1460
        my $xml = <<END
1461
<disk type='file' device='disk'>
1462
  <driver type='qcow2' name='qemu' cache='default'/>
1463
  <source file='$image'/>
1464
  <target dev='$dev' bus='virtio'/>
1465
</disk>
1466
END
1467
;
1468
        $cmd = qq|$sshcmd $macip "echo \\"$xml\\" > /tmp/attach-device-$uuid.xml"|;
1469
        $res = `$cmd`;
1470
        $res .= `$sshcmd $macip LIBVIRT_DEFAULT_URI=qemu:///system virsh attach-device $uuid /tmp/attach-device-$uuid.xml`;
1471
        chomp $res;
1472
        if ($res =~ /successfully/) {
1473
            $postreply .= "Status=OK Attaching $image to $dev\n";
1474
            $imagereg{$image}->{'status'} = 'active';
1475
            $imagereg{$image}->{'domains'} = $uuid;
1476
            $imagereg{$image}->{'domainnames'} = $serv->{'name'};
1477
            $serv->{"image$imagenum"} = $image;
1478
            $serv->{"image$imagenum"."name"} = $imagereg{$image}->{'name'};
1479
            $serv->{"image$imagenum"."type"} = 'qcow2';
1480
        } else {
1481
            $postreply .= "Status=Error Unable to attach image $image to $dev ($res)\n";
1482
        }
1483
    }
1484
    untie %imagereg;
1485
    return $postreply;
1486
}
1487

    
1488
sub do_detach {
1489
    my ($uuid, $action, $obj) = @_;
1490
    if ($help) {
1491
        return <<END
1492
GET:uuid,image:
1493
Detaches a disk device and the associated image from a running server. All associated file-systems within the server should be unmounted before detaching, otherwise data loss i very probable. Use with care.
1494
END
1495
    }
1496
    my $dev = '';
1497
    my $serv = $register{$uuid};
1498

    
1499
    if (!$serv->{'uuid'} || ($serv->{'status'} ne 'running' && $serv->{'status'} ne 'paused')) {
1500
        return "Status=Error Server must exist and be running\n";
1501
    }
1502
    my $macip = $serv->{macip};
1503

    
1504
    my $image = $obj->{image} || $obj->{path} || $serv->{'image2'};
1505
    if ($image && !($image =~ /^\//)) { # We have a uuid
1506
        unless ( tie(%imagereg2,'Tie::DBI', Hash::Merge::merge({table=>'images', CLOBBER=>1}, $Stabile::dbopts)) ) {return "Unable to access images register"};
1507
        $image = $imagereg2{$image}->{'path'} if ($imagereg2{$image});
1508
        untie %imagereg2;
1509
    }
1510
    unless (tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {$postreply .= "Status=Error Unable to access images register\n"; return $postreply;};
1511
    unless ($macip && $imagereg{$image} && $imagereg{$image}->{'user'} eq $user && $serv->{'user'} eq $user)  {$postreply .= "Status=Error Invalid image or server. Server must have a secondary image attached.\n"; return $postreply;};
1512

    
1513
    my $cmd = qq|$sshcmd $macip "LIBVIRT_DEFAULT_URI=qemu:///system virsh domblklist $uuid"|;
1514
    my $res = `$cmd`;
1515
    $dev = $1 if ($res =~ /(vd.)\s+.+$image/);
1516
    if (!$dev) {
1517
        $postreply =  qq|Status=Error Image $image, $cmd, is not currently attached\n|;
1518
    } elsif ($dev eq 'vda') {
1519
        $postreply = "Status=Error You cannot detach the primary image\n";
1520
    } else {
1521
        $res = `$sshcmd $macip LIBVIRT_DEFAULT_URI=qemu:///system virsh detach-disk $uuid $dev`;
1522
        chomp $res;
1523
        if ($res =~ /successfully/) {
1524
            $postreply .= "Status=OK Detaching image $image, $imagereg{$image}->{'uuid'} from $dev\n";
1525
            my $imagenum;
1526
            $imagenum = 2 if ($serv->{'image2'} eq $image);
1527
            $imagenum = 3 if ($serv->{'image3'} eq $image);
1528
            $imagenum = 4 if ($serv->{'image4'} eq $image);
1529
            $imagereg{$image}->{'status'} = 'unused';
1530
            $imagereg{$image}->{'domains'} = '';
1531
            $imagereg{$image}->{'domainnames'} = '';
1532
            if ($imagenum) {
1533
                $serv->{"image$imagenum"} = '';
1534
                $serv->{"image$imagenum"."name"} = '';
1535
                $serv->{"image$imagenum"."type"} = '';
1536
            }
1537
        } else {
1538
            $postreply .= "Status=Error Unable to attach image $image to $dev ($res)\n";
1539
        }
1540
    }
1541
    untie %imagereg;
1542
    return $postreply;
1543
}
1544

    
1545
sub Destroy {
1546
    my ($uuid, $action, $obj) = @_;
1547
    if ($help) {
1548
        return <<END
1549
GET:uuid,wait:
1550
Marks a server for halt, i.e. pull the plug if regular shutdown does not work or is not desired. Server and storage is preserved.
1551
END
1552
    }
1553
    my $uistatus = 'destroying';
1554
    my $name = $register{$uuid}->{'name'};
1555
    my $mac = $register{$uuid}->{'mac'};
1556
    my $macname = $register{$uuid}->{'macname'};
1557
    my $dbstatus = $register{$uuid}->{'status'};
1558
    my $wait = $obj->{'wait'};
1559
    if ($dbstatus eq 'running' or $dbstatus eq 'paused'
1560
        or $dbstatus eq 'shuttingdown' or $dbstatus eq 'starting'
1561
        or $dbstatus eq 'destroying' or $dbstatus eq 'upgrading'
1562
        or $dbstatus eq 'suspending' or $dbstatus eq 'resuming') {
1563
        if ($wait) {
1564
            my $username = $register{$uuid}->{'user'} || $user;
1565
            $username = $user unless ($isadmin);
1566
            $postreply = destroyUserServers($username, 1, $uuid);
1567
        } else {
1568
            my $node = $nodereg{$mac};
1569
            my $tasks = $node->{'tasks'};
1570
            $node->{'tasks'} = $tasks . "DESTROY $uuid $user\n";
1571
            tied(%nodereg)->commit;
1572
            $register{$uuid}->{'status'} = $uistatus;
1573
            $register{$uuid}->{'statustime'} = $current_time;
1574
            $uiuuid = $uuid;
1575
            $main::syslogit->($user, "info", "Marked $name ($uuid) for $uistatus on $macname ($mac)");
1576
            $postreply .= "Status=destroying $uistatus ". $register{$uuid}->{'name'} . "\n";
1577
        }
1578
    } else {
1579
        $main::syslogit->($user, "info", "Problem $uistatus a $dbstatus domain: $name ($uuid)");
1580
        $postreply .= "Status=ERROR problem $uistatus $name\n";
1581
    }
1582
    return $postreply;
1583
}
1584

    
1585
sub getHypervisor {
1586
	my $image = shift;
1587
	# Produce a mapping of image file suffixes to hypervisors
1588
	my %idreg;
1589
    unless ( tie(%idreg,'Tie::DBI', Hash::Merge::merge({table=>'nodeidentities', key=>'identity'}, $Stabile::dbopts)) ) {return "Unable to access nodeidentities register"};
1590
    my @idvalues = values %idreg;
1591
	my %formats;
1592
	foreach my $val (@idvalues) {
1593
		my %h = %$val;
1594
		foreach (split(/,/,$h{'formats'})) {
1595
			$formats{lc $_} = $h{'hypervisor'}
1596
		}
1597
	}
1598
	untie %idreg;
1599

    
1600
	# and then determine the hypervisor in question
1601
	my $hypervisor = "vbox";
1602
	my ($pathname, $path, $suffix) = fileparse($image, '\.[^\.]*');
1603
	$suffix = substr $suffix, 1;
1604
	my $hypervisor = $formats{lc $suffix};
1605
	return $hypervisor;
1606
}
1607

    
1608
sub nicmac1ToUuid {
1609
    my $nicmac1 = shift;
1610
    my $uuid;
1611
    return $uuid unless $nicmac1;
1612
    my @regkeys = (tied %register)->select_where("user = '$user' AND nicmac1 = '$nicmac1");
1613
	foreach my $k (@regkeys) {
1614
	    my $val = $register{$k};
1615
		my %h = %$val;
1616
		if (lc $h{'nicmac1'} eq lc $nicmac1 && $user eq $h{'user'}) {
1617
    		$uuid =  $h{'uuid'};
1618
    		last;
1619
		}
1620
	}
1621
	return $uuid;
1622
}
1623

    
1624
sub randomMac {
1625
	my ( %vendor, $lladdr, $i );
1626
#	$lladdr = '00';
1627
	$lladdr = '52:54:00';# KVM vendor string
1628
	while ( ++$i )
1629
#	{ last if $i > 10;
1630
	{ last if $i > 6;
1631
		$lladdr .= ':' if $i % 2;
1632
		$lladdr .= sprintf "%" . ( qw (X x) [int ( rand ( 2 ) ) ] ), int ( rand ( 16 ) );
1633
	}
1634
	return $lladdr;
1635
}
1636

    
1637
sub overQuotas {
1638
    my $meminc = shift;
1639
    my $vcpuinc = shift;
1640
	my $usedmemory = 0;
1641
	my $usedvcpus = 0;
1642
	my $overquota = 0;
1643
    return $overquota if ($isadmin || $Stabile::userprivileges =~ /a/); # Don't enforce quotas for admins
1644

    
1645
	my $memoryquota = $usermemoryquota;
1646
	my $vcpuquota = $uservcpuquota;
1647

    
1648
	if (!$memoryquota || !$vcpuquota) { # 0 or empty quota means use defaults
1649
        $memoryquota = $memoryquota || $Stabile::config->get('MEMORY_QUOTA');
1650
        $vcpuquota = $vcpuquota || $Stabile::config->get('VCPU_QUOTA');
1651
    }
1652

    
1653
    my @regkeys = (tied %register)->select_where("user = '$user'");
1654
	foreach my $k (@regkeys) {
1655
	    my $val = $register{$k};
1656
		if ($val->{'user'} eq $user && $val->{'status'} ne "shutoff" &&
1657
		    $val->{'status'} ne "inactive" && $val->{'status'} ne "shutdown" ) {
1658

    
1659
		    $usedmemory += $val->{'memory'};
1660
		    $usedvcpus += $val->{'vcpu'};
1661
		}
1662
	}
1663
	$overquota = $usedmemory+$meminc if ($memoryquota!=-1 && $usedmemory+$meminc > $memoryquota); # -1 means no quota
1664
	$overquota = $usedvcpus+$vcpuinc if ($vcpuquota!=-1 && $usedvcpus+$vcpuinc > $vcpuquota);
1665
	return $overquota;
1666
}
1667

    
1668
sub validateItem {
1669
    my $valref = shift;
1670
    my $img = $imagereg{$valref->{'image'}};
1671
    my $imagename = $img->{'name'};
1672
    $valref->{'imagename'} = $imagename if ($imagename);
1673
    my $imagetype = $img->{'type'};
1674
    $valref->{'imagetype'} = $imagetype if ($imagetype);
1675

    
1676
    # imagex may be registered by uuid instead of path - find the path
1677
    # We now support up to 4 images
1678
    for (my $i=2; $i<=4; $i++) {
1679
        if ($valref->{"image$i"} && $valref->{"image$i"} ne '--' && !($valref->{"image$i"} =~ /^\//)) {
1680
            unless ( tie(%imagereg2,'Tie::DBI', Hash::Merge::merge({table=>'images', CLOBBER=>1}, $Stabile::dbopts)) ) {return "Unable to access images register"};
1681
            $valref->{"image$i"} = $imagereg2{$valref->{"image$i"}}->{'path'};
1682
            untie %imagereg2;
1683
        }
1684

    
1685
        my $imgi = $imagereg{$valref->{"image$i"}};
1686
        $valref->{"image$i" . 'name'} = $imgi->{'name'} || $valref->{"image$i" . 'name'};
1687
        $valref->{"image$i" . 'type'} = $imgi->{'type'} || $valref->{"image$i" . 'type'};
1688
    }
1689

    
1690
    my $net1 = $networkreg{$valref->{'networkuuid1'}};
1691
    my $networkname1 = $net1->{'name'};
1692
    $valref->{'networkname1'} = $networkname1 if ($networkname1);
1693
    my $net2 = $networkreg{$valref->{'networkuuid2'}};
1694
    my $networkname2 = $net2->{'name'};
1695
    $valref->{'networkname2'} = $networkname2 if ($networkname2);
1696
    my $name = $valref->{'name'};
1697
    $valref->{'name'} = $imagename unless $name;
1698

    
1699
    if ($valref->{'status'} eq "shutoff" || $valref->{'status'} eq "inactive") {
1700
        my $node = $nodereg{$valref->{'mac'}};
1701
        if ($valref->{'image'} =~ /\/mnt\/stabile\/node\//) {
1702
            $valref->{'mac'} = $img->{'mac'};
1703
            $valref->{'macname'} = $node->{'name'};
1704
            $valref->{'macip'} = $node->{'ip'};
1705
        } elsif ($valref->{'image2'} =~ /\/mnt\/stabile\/node\//) {
1706
            $valref->{'mac'} = $imagereg{$valref->{'image2'}}->{'mac'};
1707
            $valref->{'macname'} = $node->{'name'};
1708
            $valref->{'macip'} = $node->{'ip'};
1709
        } elsif ($valref->{'image3'} =~ /\/mnt\/stabile\/node\//) {
1710
            $valref->{'mac'} = $imagereg{$valref->{'image3'}}->{'mac'};
1711
            $valref->{'macname'} = $node->{'name'};
1712
            $valref->{'macip'} = $node->{'ip'};
1713
        } elsif ($valref->{'image4'} =~ /\/mnt\/stabile\/node\//) {
1714
            $valref->{'mac'} = $imagereg{$valref->{'image4'}}->{'mac'};
1715
            $valref->{'macname'} = $node->{'name'};
1716
            $valref->{'macip'} = $node->{'ip'};
1717
        }
1718
    }
1719
# Mark domains we have heard from in the last 20 secs as inactive
1720
    my $dbtimestamp = 0;
1721
    $dbtimestamp = $register{$valref->{'uuid'}}->{'timestamp'} if ($register{$valref->{'uuid'}});
1722
    my $timediff = $current_time - $dbtimestamp;
1723
    if ($timediff >= 20) {
1724
        if  (! ($valref->{'status'} eq "shutoff"
1725
                || $valref->{'status'} eq "starting"
1726
            #    || $valref->{'status'} eq "shuttingdown"
1727
            #    || $valref->{'status'} eq "destroying"
1728
                || ($valref->{'status'} eq "moving" && $timediff<40)
1729
            )) { # Move has probably failed
1730
            $valref->{'status'} = "inactive";
1731
            $imagereg{$valref->{'image'}}->{'status'} = "used" if ($valref->{'image'} && $imagereg{$valref->{'image'}});
1732
            $imagereg{$valref->{'image2'}}->{'status'} = "used" if ($valref->{'image2'} && $imagereg{$valref->{'imag2'}});
1733
            $imagereg{$valref->{'image3'}}->{'status'} = "used" if ($valref->{'image3'} && $imagereg{$valref->{'image3'}});
1734
            $imagereg{$valref->{'image4'}}->{'status'} = "used" if ($valref->{'image4'} && $imagereg{$valref->{'image4'}});
1735
        }
1736
    };
1737
    return $valref;
1738
}
1739

    
1740
# Run through all domains and mark domains we have heard from in the last 20 secs as inactive
1741
sub updateRegister {
1742
    unless ( tie(%userreg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {return "Unable to access user register"};
1743
    unless ( tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {return "Unable to access images register"};
1744

    
1745
    my @regkeys = (tied %register)->select_where("user = '$user'");
1746

    
1747
    foreach my $k (@regkeys) {
1748
        my $valref = $register{$k};
1749
        next unless ($userreg{$valref->{'user'}});
1750
        my $dbtimestamp = $valref->{'timestamp'};
1751
        my $dbstatus = $valref->{'status'};
1752
        my $timediff = $current_time - $dbtimestamp;
1753
        my $imgstatus;
1754
        my $domstatus;
1755
        if ($timediff >= 20) {
1756
            if  ( $valref->{'status'} eq "shutoff" ) {
1757
                $imgstatus = 'used';
1758
            } elsif ((  $valref->{'status'} eq "starting"
1759
                            || $valref->{'status'} eq "shuttingdown"
1760
                        ) && $timediff>50) {
1761
                $imgstatus = 'used';
1762
                $domstatus = 'inactive';
1763
            } elsif ($valref->{'status'} eq "destroying" || $valref->{'status'} eq "moving") {
1764
                ;
1765
            } else {
1766
                $domstatus = 'inactive';
1767
                $imgstatus = 'used';
1768
            }
1769
            $valref->{'status'} = $domstatus if ($domstatus);
1770
            my $image = $valref->{'image'};
1771
            my $image2 = $valref->{'image2'};
1772
            my $image3 = $valref->{'image3'};
1773
            my $image4 = $valref->{'image4'};
1774
            $imagereg{$image}->{'status'} = $imgstatus if ($imgstatus);
1775
            $imagereg{$image2}->{'status'} = $imgstatus if ($image2 && $imgstatus);
1776
            $imagereg{$image3}->{'status'} = $imgstatus if ($image3 && $imgstatus);
1777
            $imagereg{$image4}->{'status'} = $imgstatus if ($image4 && $imgstatus);
1778
            if ($domstatus eq 'inactive ' && $dbstatus ne 'inactive') {
1779
                $main::updateUI->({ tab=>'servers',
1780
                                    user=>$valref->{'user'},
1781
                                    uuid=>$valref->{'uuid'},
1782
                                    sender=>'updateRegister',
1783
                                    status=>'inactive'})
1784
            }
1785
        };
1786

    
1787
    }
1788
    untie %userreg;
1789
    untie %imagereg;
1790
}
1791

    
1792

    
1793
sub locateTargetNode {
1794
    my ($uuid, $dmac, $mem, $vcpu, $image, $image2, $image3, $image4, $hypervisor, $smac)= @_;
1795
    my $targetname;
1796
    my $targetip;
1797
    my $port;
1798
    my $targetnode;
1799
    my $targetindex; # Availability index of located target node
1800
    my %avhash;
1801

    
1802
    my $mnode = $register{$uuid};
1803
    $dmac = $mnode->{'mac'}
1804
        if (!$dmac
1805
            && $mnode->{'locktonode'} eq 'true'
1806
            && $mnode->{'mac'}
1807
            && $mnode->{'mac'} ne '--'
1808
            );
1809

    
1810
    $dmac = '' unless ($isadmin); # Only allow admins to select specific node
1811
    if ($dmac && !$nodereg{$dmac}) {
1812
        $main::syslogit->($user, "info", "The target node $dmac no longer exists, starting $uuid on another node if possible");
1813
        $dmac = '';
1814
    }
1815

    
1816
    my $imageonnode = ($image =~ /\/mnt\/stabile\/node\//
1817
                                          || $image2 =~ /\/mnt\/stabile\/node\//
1818
                                          || $image3 =~ /\/mnt\/stabile\/node\//
1819
                                          || $image4 =~ /\/mnt\/stabile\/node\//
1820
                                          );
1821

    
1822
    foreach $node (values %nodereg) {
1823
        my $nstatus = $node->{'status'};
1824
        my $maintenance = $node->{'maintenance'};
1825
        my $nmac = $node->{'mac'};
1826

    
1827
        if (($nstatus eq 'running' || $nstatus eq 'asleep' || $nstatus eq 'maintenance' || $nstatus eq 'waking')
1828
         && $smac ne $nmac
1829
         && (( ($node->{'memfree'} > $mem+512*1024)
1830
         && (($node->{'vmvcpus'} + $vcpu) <= ($cpuovercommision * $node->{'cpucores'} * $node->{'cpucount'})) ) || $action eq 'listnodeavailability')
1831
        ) {
1832
        # Determine how available this node is
1833
        # Available memory
1834
            my $memweight = 0.2; # memory weighing factor
1835
            my $memindex = $avhash{$nmac}->{'memindex'} = int(100* $memweight* $node->{'memfree'} / (1024*1024) )/100;
1836
        # Free cores
1837
            my $cpuindex = $avhash{$nmac}->{'cpuindex'} = int(100*($cpuovercommision * $node->{'cpucores'} * $node->{'cpucount'} - $node->{'vmvcpus'} - $node->{'reservedvcpus'}))/100;
1838
        # Asleep - not asleep gives a +3
1839
            my $sleepindex = $avhash{$nmac}->{'sleepindex'} = ($node->{'status'} eq 'asleep' || $node->{'status'} eq 'waking')?'0':'3';
1840
            $avhash{$nmac}->{'vmvcpus'} = $node->{'vmvcpus'};
1841
#            $avhash{$nmac}->{'cpucommision'} = $cpuovercommision * $node->{'cpucores'} * $node->{'cpucount'};
1842
#            $avhash{$nmac}->{'cpureservation'} = $node->{'vmvcpus'} + $node->{'reservedvcpus'};
1843

    
1844
            $avhash{$nmac}->{'name'} = $node->{'name'};
1845
            $avhash{$nmac}->{'mac'} = $node->{'mac'};
1846

    
1847
            my $aindex = $memindex + $cpuindex + $sleepindex;
1848
        # Don't use nodes that are out of memory of cores
1849
            $aindex = 0 if ($memindex <= 0 || $cpuindex <= 0);
1850
            $avhash{$nmac}->{'index'} = $aindex;
1851

    
1852
            $avhash{$nmac}->{'storfree'} = $node->{'storfree'};
1853
            $avhash{$nmac}->{'memfree'} = $node->{'memfree'};
1854
            $avhash{$nmac}->{'ip'} = $node->{'ip'};
1855
            $avhash{$nmac}->{'identity'} = $node->{'identity'};
1856
            $avhash{$nmac}->{'status'} = $node->{'status'};
1857
            $avhash{$nmac}->{'maintenance'} = $maintenance;
1858
            $avhash{$nmac}->{'reservedvcpus'} = $node->{'reservedvcpus'};
1859
            my $nodeidentity = $node->{'identity'};
1860
            $nodeidentity = 'kvm' if ($nodeidentity eq 'local_kvm');
1861

    
1862
            if ($hypervisor eq $nodeidentity) {
1863
                # If image is on node, we must start on same node - registered when moving image
1864
                if ($imageonnode) {
1865
                    unless ( tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {return "Unable to access images register"};
1866
                    $dmac = $imagereg{$image}->{'mac'};
1867
                    $dmac = $imagereg{$image2}->{'mac'} unless ($dmac);
1868
                    $dmac = $imagereg{$image3}->{'mac'} unless ($dmac);
1869
                    $dmac = $imagereg{$image4}->{'mac'} unless ($dmac);
1870

    
1871
                    untie %imagereg;
1872
                    if (!$dmac) {
1873
                        $postreply .= "Status=ERROR Image node not found\n";
1874
                        last;
1875
                    }
1876
                }
1877
                $dmac = "" if ($dmac eq "--");
1878
            # If a specific node is asked for, match mac addresses
1879
                if ($dmac eq $nmac) {
1880
                    $targetnode = $node;
1881
                    last;
1882
                } elsif (!$dmac && $nstatus ne "maintenance" && !$maintenance) {
1883
            # pack or disperse
1884
                    if (!$targetindex) {
1885
                        $targetindex = $aindex;
1886
                        $targetnode = $node;
1887
                    } elsif ($dpolicy eq 'pack') {
1888
                        if ($aindex < $targetindex) {
1889
                            $targetnode = $node;
1890
                            $targetindex = $aindex;
1891
                        }
1892
                    } else {
1893
                        if ($aindex > $targetindex) {
1894
                            $targetnode = $node;
1895
                            $targetindex = $aindex;
1896
                        }
1897
                    }
1898
                }
1899
            }
1900
        }
1901
    }
1902

    
1903
    if ($targetnode && $uuid) {
1904
        if ($targetnode->{'status'} eq 'asleep') {
1905
            my $nmac = $targetnode->{'mac'};
1906
            my $realmac = substr($nmac,0,2).":".substr($nmac,2,2).":".substr($nmac,4,2).":".substr($nmac,6,2).":".substr($nmac,8,2).":".substr($nmac,10,2);
1907
            my $nlogmsg = "Node $nmac marked for wake ";
1908
            if ($brutalsleep && (
1909
                    ($targetnode->{'amtip'} && $targetnode->{'amtip'} ne '--')
1910
                || ($targetnode->{'ipmiip'} && $targetnode->{'ipmiip'} ne '--')
1911
                )) {
1912
                my $wakecmd;
1913
                if ($targetnode->{'amtip'} && $targetnode->{'amtip'} ne '--') {
1914
                    $wakecmd = "echo 'y' | AMT_PASSWORD='$amtpasswd' /usr/bin/amttool $targetnode->{'amtip'} powerup pxe";
1915
                } else {
1916
                    $wakecmd = "ipmitool -I lanplus -H $targetnode->{'ipmiip'} -U ADMIN -P ADMIN power on";
1917
                }
1918
                $nlogmsg .= `$wakecmd`;
1919
            } else {
1920
                my $broadcastip = $targetnode->{'ip'};
1921
                $broadcastip =~ s/\.\d{1,3}$/.255/;
1922
                $nlogmsg .= 'on lan ' . `/usr/bin/wakeonlan -i $broadcastip $realmac`;
1923
            }
1924
            $targetnode->{'status'} = "waking";
1925
            $nlogmsg =~ s/\n/ /g;
1926
            $main::syslogit->($user, "info", $nlogmsg);
1927
            $postreply .= "Status=OK waking $targetnode->{'name'}\n";
1928
        }
1929
        $targetname = $targetnode->{'name'};
1930
        $targetmac = $targetnode->{'mac'};
1931
        $targetip = $targetnode->{'ip'};
1932
        $targetip = $targetnode->{'ip'};
1933
        my $porttaken = 1;
1934
        while ($porttaken) {
1935
            $porttaken = 0;
1936
            $port = $targetnode->{'vms'} + (($hypervisor eq "vbox")?3389:5900);
1937
            $port += int(rand(200));
1938
            my @regkeys = (tied %register)->select_where("port = '$port' AND macip = '$targetip'");
1939
            foreach my $k (@regkeys) {
1940
                $r = $register{$k};
1941
                if ($r->{'port'} eq $port && $r->{'macip'} eq $targetip) {
1942
                    $porttaken = 1;
1943
                }
1944
            }
1945
        }
1946
        $targetnode->{'vms'}++;
1947
        $targetnode->{'vmvcpus'} += $vcpu;
1948
        $register{$uuid}->{'port'} = $port;
1949
#        $register{$uuid}->{'mac'} = $targetmac;
1950
#        $register{$uuid}->{'macname'} = $targetname;
1951
#        $register{$uuid}->{'macip'} = $targetip;
1952
        $register{$uuid}->{'display'} = (($hypervisor eq "vbox")?'rdp':'vnc');
1953
    } else {
1954
        my $macstatus;
1955
        $macstatus = $nodereg{$dmac}->{status} if ($nodereg{$dmac});
1956
        $main::syslogit->($user, "info", "Could not find target for $uuid, $dmac, $mem, $vcpu, $image, $image2,$image3,$image4, $hypervisor, $smac, dmac-status: $macstatus") if ($uuid);
1957
    }
1958
    return ($targetmac, $targetname, $targetip, $port, \%avhash);
1959
}
1960

    
1961
sub destroyUserServers {
1962
    my $username = shift;
1963
    my $wait = shift; # Should we wait for servers do die
1964
    my $duuid = shift;
1965
    return unless ($username && ($isadmin || $user eq $username));
1966
    my @updateList;
1967

    
1968
    my @regkeys = (tied %register)->select_where("user = '$username'");
1969
    foreach my $uuid (@regkeys) {
1970
        if ($register{$uuid}->{'user'} eq $username
1971
            && $register{$uuid}->{'status'} ne 'shutoff'
1972
            && (!$duuid || $duuid eq $uuid)
1973
        ) {
1974
            $postreply .= "Destroying $username server $register{$uuid}->{'name'}, $uuid\n";
1975
            Destroy($uuid);
1976
            push (@updateList,{ tab=>'servers',
1977
                                user=>$user,
1978
                                uuid=>$duuid,
1979
                                status=>'destroying'});
1980
        }
1981
    }
1982
    $main::updateUI->(@updateList) if (@updateList);
1983
    if ($wait) {
1984
        my @regkeys = (tied %register)->select_where("user = '$username'");
1985
        my $activeservers = 1;
1986
        my $i = 0;
1987
        while ($activeservers && $i<30) {
1988
            $activeservers = 0;
1989
            foreach my $k (@regkeys) {
1990
                my $valref = $register{$k};
1991
                if ($username eq $valref->{'user'}
1992
                    && ($valref->{'status'} ne 'shutoff'
1993
                    && $valref->{'status'} ne 'inactive')
1994
                    && (!$duuid || $duuid eq $valref->{'uuid'})
1995
                ) {
1996
                    $activeservers = $valref->{'uuid'};
1997
                }
1998
            }
1999
            $i++;
2000
            if ($activeservers) {
2001
                my $res .= "Status=OK Waiting $i for server $register{$activeservers}->{'name'}, $register{$activeservers}->{'status'} to die...\n";
2002
            #    print $res if ($console);
2003
                $postreply .= $res;
2004
                sleep 2;
2005
            }
2006
        }
2007
        $postreply .= "Status=OK Servers halted for $username\n" unless ($activeservers);
2008
    }
2009
    return $postreply;
2010
}
2011

    
2012
sub removeUserServers {
2013
    my $username = shift;
2014
    my $uuid = shift;
2015
    my $destroy = shift; # Should running servers be destroyed before removing
2016
    return unless (($isadmin || $user eq $username) && !$isreadonly);
2017
    $user = $username;
2018
    my @regkeys = (tied %register)->select_where("user = '$username'");
2019
    foreach my $ruuid (@regkeys) {
2020
        next if ($uuid && $ruuid ne $uuid);
2021
        if ($destroy && $register{$ruuid}->{'user'} eq $username && ($register{$ruuid}->{'status'} ne 'shutoff' && $register{$ruuid}->{'status'} ne 'inactive')) {
2022
            destroyUserServers($username, 1, $ruuid);
2023
        }
2024

    
2025
        if ($register{$ruuid}->{'user'} eq $username && ($register{$ruuid}->{'status'} eq 'shutoff' || $register{$ruuid}->{'status'} eq 'inactive')) {
2026
            $postreply .= "Removing $username server $register{$ruuid}->{'name'}, $ruuid" . ($console?'':'<br>') . "\n";
2027
            Remove($ruuid);
2028
        }
2029
    }
2030
}
2031

    
2032
sub Remove {
2033
    my ($uuid, $action) = @_;
2034
    if ($help) {
2035
        return <<END
2036
DELETE:uuid:
2037
Removes a server. Server must be shutoff. Does not remove associated images or networks.
2038
END
2039
    }
2040
    my $reguser = $register{$uuid}->{'user'};
2041
    my $dbstatus = $register{$uuid}->{'status'};
2042
    my $image = $register{$uuid}->{'image'};
2043
    my $image2 = $register{$uuid}->{'image2'};
2044
    my $image3 = $register{$uuid}->{'image3'};
2045
    my $image4 = $register{$uuid}->{'image4'};
2046
    my $name = $register{$uuid}->{'name'};
2047
    $image2 = '' if ($image2 eq '--');
2048
    $image3 = '' if ($image3 eq '--');
2049
    $image4 = '' if ($image4 eq '--');
2050

    
2051
    if ($reguser ne $user) {
2052
        $postreply .= "Status=ERROR You cannot delete a vm you don't own\n";
2053
    } elsif ($dbstatus eq 'inactive' || $dbstatus eq 'shutdown' || $dbstatus eq 'shutoff') {
2054

    
2055
        # Delete software packages and monitors from register
2056
        $postmsg .= deletePackages($uuid);
2057
        my $sname = $register{$uuid}->{'name'};
2058
        utf8::decode($sname);
2059
        $postmsg .= deleteMonitors($uuid)?" deleted monitors for $sname ":'';
2060

    
2061
        delete $register{$uuid};
2062
        delete $xmlreg{$uuid};
2063

    
2064
        unless ( tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {return "Unable to access images register"};
2065
        $imagereg{$image}->{'status'} = "unused" if ($imagereg{$image});
2066
        $imagereg{$image2}->{'status'} = "unused" if ($image2 && $imagereg{$image2});
2067
        $imagereg{$image3}->{'status'} = "unused" if ($image3 && $imagereg{$image3});
2068
        $imagereg{$image4}->{'status'} = "unused" if ($image4 && $imagereg{$image4});
2069
        untie %imagereg;
2070

    
2071
        # Delete metrics
2072
        my $metricsdir = "/var/lib/graphite/whisper/domains/$uuid";
2073
        `rm -r $metricsdir` if (-e $metricsdir);
2074
        my $rrdfile = "/var/cache/rrdtool/".$uuid."_highres.rrd";
2075
        `rm $rrdfile` if (-e $rrdfile);
2076

    
2077
        $main::syslogit->($user, "info", "Deleted domain $uuid from db");
2078
        utf8::decode($name);
2079
        $postmsg .= " deleted server $name";
2080
        $postreply = "[]";
2081
        sleep 1;
2082
    } else {
2083
        $postreply .= "Status=ERROR Cannot delete a $dbstatus server\n";
2084
    }
2085
    return $postreply;
2086
}
2087

    
2088
# Delete all monitors belonging to a server
2089
sub deleteMonitors {
2090
    my ($serveruuid) = @_;
2091
    my $match;
2092
    if ($serveruuid) {
2093
        if ($register{$serveruuid}->{'user'} eq $user || $isadmin) {
2094
            local($^I, @ARGV) = ('.bak', "/etc/mon/mon.cf");
2095
            # undef $/; # This makes <> read in the entire file in one go
2096
            my $uuidmatch;
2097
            while (<>) {
2098
                if (/^watch (\S+)/) {
2099
                    if ($1 eq $serveruuid) {$uuidmatch = $serveruuid}
2100
                    else {$uuidmatch = ''};
2101
                };
2102
                if ($uuidmatch) {
2103
                    $match = 1;
2104
                } else {
2105
                    #chomp;
2106
                    print unless (/^hostgroup $serveruuid/);
2107
                }
2108
                close ARGV if eof;
2109
            }
2110
            #$/ = "\n";
2111
        }
2112
        unlink glob "/var/log/stabile/*:$serveruuid:*";
2113
    }
2114
    `/usr/bin/moncmd reset keepstate` if ($match);
2115
    return $match;
2116
}
2117

    
2118
sub deletePackages {
2119
    my ($uuid, $issystem, %packreg) = @_;
2120
    unless ( tie(%packreg,'Tie::DBI', Hash::Merge::merge({table=>'packages', key=>'id'}, $Stabile::dbopts)) ) {return "Unable to access images register"};
2121

    
2122
    my @domains;
2123
    if ($issystem) {
2124
        foreach my $valref (values %register) {
2125
            if (($valref->{'system'} eq $uuid || $uuid eq '*')
2126
                    && ($valref->{'user'} eq $user || $fulllist)) {
2127
                push(@domains, $valref->{'uuid'});
2128
            }
2129
        }
2130
    } else { # Allow if domain no longer exists or belongs to user
2131
        push(@domains, $uuid) if (!$register{$uuid} || $register{$uuid}->{'user'} eq $user || $fulllist);
2132
    }
2133

    
2134
    foreach my $domuuid (@domains) {
2135
        foreach my $packref (values %packreg) {
2136
            my $id = $packref->{'id'};
2137
            if (substr($id, 0,36) eq $domuuid || ($uuid eq '*' && $packref->{'user'} eq $user)) {
2138
                delete $packreg{$id};
2139
            }
2140
        }
2141
    }
2142
    tied(%packreg)->commit;# if (%packreg);
2143
    if ($issystem) {
2144
        my $sname = $register{$uuid}->{'name'};
2145
        utf8::decode($sname);
2146
        return "Status=OK Cleared packages for $sname\n";
2147
    } elsif ($register{$uuid}) {
2148
        my $sname = $register{$uuid}->{'name'};
2149
        utf8::decode($sname);
2150
        return "Status=OK Cleared packages for $sname\n";
2151
    } else {
2152
        return "Status=OK Cleared packages. System not registered\n";
2153
    }
2154
}
2155

    
2156
sub Save {
2157
    my ($uuid, $action, $obj) = @_;
2158
    if ($help) {
2159
        return <<END
2160
POST:uuid, name, user, system, autostart, locktonode, mac, memory, vcpu, boot, loader, diskbus, nicmodel1, vgpu, cdrom, image, image2, image3, image4, networkuuid2, networkuuid3, networkuuid1, nicmac1, nicmac2, nicmac3:
2161
To save a servers of networks you either PUT or POST a JSON array to the main endpoint with objects representing the servers with the changes you want.
2162
Depending on your privileges not all changes are permitted. If you save without specifying a uuid, a new server is created.
2163
If you pass [user] parameter it is assumed you want to move server to this user's account.
2164
Supported parameters:
2165

    
2166
uuid: UUID
2167
name: string
2168
user: string
2169
system: UUID of stack this server belongs to
2170
autostart: true|false
2171
locktonode: true|false
2172
mac: MAC address of target node
2173

    
2174
memory: int bytes
2175
vcpu: int
2176
boot: hd|cdrom|network
2177
loader: bios|uefi
2178
diskbus: virtio|ide|scsi
2179
nicmodel1: virtio|rtl8139|ne2k_pci|e1000|i82551|i82557b|i82559er|pcnet
2180
vgpu: int
2181

    
2182
cdrom: string path
2183
image: string path
2184
image2: string path
2185
image3: string path
2186
image4: string path
2187

    
2188
networkuuid1: UUID of network connection
2189
networkuuid2: UUID of network connection
2190
networkuuid3: UUID of network connection
2191

    
2192
END
2193
    }
2194

    
2195
# notes, opemail, opfullname, opphone, email, fullname, phone, services, recovery, alertemail
2196
# notes: string
2197
# opemail: string
2198
# opfullname: string
2199
# opphone: string
2200
# email: string
2201
# fullname: string
2202
# phone: string
2203
# services: string
2204
# recovery: string
2205
# alertemail: string
2206

    
2207
    my $system = $obj->{system};
2208
    my $newsystem = $obj->{newsystem};
2209
    my $buildsystem = $obj->{buildsystem};
2210
    my $nicmac1 = $obj->{nicmac1};
2211
    $console = $console || $obj->{console};
2212

    
2213
    $postmsg = '' if ($buildsystem);
2214
    if (!$uuid && $nicmac1) {
2215
        $uuid = nicmac1ToUuid($nicmac1); # If no uuid try to locate based on mac
2216
    }
2217
    if (!$uuid && $uripath =~ /servers(\.cgi)?\/(.+)/) { # Try to parse uuid out of URI
2218
        my $huuid = $2;
2219
        if ($ug->to_string($ug->from_string($huuid)) eq $huuid) { # Check for valid uuid
2220
            $uuid = $huuid;
2221
        }
2222
    }
2223
    my $regserv = $register{$uuid};
2224
    my $status = $regserv->{'status'} || 'new';
2225
    if ((!$uuid) && $status eq 'new') {
2226
        my $ug = new Data::UUID;
2227
        $uuid = $ug->create_str();
2228
    };
2229
    unless ($uuid && length $uuid == 36){
2230
        $postmsg = "Status=Error No valid uuid ($uuid), $obj->{image}";
2231
        return $postmsg;
2232
    }
2233
    $nicmac1 = $nicmac1 || $regserv->{'nicmac1'};
2234
    my $name = $obj->{name} || $regserv->{'name'};
2235
    my $memory = $obj->{memory} || $regserv->{'memory'};
2236
    my $vcpu = $obj->{vcpu} || $regserv->{'vcpu'};
2237
    my $image = $obj->{image} || $regserv->{'image'};
2238
    my $imagename = $obj->{imagename} || $regserv->{'imagename'};
2239
    my $image2 = $obj->{image2} || $regserv->{'image2'};
2240
    my $image2name = $obj->{image2name} || $regserv->{'image2name'};
2241
    my $image3 = $obj->{image3} || $regserv->{'image3'};
2242
    my $image3name = $obj->{image3name} || $regserv->{'image3name'};
2243
    my $image4 = $obj->{image4} || $regserv->{'image4'};
2244
    my $image4name = $obj->{image4name} || $regserv->{'image4name'};
2245
    my $diskbus = $obj->{diskbus} || $regserv->{'diskbus'};
2246
    my $cdrom = $obj->{cdrom} || $regserv->{'cdrom'};
2247
    my $boot = $obj->{boot} || $regserv->{'boot'};
2248
    my $loader = $obj->{loader} || $regserv->{'loader'};
2249
    my $networkuuid1 = ($obj->{networkuuid1} || $obj->{networkuuid1} eq '0')?$obj->{networkuuid1}:$regserv->{'networkuuid1'};
2250
    my $networkid1 = $obj->{networkid1} || $regserv->{'networkid1'};
2251
    my $networkname1 = $obj->{networkname1} || $regserv->{'networkname1'};
2252
    my $nicmodel1 = $obj->{nicmodel1} || $regserv->{'nicmodel1'};
2253
    my $networkuuid2 = ($obj->{networkuuid2} || $obj->{networkuuid2} eq '0')?$obj->{networkuuid2}:$regserv->{'networkuuid2'};
2254
    my $networkid2 = $obj->{networkid2} || $regserv->{'networkid2'};
2255
    my $networkname2 = $obj->{networkname2} || $regserv->{'networkname2'};
2256
    my $nicmac2 = $obj->{nicmac2} || $regserv->{'nicmac2'};
2257
    my $networkuuid3 = ($obj->{networkuuid3} || $obj->{networkuuid3} eq '0')?$obj->{networkuuid3}:$regserv->{'networkuuid3'};
2258
    my $networkid3 = $obj->{networkid3} || $regserv->{'networkid3'};
2259
    my $networkname3 = $obj->{networkname3} || $regserv->{'networkname3'};
2260
    my $nicmac3 = $obj->{nicmac3} || $regserv->{'nicmac3'};
2261
    my $notes = $obj->{notes} || $regserv->{'notes'};
2262
    my $autostart = $obj->{autostart} || $regserv->{'autostart'};
2263
    my $locktonode = $obj->{locktonode} || $regserv->{'locktonode'};
2264
    my $mac = $obj->{mac} || $regserv->{'mac'};
2265
    my $created = $regserv->{'created'} || time;
2266
    # Sanity checks
2267
    my $tenderpaths = $Stabile::config->get('STORAGE_POOLS_LOCAL_PATHS') || "/mnt/stabile/images";
2268
    my @tenderpathslist = split(/,\s*/, $tenderpaths);
2269

    
2270
    $networkid1 = $networkreg{$networkuuid1}->{'id'};
2271
    my $networktype1 = $networkreg{$networkuuid1}->{'type'};
2272
    my $networktype2;
2273
    if (!$nicmac1 || $nicmac1 eq "--") {$nicmac1 = randomMac();}
2274
    if ($networkuuid2 && $networkuuid2 ne "--") {
2275
        $networkid2 = $networkreg{$networkuuid2}->{'id'};
2276
        $nicmac2 = randomMac() if (!$nicmac2 || $nicmac2 eq "--");
2277
        $networktype2 = $networkreg{$networkuuid2}->{'type'};
2278
    }
2279
    if ($networkuuid3 && $networkuuid3 ne "--") {
2280
        $networkid3 = $networkreg{$networkuuid3}->{'id'};
2281
        $networkname3 = $networkreg{$networkuuid3}->{'name'};
2282
        $nicmac3 = randomMac() if (!$nicmac3 || $nicmac3 eq "--");
2283
        $networktype3 = $networkreg{$networkuuid3}->{'type'};
2284
    }
2285

    
2286
    my $imgdup;
2287
    my $netdup;
2288
    my $json_text; # returned if all goes well
2289

    
2290
    unless ( tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {return "Unable to access images register"};
2291

    
2292
    if ($networkid1 > 1 && $networkid2 > 1 && $networktype1 ne 'gateway' && $networktype2 ne 'gateway'
2293
        && $networkuuid1 eq $networkuuid2) {
2294
        $netdup = 1;
2295
    }
2296
    if ($networkid1 > 1 && $networkid3 > 1 && $networktype1 ne 'gateway' && $networktype3 ne 'gateway'
2297
        && $networkuuid1 eq $networkuuid3) {
2298
        $netdup = 11;
2299
    }
2300

    
2301
    if ($image eq $image2
2302
        || $image eq $image3
2303
        || $image eq $image4
2304
        || $image2 && $image2 ne '--' && $image2 eq $image3
2305
        || $image2 && $image2 ne '--' && $image2 eq $image4
2306
        || $image3 && $image3 ne '--' && $image3 eq $image4
2307
    ) {
2308
        $imgdup = 1;
2309
    } elsif ($image =~ m/\.master\.qcow2/
2310
        || $image2 =~ m/\.master\.qcow2/
2311
        || $image3 =~ m/\.master\.qcow2/
2312
        || $image4 =~ m/\.master\.qcow2/
2313
    ) {
2314
        $imgdup = 2;
2315
    } else {
2316
        # Check if another server is using image
2317
        my @regkeys = (tied %register)->select_where("user = '$user' OR user = 'common'");
2318
        foreach my $k (@regkeys) {
2319
            my $val = $register{$k};
2320
            my %h = %$val;
2321
            if ($h{'uuid'} ne $uuid) {
2322
                if (
2323
                    $image eq $h{'image'} || $image eq $h{'image2'}|| $image eq $h{'image3'}|| $image eq $h{'image4'}
2324
                ) {
2325
                    $imgdup = 51;
2326
                } elsif ($image2 && $image2 ne "--" &&
2327
                    ($image2 eq $h{'image'} || $image2 eq $h{'image2'} || $image2 eq $h{'image3'} || $image2 eq $h{'image4'})
2328
                ) {
2329
                    $imgdup = 52;
2330
                } elsif ($image3 && $image3 ne "--" &&
2331
                    ($image3 eq $h{'image'} || $image3 eq $h{'image2'} || $image3 eq $h{'image3'} || $image3 eq $h{'image4'})
2332
                ) {
2333
                    $imgdup = 53;
2334
                } elsif ($image4 && $image4 ne "--" &&
2335
                    ($image4 eq $h{'image'} || $image4 eq $h{'image2'} || $image4 eq $h{'image3'} || $image4 eq $h{'image4'})
2336
                ) {
2337
                    $imgdup = 54;
2338
                }
2339

    
2340
                if ($networkid1>1) {
2341
                    if ($networktype1 ne 'gateway' &&
2342
                        ($networkuuid1 eq $h{'networkuuid1'} || $networkuuid1 eq $h{'networkuuid2'})
2343
                    ) {
2344
                        $netdup = 51;
2345
                    }
2346
                }
2347
                if ($networkid2>1) {
2348
                    if ($networktype2 ne 'gateway' && $networkuuid2 && $networkuuid2 ne "--" &&
2349
                        ($networkuuid2 eq $h{'networkuuid1'} || $networkuuid2 eq $h{'networkuuid2'})
2350
                    ) {
2351
                        $netdup = 52;
2352
                    }
2353
                }
2354
            }
2355
        }
2356
        my $legalpath;
2357
        if ($image =~ m/\/mnt\/stabile\/node\/$user/) {
2358
            $legalpath = 1;
2359
        } else {
2360
            foreach my $path (@tenderpathslist) {
2361
                if ($image =~ m/$path\/$user/) {
2362
                    $legalpath = 1;
2363
                    last;
2364
                }
2365
            }
2366
        }
2367
        $imgdup = 6 unless $legalpath;
2368
        if ($image2 && $image2 ne "--") { # TODO: We should probably check for conflicting nodes for image3 and image 4 too
2369
            if ($image2 =~ m/\/mnt\/stabile\/node\/$user/) {
2370
                if ($image =~ m/\/mnt\/stabile\/node\/$user/) {
2371
                    if ($imagereg{$image}->{'mac'} eq $imagereg{$image2}->{'mac'}) {
2372
                        $legalpath = 1;
2373
                    } else {
2374
                        $legalpath = 0; # Images are on two different nodes
2375
                    }
2376
                } else {
2377
                    $legalpath = 1;
2378
                }
2379
            } else {
2380
                $legalpath = 0;
2381
                foreach my $path (@tenderpathslist) {
2382
                    if ($image2 =~ m/$path\/$user/) {
2383
                        $legalpath = 1;
2384
                        last;
2385
                    }
2386
                }
2387
            }
2388
            $imgdup = 7 unless $legalpath;
2389
        }
2390
    }
2391

    
2392
    if (!$imgdup && !$netdup) {
2393
        if ($status eq "new") {
2394
            $status = "shutoff";
2395
            $name = $name || 'New Server';
2396
            $memory = $memory || 1024;
2397
            $vcpu = $vcpu || 1;
2398
            $imagename = $imagename || '--';
2399
            $image2 = $image2 || '--';
2400
            $image2name = $image2name || '--';
2401
            $image3 = $image3 || '--';
2402
            $image3name = $image3name || '--';
2403
            $image4 = $image4 || '--';
2404
            $image4name = $image4name || '--';
2405
            $diskbus = $diskbus || 'ide';
2406
            $cdrom = $cdrom || '--';
2407
            $boot = $boot || 'hd';
2408
            $loader = $loader || 'bios';
2409
            $networkuuid1 = $networkuuid1 || 1;
2410
            $networkid1 = $networkid1 || 1;
2411
            $networkname1 = $networkname1 || '--';
2412
            $nicmodel1 = $nicmodel1 || 'rtl8139';
2413
            $nicmac1 = $nicmac1 || randomMac();
2414
            $networkuuid2 = $networkuuid2 || '--';
2415
            $networkid2 = $networkid2 || '--';
2416
            $networkname2 = $networkname2 || '--';
2417
            $nicmac2 = $nicmac2 || randomMac();
2418
            $networkuuid3 = $networkuuid3 || '--';
2419
            $networkid3 = $networkid3 || '--';
2420
            $networkname3 = $networkname3 || '--';
2421
            $nicmac3 = $nicmac3 || randomMac();
2422
            #    $uiuuid = $uuid; # No need to update ui for new server with jsonreststore
2423
            $postmsg .= "OK Created new server: $name";
2424
            $postmsg .= ", uuid: $uuid " if ($console);
2425
        }
2426
        # Update status of images
2427
        my @imgs = ($image, $image2, $image3, $image4);
2428
        my @imgkeys = ('image', 'image2', 'image3', 'image4');
2429
        for (my $i=0; $i<4; $i++) {
2430
            my $img = $imgs[$i];
2431
            my $k = $imgkeys[$i];
2432
            my $regimg = $imagereg{$img};
2433
            # if ($img && $img ne '--' && ($status eq 'new' || $img ne $regserv->{$k})) { # Servers image changed - update image status
2434
            if ($img && $img ne '--') { # Always update image status
2435
                $regimg->{'status'} = 'used' if (
2436
                    $regimg->{'status'} eq 'unused'
2437
                        # Image cannot be active if server is shutoff
2438
                        || ($regimg->{'status'} eq 'active' && $status eq 'shutoff')
2439
                );
2440
                $regimg->{'domains'} = $uuid;
2441
                $regimg->{'domainnames'} = $name;
2442
            }
2443
            # If image has changed, release the old image
2444
            if ($status ne 'new' && $img ne $regserv->{$k} && $imagereg{$regserv->{$k}}) {
2445
                $imagereg{$regserv->{$k}}->{'status'} = 'unused';
2446
                delete $imagereg{$regserv->{$k}}->{'domains'};
2447
                delete $imagereg{$regserv->{$k}}->{'domainnames'};
2448
            }
2449
        }
2450

    
2451
        my $valref = {
2452
            uuid=>$uuid,
2453
            user=>$user,
2454
            name=>$name,
2455
            memory=>$memory,
2456
            vcpu=>$vcpu,
2457
            image=>$image,
2458
            imagename=>$imagename,
2459
            image2=>$image2,
2460
            image2name=>$image2name,
2461
            image3=>$image3,
2462
            image3name=>$image3name,
2463
            image4=>$image4,
2464
            image4name=>$image4name,
2465
            diskbus=>$diskbus,
2466
            cdrom=>$cdrom,
2467
            boot=>$boot,
2468
            loader=>$loader,
2469
            networkuuid1=>$networkuuid1,
2470
            networkid1=>$networkid1,
2471
            networkname1=>$networkname1,
2472
            nicmodel1=>$nicmodel1,
2473
            nicmac1=>$nicmac1,
2474
            networkuuid2=>$networkuuid2,
2475
            networkid2=>$networkid2,
2476
            networkname2=>$networkname2,
2477
            nicmac2=>$nicmac2,
2478
            networkuuid3=>$networkuuid3,
2479
            networkid3=>$networkid3,
2480
            networkname3=>$networkname3,
2481
            nicmac3=>$nicmac3,
2482
            status=>$status,
2483
            notes=>$notes,
2484
            autostart=>$autostart,
2485
            locktonode=>$locktonode,
2486
            action=>"",
2487
            created=>$created
2488
        };
2489
        $valref->{'system'} = $system if ($system);
2490
        if ($mac && $locktonode eq 'true') {
2491
            $valref->{'mac'} = $mac;
2492
            $valref->{'macip'} = $nodereg{$mac}->{'ip'};
2493
            $valref->{'macname'} = $nodereg{$mac}->{'name'};
2494
        }
2495
        if ($newsystem) {
2496
            my $ug = new Data::UUID;
2497
            $sysuuid = $ug->create_str();
2498
            $valref->{'system'} = $sysuuid;
2499
            $postmsg .= "OK sysuuid: $sysuuid " if ($console);
2500
        }
2501

    
2502
        # Remove domain uuid from old networks. Leave gateways alone - they get updated on next listing
2503
        my $oldnetworkuuid1 = $regserv->{'networkuuid1'};
2504
        if ($oldnetworkuuid1 ne $networkuuid1 && $networkreg{$oldnetworkuuid1}) {
2505
            $networkreg{$oldnetworkuuid1}->{'domains'} =~ s/($uuid)(,?)( ?)//;
2506
        }
2507

    
2508
        $register{$uuid} = validateItem($valref);
2509

    
2510
        if ($networkreg{$networkuuid1}->{'type'} eq 'gateway') {
2511
            # We now remove before adding to support API calls that dont necessarily list afterwards
2512
            $networkreg{$networkuuid1}->{'domains'} =~ s/($uuid)(,?)( ?)//;
2513
            my $domains = $networkreg{$networkuuid1}->{'domains'};
2514
            $networkreg{$networkuuid1}->{'domains'} = ($domains?"$domains, ":"") . $uuid;
2515

    
2516
            $networkreg{$networkuuid1}->{'domainnames'} =~ s/($name)(,?)( ?)//;
2517
            my $domainnames = $networkreg{$networkuuid1}->{'domainnames'};
2518
            $networkreg{$networkuuid1}->{'domainnames'} = ($domainnames?"$domainnames, ":"") . $name;
2519
        } else {
2520
            $networkreg{$networkuuid1}->{'domains'}  = $uuid;
2521
            $networkreg{$networkuuid1}->{'domainnames'}  = $name;
2522
        }
2523

    
2524
        if ($networkuuid2 && $networkuuid2 ne '--') {
2525
            if ($networkreg{$networkuuid2}->{'type'} eq 'gateway') {
2526
                $networkreg{$networkuuid2}->{'domains'} =~ s/($uuid)(,?)( ?)//;
2527
                my $domains = $networkreg{$networkuuid2}->{'domains'};
2528
                $networkreg{$networkuuid2}->{'domains'} = ($domains?"$domains, ":"") . $uuid;
2529

    
2530
                $networkreg{$networkuuid2}->{'domainnames'} =~ s/($name)(,?)( ?)//;
2531
                my $domainnames = $networkreg{$networkuuid2}->{'domainnames'};
2532
                $networkreg{$networkuuid2}->{'domainnames'} = ($domainnames?"$domainnames, ":"") . $name;
2533
            } else {
2534
                $networkreg{$networkuuid2}->{'domains'}  = $uuid;
2535
                $networkreg{$networkuuid2}->{'domainnames'}  = $name;
2536
            }
2537
        }
2538

    
2539
        if ($networkuuid3 && $networkuuid3 ne '--') {
2540
            if ($networkreg{$networkuuid3}->{'type'} eq 'gateway') {
2541
                my $domains = $networkreg{$networkuuid3}->{'domains'};
2542
                $networkreg{$networkuuid3}->{'domains'} = ($domains?"$domains, ":"") . $uuid;
2543
                my $domainnames = $networkreg{$networkuuid3}->{'domainnames'};
2544
                $networkreg{$networkuuid3}->{'domainnames'} = ($domainnames?"$domainnames, ":"") . $name;
2545
            } else {
2546
                $networkreg{$networkuuid3}->{'domains'}  = $uuid;
2547
                $networkreg{$networkuuid3}->{'domainnames'}  = $name;
2548
            }
2549
        }
2550
        my %jitem = %{$register{$uuid}};
2551
        $json_text = to_json(\%jitem, {pretty=>1});
2552
        $json_text =~ s/null/"--"/g;
2553
        $uiuuid = $uuid;
2554
        $uiname = $name;
2555

    
2556
        tied(%register)->commit;
2557
        tied(%imagereg)->commit;
2558
        tied(%networkreg)->commit;
2559

    
2560
    } else {
2561
        $postmsg .= "ERROR This image ($image) cannot be used ($imgdup) " if ($imgdup);
2562
        $postmsg .= "ERROR This network ($networkname1) cannot be used ($netdup)" if ($netdup);
2563
    }
2564

    
2565
    my $domuser = $obj->{'user'};
2566
    # We were asked to move server to another account
2567
    if ($domuser && $domuser ne '--' && $domuser ne $user) {
2568
        unless ( tie(%userreg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>0}, $Stabile::dbopts)) ) {throw Error::Simple("Stroke=Error User register could not be  accessed")};
2569
        if ($status eq 'shutoff' || $status eq 'inactive') {
2570
            unless ( tie(%userreg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {$posterror =  "Unable to access user register"; return 0;};
2571
            my @accounts = split(/,\s*/, $userreg{$tktuser}->{'accounts'});
2572
            my @accountsprivs = split(/,\s*/, $userreg{$tktuser}->{'accountsprivileges'});
2573
            %ahash = ($tktuser, $userreg{$tktuser}->{'privileges'}); # Include tktuser in accounts hash
2574
            for my $i (0 .. scalar @accounts)
2575
            {
2576
                next unless $accounts[$i];
2577
                $ahash{$accounts[$i]} = $accountsprivs[$i] || 'r';
2578
            }
2579
            untie %userreg;
2580

    
2581
            if (!$isreadonly && $ahash{$domuser} && !($ahash{$domuser} =~ /r/)) { # Check if user is allow to access account
2582
                my $imgdone;
2583
                my $netdone;
2584
                # First move main image
2585
                $Stabile::Images::user = $user;
2586
                require "$Stabile::basedir/cgi/images.cgi";
2587
                $Stabile::Images::console = 1;
2588
                $main::updateUI->({tab=>"servers", user=>$user, message=>"Moving image $imagename to account: $domuser"});
2589
                my $nimage = Stabile::Images::Move($image, $domuser);
2590
                chomp $nimage;
2591
                if ($nimage) {
2592
                    $main::syslogit->($user, "info", "Moving $nimage to account: $domuser");
2593
                    $register{$uuid}->{'image'} = $nimage;
2594
                    $imgdone = 1;
2595
                } else {
2596
                    $main::syslogit->($user, "info", "Unable to move image $imagename to account: $domuser");
2597
                }
2598
                # Move other attached images
2599
                my @images = ($image2, $image3, $image4);
2600
                my @imagenames = ($image2name, $image3name, $image4name);
2601
                my @imagekeys = ('image2', 'image3', 'image4');
2602
                for (my $i=0; $i<3; $i++) {
2603
                    my $img = $images[$i];
2604
                    my $imgname = $imagenames[$i];
2605
                    my $imgkey = $imagekeys[$i];
2606
                    if ($img && $img ne '--') {
2607
                        $main::updateUI->({tab=>"servers", user=>$user, message=>"Moving $imgkey $imgname to account: $domuser"});
2608
                        $nimage = Stabile::Images::Move($img, $domuser);
2609
                        chomp $nimage;
2610
                        if ($nimage) {
2611
                            $main::syslogit->($user, "info", "Moving $nimage to account: $domuser");
2612
                            $register{$uuid}->{$imgkey} = $nimage;
2613
                        } else {
2614
                            $main::syslogit->($user, "info", "Unable to move $imagekeys[$i] $img to account: $domuser");
2615
                        }
2616
                    }
2617
                }
2618
                # Then move network(s)
2619
                if ($imgdone) {
2620
                    $Stabile::Networks::user = $user;
2621
                    require "$Stabile::basedir/cgi/networks.cgi";
2622
                    $Stabile::Networks::console = 1;
2623
                    my @networks = ($networkuuid1, $networkuuid2, $networkuuid3);
2624
                    my @netkeys = ('networkuuid1', 'networkuuid2', 'networkuuid3');
2625
                    my @netnamekeys = ('networkname1', 'networkname2', 'networkname3');
2626
                    for (my $i=0; $i<scalar @networks; $i++) {
2627
                        my $net = $networks[$i];
2628
                        my $netkey = $netkeys[$i];
2629
                        my $netnamekey = $netnamekeys[$i];
2630
                        my $regnet = $networkreg{$net};
2631
                        my $oldid = $regnet->{'id'};
2632
                        next if ($net eq '' || $net eq '--');
2633
                        if ($regnet->{'type'} eq 'gateway') {
2634
                            if ($oldid > 1) { # Private gateway
2635
                                foreach my $networkvalref (values %networkreg) { # use gateway with same id if it exists
2636
                                    if ($networkvalref->{'user'} eq $domuser
2637
                                        && $networkvalref->{'type'} eq 'gateway'
2638
                                        && $networkvalref->{'id'} == $oldid) {
2639
                                        # We found an existing gateway with same id - use it
2640
                                        $register{$uuid}->{$netkey} = $networkvalref->{'uuid'};
2641
                                        $register{$uuid}->{$netnamekey} = $networkvalref->{'name'};
2642
                                        $netdone = 1;
2643
                                        $main::updateUI->({tab=>"networks", user=>$user, message=>"Using network $networkvalref->{'name'} from account: $domuser"});
2644
                                        last;
2645
                                    }
2646
                                }
2647
                                if (!($netdone)) {
2648
                                    # Make a new gateway
2649
                                    my $ug = new Data::UUID;
2650
                                    my $newuuid = $ug->create_str();
2651
                                    Stabile::Networks::save($oldid, $newuuid, $regnet->{'name'}, 'new', 'gateway', '', '', $regnet->{'ports'}, 0, $domuser);
2652
                                    $register{$uuid}->{$netkey} = $newuuid;
2653
                                    $register{$uuid}->{$netnamekey} = $regnet->{'name'};
2654
                                    $netdone = 1;
2655
                                    $main::updateUI->({tab=>"networks", user=>$user, message=>"Created gateway $regnet->{'name'} for account: $domuser"});
2656
                                    $main::syslogit->($user, "info", "Created gateway $regnet->{'name'} for account: $domuser");
2657
                                }
2658
                            } elsif ($oldid==0 || $oldid==1) {
2659
                                $netdone = 1; # Use common gateway
2660
                                $main::updateUI->({tab=>"networks", user=>$user, message=>"Reused network $regnet->{'name'} for account: $domuser"});
2661
                            }
2662
                        } else {
2663
                            my $newid = Stabile::Networks::getNextId('', $domuser);
2664
                            $networkreg{$net}->{'id'} = $newid;
2665
                            $networkreg{$net}->{'user'} = $domuser;
2666
                        #    if ($regnet->{'type'} eq 'internalip' || $regnet->{'type'} eq 'ipmapping') {
2667
                                # Deactivate network and assign new internal ip
2668
                                Stabile::Networks::Deactivate($regnet->{'uuid'});
2669
                                $networkreg{$net}->{'internalip'} =
2670
                                    Stabile::Networks::getNextInternalIP('',$regnet->{'uuid'}, $newid, $domuser);
2671
                        #    }
2672
                            $netdone = 1;
2673
                            $main::updateUI->({tab=>"networks", user=>$user, message=>"Moved network $regnet->{'name'} to account: $domuser"});
2674
                            $main::syslogit->($user, "info", "Moved network $regnet->{'name'} to account: $domuser");
2675
                        }
2676
                    }
2677
                    if ($netdone) {
2678
                        # Finally move the server
2679
                        $register{$uuid}->{'user'} = $domuser;
2680
                        $postmsg .= "OK Moved server $name to account: $domuser";
2681
                        $main::syslogit->($user, "info", "Moved server $name ($uuid) to account: $domuser");
2682
                        $main::updateUI->({tab=>"servers", user=>$user, type=>"update"});
2683
                    } else {
2684
                        $postmsg .= "ERROR Unable to move network to account: $domuser";
2685
                        $main::updateUI->({tab=>"image", user=>$user, message=>"Unable to move network to account: $domuser"});
2686
                    }
2687
                } else {
2688
                    $main::updateUI->({tab=>"image", user=>$user, message=>"Could not move image to account: $domuser"});
2689
                }
2690
            } else {
2691
                $postmsg .= "ERROR No access to move server";
2692
            }
2693
        } else {
2694
            $postmsg .= "Error Unable to move $status server";
2695
            $main::updateUI->({tab=>"servers", user=>$user, message=>"Please shut down before moving server"});
2696
        }
2697
        untie %userreg;
2698
    }
2699

    
2700
    if ($console) {
2701
        $postreply = $postmsg;
2702
    } else {
2703
        $postreply = $json_text || $postmsg;
2704
    }
2705
    return $postreply;
2706
    untie %imagereg;
2707
}
2708

    
2709

    
2710
sub Shutdown {
2711
    my ($uuid, $action, $obj) = @_;
2712
    if ($help) {
2713
        return <<END
2714
GET:uuid:
2715
Marks a server for shutdown, i.e. send and ACPI shutdown event to the server. If OS supports ACPI, it begins a shutdown.
2716
END
2717
    }
2718
    $uistatus = "shuttingdown";
2719
    my $dbstatus = $obj->{status};
2720
    my $mac = $obj->{mac};
2721
    my $macname = $obj->{macname};
2722
    my $name = $obj->{name};
2723
    if ($dbstatus eq 'running') {
2724
        my $tasks;
2725
        $tasks = $nodereg{$mac}->{'tasks'} if ($nodereg{$mac});
2726
        $nodereg{$mac}->{'tasks'} = $tasks . "SHUTDOWN $uuid $user\n";
2727
        tied(%nodereg)->commit;
2728
        $register{$uuid}->{'status'} = $uistatus;
2729
        $register{$uuid}->{'statustime'} = $current_time;
2730
        $uiuuid = $uuid;
2731
        $main::syslogit->($user, "info", "Marked $name ($uuid) for $uistatus by $macname ($mac)");
2732
        $postreply .= "Status=$uistatus OK $uistatus $name\n";
2733
    } else {
2734
        $main::syslogit->($user, "info", "Problem $uistatus a $dbstatus domain: $uuid");
2735
        $postreply .= "Status=ERROR problem $uistatus $name...\n";
2736
    }
2737
    return $postreply;
2738
}
2739

    
2740
sub Suspend {
2741
    my ($uuid, $action, $obj) = @_;
2742
    if ($help) {
2743
        return <<END
2744
GET:uuid:
2745
Marks a server for suspend, i.e. pauses the server. Server must be running
2746
END
2747
    }
2748
    $uistatus = "suspending";
2749
    my $dbstatus = $obj->{status};
2750
    my $mac = $obj->{mac};
2751
    my $macname = $obj->{macname};
2752
    my $name = $obj->{name};
2753
    if ($dbstatus eq 'running') {
2754
        my $tasks = $nodereg{$mac}->{'tasks'};
2755
        $nodereg{$mac}->{'tasks'} = $tasks . "SUSPEND $uuid $user\n";
2756
        tied(%nodereg)->commit;
2757
        $register{$uuid}->{'status'} = $uistatus;
2758
        $register{$uuid}->{'statustime'} = $current_time;
2759
        $uiuuid = $uuid;
2760
        $main::syslogit->($user, "info", "Marked $name ($uuid) for $uistatus by $macname ($mac)");
2761
        $postreply .= "Status=$uistatus OK $uistatus $name.\n";
2762
    } else {
2763
        $main::syslogit->($user, "info", "Problem $uistatus a $dbstatus domain: $uuid");
2764
        $postreply .= "Status=ERROR problem $uistatus $name.\n";
2765
    }
2766
    return $postreply;
2767
}
2768

    
2769
sub Resume {
2770
    my ($uuid, $action, $obj) = @_;
2771
    if ($help) {
2772
        return <<END
2773
GET:uuid:
2774
Marks a server for resume running. Server must be paused.
2775
END
2776
    }
2777
    my $dbstatus = $obj->{status};
2778
    my $mac = $obj->{mac};
2779
    my $macname = $obj->{macname};
2780
    my $name = $obj->{name};
2781
    my $image = $obj->{image};
2782
    my $image2 = $obj->{image2};
2783
    my $image3 = $obj->{image3};
2784
    my $image4 = $obj->{image4};
2785
    unless ( tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {$posterror = "Unable to access image register"; return;};
2786
    if ($imagereg{$image}->{'status'} ne "paused"
2787
        || ($image2 && $image2 ne '--' && $imagereg{$image}->{'status'} ne "paused")
2788
        || ($image3 && $image3 ne '--' && $imagereg{$image3}->{'status'} ne "paused")
2789
        || ($image4 && $image4 ne '--' && $imagereg{$image4}->{'status'} ne "paused")
2790
    ) {
2791
        $postreply .= "Status=ERROR Image $uuid busy ($imagereg{$image}->{'status'}), please wait 30 sec.\n";
2792
        untie %imagereg;
2793
        return $postreply   ;
2794
    } else {
2795
        untie %imagereg;
2796
    }
2797
    $uistatus = "resuming";
2798
    if ($dbstatus eq 'paused') {
2799
        my $tasks = $nodereg{$mac}->{'tasks'};
2800
        $nodereg{$mac}->{'tasks'} = $tasks . "RESUME $uuid $user\n";
2801
        tied(%nodereg)->commit;
2802
        $register{$uuid}->{'status'} = $uistatus;
2803
        $register{$uuid}->{'statustime'} = $current_time;
2804
        $uiuuid = $uuid;
2805
        $main::syslogit->($user, "info", "Marked $name ($uuid) for $uistatus by $macname ($mac)");
2806
        $postreply .= "Status=$uistatus OK $uistatus ". $register{$uuid}->{'name'} . "\n";
2807
    } else {
2808
        $main::syslogit->($user, "info", "Problem $uistatus a $dbstatus domain: $uuid");
2809
        $postreply .= "Status=ERROR problem $uistatus ". $register{$uuid}->{'name'} . "\n";
2810
    }
2811
    return $postreply;
2812
}
2813

    
2814
sub Move {
2815
    my ($uuid, $action, $obj) = @_;
2816
    if ($help) {
2817
        return <<END
2818
GET:uuid,mac:
2819
Moves a server to a different node (Qemu live migration). Server must be running
2820
END
2821
    }
2822
    my $dbstatus = $obj->{status};
2823
    my $dmac = $obj->{mac};
2824
    my $name = $obj->{name};
2825
    my $mem = $obj->{memory};
2826
    my $vcpu = $obj->{vcpu};
2827
    my $image = $obj->{image};
2828
    my $image2 = $obj->{image2};
2829
    my $image3 = $obj->{image3};
2830
    my $image4 = $obj->{image4};
2831
    $uistatus = "moving";
2832
    if ($dbstatus eq 'running' && $isadmin) {
2833
        my $hypervisor = getHypervisor($image);
2834
        my $mac = $register{$uuid}->{'mac'};
2835
        $dmac = "" if ($dmac eq "--");
2836
        $mac = "" if ($mac eq "--");
2837

    
2838
        if ($image =~ /\/mnt\/stabile\/node\//
2839
            || $image2 =~ /\/mnt\/stabile\/node\//
2840
            || $image3 =~ /\/mnt\/stabile\/node\//
2841
            || $image4 =~ /\/mnt\/stabile\/node\//
2842
        ) {
2843
            # We do not support moving locally stored VM's yet...
2844
            $postreply = qq|{"error": 1, "message": "Moving servers with local storage not supported"}|;
2845
        } else {
2846
            my ($targetmac, $targetname, $targetip, $port) =
2847
                locateTargetNode($uuid, $dmac, $mem, $vcpu, $image, $image2, $image3, $image4, $hypervisor, $mac);
2848
            if ($targetmac) {
2849
                my $tasks = $nodereg{$targetmac}->{'tasks'};
2850
                $tasks = $tasks . "RECEIVE $uuid $user\n";
2851
                # Also update allowed port forwards
2852
                $nodereg{$targetmac}->{'tasks'} = $tasks . "PERMITOPEN $user\n";
2853
                $register{$uuid}->{'status'} = "moving";
2854
                $register{$uuid}->{'statustime'} = $current_time;
2855
                $uiuuid = $uuid;
2856
                $uidisplayip = $targetip;
2857
                $uidisplayport = $port;
2858
                $main::syslogit->($user, "info", "Marked $name ($uuid) for $uistatus to $targetname ($targetmac)");
2859
                $postreply .= "Status=OK $uistatus ". $register{$uuid}->{'name'} . "\n";
2860

    
2861
                if ($params{'PUTDATA'}) {
2862
                    my %jitem = %{$register{$uuid}};
2863
                    my $json_text = to_json(\%jitem);
2864
                    $json_text =~ s/null/"--"/g;
2865
                    $postreply = $json_text;
2866
                }
2867
                $main::updateUI->({tab=>"servers", user=>$user, status=>'moving', uuid=>$uuid, type=>'update', message=>"Moving $register{$uuid}->{name} to $targetmac"});
2868
            } else {
2869
                $main::syslogit->($user, "info", "Could not find $hypervisor target for $uistatus $uuid ($image)");
2870
                $postreply = qq|{"error": 1, "message": "Could not find target for $uistatus $register{$uuid}->{'name'}"}|;
2871
            }
2872
        }
2873
    } else {
2874
        $main::syslogit->($user, "info", "Problem moving a $dbstatus domain: $uuid");
2875
        $postreply .= qq|{"error": 1, "message": "ERROR problem moving $register{$uuid}->{'name'} ($dbstatus)"}|;
2876
    }
2877
    return $postreply;
2878
}
2879

    
2880
sub Changepassword {
2881
    my ($uuid, $action, $obj) = @_;
2882
    if ($help) {
2883
        return <<END
2884
POST:uuid,username,password:
2885
Attempts to set password for [username] to [password] using guestfish. If no username is specified, user 'stabile' is assumed.
2886
END
2887
    }
2888
    my $img = $register{$uuid}->{'image'};
2889
    my $username = $obj->{'username'} || 'stabile';
2890
    my $password = $obj->{'password'};
2891
    return "Status=Error Please supply a password\n" unless ($password);
2892
    return "Status=Error Please shut down the server before changing password\n" unless ($register{$uuid} && $register{$uuid}->{'status'} eq 'shutoff');
2893
    return "Status=Error Not allowed\n" unless ($isadmin || $register{$uuid}->{'user'} eq $user);
2894

    
2895
    unless (tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {$res .= qq|{"status": "Error": "message": "Unable to access images register"}|; return $res;};
2896
    my $cmd = qq/guestfish --rw -a $img -i command "bash -c 'echo $username:$password | chpasswd'" 2>\&1/;
2897
    if ($imagereg{$img} && $imagereg{$img}->{'mac'}) {
2898
        my $mac = $imagereg{$img}->{'mac'};
2899
        my $macip = $nodereg{$mac}->{'ip'};
2900
        $cmd = "$sshcmd $macip $cmd";
2901
    }
2902
    my $res = `$cmd`;
2903
    $res = $1 if ($res =~ /guestfish: (.*)/);
2904
    chomp $res;
2905
    return "Status=OK Ran chpasswd for user $username in server $register{$uuid}->{'name'}: $res\n";
2906
}
2907

    
2908
sub Sshaccess {
2909
    my ($uuid, $action, $obj) = @_;
2910
    if ($help) {
2911
        return <<END
2912
POST:uuid,address:
2913
Attempts to change the ip addresses you can access the server over SSH (port 22) from, by adding [address] to /etc/hosts.allow.
2914
[address] should either be an IP address or a range in CIDR notation. Please note that no validation of [address] is performed.
2915
END
2916
    }
2917
    my $img = $register{$uuid}->{'image'};
2918
    my $address = $obj->{'address'};
2919
    return "Status=Error Please supply an aaddress\n" unless ($address);
2920
    return "Status=Error Please shut down the server before changing SSH access\n" unless ($register{$uuid} && $register{$uuid}->{'status'} eq 'shutoff');
2921
    return "Status=Error Not allowed\n" unless ($isadmin || $register{$uuid}->{'user'} eq $user);
2922

    
2923
    unless (tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {$res .= qq|{"status": "Error": "message": "Unable to access images register"}|; return $res;};
2924

    
2925
    my $isshcmd = '';
2926
    my $cmd = qq[guestfish --rw -a $img -i command "sed -i -re 's|(sshd: .*)#stabile|\\1 $address #stabile|' /etc/hosts.allow"];
2927
#    my $cmd = qq[guestfish --rw -a $img -i command "bash -c 'echo sshd: $address >> /etc/hosts.allow'"];
2928
    if ($imagereg{$img} && $imagereg{$img}->{'mac'}) {
2929
        my $mac = $imagereg{$img}->{'mac'};
2930
        my $macip = $nodereg{$mac}->{'ip'};
2931
        $isshcmd = "$sshcmd $macip ";
2932
    }
2933
    my $res = `$isshcmd$cmd`;
2934
    chomp $res;
2935
    #$cmd = qq[guestfish --rw -a $img -i command "bash -c 'cat /etc/hosts.allow'"];
2936
    #$res .= `$isshcmd$cmd`;
2937
    #chomp $res;
2938
    return "Status=OK Tried to add sshd: $address to /etc/hosts.allow in server $register{$uuid}->{'name'}\n";
2939
}
2940

    
2941
sub Mountcd {
2942
    my ($uuid, $action, $obj) = @_;
2943
    if ($help) {
2944
        return <<END
2945
GET:uuid,cdrom:
2946
Mounts a cdrom on a server. Server must be running. Mounting the special cdrom named '--' unomunts any currently mounted cdrom.
2947
END
2948
    }
2949
    my $dbstatus = $obj->{status};
2950
    my $mac = $obj->{mac};
2951
    my $cdrom = $obj->{cdrom};
2952
    unless ($cdrom && $dbstatus eq 'running') {
2953
        $main::updateUI->({tab=>"servers", user=>$user, uuid=>$uuid, type=>'update', message=>"Unable to mount cdrom"});
2954
        $postreply = qq|{"Error": 1, "message": "Problem mounting cdrom on $obj->{name}"}|;
2955
        return;
2956
    }
2957
    my $tasks = $nodereg{$mac}->{'tasks'};
2958
    # $user is in the middle here, because $cdrom may contain spaces...
2959
    $nodereg{$mac}->{'tasks'} = $tasks . "MOUNT $uuid $user \"$cdrom\"\n";
2960
    tied(%nodereg)->commit;
2961
    if ($cdrom eq "--") {
2962
        $postreply = qq|{"OK": 1, "message": "OK unmounting cdrom from $obj->{name}"}|;
2963
    } else {
2964
        $postreply = qq|{"OK": 1, "message": "OK mounting cdrom $cdrom on $obj->{name}"}|;
2965
    }
2966
    $register{$uuid}->{'cdrom'} = $cdrom unless ($cdrom eq 'virtio');
2967
    return $postreply;
2968
}
(5-5/9)