Project

General

Profile

Download (253 KB) Statistics
| Branch: | Revision:

stabile / cgi / images.cgi @ master

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::Images;
9

    
10
use Error qw(:try);
11
use File::Basename;
12
use Data::UUID;
13
use Proc::Daemon;
14
use Time::Local;
15
#use Time::HiRes qw( time );
16
use Date::Format;
17
use Date::Parse;
18
use Getopt::Std;
19
#use Encode::Escape;
20
use String::Escape;
21
use File::Glob qw(bsd_glob);
22
use Sys::Guestfs;
23
use Data::Dumper;
24
use XML::Simple;
25
#use POSIX qw(strftime);
26
use Time::Piece;
27
use Config::Simple;
28
use lib dirname (__FILE__); # Allows us to source libraries from current directory no matter where we are called from
29
use Stabile;
30

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

    
33
# Read in some settings from config
34
$backupdir = $Stabile::config->get('STORAGE_BACKUPDIR') || "/mnt/stabile/backups";
35
$backupdir = $1 if ($backupdir =~ /(.+)/); #untaint
36
my $tenders = $Stabile::config->get('STORAGE_POOLS_ADDRESS_PATHS');
37
my @tenderlist = split(/,\s*/, $tenders);
38
my $tenderpaths = $Stabile::config->get('STORAGE_POOLS_LOCAL_PATHS') || "/mnt/stabile/images";
39
my @tenderpathslist = split(/,\s*/, $tenderpaths);
40
my $tendernames = $Stabile::config->get('STORAGE_POOLS_NAMES') || "Standard storage";
41
my @tendernameslist = split(/,\s*/, $tendernames);
42
my $mountabletenders = $Stabile::config->get('STORAGE_POOLS_MOUNTABLE');
43
my @mountabletenderslist = split(/,\s*/, $mountabletenders);
44
my $storagepools = $Stabile::config->get('STORAGE_POOLS_DEFAULTS') || "0";
45
my $spoolsrdiffenabled = $Stabile::config->get('STORAGE_POOLS_RDIFF-BACKUP_ENABLED') || "0";
46
my @rdiffenabledlist = split(/,\s*/, $spoolsrdiffenabled);
47
my $rdiffenabled = $Stabile::config->get('RDIFF-BACKUP_ENABLED') || "0";
48
my $userrdiffenabled = $Stabile::config->get('RDIFF-BACKUP_USERS') || "0";
49
my $nodestorageovercommission = $Stabile::config->get('NODE_STORAGE_OVERCOMMISSION') || "1";
50
my $engineid = $Stabile::config->get('ENGINEID') || "";
51

    
52
my $valve_readlimit = $Stabile::config->get('VALVE_READ_LIMIT'); # e.g. 125829120 = 120 * 1024 * 1024 = 120 MB / s
53
my $valve_writelimit = $Stabile::config->get('VALVE_WRITE_LIMIT');
54
my $valve_iopsreadlimit = $Stabile::config->get('VALVE_IOPS_READ_LIMIT'); # e.g. 1000 IOPS
55
my $valve_iopswritelimit = $Stabile::config->get('VALVE_IOPS_WRITE_LIMIT');
56

    
57
my $valve001id = '995e86b7-ae85-4ae0-9800-320c1f59ae33';
58
my $stackspool = '/mnt/stabile/images001';
59

    
60
our %ahash; # A hash of accounts and associated privileges current user has access to
61
#our %options=();
62
# -a action -h help -f full list -p full update -u uuid -i image -m match pattern -k keywords -g args to gearman task
63
# -v verbose, include HTTP headers -s impersonate subaccount -t target [uuid or image]
64
#Getopt::Std::getopts("a:hfpu:i:g:m:k:vs:t:", \%options);
65

    
66
try {
67
    Init(); # Perform various initalization tasks
68
    process() if ($package); # Parse and process request. $package is not set if called as a library
69

    
70
} catch Error with {
71
    my $ex = shift;
72
    print header('text/html', '500 Internal Server Error') unless ($console);
73
    if ($ex->{-text}) {
74
        print "Got error: ", $ex->{-text}, " on line ", $ex->{-line}, "\n";
75
    } else {
76
        print "Status=ERROR\n";
77
    }
78
} finally {
79
};
80

    
81
1;
82

    
83
sub Init {
84

    
85
    # Tie database tables to hashes
86
    unless ( tie(%userreg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {return "Unable to access user register"};
87
    unless ( tie(%register,'Tie::DBI', Hash::Merge::merge({table=>'images', key=>'path'}, $Stabile::dbopts)) ) {return "Unable to access image register"};
88
    unless ( tie(%networkreg,'Tie::DBI', Hash::Merge::merge({table=>'networks'}, $Stabile::dbopts)) ) {return "Unable to access network register"};
89
    unless ( tie(%imagereg,'Tie::DBI', Hash::Merge::merge({table=>'images', CLOBBER=>1}, $Stabile::dbopts)) ) {return "Unable to access image uuid register"};
90
    unless ( tie(%domreg,'Tie::DBI', Hash::Merge::merge({table=>'domains'}, $Stabile::dbopts)) ) {return "Unable to access domain register"};
91

    
92
    # simplify globals initialized in Stabile.pm
93
    $tktuser = $tktuser || $Stabile::tktuser;
94
    $user = $user || $Stabile::user;
95
    $isadmin = $isadmin || $Stabile::isadmin;
96
    $sshcmd = $sshcmd || $Stabile::sshcmd;
97
    $disablesnat = $disablesnat || $Stabile::disablesnat;
98

    
99
    # Create aliases of functions
100
    *header = \&CGI::header;
101

    
102
    *Getimagesdevice = \&Liststoragedevices;
103
    *Getbackupdevice = \&Liststoragedevices;
104
    *Listimagesdevices = \&Liststoragedevices;
105
    *Listbackupdevices = \&Liststoragedevices;
106
    *Rebase = \&Unmaster;
107

    
108
    *do_save = \&privileged_action_async;
109
    *do_sync_save = \&privileged_action;
110
    *do_sync_backup = \&privileged_action;
111
    *do_sync_clone = \&privileged_action;
112
    *do_updateregister = \&action;
113
    *do_fullupdateregister = \&action;
114
    *do_tablelistall = \&do_list;
115
    *do_tablelist = \&do_list;
116
    *Sync_save = \&Save;
117
    *Sync_backup = \&Backup;
118
    *Sync_clone = \&Clone;
119
    *do_help = \&action;
120

    
121
    *do_mount = \&privileged_action;
122
    *do_unmount = \&privileged_action;
123
    *do_convert = \&privileged_action;
124
    *do_activate = \&privileged_action;
125
    *do_publish = \&privileged_action;
126
    *do_uploadtoregistry = \&privileged_action;
127
    *do_release = \&privileged_action;
128
    *do_download = \&privileged_action;
129
    *do_linkmaster = \&privileged_action;
130
    *do_listbackups = \&privileged_action;
131
    *do_listcdroms = \&action;
132
    *do_listfiles = \&privileged_action;
133
    *do_getserverbackups = \&privileged_action;
134
    *do_listserverbackups = \&privileged_action;
135
    *Listserverbackups = \&Getserverbackups;
136
    *do_restorefiles = \&privileged_action;
137
    *do_remove = \&privileged_action;
138
    *do_removeuserimages = \&privileged_action;
139
    *do_updatedownloads = \&privileged_action;
140
    *do_master = \&privileged_action_async;
141
    *do_unmaster = \&privileged_action_async;
142
    *do_rebase = \&privileged_action_async;
143
    *do_clone = \&privileged_action_async;
144
    *do_snapshot = \&privileged_action_async;
145
    *do_unsnap = \&privileged_action_async;
146
    *do_revert = \&privileged_action_async;
147
    *do_inject = \&privileged_action_async;
148
    *do_backup = \&privileged_action_async;
149
    *do_zbackup = \&privileged_action;
150
    *do_restore = \&privileged_action_async;
151
    *do_updatebackingfile = \&privileged_action;
152
    *do_updatebtime = \&privileged_action;
153
    *do_updateallbtimes = \&privileged_action;
154
    *do_initializestorage = \&privileged_action;
155
    *do_liststoragedevices = \&privileged_action;
156
    *do_listimagesdevices = \&privileged_action;
157
    *do_listbackupdevices = \&privileged_action;
158
    *do_getimagesdevice = \&privileged_action;
159
    *do_getbackupdevice = \&privileged_action;
160
    *do_setstoragedevice = \&privileged_action;
161
    *do_backupfuel = \&privileged_action;
162

    
163
    *do_gear_save = \&do_gear_action;
164
    *do_gear_sync_save = \&do_gear_action;
165
    *do_gear_sync_backup = \&do_gear_action;
166
    *do_gear_sync_clone = \&do_gear_action;
167
    *do_gear_mount = \&do_gear_action;
168
    *do_gear_unmount = \&do_gear_action;
169
    *do_gear_convert = \&do_gear_action;
170
    *do_gear_activate = \&do_gear_action;
171
    *do_gear_publish = \&do_gear_action;
172
    *do_gear_uploadtoregistry = \&do_gear_action;
173
    *do_gear_release = \&do_gear_action;
174
    *do_gear_download = \&do_gear_action;
175
    *do_gear_linkmaster = \&do_gear_action;
176
    *do_gear_listbackups = \&do_gear_action;
177
    *do_gear_listserverbackups = \&do_gear_action;
178
    *do_gear_getserverbackups = \&do_gear_action;
179
    *do_gear_listfiles = \&do_gear_action;
180
    *do_gear_restorefiles = \&do_gear_action;
181
    *do_gear_remove = \&do_gear_action;
182
    *do_gear_removeuserimages = \&do_gear_action;
183
    *do_gear_updatedownloads = \&do_gear_action;
184
    *do_gear_master = \&do_gear_action;
185
    *do_gear_unmaster = \&do_gear_action;
186
    *do_gear_rebase = \&do_gear_action;
187
    *do_gear_clone = \&do_gear_action;
188
    *do_gear_snapshot = \&do_gear_action;
189
    *do_gear_unsnap = \&do_gear_action;
190
    *do_gear_revert = \&do_gear_action;
191
    *do_gear_inject = \&do_gear_action;
192
    *do_gear_backup = \&do_gear_action;
193
    *do_gear_zbackup = \&do_gear_action;
194
    *do_gear_restore = \&do_gear_action;
195
    *do_gear_updatebackingfile = \&do_gear_action;
196
    *do_gear_updatebtime = \&do_gear_action;
197
    *do_gear_updateallbtimes = \&do_gear_action;
198
    *do_gear_initializestorage = \&do_gear_action;
199
    *do_gear_liststoragedevices = \&do_gear_action;
200
    *do_gear_listimagesdevices = \&do_gear_action;
201
    *do_gear_listbackupdevices = \&do_gear_action;
202
    *do_gear_getimagesdevice = \&do_gear_action;
203
    *do_gear_getbackupdevice = \&do_gear_action;
204
    *do_gear_setstoragedevice = \&do_gear_action;
205
    *do_gear_backupfuel = \&do_gear_action;
206

    
207
    *Fullupdateregister = \&Updateregister;
208

    
209
    @users; # global
210
    if ($fulllist) {
211
        @users = keys %userreg;
212
        push @users, "common";
213
    } else {
214
        @users = ($user, "common");
215
    }
216

    
217
    untie %userreg;
218

    
219
#    my $mounts = decode('ascii-escape', `/bin/cat /proc/mounts`);
220
    my $mounts = `/bin/cat /proc/mounts`;
221
    @spools;
222

    
223
    # Enumerate and define the storage pools a user has access to
224
    my @spl = split(/,\s*/, $storagepools);
225
    my $reloadnfs;
226
    foreach my $p (@spl) {
227
        if ($tenderlist[$p] && $tenderpathslist[$p] && $tendernameslist[$p]) {
228
            my $rd = (defined $rdiffenabledlist[$p])?$rdiffenabledlist[$p]:"$rdiffenabledlist[0]";
229
            my %pool = ("hostpath", $tenderlist[$p],
230
                "path", $tenderpathslist[$p],
231
                "name", $tendernameslist[$p],
232
                "rdiffenabled", $rd,
233
                "mountable", ($tenderlist[$p] eq 'local') || $mountabletenderslist[$p] || '0', # local pools always mountable
234
                "lvm", 0+($tenderlist[$p] eq 'local' && ($mounts =~ m/\/dev\/mapper\/(\S+)-(\S+) $tenderpathslist[$p].+/g) ),
235
                "zfs", (($mounts =~ /(\S+) $tenderpathslist[$p] zfs/)?$1:''),
236
                "id", $p);
237
            $spools[$p] = \%pool;
238

    
239
            # Directory / mount point must exist
240
            unless (-d $tenderpathslist[$p]) {return "Status=Error $tenderpathslist[$p] could not be accessed"};
241

    
242
            # TODO: This section should be moved to pressurecontrol
243
            if ($tenderlist[$p] eq "local") {
244
                my $lpath = $tenderpathslist[$p];
245
                `mkdir "$lpath"` unless (-e $lpath);
246
                unless (`grep "$lpath 10" /etc/exports`) {
247
                    `echo "$lpath 10.0.0.0/255.255.255.0(sync,no_subtree_check,no_root_squash,rw)" >> /etc/exports`;
248
                    $reloadnfs = 1;
249
                }
250
            } elsif ($mounts =~ m/$tenderpathslist[$p]/i) {
251
                ; # do nothing
252
            } else {
253
                $main::syslogit->($user, 'info', "Mounting $tenderpathslist[$p] from $tenderlist[$p]");
254
                eval {
255
                    system("/bin/mount -o intr,noatime,nfsvers=3 $tenderlist[$p] $tenderpathslist[$p]");
256
                    1;
257
                } or {return "Status=Error $tenderpathslist[$p] could not be mounted"};
258
            }
259

    
260
            # Create user dir if it does not exist
261
            unless(-d "$tenderpathslist[$p]/$user"){
262
                umask "0000";
263
                mkdir "$tenderpathslist[$p]/$user" or {return "Status=Cannot create user dir for $user in  $tenderpathslist[$p]"};
264
            }
265
            unless(-d "$tenderpathslist[$p]/common"){
266
                umask "0000";
267
                mkdir "$tenderpathslist[$p]/common" or {return "Status=Cannot create common dir for $user in $tenderpathslist[$p]"};
268
            }
269
        }
270
    }
271
    `/usr/sbin/exportfs -r` if ($reloadnfs); #Reexport nfs shares
272

    
273
    # Create user's backupdir if it does not exist
274
    unless(-d "$backupdir/$user"){
275
        umask "0000";
276
        mkdir "$backupdir/$user" or {$postreply .= "Status=ERROR No backup dir $backupdir/$user\n"};
277
    }
278

    
279
}
280

    
281
sub getObj {
282
    my %h = %{@_[0]};
283
    my $status = $h{"status"};
284
    $console = 1 if $h{"console"};
285
    $api = 1 if $h{"api"};
286
    my $obj;
287
    $action = $action || $h{'action'};
288
    if (
289
        $action =~ /^clone|^sync_clone|^removeuserimages|^gear_removeuserimages|^activate|^gear_activate|^publish|uploadtoregistry|^release|^download|^gear_publish/
290
        || $action =~ /^gear_release|^zbackup|setimagesdevice|setbackupdevice|initializestorage|setstoragedevice|backupfuel|sync_backup/
291

    
292
    ) {
293
        $obj = \%h;
294
        return $obj;
295
    }
296
    my $uuid = $h{"uuid"};
297
    if ($uuid && $uuid =~ /^\// ) { # Ugly clutch
298
        $uuid = $register{$uuid}->{'uuid'};
299
    }
300
    if ($uuid eq 'this' && $curimg
301
        && ($register{$curimg}->{'user'} eq $user || $isadmin )) { # make an ugly exception
302
        $uuid = $register{$curimg}->{'uuid'};
303
    }
304
    my $objaction = lc $h{"action"};
305
    $status = "new" unless ($status || $h{'path'} || $uuid);
306
    if ($status eq "new") {
307
        $objaction = "";
308
    }
309
    if (!$uuid && $register{$h{'path'}} && ( $register{$h{'path'}}->{'user'} eq $user || $isadmin )) {
310
        $uuid = $register{$h{'path'}}->{'uuid'};
311
    }
312
    my $img = $imagereg{$uuid};
313
    $status = $img->{'status'} if ($imagereg{$uuid});
314
    if ($objaction eq 'buildsystem' && !$uuid && $h{'master'}) { # make another exception
315
        my $master = $h{'master'};
316
        foreach my $p (@spools) {
317
            my $dir = $p->{'path'};
318
            if ($master =~ /^$dir\/(common|$user)\/.+/ && $register{$master}) { # valid master image
319
                $uuid = $register{$master}->{'uuid'};
320
                last;
321
            }
322
            elsif ($register{"$dir/common/$master"}) { # valid master image
323
                $uuid = $register{"$dir/$user/$master"}->{'uuid'};
324
                last;
325
            }
326
            elsif ($register{"$dir/$user/$master"}) { # valid master image
327
                $uuid = $register{"$dir/$user/$master"}->{'uuid'};
328
                last;
329
            }
330
        }
331
    }
332
    my $path = '';
333
    $path = $img->{'path'} unless ($status eq "new"); # Only trust path from db /co
334
    my $dbobj = $register{$path} || {};
335
    return 0 unless (($path && $dbobj->{'user'} eq $user) || $isadmin || $status eq "new"); # Security check
336

    
337
    unless (($uuid && $imagereg{$uuid} && $status ne 'new') || ($status eq 'new' && !$imagereg{$uuid} && (!$uuid || length($uuid) == 36))) {
338
        $postreply .= "Status=ERROR Invalid image " . (($uuid)?" uuid: $uuid":"") . (($path)?" path: $path":"") . "\n";
339
        return 0;
340
    }
341
    if ($isadmin && $h{"status"}) {
342
        $status = $h{"status"} unless ($status eq "new");
343
    } else {
344
        $status = $dbobj->{'status'} unless ($status eq "new"); # Read status from db for existing images
345
    }
346
    my $virtualsize = $h{"virtualsize"} || $dbobj->{'virtualsize'};
347
    # allow shorthand size specifications
348
    $virtualsize = 1024 * $virtualsize if ($virtualsize =~ /k$/i);
349
    $virtualsize = 1024*1024* $virtualsize if ($virtualsize =~ /m$/i);
350
    $virtualsize = 1024*1024*1024* $virtualsize if ($virtualsize =~ /g$/i);
351
    $virtualsize = 10737418240 if ($status eq 'new' && !$virtualsize); # 10 GB
352

    
353
    $obj = {
354
        path           => $path,
355
        uuid           => $uuid,
356
        status         => $status,
357
        name           => $h{"name"} || $dbobj->{'name'}, # || 'New Image',
358
        size           => $h{"size"} || $dbobj->{'size'},
359
        realsize       => $dbobj->{'realsize'} || 0,
360
        virtualsize    => $virtualsize,
361
        ksize          => int($virtualsize / 1024),
362
        msize          => int($virtualsize / (1024 * 1024)),
363
        type           => $h{"type"} || $dbobj->{'type'} || 'qcow2',
364
        user           => $h{"user"} || $dbobj->{'user'},
365
        reguser        => $dbobj->{'user'},
366
        master         => $dbobj->{'master'},
367
        regstoragepool => $dbobj->{'storagepool'},
368
        storagepool   => (!$h{"storagepool"} && $h{"storagepool"} ne "0") ? $dbobj->{'storagepool'} : $h{"storagepool"},
369
        bschedule      => $h{"bschedule"} || $dbobj->{'bschedule'},
370
        notes          => $h{"notes"},
371
        installable    => ($installable && $installable ne "false") ? "true" : $h{"installable"},
372
        snap1          => $dbobj->{'snap1'},
373
        managementlink => $h{"managementlink"} || $dbobj->{'managementlink'},
374
        upgradelink    => $h{"upgradelink"} || $dbobj->{'upgradelink'},
375
        terminallink   => $h{"terminallink"} || $dbobj->{'terminallink'},
376
        image2         => $h{"image2"} || $dbobj->{'image2'},
377
        mac            => $h{"mac"} || $dbobj->{'mac'},
378
        backup         => $h{"backup"} || '',
379
        domains        => $dbobj->{'domains'} || '--',
380
        domainnames    => $dbobj->{'domainnames'} || '--'
381
    };
382
    # Handle restore of files
383
    $obj->{'restorepath'} = $h{'restorepath'} if ($h{'restorepath'});
384
    $obj->{'files'} = $h{'files'} if ($h{'files'});
385
    $obj->{'sync'} = 1 if ($h{'sync'});
386
    # For backup
387
    $obj->{'skipzfs'} = 1 if ($h{'skipzfs'});
388

    
389
    # Sanity checks
390
    if (
391
        ($obj->{name} && length $obj->{name} > 255)
392
            || ($obj->{virtualsize} && ($obj->{virtualsize}<1024 || $obj->{virtualsize} >1024**5))
393
            || ($obj->{master} && length $obj->{master} > 255)
394
            || ($obj->{bschedule} && length $obj->{bschedule} > 255)
395
            || ($path && length $path > 255)
396
            || ($obj->{image2} && length $obj->{image2} > 255)
397
    ) {
398
        $postreply .= "Status=ERROR Bad image data for: $obj->{name}\n";
399
        return 0;
400
    }
401
    # Security check
402
    if (($user ne $obj->{reguser} && $objaction ne 'clone' && $objaction ne 'buildsystem' && !$isadmin && $objaction))
403
    {
404
        $postreply .= "Status=ERROR No privs\n";
405
        return 0;
406
    }
407
    if ($status eq "new" && ($obj->{reguser} || -e $path)) {
408
        $postreply .= "Status=ERROR Image \"$obj->{name}\" already exists in $path\n";
409
        return 0;
410
    }
411
    if (!$path && $status ne "new") {
412
        $postreply .= "Status=ERROR Image $obj->{name} not found\n";
413
        return 0;
414
    }
415
    return $obj;
416
}
417

    
418
sub createNodeTask {
419
    my ($mac, $newtask, $wake) = @_;
420
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac'}, $Stabile::dbopts)) )
421
        {$postreply .= "Status=Error Node register could not be accessed"};
422

    
423
    if ($nodereg{$mac}->{'status'} =~ /asleep|inactive/  && !$wake) {
424
        $postreply .= "Status=Error Node $mac is asleep, not waking\n";
425
        return "Node is asleep, please wake first!";
426
    } else {
427
        my $tasks = $nodereg{$mac}->{'tasks'};
428
        $nodereg{$mac}->{'tasks'} = $tasks . "$newtask\n";
429
        tied(%nodereg)->commit;
430
    }
431
    untie %nodereg;
432
    return 0;
433
}
434

    
435
sub Recurse {
436
	my($path) = shift; # @_;
437
	my @files;
438
	## append a trailing / if it's not there
439
	$path .= '/' if($path !~ /\/$/);
440
	## loop through the files contained in the directory
441
	for my $eachFile (bsd_glob($path.'*')) {
442
	    next if ($eachFile =~ /\/fuel$/);
443
		## if the file is a directory
444
		if( -d $eachFile) {
445
			## pass the directory to the routine ( recursion )
446
			push(@files,Recurse($eachFile));
447
		} else {
448
			push(@files,$eachFile);
449
		}
450
	}
451
	return @files;
452
}
453

    
454
# If used with the -f switch ($fulllist) from console, all users images are updated in the db
455
# If used with the -p switch ($fullupdate), also updates status information (ressource intensive - runs through all domains)
456
sub Updateregister {
457
    my ($spath, $action) = @_;
458
    if ($help) {
459
        return <<END
460
GET:image,uuid:
461
If used with the -f switch ($fulllist) from console, all users images are updated in the db.
462
If used with the -p switch ($fullupdate), also updates status information (ressource intensive - runs through all domains)
463
Only images on shared storage are updated, images on node storage are handled on the node.
464
END
465
    }
466
    return "Status=ERROR You must be an admin to do this!\n" unless ($isadmin);
467
    $fullupdate = 1 if ((!$fullupdate && $params{'fullupdate'}) || $action eq 'fullupdateregister');
468
    my $force = $params{'force'};
469
    my %userregister;
470
    my $res;
471
    # Update size information in db
472
    foreach my $u (@users) {
473
        foreach my $spool (@spools) {
474
            my $pooldir = $spool->{"path"};
475
            my $dir = "$pooldir/$u";
476
            my @thefiles = Recurse($dir);
477
            foreach my $f (@thefiles) {
478
                next if ($spath && $spath ne $f); # Only specific image being updated
479
                if ($f =~ /(.+)(-s\d\d\d\.vmdk$)/) {
480
                #   `touch "$1.vmdk" 2>/dev/null` unless -e "$1.vmdk";
481
                } elsif ($f =~ /(.+)(-flat\.vmdk$)/) {
482
                #    `touch "$1.vmdk" 2>/dev/null` unless -e "$1.vmdk";
483
                } elsif(-s $f && $f =~ /(\.vmdk$)|(\.img$)|(\.vhd$)|(\.qcow$)|(\.qcow2$)|(\.vdi$)|(\.iso$)/i) {
484
                    my($fname, $dirpath, $suffix) = fileparse($f, ("vmdk", "img", "vhd", "qcow", "qcow2", "vdi", "iso"));
485
                    my $uuid;
486
                    my $img = $register{$f};
487
                    $uuid = $img->{'uuid'};
488
            # Create a new uuid if we are dealing with a new file in the file-system
489
                    if (!$uuid) {
490
                        my $ug = new Data::UUID;
491
                        $uuid = $ug->create_str();
492
                    }
493
                    my $storagepool = $spool->{"id"};
494
            # Deal with sizes
495
                    my ($newmtime, $newbackupsize, $newsize, $newrealsize, $newvirtualsize) =
496
                        getSizes($f, $img->{'mtime'}, $img->{'status'}, $u, $force);
497
                    my $size = $newsize || $img->{'size'};
498
                    my $realsize = $newrealsize || $img->{'realsize'};
499
                    my $virtualsize = $newvirtualsize || $img->{'virtualsize'};
500
                    my $mtime = $newmtime || $img->{'mtime'};
501
                    my $created = $img->{'created'} || $mtime;
502
                    my $name = $img->{'name'} || substr($fname,0,-1);
503
                    $register{$f} = {
504
                        path=>$f,
505
                        user=>$u,
506
                        type=>$suffix,
507
                        size=>$size,
508
                        realsize=>$realsize,
509
                        virtualsize=>$virtualsize,
510
                        backupsize=>$newbackupsize,
511
                        name=>$name,
512
                        uuid=>$uuid,
513
                    #    domains=>$domains,
514
                    #    domainnames=>$domainnames,
515
                        storagepool=>$storagepool,
516
                        backup=>"", # Only set in uservalues at runtime
517
                        created=>$created,
518
                        mtime=>$mtime
519
                    };
520
                #    $postreply .= "Status=OK $f, $size, $newbackupsize\n" if ($console);
521
                }
522
            }
523
        }
524
    }
525
    # Update status information in db
526
#    my $mounts = decode('ascii-escape', `/bin/cat /proc/mounts`);
527
    my $mounts = `/bin/cat /proc/mounts`;
528
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
529
    foreach my $u (@users) {
530
        my @regkeys = (tied %register)->select_where("user = '$u'");
531
        foreach my $k (@regkeys) {
532
            my $valref = $register{$k};
533
            my $path = $valref->{'path'};
534
# Only update info for images the user has access to.
535
# Remove DB entries for images on removed nodes
536
            if ($valref->{'storagepool'}==-1 && $valref->{'mac'} && $valref->{'mac'} ne '--' && !$nodereg{$valref->{'mac'}}) {
537
                delete $register{$path}; # Clean up database, remove rows which don't have corresponding file
538
                $main::updateUI->({tab=>'images', user=>$u}) unless ($u eq 'common');
539
            } elsif ($valref->{'user'} eq $u && (defined $spools[$valref->{'storagepool'}]->{'id'} || $valref->{'storagepool'}==-1)) {
540
                my $path = $valref->{'path'};
541
                next if ($spath && $spath ne $path); # Only specific image being updated
542
                my $mounted = ($mounts =~ /$path/);
543
                my $domains;
544
                my $domainnames;
545
                my $regstatus = $valref->{'status'};
546
                my $status = $regstatus;
547
                if (!$status || $status eq '--') {
548
                    $status = 'unused';
549
                }
550
                if (-e $path || $valref->{'storagepool'}==-1 || -s "$path.meta") {
551
                # Deal with status
552
                    if ($valref->{'storagepool'}!=-1 && -s "$path.meta") {
553
                        my $metastatus;
554
                        $metastatus = `/bin/cat "$path.meta" 2>/dev/null`;
555
                        chomp $metastatus;
556

    
557
                        if ($metastatus =~ /status=(.+)&chunk=/) {
558
                            $status = $1;
559
                        } elsif ($metastatus =~ /status=(.+)&path2:(.+)=(.+)/) {
560
                        # A move operation has been completed - update status of both involved
561
                            $status = $1;
562
                            $register{$2}->{'status'} = $3;
563
                            unless ($userregister{$2}) { # If we have not yet parsed image, it is not yet in userregister, so put it there
564
                                my %mval = %{$register{$2}};
565
                                $userregister{$2} = \%mval;
566
                            }
567
                            $userregister{$2}->{'status'} = $3;
568
                        } elsif ($metastatus =~ /status=(\w+)/) {
569
                            $status = $1;
570
                        } else {
571
                        #    $status = $metastatus; # Do nothing - this meta file contains no status info
572
                        }
573
                    } elsif (
574
                            $status eq "restoring"
575
                            || $status eq "frestoring"
576
                            || ($status eq "mounted" && $mounted)
577
                            || $status eq "snapshotting"
578
                            || $status eq "unsnapping"
579
                            || $status eq "reverting"
580
                            || $status eq "moving"
581
                            || $status eq "converting"
582
                            || $status eq "cloning"
583
                            || $status eq "copying"
584
                            || $status eq "rebasing"
585
                            || $status eq "creating"
586
                            || $status eq "resizing"
587
                        ) { # When operation is done, status is updated by piston.cgi
588
                        ; # Do nothing
589
                    } elsif ($status =~ /.(backingup)/) { # When backup is done, status is updated by steamExec
590
                        if ($valref->{'storagepool'}==-1) {
591
                        #    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
592
                            if ($nodereg{$valref->{'mac'}}) {
593
                                my $nodestatus = $nodereg{$valref->{'mac'}}->{status};
594
                                # If node is not available, it cannot be backing up...
595
                                if ($nodestatus eq 'inactive'
596
                                    || $nodestatus eq 'asleep'
597
                                    || $nodestatus eq 'shutoff'
598
                                ) {
599
                                    $valref->{'status'} = 'unused'; # Make sure we don't end here again in endless loop
600
                                    $rstatus = Updateregister(0, $path);
601
                                    $status = $rstatus if ($rstatus);
602
                                    $main::syslogit->($user, 'info', "Updated image status for aborted backup - $user, $path, $rstatus");
603
                                }
604
                            }
605
                            #untie %nodereg;
606
                        }
607

    
608
                    } elsif ($status eq 'uploading') {
609
                        $status = 'unused' unless (-s "$path.meta");
610

    
611
                    } elsif (!$status || $status eq 'unused' || $status eq 'active') {
612
                        if ($fullupdate) {
613
                            $status = "unused";
614
                            my @domregkeys;
615
                            if ($fulllist) {@domregkeys = keys %domreg;}
616
                            else {@domregkeys = (tied %domreg)->select_where("user = '$u'");}
617
                            foreach my $domkey (@domregkeys) {
618
                                my $dom = $domreg{$domkey};
619
                                my $img = $dom->{'image'};
620
                                my $img2 = $dom->{'image2'};
621
                                my $img3 = $dom->{'image3'};
622
                                my $img4 = $dom->{'image4'};
623
                                if ($path eq $img || $path eq $img2 || $path eq $img3 || $path eq $img4) {
624
                                    $status = "active";
625
                                    my $domstatus = $dom->{'status'};
626
                                    if ($domstatus eq "shutoff" || $domstatus eq "inactive") {$status = "used";}
627
                                    elsif ($domstatus eq "paused") {$status = "paused";}
628
                                    $domains = $dom->{'uuid'};
629
                                    $domainnames = $dom->{'name'};
630
                                };
631
                            }
632
                            $valref->{'domains'} = $domains ;
633
                            $valref->{'domainnames'} = $domainnames ;
634
                        } elsif ($valref->{'domains'} && $valref->{'domains'} ne '--'){
635
                            my $dom = $domreg{$valref->{'domains'}};
636
                            if ($dom) {
637
                                my $img = $dom->{'image'};
638
                                my $img2 = $dom->{'image2'};
639
                                my $img3 = $dom->{'image3'};
640
                                my $img4 = $dom->{'image4'};
641
                                if ($path eq $img || $path eq $img2 || $path eq $img3 || $path eq $img4) {
642
                                    $status = "active";
643
                                    my $domstatus = $dom->{'status'};
644
                                    if ($domstatus eq "shutoff" || $domstatus eq "inactive") {$status = "used";}
645
                                    elsif ($domstatus eq "paused") {$status = "paused";}
646
                                    $valref->{'domainnames'} = $dom->{'name'};
647
                                };
648
                            };
649
                        }
650
                    }
651
                    # Update info in db
652
                    $valref->{'status'} = $status ;
653
                    $res .= $status if ($spath);
654
                } else {
655
                    delete $register{$path}; # Clean up database, remove rows which don't have corresponding file
656
                    $main::updateUI->({tab=>'images', user=>$u}) unless ($u eq 'common');
657
                }
658
            }
659
        }
660
    }
661
    untie %nodereg;
662
    tied(%register)->commit;
663
    $res .= "Status=OK Updated image register for " . join(', ', @users) . "\n";
664
    $res .= $postreply;
665
    return $res if ($res);
666
}
667

    
668
sub getVirtualSize {
669
    my $vpath = shift;
670
    my $macip = shift;
671
    my $qinfo;
672
    my($bname, $dirpath, $suffix) = fileparse($vpath, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
673
    if ($suffix eq ".qcow2") {
674
        if ($macip) {
675
            $qinfo = `$sshcmd $macip /usr/bin/qemu-img info --force-share "$vpath"`;
676
        } else {
677
            $qinfo = `/usr/bin/qemu-img info --force-share "$vpath"`;
678
        }
679
        $qinfo =~ /virtual size:.*\((.+) bytes\)/g;
680
        return(int($1)); # report size of new image for billing purposes
681
    } elsif ($status eq ".vdi") {
682
        if ($macip) {
683
            $qinfo = `$sshcmd $macip /usr/bin/VBoxManage showhdinfo "$vpath"`;
684
        } else {
685
            $qinfo = `/usr/bin/VBoxManage showhdinfo "$vpath"`;
686
        }
687
        $qinfo =~ /Logical size:\s*(\d+) MBytes/g;
688
        return(int($1) * 1024 * 1024); # report size of new image for billing purposes
689
    } else {
690
        if ($macip) {
691
            return `$sshcmd $macip perl -e 'my @stat=stat("$vpath"); print $stat[7];'`;
692
        } else {
693
            my @stat = stat($vpath);
694
            return($stat[7]); # report size of new image for billing purposes
695
        }
696
    }
697
}
698

    
699
sub getSizes {
700
    my ($f, $lmtime, $status, $buser, $force) = @_;
701

    
702
    my @stat = stat($f);
703
    my $size = $stat[7];
704
    my $realsize = $stat[12] * 512;
705
    my $virtualsize = $size;
706
    my $backupsize = 0;
707
    my $mtime = $stat[9];
708
    my($fname, $dirpath, $suffix) = fileparse($f, ("vmdk", "img", "vhd", "qcow", "qcow2", "vdi", "iso"));
709
    my $subdir = "";
710
    if ($dirpath =~ /.+\/$buser(\/.+)?\//) {
711
        $subdir = $1;
712
    }
713
    $backupsize = getBackupSize($subdir, "$fname$suffix", $buser);
714
    my $ps = `/bin/ps ax`;
715

    
716
# Only fire up qemu-img etc. if image has been modified and is not being used
717
    if ((
718
        ($mtime - $lmtime)>300 &&
719
        ($status ne 'active' && $status ne 'downloading') &&
720
        !($ps =~ /$f/)) || $force
721
    ) {
722

    
723
# Special handling of vmdk's
724
        if ($suffix eq "vmdk") {
725
            my $qinfo = `/usr/bin/qemu-img info --force-share "$f"`;
726
            $qinfo =~ /virtual size:.*\((.+) bytes\)/g;
727
            $virtualsize = int($1);
728
            if ( -s ($dirpath . substr($fname,0,-1) . "-flat." . $suffix)) {
729
                my @fstatus = stat($dirpath . substr($fname,0,-1) . "-flat." . $suffix);
730
                my $fsize = $fstatus[7];
731
                my $frealsize = $fstatus[12] * 512;
732
                $size += $fsize;
733
                $virtualsize += $fsize;
734
                $realsize += $frealsize;
735
            } else {
736
#                $main::syslogit->($user, "info", "VMDK " . $dirpath . substr($fname,0,-1) . "-flat." . $suffix . " does not exist");
737
            }
738
            my $i = 1;
739
            while (@fstatus = stat($dirpath . substr($fname,0,-1) . "-s00$i." . $suffix)) {
740
                my $fsize = $fstatus[7];
741
                my $frealsize = $fstatus[12] * 512;
742
                $size += $fsize;
743
                #$virtualsize += $fsize;
744
                $realsize += $frealsize;
745

    
746
                my $cmdpath = $dirpath . substr($fname,0,-1) . "-s00$i." . $suffix;
747
                my $qinfo = `/usr/bin/qemu-img info --force-share "$cmdpath"`;
748
                $qinfo =~ /virtual size:.*\((.+) bytes\)/g;
749
                $virtualsize += int($1);
750

    
751
                $i++;
752
            }
753
# Get virtual size of qcow2 auto-grow volumes
754
        } elsif ($suffix eq "qcow2") {
755
            my $qinfo = `/usr/bin/qemu-img info --force-share "$f"`;
756
            $qinfo =~ /virtual size:.*\((.+) bytes\)/g;
757
            $virtualsize = int($1);
758
# Get virtual size of vdi auto-grow volumes
759
        } elsif ($suffix eq "vdi") {
760
            my $qinfo = `/usr/bin/VBoxManage showhdinfo "$f"`;
761
            $qinfo =~ /Logical size:\s*(\d+) MBytes/g;
762
            $virtualsize = int($1) * 1024 * 1024;
763
        }
764
# Actual used blocks times block size on disk, i.e. $realsize may be bigger than the
765
# logical size of the image file $size and the logical provisioned size of the disk $virtualsize
766
# in order to minimize confusion, we set $realsize to $size if this is the case
767
        $realsize = $size if ($realsize > $size);
768

    
769
        return ($mtime, $backupsize, $size, $realsize, $virtualsize);
770
    } else {
771
        return (0, $backupsize, $size, $realsize);
772
    }
773

    
774
}
775

    
776
sub getHypervisor {
777
	my $image = shift;
778
	# Produce a mapping of image file suffixes to hypervisors
779
	my %idreg;
780
    unless ( tie(%idreg,'Tie::DBI', Hash::Merge::merge({table=>'nodeidentities', key=>'identity'}, $Stabile::dbopts)) )
781
        {$postreply .= "Status=Error identity register could not be accessed"};
782

    
783
	my @idvalues = values %idreg;
784
	my %formats;
785
	foreach my $val (@idvalues) {
786
		my %h = %$val;
787
		foreach (split(/,/,$h{'formats'})) {
788
			$formats{lc $_} = $h{'hypervisor'}
789
		}
790
	}
791
	untie %idreg;
792

    
793
	# and then determine the hypervisor in question
794
	my $hypervisor = "vbox";
795
	my ($pathname, $path, $suffix) = fileparse($image, '\.[^\.]*');
796
	$suffix = substr $suffix, 1;
797
	my $hypervisor = $formats{lc $suffix};
798
	return $hypervisor;
799
}
800

    
801
sub Getserverbackups {
802
    my ($domuuid, $action) = @_;
803
    if ($help) {
804
        return <<END
805
GET:uuid:
806
Lists the image backups associated with a server, i.e. the backups of all the images attached to a server.
807
A server UUID should be passed as parameter. A JSON object is returned. May be called as <b>getserverbackups</b>, in
808
which case a JSON object is returned, or as <b>listserverbackups</b>, in which case a string is returned.
809
END
810
    }
811
    my $res;
812
    my @sbackups;
813
    my $backuplist;
814

    
815
    if ($domreg{$domuuid} && (($domreg{$domuuid}->{'user'} eq $user) || $isadmin)) {
816
        push @sbackups, Listbackups($domreg{$domuuid}->{'image'}, 'getbackups');
817
        push @sbackups, Listbackups($domreg{$domuuid}->{'image2'}, 'getbackups') if ($domreg{$domuuid}->{'image2'} && $domreg{$domuuid}->{'image2'} ne '--');
818
        push @sbackups, Listbackups($domreg{$domuuid}->{'image3'}, 'getbackups') if ($domreg{$domuuid}->{'image3'} && $domreg{$domuuid}->{'image3'} ne '--');
819
        push @sbackups, Listbackups($domreg{$domuuid}->{'image4'}, 'getbackups') if ($domreg{$domuuid}->{'image4'} && $domreg{$domuuid}->{'image4'} ne '--');
820
    }
821
    foreach my $sbackup (@sbackups) {
822
        my @back = @{$sbackup};
823
        my $t = $back[0]->{time};
824
        my $epoch;
825
        my $z;
826
        if ($t eq '--') {
827
            $epoch = $t;
828
        } elsif ($t =~ /(z)/) {
829
#            my $time = Time::Piece->strptime($t, "%Y-%m-%d-%H-%M-%S (z)");
830
            my $time = Time::Piece->strptime($t, "%b %d %T %Y (z)");
831
            $epoch = $time->epoch;
832
            $z = ' (z)';
833
        } else {
834
            $t = $1 if ($t =~ /\* (.*)/);
835
            my $time = Time::Piece->strptime($t, "%b %d %T %Y");
836
            $epoch = $time->epoch;
837
        }
838
        $backuplist .= "$back[-1]->{name}$z/$epoch, " if (@back && $epoch);
839
    }
840
    $backuplist = substr($backuplist,0,-2);
841

    
842
    if ($action eq 'getserverbackups') {
843
        $res .= to_json(\@sbackups, {pretty=>1});
844
    } else {
845
        $res .= header() unless ($console);
846
        $res .= $backuplist;
847
    }
848
    return $res;
849

    
850
}
851

    
852
sub Listbackups {
853
    my ($curimg, $action) = @_;
854
    if ($help) {
855
        return <<END
856
GET:image:
857
List backups on file for the give image, which may be specified as path or uuid.
858
END
859
    }
860

    
861
    my $res;
862
    my $buser = $user;
863
    $curimg = '' unless ($register{$curimg}); # Image must exist
864
    $buser = $register{$curimg}->{'user'} if ($isadmin && $curimg);
865
    my @backups;
866
    my $subdir = "";
867
    if ($curimg && $curimg ne '--') {
868
        my($bname, $dirpath) = fileparse($curimg);
869
        if ($dirpath =~ /.+\/$buser(\/.+)?\//) {
870
            $subdir = $1;
871
        }
872
        my $sbname = "$subdir/$bname";
873
        $sbname =~ s/ /\\ /g;
874
        $sbname = $1 if ($sbname =~ /(.+)/); # untaint
875
        foreach my $spool (@spools) {
876
            my $imgbasedir = $spool->{"path"};
877
            if (-d "$imgbasedir/.zfs/snapshot") {
878
                my $snaps = `/bin/ls -l --time-style=full-iso $imgbasedir/.zfs/snapshot/*/$buser$sbname 2> /dev/null`;
879
                my @snaplines = split("\n", $snaps);
880
                # -rw-r--r-- 1 root root 216174592 2012-02-19 17:51 /mnt/stabile/images/.zfs/snapshot/SNAPSHOT-20120106002116/cabo/Outlook2007.iso
881
                foreach $line (@snaplines) {
882
                    if ($line =~ /$imgbasedir\/.zfs\/snapshot\/SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})\/$buser$subdir\/$bname$/) {
883
                        my $timestamp = timelocal($6,$5,$4,$3,$2-1,$1); #$sec,$min,$hour,$mday,$mon,$year
884
                        my $t = localtime($timestamp)->strftime("%b %e %H:%M:%S %Y");
885
                        # my %incr = ("increment", "SNAPSHOT-$1$2$3$4$5$6", "time", "$1-$2-$3-$4-$5-$6 (z)", "pool", $imgbasedir);
886
                        my %incr = ("increment", "SNAPSHOT-$1$2$3$4$5$6", "time", "$t (z)", "pool", $imgbasedir);
887
                        unshift (@backups, \%incr);
888
                    };
889
                }
890
            }
891
        }
892
        # Also include ZFS snapshots transferred from nodes
893
        $imgbasedir = "/stabile-backup";
894
        my $snaps = `/bin/ls -l --time-style=full-iso $imgbasedir/node-*/.zfs/snapshot/*/$buser$sbname 2> /dev/null`;
895
        my @snaplines = split("\n", $snaps);
896
        foreach $line (@snaplines) {
897
            if ($line =~ /($imgbasedir\/node-.+)\/.zfs\/snapshot\/SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})\/$buser$subdir\/$bname$/) {
898
                my $timestamp = timelocal($7,$6,$5,$4,$3-1,$2); #$sec,$min,$hour,$mday,$mon,$year
899
                my $t = localtime($timestamp)->strftime("%b %e %H:%M:%S %Y");
900
                # my %incr = ("increment", "SNAPSHOT-$2$3$4$5$6$7", "time", "$2-$3-$4-$5-$6-$7 (z)", "pool", $1);
901
                my %incr = ("increment", "SNAPSHOT-$2$3$4$5$6$7", "time", "$t (z)", "pool", $1);
902
                unshift (@backups, \%incr);
903
            };
904
        }
905
        my $bpath = "$backupdir/$buser$subdir/$bname";
906
        $bpath = $1 if ($bpath =~ /(.+)/); # untaint
907
        if (-d "$bpath") {
908
            my $rdiffs = `/usr/bin/rdiff-backup -l "$bpath"`;
909
            my @mlines = split("\n", $rdiffs);
910
            my $curmirror;
911
            foreach my $line (@mlines) {
912
                if ($line =~ /\s+increments\.(\S+)\.dir\s+\S\S\S (.+)$/) {
913
                    my %incr = ("increment", $1, "time", $2);
914
                    if (-e "$bpath/rdiff-backup-data/increments/$bname.$1.diff.gz"
915
                    ) {
916
                        unshift (@backups, \%incr);
917
                    }
918
                };
919
                if ($line =~ /Current mirror: \S\S\S (.+)$/) {
920
                    $curmirror = $1;
921
                };
922
            }
923
            if ($curmirror) {
924
                my %incr = ("increment", "mirror", "time", "* $curmirror");
925
                unshift @backups, \%incr;
926
            }
927
            my %incr = ("increment", "--", "time", "--", "name", $bname);
928
            push @backups, \%incr;
929
        } else {
930
            my %incr = ("increment", "--", "time", "--", "name", $bname);
931
            push @backups, \%incr;
932
        }
933
    }
934

    
935
    if ($action eq 'getbackups') {
936
        return \@backups;
937
    } elsif ($console) {
938
        my $t2 = Text::SimpleTable->new(28,28);
939
        $t2->row('increment', 'time');
940
        $t2->hr;
941
        foreach my $fref (@backups) {
942
            $t2->row($fref->{'increment'}, scalar localtime( $fref->{'time'} )) unless ($fref->{'increment'} eq '--');
943
        }
944
        return $t2->draw;
945
    } else {
946
        $res .= header('application/json');
947
        my $json_text = to_json(\@backups, {pretty=>1});
948
        $res .= qq|{"identifier": "increment", "label": "time", "items": $json_text }|;
949
        return $res;
950
    }
951
}
952

    
953
# Get the timestamp of latest backup of an image
954
sub getBtime {
955
    my $curimg = shift;
956
    my $buser = shift || $user;
957
    return unless ($buser eq $user || $isadmin);
958
    $buser = 'common' if ($register{$curimg}->{user} eq 'common' && $isadmin);
959
    my $subdir = "";
960
    my $lastbtimestamp;
961
    my($bname, $dirpath) = fileparse($curimg);
962
    if ($dirpath =~ /.+\/$buser(\/.+)?\//) {
963
        $subdir = $1;
964
    }
965

    
966
    #require File::Spec;
967
    #my $devnull = File::Spec->devnull();
968

    
969
    foreach my $spool (@spools) {
970
        my $imgbasedir = $spool->{"path"};
971
        if (-d "$imgbasedir/.zfs/snapshot") {
972
            my $sbname = "$subdir/$bname";
973
            $sbname =~ s/ /\\ /g;
974
            my $cmd = qq|/bin/ls -l --time-style=full-iso $imgbasedir/.zfs/snapshot/*/$buser$sbname 2>/dev/null|;
975
            my $snaps = `$cmd`;
976
            my @snaplines = split("\n", $snaps);
977
            foreach $line (@snaplines) {
978
                if ($line =~ /$imgbasedir\/.zfs\/snapshot\/SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})\/$buser$subdir\/$bname$/) {
979
                    my $timestamp = timelocal($6,$5,$4,$3,$2-1,$1); #$sec,$min,$hour,$mday,$mon,$year
980
                    $lastbtimestamp = $timestamp if ($timestamp > $lastbtimestamp);
981
                };
982
            }
983
        }
984
    }
985
    # Also include ZFS snapshots transferred from nodes
986
    $imgbasedir = "/stabile-backup";
987
    my $snaps = `/bin/ls -l --time-style=full-iso $imgbasedir/node-*/.zfs/snapshot/*/$buser/$bname 2> /dev/null`;
988
    my @snaplines = split("\n", $snaps);
989
    foreach $line (@snaplines) {
990
        if ($line =~ /$imgbasedir\/node-.+\/.zfs\/snapshot\/SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})\/$buser$subdir\/$bname$/) {
991
            my $timestamp = timelocal($6,$5,$4,$3,$2-1,$1); #$sec,$min,$hour,$mday,$mon,$year
992
            $lastbtimestamp = $timestamp if ($timestamp > $lastbtimestamp);
993
        };
994
    }
995
    my $bpath = "$backupdir/$buser$subdir/$bname";
996
    $bpath = $1 if ($bpath =~ /(.+)/);
997
    if (-d "$bpath") {
998
        my $rdiffs = `/usr/bin/rdiff-backup --parsable-output -l "$bpath"`;
999
        my @mlines = split("\n", $rdiffs);
1000
        foreach my $line (@mlines) {
1001
            if ($line =~ /(\d+) (\S+)$/) {
1002
                my $timestamp = $1;
1003
                $lastbtimestamp = $timestamp if ($timestamp > $lastbtimestamp);
1004
            };
1005
        }
1006
    }
1007
    return $lastbtimestamp;
1008
}
1009

    
1010
sub Unmount {
1011
    my $path = shift;
1012
	my $action = shift;
1013
    if ($help) {
1014
        return <<END
1015
GET:image: Unmounts a previously mounted image.
1016
END
1017
    }
1018
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1019
    my $mountpath = "$dirpath.$bname$suffix";
1020
#    my $mounts = decode('ascii-escape', `/bin/cat /proc/mounts`);
1021
    my $mounts = `/bin/cat /proc/mounts`;
1022
    my $mounted = ($mounts =~ /$mountpath/);
1023

    
1024
#    eval {`/bin/umount "$mountpath"` if ($mounted); 1;}
1025
#    eval {`/bin/fusermount -u "$mountpath"` if ($mounted); 1;}
1026
#        or do {$postreply .= "Status=ERROR Problem mounting image $@\n";};
1027

    
1028
    if ($mounted) {
1029
        $cmd = qq|/bin/fusermount -u "$mountpath" 2>&1|;
1030
        my $mes = qx($cmd);
1031
        my $xc = $? >> 8;
1032
        $main::syslogit->($user, 'info', "Unmounted $curimg $xc");
1033
        if ($xc) {
1034
            $postreply .= "Status=ERROR Problem unmounting image ($mes). ";
1035
            return $postreply;
1036
        }
1037
    }
1038
#    my $mounts2 = decode('ascii-escape', `/bin/cat /proc/mounts`);
1039
    my $mounts2 = `/bin/cat /proc/mounts`;
1040
    $mounts2 = String::Escape::unbackslash($mounts2);
1041
    my $mounted2 = ($mounts2 =~ /$mountpath/);
1042
    eval {`/bin/rmdir "$mountpath"` if (!$mounted2 && -e $mountpath); 1;}
1043
        or do {$postreply .= "Status=ERROR Problem removing mount point $@\n";};
1044

    
1045
    if ($mounted) {
1046
        if ($mounted2) {
1047
            $postreply .= "Status=ERROR Unable to unmount $register{$path}->{'name'}\n";
1048
            return $postreply;
1049
        } else {
1050
            $postreply .= "Status=OK Unmounted image $register{$path}->{'name'}\n";
1051
            return $postreply;
1052
        }
1053
    } else {
1054
        $postreply .= "Status=OK Image $path not mounted\n";
1055
        return $postreply;
1056
    }
1057
}
1058

    
1059
sub unmountAll {
1060
    my @mounts = split(/\n/, `/bin/cat /proc/mounts`);
1061
    foreach my $mount (@mounts) {
1062
        foreach my $spool (@spools) {
1063
            my $pooldir = $spool->{"path"};
1064
            if ($mount =~ /($pooldir\/$user\/\S+) / || ($mount =~ /($pooldir\/common\/\S+) / && $isadmin)) {
1065
#                $mountpath = decode('ascii-escape', $1);
1066
                $mountpath =  $1;
1067
                $rpath = $mountpath;
1068
                $rpath =~ s/\/\./\//;
1069
                my $processes = `/bin/ps`;
1070
#                if ($register{$rpath} && !($processes =~ /steamExec.+$rpath/)) {
1071
                    $postreply .= "Status=OK Unmounting $rpath\n";
1072
                    Unmount($rpath);
1073
#                }
1074
            }
1075
        }
1076
    }
1077
    return;
1078
}
1079

    
1080
sub Mount {
1081
    my $path = shift;
1082
	my $action = shift;
1083
    if ($help) {
1084
        return <<END
1085
GET:image:
1086
Tries to mount an image on admin server for listfiles/restorefiles operations.
1087
END
1088
    }
1089
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1090
    my $mountpath = "$dirpath.$bname$suffix";
1091
    my $mounts = `/bin/cat /proc/mounts`;
1092
    $mounts = String::Escape::unbackslash($mounts);
1093
    my $mounted = ($mounts =~ /$mountpath/);
1094
    if ($mounted) {
1095
        unless (`ls "$mountpath"`) { # Check if really mounted
1096
            Unmount($mountpath);
1097
            $mounted = 0;
1098
        }
1099
    }
1100

    
1101
    if ($mounted) {
1102
        $postreply .= "Status=OK Image $register{$path}->{'name'} already mounted\n";
1103
        return $postreply;
1104
    } else {
1105
        `/bin/mkdir "$mountpath"` unless (-e "$mountpath");
1106
        `/bin/chown www-data:www-data  "$mountpath"`;
1107
        my $cmd;
1108

    
1109
        if (lc $suffix eq '.iso') {
1110
            #eval {`/bin/mount -o allow_other,ro,loop "$path" "$mountpath"`; 1;}
1111
            #eval {`/usr/bin/fuseiso -n "$path" "$mountpath" -o user=www-data`; 1;}
1112
            eval {`/usr/bin/fuseiso -n "$path" "$mountpath" -o allow_other`; 1;}
1113
            or do {
1114
                $postreply .= header('text/html', '500 Internal Server Error') unless ($console);
1115
                $postreply .= "Status=ERROR Problem mounting image $@\n";
1116
                return $postreply;
1117
            };
1118
        } else {
1119
            $cmd = qq|/usr/bin/guestmount --ro -o allow_other -a "$path" "$mountpath" -i 2>&1|;
1120
            my $mes = qx($cmd);
1121
            my $xc = $? >> 8;
1122
            $main::syslogit->($user, 'info', "Mounted $curimg $xc");
1123
            if ($xc) {
1124
                $postreply = header('text/html', '500 Internal Server Error') . $postreply unless ($console);
1125
                chomp $mes;
1126
                $postreply .= "Status=Error Problem mounting image ($mes).\n$cmd\n";
1127
                return $postreply;
1128
            }
1129
        }
1130

    
1131
        my $mounts2;
1132
        for (my $i=0; $i<5; $i++) {
1133
            $mounts2 = `/bin/cat /proc/mounts`;
1134
            $mounts2 = String::Escape::unbackslash($mounts2);
1135
            next if ( $mounts2 =~ /$mountpath/);
1136
            sleep 2;
1137
        }
1138
        if ( $mounts2 =~ /$mountpath/) {
1139
            $postreply .= "Status=OK Mounted image $register{$path}->{'name'}\n";
1140
            return $postreply;
1141
        } else {
1142
            $postreply .= header('text/html', '500 Internal Server Error') unless ($console);
1143
            $postreply .= "Status=ERROR Giving up mounting image $register{$path}->{'name'}\n";
1144
            return $postreply;
1145
        }
1146
    }
1147
}
1148

    
1149
sub Updatebackingfile {
1150
    my ($img, $action) = @_;
1151
    if ($help) {
1152
        return <<END
1153
GET:image:
1154
END
1155
    }
1156
    my $f = $img || $curimg;
1157
    return "Status=Error Image $f not found\n" unless (-e $f);
1158
    my $vinfo = `qemu-img info --force-share "$f"`;
1159
    my $master = $1 if ($vinfo =~ /backing file: (.+)/);
1160
    (my $fname, my $fdir) = fileparse($f);
1161
    if (!$master) {
1162
        $register{$f}->{'master'} = '';
1163
        $postreply .=  "Status=OK Image $f does not use a backing file\n";
1164
    } elsif (-e $master){ # Master OK
1165
        $register{$f}->{'master'} = $master;
1166
        $postreply .=  "Status=OK $master exists, no changes to $f.\n";
1167
    } elsif (-e "$fdir/$master") { # Master OK
1168
        $register{$f}->{'master'} = "$fdir/$master";
1169
        $postreply .=  "Status=OK $master exists in $fdir. No changes to $f.\n"
1170
    } else {
1171
        # Master not immediately found, look for it
1172
        (my $master, my $mdir) = fileparse($master);
1173
        my @busers = @users;
1174
        push (@busers, $billto) if ($billto); # We include images from 'parent' user
1175
        foreach my $u (@busers) {
1176
            foreach my $spool (@spools) {
1177
                my $pooldir = $spool->{"path"};
1178
                my $masterpath = "$pooldir/$u/$master";
1179
                if (-e $masterpath) {
1180
                    my $cmd = qq|qemu-img rebase -f qcow2 -u -b "$masterpath" "$f"|;
1181
                    $register{$f}->{'master'} = $masterpath;
1182
                    $postreply .= "Status=OK found $masterpath, rebasing from $mdir to $pooldir/$u ";
1183
                    $postreply .= `$cmd` . "\n";
1184
                    last;
1185
                }
1186
            }
1187
        }
1188
        $postreply .= "Status=Error $master not found in any user dir. You must provide this backing file to use this image.\n" unless ($postreply);
1189
    }
1190
    tied(%register)->commit;
1191
    return $postreply;
1192
}
1193

    
1194
# List files in a mounted image. Mount image if not mounted.
1195
sub Listfiles {
1196
    my ($curimg, $action, $obj) = @_;
1197
    if ($help) {
1198
        return <<END
1199
GET:image,path:
1200
Try to mount the file system on the given image, and list the files from the given path in the mounted file system.
1201
The image must contain a bootable file system, in order to locate a mount point.
1202
END
1203
    }
1204
    my $res;
1205
    my $curpath = $obj->{'restorepath'};
1206
    $res .= header('application/json') unless ($console);
1207

    
1208
    my($bname, $dirpath, $suffix) = fileparse($curimg, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1209
    my $mountpath = "$dirpath.$bname$suffix";
1210
	my @files;
1211
	my @dirs;
1212
    my $mounted = (Mount($curimg) =~ /\w=OK/);
1213

    
1214
    if ($mounted) {
1215
        my @patterns = ('');
1216
        $curpath .= '/' unless ($curpath =~ /\/$/);
1217
        $mountpath .= "$curpath";
1218
        if (-d $mountpath) { # We are listing a directory
1219
            # loop through the files contained in the directory
1220
            @patterns = ('*', '.*');
1221
        }
1222
        foreach $pat (@patterns) {
1223
            for my $f (bsd_glob($mountpath.$pat)) {
1224
                my %fhash;
1225
                ($bname, $dirpath) = fileparse($f);
1226
                my @stat = stat($f);
1227
                my $size = $stat[7];
1228
                my $realsize = $stat[12] * 512;
1229
                my $mtime = $stat[9];
1230

    
1231
                $fhash{'name'} = $bname;
1232
                $fhash{'mtime'} = $mtime;
1233
                ## if the file is a directory
1234
                if( -d $f) {
1235
                    $fhash{'size'} = 0;
1236
                    $fhash{'fullpath'} = $f . '/';
1237
                    $fhash{'path'} = $curpath . $bname . '/';
1238
                    push(@dirs, \%fhash) unless ($bname eq '.' || $bname eq '..');
1239
                } else {
1240
                    $fhash{'size'} = $size;
1241
                    $fhash{'fullpath'} = $f;
1242
                    $fhash{'path'} = $curpath . $bname;
1243
                    push(@files, \%fhash);
1244
                }
1245
            }
1246
        }
1247

    
1248
        if ($console) {
1249
            my $t2 = Text::SimpleTable->new(48,16,28);
1250
            $t2->row('name', 'size', 'mtime');
1251
            $t2->hr;
1252
            foreach my $fref (@dirs) {
1253
                $t2->row($fref->{'name'}, $fref->{'size'}, scalar localtime( $fref->{'mtime'} )) unless ($bname eq '.' || $bname eq '..');
1254
            }
1255
            foreach my $fref (@files) {
1256
                $t2->row($fref->{'name'}, $fref->{'size'}, scalar localtime( $fref->{'mtime'} ) ) unless ($bname eq '.' || $bname eq '..');
1257
            }
1258
            return $t2->draw;
1259
        } else {
1260
            my @comb = (@dirs, @files);
1261
            $res .= to_json(\@comb, {pretty => 1});
1262
        }
1263
    } else {
1264
        $res .= qq|{"status": "Error", "message": "Image $curimg not mounted. Mount first."}|;
1265
    }
1266
    return $res;
1267
}
1268

    
1269
sub Restorefiles {
1270
    my ($path, $action, $obj) = @_;
1271
    if ($help) {
1272
        return <<END
1273
GET:image,files:
1274
Restores files from the given path in the given image to a newly created ISO image. The given image must be mountable.
1275
END
1276
    }
1277
    my $res;
1278
    $curfiles = $obj->{'files'};
1279
    $path = $path || $curimg;
1280

    
1281
    return "Status=ERROR Your account does not have the necessary privileges\n" if ($isreadonly);
1282
    return "Status=ERROR You must specify which files you want to restore\n" unless ($curfiles);
1283

    
1284
    my $name = $register{$path}->{'name'};
1285
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1286
    my $mountpath = "$dirpath.$bname$suffix";
1287
#    my $mounts = decode('ascii-escape', `/bin/cat /proc/mounts`);
1288
    my $mounts = `/bin/cat /proc/mounts`;
1289
    my $mmounts = `/bin/df`;
1290
    my $mounted = ($mounts =~ /$mountpath/ && $mmounts =~ /$mountpath/);
1291
    my $restorepath = "$dirpath$bname.iso";
1292

    
1293
    if (-e $restorepath) {
1294
        my $i = 1;
1295
        while (-e "$dirpath$bname.$i.iso") {$i++;}
1296
        $restorepath = "$dirpath$bname.$i.iso";
1297
    }
1298

    
1299
    my $uistatus = "frestoring";
1300
    if ($mounted && $curfiles) {
1301
        my $ug = new Data::UUID;
1302
        my $newuuid = $ug->create_str();
1303
        $register{$restorepath} = {
1304
                            uuid=>$newuuid,
1305
                            status=>$uistatus,
1306
                            name=>"Files from: $name",
1307
                            size=>0,
1308
                            realsize=>0,
1309
                            virtualsize=>0,
1310
                            type=>"iso",
1311
                            user=>$user
1312
                        };
1313

    
1314
        eval {
1315
                my $oldstatus = $register{$path}->{'status'};
1316
#                my $cmd = qq|steamExec $user $uistatus $oldstatus "$path" "$curfiles"|;
1317
#                my $cmdres = `$cmd`;
1318
            if ($mounted) {
1319
                $res .= "Restoring files to: /tmp/restore/$user/$bname$suffix -> $restorepath\n";
1320
                $res .= `/bin/echo $status > "$restorepath.meta"`;
1321

    
1322
                `/bin/mkdir -p "/tmp/restore/$user/$bname$suffix"` unless (-e "/tmp/restore/$user/$bname$suffix");
1323
                my @files = split(/:/, uri_unescape($curfiles));
1324
                foreach $f (@files) {
1325
                    if (-e "$mountpath$f" && chdir($mountpath)) {
1326
                        $f = substr($f,1) if ($f =~ /^\//);
1327
                        eval {`/usr/bin/rsync -aR --sparse "$f" /tmp/restore/$user/$bname$suffix`; 1;}
1328
                            or do {$e=1; $res .= "ERROR Problem restoring files $@\n";};
1329
                    } else {
1330
                        $res .= "Status=Error $f not found in $mountpath\n";
1331
                    }
1332
                }
1333
                if (chdir "/tmp/restore/$user/$bname$suffix") {
1334
                    eval {$res .= `/usr/bin/genisoimage -o "$restorepath" -iso-level 4 .`; 1;}
1335
                        or do {$e=1; $res .= "Status=ERROR Problem restoring files $@\n";};
1336
                    $res .= `/bin/rm -rf /tmp/restore/$user/$bname$suffix`;
1337
                    $res .= "Status=OK Restored files from /tmp/restore/$user/$bname$suffix to $restorepath\n";
1338
                } else {
1339
                    $res .= "Status=ERROR Unable to chdir to /tmp/restore/$user/$bname$suffix\n";
1340
                }
1341
                $main::updateUI->({tab=>"images", user=>$user, type=>"update"});
1342

    
1343
                # Update billing
1344
                my $newvirtualsize = getVirtualSize($restorepath);
1345
                unlink "$restorepath.meta";
1346
                $res .= Unmount($path);
1347
                $register{$restorepath}->{'status'} = 'unused';
1348
                $register{$restorepath}->{'virtualsize'} = $newvirtualsize;
1349
                $register{$restorepath}->{'realsize'} = $newvirtualsize;
1350
                $register{$restorepath}->{'size'} = $newvirtualsize;
1351
                $postmsg = "OK - restored your files into a new ISO.";
1352
            } else {
1353
                $res .= "Status=Error You must mount image on $mountpath before restoring\n";
1354
            }
1355
            $res .=  "Status=OK $uistatus files from $name to iso, $newuuid, $cmd\n";
1356
            $main::syslogit->($user, "info", "$uistatus files from $path to iso, $newuuid");
1357
            1;
1358
        } or do {$res .= "Status=ERROR $@\n";}
1359

    
1360
    } else {
1361
        $res .= "Status=ERROR Image not mounted, mount before restoring: ". $curfiles ."\n";
1362
    }
1363
    return $res;
1364
}
1365

    
1366
sub trim{
1367
   my $string = shift;
1368
   $string =~ s/^\s+|\s+$//g;
1369
   return $string;
1370
}
1371

    
1372
sub overQuotas {
1373
    my $inc = shift;
1374
    my $onnode = shift;
1375
	my $usedstorage = 0;
1376
	my $overquota = 0;
1377
    return $overquota if ($Stabile::userprivileges =~ /a/); # Don't enforce quotas for admins
1378

    
1379
	my $storagequota = ($onnode)?$Stabile::usernodestoragequota:$Stabile::userstoragequota;
1380
	if (!$storagequota) { # 0 or empty quota means use defaults
1381
        $storagequota = (($onnode)?$Stabile::config->get('NODESTORAGE_QUOTA'):$Stabile::config->get('STORAGE_QUOTA')) + 0;
1382
	}
1383
    return $overquota if ($storagequota == -1); # -1 means no quota
1384

    
1385
    my @regkeys = (tied %register)->select_where("user = '$user'");
1386
    foreach my $k (@regkeys) {
1387
        my $val = $register{$k};
1388
		if ($val->{'user'} eq $user) {
1389
		    $usedstorage += $val->{'virtualsize'} if ((!$onnode &&  $val->{'storagepool'}!=-1) || ($onnode &&  $val->{'storagepool'}==-1));
1390
		}
1391
	}
1392
    #print header(), "$package, $Stabile::Systems::userstoragequota, $onnode, $usedstorage, $inc, $storagequota, " . $storagequota*1024*1024; exit;
1393
	return $overquota;
1394
}
1395

    
1396
sub overStorage {
1397
    my ($reqstor, $spool, $mac) = @_;
1398
    my $storfree;
1399
    if ($spool == -1) {
1400
        if ($mac) {
1401
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
1402
            $storfree = $nodereg{$mac}->{'storfree'};
1403
            $storfree = $storfree *1024 * $nodestorageovercommission;
1404
            untie %nodereg;
1405
        } else {
1406
            return 1;
1407
        }
1408
    } else {
1409
        my $storpath = $spools[$spool]->{'path'};
1410
        $storfree = `df $storpath`;
1411
        $storfree =~ m/(\d\d\d\d+)(\s+)(\d\d*)(\s+)(\d\d+)(\s+)(\S+)/i;
1412
        my $stortotal = $1;
1413
        my $storused = $3;
1414
        $storfree = $5 *1024;
1415
    }
1416
    return ($reqstor > $storfree);
1417
}
1418

    
1419
sub updateBilling {
1420
    my $event = shift;
1421
    my %billing;
1422

    
1423
    my @regkeys = (tied %register)->select_where("user = '$user'");
1424
    foreach my $k (@regkeys) {
1425
        my $valref = $register{$k};
1426
        my %val = %{$valref}; # Deference and assign to new array, effectively cloning object
1427
        $val{'virtualsize'} += 0;
1428
        $val{'realsize'} += 0;
1429
        $val{'backupsize'} += 0;
1430

    
1431
        if ($val{'user'} eq $user && (defined $spools[$val{'storagepool'}]->{'id'} || $val{'storagepool'}==-1)) {
1432
            $billing{$val{'storagepool'}}->{'virtualsize'} += $val{'virtualsize'};
1433
            $billing{$val{'storagepool'}}->{'realsize'} += $val{'realsize'};
1434
            $billing{$val{'storagepool'}}->{'backupsize'} += $val{'backupsize'};
1435
        }
1436
    }
1437

    
1438
    my %billingreg;
1439

    
1440
    unless (tie %billingreg,'Tie::DBI', {
1441
            db=>'mysql:steamregister',
1442
            table=>'billing_images',
1443
            key=>'userstoragepooltime',
1444
            autocommit=>0,
1445
            CLOBBER=>3,
1446
            user=>$dbiuser,
1447
            password=>$dbipasswd}) {throw Error::Simple("Stroke=Error Billing register (images) could not be accessed")};
1448

    
1449
    my $monthtimestamp = timelocal(0,0,0,1,$mon,$year); #$sec,$min,$hour,$mday,$mon,$year
1450

    
1451
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'billing_images', key=>'userstoragepooltime'}, $Stabile::dbopts)) )
1452
        {throw Error::Simple("Status=Error Billing register could not be accessed")};
1453

    
1454
    my %pool = ("hostpath", "--",
1455
                "path", "--",
1456
                "name", "local",
1457
                "rdiffenabled", 1,
1458
                "id", -1);
1459
    my @bspools = @spools;
1460
    push @bspools, \%pool;
1461

    
1462
    foreach my $spool (@bspools) {
1463
        my $storagepool = $spool->{"id"};
1464
        my $b = $billing{$storagepool};
1465
        my $virtualsize = $b->{'virtualsize'} +0;
1466
        my $realsize = $b->{'realsize'} +0;
1467
        my $backupsize = $b->{'backupsize'} +0;
1468

    
1469
# Setting default start averages for use when no row found under the assumption that we entered a new month
1470
        my $startvirtualsizeavg = 0;
1471
        my $virtualsizeavg = 0;
1472
        my $startrealsizeavg = 0;
1473
        my $realsizeavg = 0;
1474
        my $startbackupsizeavg = 0;
1475
        my $backupsizeavg = 0;
1476
        my $starttimestamp = $current_time;
1477
# We have proably entered a new month if less than 4 hours since change of month, since this is run hourly
1478
        if ($current_time - $monthtimestamp < 4*3600) {
1479
            $starttimestamp = $monthtimestamp;
1480
            $startvirtualsizeavg = $virtualsizeavg = $virtualsize;
1481
            $startrealsizeavg = $realsizeavg = $realsize;
1482
            $startbackupsizeavg = $backupsizeavg = $backupsize;
1483
        }
1484
        # Update existing row
1485
        if ($billingreg{"$user-$storagepool-$year-$month"}) {
1486
            if (
1487
                ($virtualsize != $billingreg{"$user-$storagepool-$year-$month"}->{'virtualsize'})
1488
                || ($realsize != $billingreg{"$user-$storagepool-$year-$month"}->{'realsize'})
1489
                || ($backupsize != $billingreg{"$user-$storagepool-$year-$month"}->{'backupsize'})
1490
            )
1491
            {
1492
            # Sizes changed, update start averages and time, i.e. move the marker
1493
            # Averages and start averages are the same when a change has occurred
1494
                $startvirtualsizeavg = $virtualsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'virtualsizeavg'};
1495
                $startrealsizeavg = $realsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'realsizeavg'};
1496
                $startbackupsizeavg = $backupsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'backupsizeavg'};
1497
                $starttimestamp = $current_time;
1498
            } else {
1499
            # Update averages and timestamp when no change on existing row
1500
                $startvirtualsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'startvirtualsizeavg'};
1501
                $startrealsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'startrealsizeavg'};
1502
                $startbackupsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'startbackupsizeavg'};
1503
                $starttimestamp = $billingreg{"$user-$storagepool-$year-$month"}->{'starttimestamp'};
1504

    
1505
                $virtualsizeavg = ($startvirtualsizeavg*($starttimestamp - $monthtimestamp) + $virtualsize*($current_time - $starttimestamp)) /
1506
                                ($current_time - $monthtimestamp);
1507
                $realsizeavg = ($startrealsizeavg*($starttimestamp - $monthtimestamp) + $realsize*($current_time - $starttimestamp)) /
1508
                                ($current_time - $monthtimestamp);
1509
                $backupsizeavg = ($startbackupsizeavg*($starttimestamp - $monthtimestamp) + $backupsize*($current_time - $starttimestamp)) /
1510
                                ($current_time - $monthtimestamp);
1511
            }
1512
            # Update sizes in DB
1513
                $billingreg{"$user-$storagepool-$year-$month"}->{'virtualsize'} = $virtualsize;
1514
                $billingreg{"$user-$storagepool-$year-$month"}->{'realsize'} = $realsize;
1515
                $billingreg{"$user-$storagepool-$year-$month"}->{'backupsize'} = $backupsize;
1516
            # Update start averages
1517
                $billingreg{"$user-$storagepool-$year-$month"}->{'startvirtualsizeavg'} = $startvirtualsizeavg;
1518
                $billingreg{"$user-$storagepool-$year-$month"}->{'startrealsizeavg'} = $startrealsizeavg;
1519
                $billingreg{"$user-$storagepool-$year-$month"}->{'startbackupsizeavg'} = $startbackupsizeavg;
1520
            # Update current averages with values just calculated
1521
                $billingreg{"$user-$storagepool-$year-$month"}->{'virtualsizeavg'} = $virtualsizeavg;
1522
                $billingreg{"$user-$storagepool-$year-$month"}->{'realsizeavg'} = $realsizeavg;
1523
                $billingreg{"$user-$storagepool-$year-$month"}->{'backupsizeavg'} = $backupsizeavg;
1524
            # Update time stamps and inc
1525
                $billingreg{"$user-$storagepool-$year-$month"}->{'timestamp'} = $current_time;
1526
                $billingreg{"$user-$storagepool-$year-$month"}->{'starttimestamp'} = $starttimestamp;
1527
                $billingreg{"$user-$storagepool-$year-$month"}->{'inc'}++;
1528

    
1529
        # Write new row
1530
        } else {
1531
            $billingreg{"$user-$storagepool-$year-$month"} = {
1532
                virtualsize=>$virtualsize+0,
1533
                realsize=>$realsize+0,
1534
                backupsize=>$backupsize+0,
1535

    
1536
                virtualsizeavg=>$virtualsizeavg,
1537
                realsizeavg=>$realsizeavg,
1538
                backupsizeavg=>$backupsizeavg,
1539

    
1540
                startvirtualsizeavg=>$startvirtualsizeavg,
1541
                startrealsizeavg=>$startrealsizeavg,
1542
                startbackupsizeavg=>$startbackupsizeavg,
1543

    
1544
                timestamp=>$current_time,
1545
                starttimestamp=>$starttimestamp,
1546
                event=>$event,
1547
                inc=>1,
1548
            };
1549
        }
1550
    }
1551
    tied(%billingreg)->commit;
1552
    untie %billingreg;
1553
}
1554

    
1555
sub Removeuserimages {
1556
    my ($path, $action, $obj) = @_;
1557
    if ($help) {
1558
        return <<END
1559
GET::
1560
Removes all images belonging to a user from storage, i.e. completely deletes the image and its backups (be careful).
1561
END
1562
    }
1563

    
1564
    $postreply = removeUserImages($user) unless ($isreadonly);
1565
    return $postreply;
1566
}
1567

    
1568
sub removeUserImages {
1569
    my $username = shift;
1570
    return unless ($username && ($isadmin || $user eq $username) && !$isreadonly);
1571
    $user = $username;
1572
    foreach my $path (keys %register) {
1573
        if ($register{$path}->{'user'} eq $user) {
1574
            $postreply .=  "Removing " . ($preserveimagesonremove?"(preserving) ":"") . " $username image $register{$path}->{'name'}, $uuid" . ($console?'':'<br>') . "\n";
1575
            Remove($path, 'remove', 0, $preserveimagesonremove);
1576
        }
1577
    }
1578
    $postreply .= "Status=Error No storage pools!\n" unless (@spools);
1579
    foreach my $spool (@spools) {
1580
        my $pooldir = $spool->{"path"};
1581
        unless (-e $pooldir) {
1582
            $postreply .= "Status=Error Storage $pooldir, $spool->{name} does not exist\n" unless (@spools);
1583
            next;
1584
        }
1585

    
1586
        $postreply .= "Status=OK Removing user dir $pooldir/$username ";
1587
        $postreply .= `/bin/rm "$pooldir/$username/.htaccess"` if (-e "$pooldir/$username/.htaccess");
1588
        $postreply .= `/bin/rmdir --ignore-fail-on-non-empty "$pooldir/$username/fuel"` if (-e "$pooldir/$username/fuel");
1589
        $postreply .= `/bin/rmdir --ignore-fail-on-non-empty "$pooldir/$username"` if (-e "$pooldir/$username");
1590
        $postreply .= "\n";
1591
    }
1592

    
1593
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
1594

    
1595
    foreach $mac (keys %nodereg) {
1596
        $macip = $nodereg{$mac}->{'ip'};
1597
        my $esc_path = "/mnt/stabile/node/$username";
1598
        $esc_path =~ s/([ ])/\\$1/g;
1599
        if (!$preserveimagesonremove) {
1600
            `$sshcmd $macip "/bin/rmdir $esc_path"`;
1601
            $postreply .= "Status=OK Removing node user dir /mnt/stabile/node/$username on node $mac\n";
1602
        }
1603
    }
1604
    untie %nodereg;
1605

    
1606
    return $postreply;
1607
}
1608

    
1609
sub Remove {
1610
    my ($path, $action, $obj, $preserve) = @_;
1611
    if ($help) {
1612
        return <<END
1613
DELETE:image:
1614
Removes an image from storage, i.e. completely deletes the image and its backups (be careful).
1615
END
1616
    }
1617
    $path = $imagereg{$path}->{'path'} if ($imagereg{$path}); # Check if we were passed a uuid
1618
    $path = $curimg if (!$path && $register{$curimg});
1619
    if (!$curimg && $path && !($path =~ /^\//)) {
1620
        $curimg = $path;
1621
        $path = '';
1622
    }
1623
    if (!$path && $curimg && !($curimg =~ /\//) ) { # Allow passing only image name if we are deleting an app master
1624
        my $dspool = $stackspool;
1625
        $dspool = $spools[0]->{'path'} unless ($engineid eq $valve001id);
1626
        if ($curimg =~ /\.master.qcow2$/ && $register{"$dspool/$user/$curimg"}) {
1627
            $path = "$dspool/$user/$curimg";
1628
        } elsif ($isadmin && $curimg =~ /\.master.qcow2$/ && $register{"$dspool/common/$curimg"}) {
1629
            $path = "$dspool/common/$curimg";
1630
        }
1631
    }
1632
    utf8::decode($path);
1633

    
1634
    my $img = $register{$path};
1635
    my $status = $img->{'status'};
1636
    my $mac = $img->{'mac'};
1637
    my $name = $img->{'name'};
1638
    my $uuid = $img->{'uuid'};
1639
    utf8::decode($name);
1640
    my $type = $img->{'type'};
1641
    my $username = $img->{'user'};
1642

    
1643
    unless ($username && ($isadmin || $user eq $username) && !$isreadonly) {
1644
        return qq|[]|;
1645
#        $postmsg = "Cannot delete image";
1646
#        $postreply .= "Status=Error $postmsg\n";
1647
#        return $postreply;
1648
    }
1649

    
1650
    $uistatus = "deleting";
1651
    if ($status eq "unused" || $status eq "uploading" || $path =~ /(.+)\.master\.$type/) {
1652
        my $haschildren;
1653
        my $child;
1654
        my $hasprimary;
1655
        my $primary;
1656
        my $master = ($img->{'master'} && $img->{'master'} ne '--')?$img->{'master'}:'';
1657
        my $usedmaster = '';
1658
        my @regvalues = values %register;
1659
        foreach my $valref (@regvalues) {
1660
            if ($valref->{'master'} eq $path) {
1661
                $haschildren = 1;
1662
                $child = $valref->{'name'};
1663
            #    last;
1664
            }
1665
            if ($master) {
1666
                $usedmaster = 1 if ($valref->{'master'} eq $master && $valref->{'path'} ne $path); # Check if another image is also using this master
1667
            }
1668
        }
1669
        if ($master && !$usedmaster) {
1670
            $register{$master}->{'status'} = 'unused';
1671
            $main::syslogit->($user, "info", "Freeing master $master");
1672
        }
1673
        if ($type eq "qcow2") {
1674
            my @regkeys = (tied %register)->select_where("image2 = '$path'");
1675
            foreach my $k (@regkeys) {
1676
                my $val = $register{$k};
1677
                if ($val->{'image2'} eq $path) {
1678
                    $hasprimary = 1;
1679
                    $primary = $val->{'name'};
1680
                    last;
1681
                }
1682
            }
1683
        }
1684

    
1685
        if ($haschildren) {
1686
            $postmsg = "Cannot delete image. This image is used as master by: $child";
1687
            $postreply .= "Status=Error $postmsg\n";
1688
#        } elsif ($hasprimary) {
1689
#            $postmsg = "Cannot delete image. This image is used as secondary image by: $primary";
1690
#            $postreply .= "Status=Error $postmsg\n";
1691
        } else {
1692
            if ($mac && $path =~ /\/mnt\/stabile\/node\//) {
1693
                unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return "Status=Error Cannot connect to DB\n";};
1694
                $macip = $nodereg{$mac}->{'ip'};
1695
                my $wakenode = ($nodereg{$mac}->{'status'} eq 'asleep' || $nodereg{$mac}->{'status'} eq 'waking');
1696

    
1697
                if ($wakenode) {
1698
                    my $tasks = $nodereg{$mac}->{'tasks'};
1699
                    my $upath = URI::Escape::uri_escape($path);
1700
                    $tasks .= "REMOVE $upath $user\n";
1701
                    $nodereg{$mac}->{'tasks'} = $tasks;
1702
                    tied(%nodereg)->commit;
1703
                    $postmsg = "We are waking up the node your image $name is on - it will be removed shortly";
1704
                    if ($nodereg{$mac}->{'status'} eq 'asleep') {
1705
                        require "$Stabile::basedir/cgi/nodes.cgi";
1706
                        $Stabile::Nodes::console = 1;
1707
                        Stabile::Nodes::wake($mac);
1708
                    }
1709
                    $register{$path}->{'status'} = $uistatus;
1710
                } else {
1711
                    my $esc_path = $path;
1712
                    $esc_path =~ s/([ ])/\\$1/g;
1713
                    if ($preserve) {
1714
                        `$sshcmd $macip "/bin/mv $esc_path $esc_path.bak"`;
1715
                    } else {
1716
                        `$sshcmd $macip "/usr/bin/unlink $esc_path"`;
1717
                    }
1718
                    `$sshcmd $macip "/usr/bin/unlink $esc_path.meta"`;
1719
                    delete $register{$path};
1720
                }
1721
                untie %nodereg;
1722

    
1723
            } else {
1724
                if ($preserve) {
1725
                    `/bin/mv "$path" "$path.bak"`;
1726
                } else {
1727
                    unlink $path;
1728
                }
1729
                if (substr($path,-5) eq '.vmdk') {
1730
                    if ( -s (substr($path,0,-5) . "-flat.vmdk")) {
1731
                        my $flat = substr($path,0,-5) . "-flat.vmdk";
1732
                        if ($preserve) {
1733
                            `/bin/mv $flat "$flat.bak"`;
1734
                        } else {
1735
                            unlink($flat);
1736
                        }
1737
                    } elsif ( -e (substr($path,0,-5) . "-s001.vmdk")) {
1738
                        my $i = 1;
1739
                        my $rmpath = substr($path,0,-5);
1740
                        while (-e "$rmpath-s00$i.vmdk") {
1741
                            if ($preserve) {
1742
                                `/bin/mv "$rmpath-s00$i.vmdk" "$rmpath-s00$i.vmdk.bak"`;
1743
                            } else {
1744
                                unlink("$rmpath-s00$i.vmdk");
1745
                            }
1746
                            $i++;
1747
                        }
1748
                    }
1749
                }
1750
                unlink "$path.meta" if (-e "$path.meta");
1751
                delete $register{$path};
1752
            }
1753

    
1754
            my $subdir = "";
1755
            my($bname, $dirpath) = fileparse($path);
1756
            if ($dirpath =~ /.+\/$buser(\/.+)?\//) {
1757
                $subdir = $1;
1758
            }
1759
            my $bpath = "$backupdir/$user$subdir/$bname";
1760
            $bpath = $1 if ($bpath =~ /(.+)/);
1761
            # Remove backup of image if it exists
1762
            if (-d "$bpath") {
1763
                `/bin/rm -rf "$bpath"`;
1764
            }
1765

    
1766
#            $postmsg = "Deleted image $name ($path, $uuid, $mac)";
1767
            $postreply =  "[]";
1768
#            $postreply .=  "Status=deleting OK $postmsg\n";
1769
            updateBilling("delete $path");
1770
            $main::syslogit->($user, "info", "$uistatus $type image: $name: $path");
1771
            if ($status eq 'downloading') {
1772
                my $daemon = Proc::Daemon->new(
1773
                    work_dir => '/usr/local/bin',
1774
                    exec_command => qq|pkill -f "$path"|
1775
                ) or do {$postreply .= "Status=ERROR $@\n";};
1776
                my $pid = $daemon->Init();
1777
            }
1778
            sleep 1;
1779
        }
1780
    } else {
1781
        $postmsg = "Cannot delete $type image with status: $status";
1782
        $postreply .= "Status=ERROR $postmsg\n";
1783
    }
1784
    return $postreply;
1785
}
1786

    
1787
# Clone image $path to destination storage pool $istoragepool, possibly changing backup schedule $bschedule
1788
sub Clone {
1789
    my ($path, $action, $obj, $istoragepool, $imac, $name, $bschedule, $buildsystem, $managementlink, $appid, $wait, $vcpu, $mem) = @_;
1790
    if ($help) {
1791
        return <<END
1792
GET:image,name,storagepool,wait:
1793
Clones an image. In the case of cloning a master image, a child is produced.
1794
Only cloning to same storagepool is supported, with the exception of cloning to nodes (storagepool -1).
1795
If you want to perform the clone synchronously, set wait to 1;
1796
END
1797
    }
1798
    $postreply = "" if ($buildsystem);
1799
    return "Status=Error no valid user\n" unless ($user);
1800

    
1801
    unless ($register{$path} && ($register{$path}->{'user'} eq $user
1802
                || $register{$path}->{'user'} eq 'common'
1803
                || $register{$path}->{'user'} eq $billto
1804
                || $isadmin)) {
1805
        $postreply .= "Status=ERROR Cannot clone!\n";
1806
        return;
1807
    }
1808
    $istoragepool = $istoragepool || $obj->{storagepool};
1809
    $name = $name || $obj->{name};
1810
    $wait = $wait || $obj->{wait};
1811
    my $status = $register{$path}->{'status'};
1812
    my $type = $register{$path}->{'type'};
1813
    my $master = $register{$path}->{'master'};
1814
    my $notes = $register{$path}->{'notes'};
1815
    my $image2 = $register{$path}->{'image2'};
1816
    my $snap1 = $register{$path}->{'snap1'};
1817
    $managementlink = $register{$path}->{'managementlink'} unless ($managementlink);
1818
    $appid = $register{$path}->{'appid'} unless ($appid);
1819
    my $upgradelink = $register{$path}->{'upgradelink'} || '';
1820
    my $terminallink = $register{$path}->{'terminallink'} || '';
1821
    my $version = $register{$path}->{'version'} || '';
1822
    my $regmac = $register{$path}->{'mac'};
1823

    
1824
    my $virtualsize = $register{$path}->{'virtualsize'};
1825
    my $dindex = 0;
1826

    
1827
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1828
    $path =~ /(.+)\.$type/;
1829
    my $namepath = $1;
1830
    if ($namepath =~ /(.+)\.master/) {
1831
        $namepath = $1;
1832
    }
1833
    if ($namepath =~ /(.+)\.clone\d+/) {
1834
        $namepath = $1;
1835
    }
1836
    if ($namepath =~ /.+\/common\/(.+)/) { # Support one subdir
1837
        $namepath = $1;
1838
    } elsif ($namepath =~ /.+\/$user\/(.+)/) { # Support one subdir
1839
        $namepath = $1;
1840
    } elsif ($namepath =~ /.+\/(.+)/) { # Extract only the name
1841
        $namepath = $1;
1842
    }
1843

    
1844
    # Find unique path in DB across storage pools
1845
    my $upath;
1846
    my $npath = "/mnt/stabile/node/$user/$namepath"; # Also check for uniqueness on nodes
1847
    my $i = 1;
1848
    foreach my $spool (@spools) {
1849
        $upath = $spool->{'path'} . "/$user/$namepath";
1850
        while ($register{"$upath.clone$i.$type"} || $register{"$npath.clone$i.$type"}) {$i++;};
1851
    }
1852
    $upath = "$spools[$istoragepool]->{'path'}/$user/$namepath";
1853

    
1854
    my $iname = $register{$path}->{'name'};
1855
    $iname = "$name" if ($name); # Used when name supplied when building a system
1856
    $iname =~ /(.+)( \(master\))/;
1857
    $iname = $1 if $2;
1858
    $iname =~ /(.+)( \(clone\d*\))/;
1859
    $iname = $1 if $2;
1860
    $iname =~ /(.+)( \(child\d*\))/;
1861
    $iname = $1 if $2;
1862
    my $ippath = $path;
1863
    my $macip;
1864
    my $ug = new Data::UUID;
1865
    my $newuuid = $ug->create_str();
1866
    my $wakenode;
1867
    my $identity;
1868

    
1869
    # We only support cloning images to nodes - not the other way round
1870
    if ($imac && $regmac && $imac ne $regmac) {
1871
        $postreply .= "Status=ERROR Cloning from a node not supported\n";
1872
        return $postreply;
1873
    }
1874

    
1875
    if ($istoragepool==-1) {
1876
    # Find the ip address of target node
1877
        ($imac, $macip, $dindex, $wakenode, $identity) = locateNode($virtualsize, $imac, $vcpu, $mem);
1878
        if ($identity eq 'local_kvm') {
1879
            $postreply .= "Status=OK Cloning to local node with index: $dindex\n";
1880
            $istoragepool = 0; # cloning to local node
1881
            $upath = "$spools[$istoragepool]->{'path'}/$user/$namepath";
1882
        } elsif (!$macip) {
1883
            $postreply .= "Status=ERROR Unable to locate node with sufficient ressources\n";
1884
            $postmsg = "Unable to locate node with sufficient ressources!";
1885
            $main::updateUI->({tab=>"images", user=>$user, type=>"message", message=>$postmsg});
1886
            return $postreply;
1887
        } else {
1888
            $postreply .= "Status=OK Cloning to $macip with index: $dindex\n";
1889
            $ippath = "$macip:$path";
1890
            $upath = "/mnt/stabile/node/$user/$namepath";
1891
        }
1892
    }
1893
    my $ipath = "$upath.clone$i.$type";
1894

    
1895
    if ($bschedule eq 'daily7' || $bschedule eq 'daily14') {
1896
         $bschedule = "manually" if ($istoragepool!=-1 && (!$spools[$istoragepool]->{'rdiffenabled'} || !$spools[$istoragepool]->{'lvm'}));
1897
    } elsif ($bschedule ne 'manually') {
1898
        $bschedule = '';
1899
    }
1900

    
1901
# Find storage pool with space
1902
    my $foundstorage = 1;
1903
    if (overStorage($virtualsize, $istoragepool, $imac)) {
1904
        $foundstorage = 0;
1905
        foreach my $p (@spools) {
1906
            if (overStorage($virtualsize, $p->{'id'}, $imac)) {
1907
                ;
1908
            } else {
1909
                $istoragepool = $p->{'id'};
1910
                $foundstorage = 1;
1911
                last;
1912
            }
1913
        }
1914
    }
1915

    
1916
# We allow multiple clone operations on master images
1917
    if ($status ne "used" && $status ne "unused" && $status ne "paused" && $path !~ /(.+)\.master\.$type/) {
1918
        $postreply .= "Status=ERROR Please shut down your virtual machine before cloning\n";
1919

    
1920
    } elsif ($type eq 'vmdk' && (-e "$dirpath$bname-s001$suffix" || -e "$dirpath$bname-flat$suffix")) {
1921
        $postreply .= "Status=ERROR Cannot clone this image - please convert first!\n";
1922

    
1923
    } elsif (overQuotas($virtualsize, ($istoragepool==-1))) {
1924
        $postreply .= "Status=ERROR Over quota (". overQuotas($virtualsize, ($istoragepool==-1)) . ") cloning: $name\n";
1925

    
1926
    } elsif (!$foundstorage) {
1927
        $postreply .= "Status=ERROR Not enough storage ($virtualsize) in destination pool $istoragepool $imac cloning: $name\n";
1928

    
1929
    } elsif ($wakenode && !($path =~ /(.+)\.master\.$type/)) { # For now we dont support simply copying images on sleeping nodes
1930
        $postreply .= "Status=ERROR We are waking up the node your image $name is on, please try again later\n";
1931
        require "$Stabile::basedir/cgi/nodes.cgi";
1932
        $Stabile::Nodes::console = 1;
1933
        Stabile::Nodes::wake($imac);
1934
    } elsif ($type eq "img" || $type eq "qcow2" || $type eq "vmdk") {
1935
        my $masterimage2 = $register{"$path"}->{'image2'};
1936
    # Cloning a master produces a child
1937
        if ($type eq "qcow2" && $path =~ /(.+)\.master\.$type/) {
1938
            $uistatus = "cloning";
1939
    # VBoxManage probably does a more efficient job at cloning than simply copying
1940
        } elsif ($type eq "vdi" || $type eq "vhd") {
1941
            $uistatus = "vcloning";
1942
    # Cloning another child produces a sibling with the same master
1943
        } else {
1944
            $uistatus = "copying";
1945
        }
1946
        $uipath = $path;
1947
        eval {
1948
            $register{$ipath} = {
1949
                uuid=>$newuuid,
1950
                master=>($uistatus eq 'cloning')?$path:$master,
1951
                name=>"$iname (clone$i)",
1952
                notes=>$notes,
1953
                image2=>$image2,
1954
                snap1=>($uistatus eq 'copying')?$snap1:'',
1955
                storagepool=>$istoragepool,
1956
                status=>$uistatus,
1957
                mac=>($istoragepool == -1)?$imac:"",
1958
                size=>0,
1959
                realsize=>0,
1960
                virtualsize=>$virtualsize,
1961
                bschedule=>$bschedule,
1962
                type=>"qcow2",
1963
                created=>$current_time,
1964
                user=>$user
1965
            };
1966
            $register{$ipath}->{'managementlink'} = $managementlink if ($managementlink);
1967
            $register{$ipath}->{'appid'} = $appid if ($appid);
1968
            $register{$ipath}->{'upgradelink'} = $upgradelink if ($upgradelink);
1969
            $register{$ipath}->{'terminallink'} = $terminallink if ($terminallink);
1970
            $register{$ipath}->{'version'} = $version if ($version);
1971
            $register{$path}->{'status'} = $uistatus;
1972
            my $dstatus = ($buildsystem)?'bcloning':$uistatus;
1973
            if ($wakenode) { # We are waking a node for clone operation, so ask movepiston to do the work
1974
                unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
1975
                my $tasks = $nodereg{$imac}->{'tasks'};
1976
                $upath = URI::Escape::uri_escape($ipath);
1977
                $tasks .= "BCLONE $upath $user\n";
1978
                $nodereg{$imac}->{'tasks'} = $tasks;
1979
                tied(%nodereg)->commit;
1980
                untie %nodereg;
1981
            } elsif ($wait) {
1982
                my $cmd = qq|steamExec $user $dstatus $status "$ippath" "$ipath"|;
1983
                $cmd = $1 if ($cmd =~ /(.+)/);
1984
                `$cmd`;
1985
            } else {
1986
                my $daemon = Proc::Daemon->new(
1987
                        work_dir => '/usr/local/bin',
1988
                        exec_command => "perl -U steamExec $user $dstatus $status \"$ippath\" \"$ipath\""
1989
                    ) or do {$postreply .= "Status=ERROR $@\n";};
1990
                my $pid = $daemon->Init();
1991
            }
1992
            $postreply .= "Status=$uistatus OK $uistatus to: $iname (clone$i)" . ($isadmin? " -> $ipath ":"") . "\n";
1993
            $postreply .= "Status=OK uuid: $newuuid\n"; # if ($console || $api);
1994
            $postreply .= "Status=OK path: $ipath\n"; # if ($console || $api);
1995
            $postreply .= "Status=OK mac: $imac\n"; # if ($console || $api);
1996
            $postreply .= "Status=OK wakenode: $wakenode\n"; # if ($console || $api);
1997
            $main::syslogit->($user, "info", "$uistatus $wakenode $type image: $name $uuid to $ipath");
1998
            1;
1999
        } or do {$postreply .= "Status=ERROR $@\n";}
2000

    
2001
    } else {
2002
        $postreply .= "Status=ERROR Not a valid type: $type\n";
2003
    }
2004
    tied(%register)->commit;
2005
    $main::updateUI->({tab=>"images", user=>$user, type=>"update"});
2006
    return $postreply;
2007
}
2008

    
2009

    
2010
# Link master image to fuel
2011
sub Linkmaster {
2012
    my ($mpath, $action) = @_;
2013
    if ($help) {
2014
        return <<END
2015
GET:image:
2016
Link master image to fuel
2017
END
2018
    }
2019
    my $res;
2020

    
2021
    return "Your account does not have the necessary privileges\n" if ($isreadonly);
2022
    return "Please specify master image to link\n" unless ($mpath);
2023

    
2024
    unless ($mpath =~ /^\//) { # We did not get an absolute path, look for it in users storagepools
2025
        foreach my $p (@spools) {
2026
            my $dir = $p->{'path'};
2027
            my $cpath = "$dir/common/$mpath";
2028
            my $upath = "$dir/$user/$mpath";
2029
            if (-e $cpath) {
2030
                $mpath = $cpath;
2031
                last;
2032
            } elsif (-e $upath) {
2033
                $mpath = $upath;
2034
                last;
2035
            }
2036
        }
2037
    }
2038
    my $img = $register{$mpath};
2039
    $mpath = $img->{"path"};
2040
    $imguser = $img->{"user"};
2041
    if (!$mpath || ($imguser ne $user && $imguser ne 'common' && !$isadmin)) {
2042
        $postreply = qq|{"status": "Error", "message": "No privs. or not found @_[0]"}|;
2043
        return $postreply;
2044
    }
2045
    my $status = $img->{"status"};
2046
    my $type = $img->{"type"};
2047
    $mpath =~ /(.+)\/(.+)\.master\.$type$/;
2048
    my $namepath = $2;
2049
    my $msg;
2050
    if ($status ne "unused" && $status ne "used") {
2051
        $res .= qq|{"status": "Error", "message": "Only used and unused images may be linked ($status, $mpath)."}|;
2052
    } elsif (!( $mpath =~ /(.+)\.master\.$type$/ ) ) {
2053
        $res .= qq|{"status": "Error", "message": "You can only link master images"}|;
2054
    } elsif ($type eq "qcow2") {
2055
        my $pool = $img->{'storagepool'};
2056
        `chmod 444 "$mpath"`;
2057
        my $linkpath = $tenderpathslist[$pool] . "/$user/fuel/$namepath.link.master.$type";
2058
        my $fuellinkpath = "/mnt/fuel/pool$pool/$namepath.link.master.$type";
2059
        if (-e $tenderpathslist[$pool] . "/$user/fuel") { # master should be on fuel-enabled storage
2060
            unlink ($linkpath) if (-e $linkpath);
2061
            `ln "$mpath" "$linkpath"`;
2062
        } else {
2063
            foreach my $p (@spools) {
2064
                my $dir = $p->{'path'};
2065
                my $poolid = $p->{'id'};
2066
                if (-e "$dir/$user/fuel") {
2067
                    $linkpath = "$dir/$user/fuel/$namepath.copy.master.$type";
2068
                    $fuellinkpath = "/mnt/fuel/pool$poolid/$namepath.copy.master.$type";
2069
                    unlink ($linkpath) if (-e $linkpath);
2070
                    `cp "$mpath" "$linkpath"`;
2071
                    $msg = "Different file systems, master copied";
2072
                    last;
2073
                }
2074
            }
2075
        }
2076
        $res .= qq|{"status": "OK", "message": "$msg", "path": "$fuellinkpath", "linkpath": "$linkpath", "masterpath": "$mpath"}|;
2077
    } else {
2078
        $res .= qq|{"status": "Error", "message": "You can only link qcow2 images"}|;
2079
    }
2080
    $postreply = $res;
2081
    return $res;
2082
}
2083

    
2084
# Link master image to fuel
2085
sub unlinkMaster {
2086
    my $mpath = shift;
2087
    unless ($mpath =~ /^\//) { # We did not get an absolute path, look for it in users storagepools
2088
        foreach my $p (@spools) {
2089
            my $dir = $p->{'path'};
2090
            my $upath = "$dir/$user/fuel/$mpath";
2091
            if (-e $upath) {
2092
                $mpath = "/mnt/fuel/pool$p->{id}/$mpath";
2093
                last;
2094
            }
2095
        }
2096
    }
2097

    
2098
    $mpath =~ /\/pool(\d+)\/(.+)\.link\.master\.qcow2$/;
2099
    my $pool = $1;
2100
    my $namepath = $2;
2101
    if (!( $mpath =~ /\/pool(\d+)\/(.+)\.link\.master\.qcow2$/ ) ) {
2102
        $postreply = qq|{"status": "Error", "message": "You can only unlink linked master images ($mpath)"}|;
2103
    } else {
2104
        my $linkpath = $tenderpathslist[$pool] . "/$user/fuel/$namepath.link.master.qcow2";
2105
        if (-e $linkpath) {
2106
            `chmod 644 "$linkpath"`;
2107
            `rm "$linkpath"`;
2108
            $postreply = qq|{"status": "OK", "message": "Link removed", "path": "/mnt/fuel/pool$pool/$namepath.qcow2", "linkpath": "$linkpath"}|;
2109
        } else {
2110
            $postreply = qq|{"status": "Error", "message": "Link $linkpath does not exists."}|;
2111
        }
2112
    }
2113
}
2114

    
2115
#sub do_getstatus {
2116
#    my ($img, $action) = @_;
2117
#    if ($help) {
2118
#        return <<END
2119
#GET::
2120
#END
2121
#    }
2122
#    # Allow passing only image name if we are dealing with an app master
2123
#    my $dspool = $stackspool;
2124
#    my $masteruser = $params{'masteruser'};
2125
#    my $destuser = $params{'destuser'};
2126
#    my $destpath;
2127
#    $dspool = $spools[0]->{'path'} unless ($engineid eq $valve001id);
2128
#    if (!$register{$img} && $img && !($img =~ /\//) && $masteruser) {
2129
#        if ($img =~ /\.master\.qcow2$/ && $register{"$dspool/$masteruser/$img"}) {
2130
#            if ($ismanager || $isadmin
2131
#                || ($userreg{$masteruser}->{'billto'} eq $user)
2132
#            ) {
2133
#                $img = "$dspool/$masteruser/$img";
2134
#            }
2135
#        }
2136
#    }
2137
#    my $status = $register{$img}->{'status'};
2138
#    if ($status) {
2139
#        my $iuser = $register{$img}->{'user'};
2140
#        # First check if user is allowed to access image
2141
#        if ($iuser ne $user && $iuser ne 'common' && $userreg{$iuser}->{'billto'} ne $user) {
2142
#            $status = '' unless ($isadmin || $ismanager);
2143
#        }
2144
#        if ($destuser) { # User is OK, now check if destination exists
2145
#            my ($dest, $folder) = fileparse($img);
2146
#            $destpath = "$dspool/$destuser/$dest";
2147
#            $status = 'exists' if ($register{$destpath} || -e ($destpath));
2148
#        }
2149
#    }
2150
#    my $res;
2151
#    $res .= $Stabile::q->header('text/plain') unless ($console);
2152
#    $res .= "$status";
2153
#    return $res;
2154
#}
2155

    
2156
# sub do_move {
2157
#     my ($uuid, $action) = @_;
2158
#     if ($help) {
2159
#         return <<END
2160
# GET:image,destuser,masteruser:
2161
# Move image to a different storage pool or user
2162
# END
2163
#     }
2164
#     return "Your account does not have the necessary privileges\n" if ($isreadonly);
2165
#     Move($curimg, $params{'user'});
2166
#     return $postreply;
2167
# }
2168

    
2169
sub Move {
2170
    my ($path, $iuser, $istoragepool, $mac, $force) = @_;
2171
    # Allow passing only image name if we are deleting an app master
2172
    my $dspool = $stackspool;
2173
    my $masteruser = $params{'masteruser'};
2174
    $dspool = $spools[0]->{'path'} unless ($engineid eq $valve001id);
2175
    unless ( tie(%userreg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2176
    if (!$register{$path} && $path && !($path =~ /\//) && $masteruser) {
2177
        if ($path =~ /\.master\.qcow2$/ && $register{"$dspool/$masteruser/$path"}) {
2178
            if ($ismanager || $isadmin
2179
                || ($userreg{$masteruser}->{'billto'} eq $user && $iuser eq $user)
2180
                || ($masteruser eq $user && $userreg{$iuser}->{'billto'} eq $user)
2181
            ) {
2182
                $path = "$dspool/$masteruser/$path";
2183
            }
2184
        }
2185
    }
2186
    my $regimg = $register{$path};
2187
    $istoragepool = ($istoragepool eq '0' || $istoragepool)? $istoragepool: $regimg->{'storagepool'};
2188
    $mac = $mac || $regimg->{'mac'};
2189
    my $bschedule = $regimg->{'bschedule'};
2190
    my $name = $regimg->{'name'};
2191
    my $status = $regimg->{'status'};
2192
    my $type = $regimg->{'type'};
2193
    my $reguser = $regimg->{'user'};
2194
    my $regstoragepool = $regimg->{'storagepool'};
2195
    my $virtualsize = $regimg->{'virtualsize'};
2196

    
2197
    my $newpath;
2198
    my $newdirpath;
2199
    my $oldpath = $path;
2200
    my $olddirpath = $path;
2201
    my $newuser = $reguser;
2202
    my $newstoragepool = $regstoragepool;
2203
    my $haschildren;
2204
    my $hasprimary;
2205
    my $child;
2206
    my $primary;
2207
    my $macip;
2208
    my $alreadyexists;
2209
    my $subdir;
2210
#    $subdir = $1 if ($path =~ /\/$reguser(\/.+)\//);
2211
    $subdir = $1 if ($path =~ /.+\/$reguser(\/.+)?\//);
2212
    my $restpath;
2213
    $restpath = $1 if ($path =~ /.+\/$reguser\/(.+)/);
2214

    
2215
    if ($type eq "qcow2" && $path =~ /(.+)\.master\.$type/) {
2216
        my @regkeys = (tied %register)->select_where("master = '$path'");
2217
        foreach my $k (@regkeys) {
2218
            my $val = $register{$k};
2219
            if ($val->{'master'} eq $path) {
2220
                $haschildren = 1;
2221
                $child = $val->{'name'};
2222
                last;
2223
            }
2224
        }
2225
    }
2226
    if ($type eq "qcow2") {
2227
        my @regkeys = (tied %register)->select_where("image2 = '$path'");
2228
        foreach my $k (@regkeys) {
2229
            my $val = $register{$k};
2230
            if ($val->{'image2'} eq $path) {
2231
                $hasprimary = 1;
2232
                $primary = $val->{'name'};
2233
                last;
2234
            }
2235
        }
2236
    }
2237
    if (!$register{$path}) {
2238
        $postreply .= "Status=ERROR Unable to move $path (invalid path, $path, $masteruser)\n" unless ($istoragepool eq '--' || $regstoragepool eq '--');
2239
    } elsif ($type eq 'vmdk' && -s (substr($path,0,-5) . "-flat.vmdk") || -s (substr($path,0,-5) . "-s001.vmdk")) {
2240
        $postreply .= "Status=Error Cannot move this image. Please convert before moving\n";
2241
# Moving an image to a different users dir
2242
    } elsif ($iuser ne $reguser && ($status eq "unused" || $status eq "used")) {
2243
        unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2244
        my @accounts = split(/,\s*/, $userreg{$tktuser}->{'accounts'});
2245
        my @accountsprivs = split(/,\s*/, $userreg{$tktuser}->{'accountsprivileges'});
2246
        %ahash = ($tktuser, $userreg{$tktuser}->{'privileges'} || 'r' ); # Include tktuser in accounts hash
2247
        for my $i (0 .. scalar @accounts)
2248
        {
2249
            next unless $accounts[$i];
2250
            $ahash{$accounts[$i]} = $accountsprivs[$i] || 'u';
2251
        }
2252

    
2253
        if ((($isadmin || $ismanager ) && $iuser eq 'common') # Check if user is allowed to access account
2254
                || ($isadmin && $userreg{$iuser})
2255
                || ($user eq $engineuser)
2256
                || ($userreg{$iuser}->{'billto'} eq $user)
2257
                || ($ahash{$iuser} && !($ahash{$iuser} =~ /r/))
2258
        ) {
2259
            if ($haschildren) {
2260
                $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"Error Cannot move image. This image is used as master by: $child"});
2261
                $postreply .= "Status=Error Cannot move image. This image is used as master by: $child\n";
2262
            } elsif ($hasprimary) {
2263
                $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"Error Cannot move image. This image is used as secondary image by: $primary"});
2264
                $postreply .= "Status=Error Cannot move image. This image is used as secondary image by: $primary\n";
2265
            } else {
2266
                if ($regstoragepool == -1) { # The image is located on a node
2267
                    my $uprivs = $userreg{$iuser}->{'privileges'};
2268
                    if ($uprivs =~ /[an]/) {
2269
                        unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2270
                        $macip = $nodereg{$mac}->{'ip'};
2271
                        untie %nodereg;
2272
                        $oldpath = "$macip:/mnt/stabile/node/$reguser/$restpath";
2273
                        $newdirpath = "/mnt/stabile/node/$iuser/$restpath";
2274
                        $newpath = "$macip:$newdirpath";
2275
                        $newuser = $iuser;
2276
                        $newstoragepool = $istoragepool;
2277
                # Check if image already exists in target dir
2278
                        $alreadyexists = `ssh -l irigo -i /var/www/.ssh/id_rsa_www -o UserKnownHostsFile=/dev/null -o StrictHostKeyChecking=no $macip "perl -e 'print 1 if -e q{/mnt/stabile/node/$iuser/$restpath}'"`;
2279
                    } else {
2280
                        $postreply .= "Status=Error Target account $iuser cannot use node storage\n";
2281
                    }
2282
                } else {
2283
                    my $reguser = $userreg{$iuser};
2284
                    my $upools = $reguser->{'storagepools'} || $Stabile::config->get('STORAGE_POOLS_DEFAULTS') || "0";
2285
                    my @nspools = split(/, ?/, $upools);
2286
                    my %ispools = map {$_=>1} @nspools; # Build a hash with destination users storagepools
2287
                    if ($ispools{$regstoragepool}) { # Destination user has access to image's storagepool
2288
                        $newpath = "$spools[$regstoragepool]->{'path'}/$iuser/$restpath";
2289
                    } else {
2290
                        $newpath = "$spools[0]->{'path'}/$iuser/$restpath";
2291
                    }
2292
                    $newdirpath = $newpath;
2293
                    $newuser = $iuser;
2294
            # Check if image already exists in target dir
2295
                    $alreadyexists = -e $newpath;
2296
                }
2297
            }
2298
        } else {
2299
            $postreply .= "Status=Error Cannot move image to account $iuser $ahash{$iuser} - not allowed\n";
2300
        }
2301
# Moving an image to a different storage pool
2302
    } elsif ($istoragepool ne '--' &&  $regstoragepool ne '--' && $istoragepool ne $regstoragepool
2303
            && ($status eq "unused" || $status eq "used" || $status eq "paused")) {
2304

    
2305
        my $dindex;
2306
        my $wakenode;
2307
        if ($istoragepool == -1 && $regstoragepool != -1) {
2308
            ($mac, $macip, $dindex, $wakenode) = locateNode($virtualsize, $mac);
2309
        }
2310

    
2311
        $main::syslogit->($user, "info", "Moving $name from $regstoragepool to $istoragepool $macip $wakenode");
2312

    
2313
        if ($haschildren) {
2314
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"ERROR Unable to move $name (has children)"});
2315
            $postreply .= "Status=ERROR Unable to move $name (has children)\n";
2316
        } elsif ($hasprimary) {
2317
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"Error Cannot move image. This image is used as secondary image by: $primary"});
2318
            $postreply .= "Status=Error Cannot move image. This image is used as secondary image by: $primary\n";
2319
        } elsif ($wakenode) {
2320
            $postreply .= "Status=ERROR All available nodes are asleep moving $name, waking $mac, please try again later\n";
2321
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"All available nodes are asleep moving $name, waking $mac, please try again later"});
2322
            require "$Stabile::basedir/cgi/nodes.cgi";
2323
            $Stabile::Nodes::console = 1;
2324
            Stabile::Nodes::wake($mac);
2325
        } elsif (overStorage($virtualsize, $istoragepool+0, $mac)) {
2326
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"ERROR Out of storage in destination pool $istoragepool $mac moving: $name"});
2327
            $postreply .= "Status=ERROR Out of storage in destination pool $istoragepool $mac moving: $name\n";
2328
        } elsif (overQuotas($virtualsize, ($istoragepool==-1))) {
2329
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"ERROR Over quota (". overQuotas($virtualsize, ($istoragepool==-1)) . ") moving: $name"});
2330
            $postreply .= "Status=ERROR Over quota (". overQuotas($virtualsize, ($istoragepool==-1)) . ") moving: $name\n";
2331
        } elsif ($istoragepool == -1 && $regstoragepool != -1 && $path =~ /\.master\.$type/) {
2332
            $postreply .= "Status=ERROR Unable to move $name (master images are not supported on node storage)\n";
2333
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"Unable to move $name (master images are not supported on node storage)"});
2334
    # Moving to node
2335
        } elsif ($istoragepool == -1 && $regstoragepool != -1) {
2336
            if (index($privileges,"a")!=-1 || index($privileges,"n")!=-1) { # Privilege "n" means user may use node storage
2337
                if ($macip) {
2338
                    $newdirpath = "/mnt/stabile/node/$reguser/$restpath";
2339
                    $newpath = "$macip:$newdirpath";
2340
                    $newstoragepool = $istoragepool;
2341
            # Check if image already exists in target dir
2342
                    $alreadyexists = `ssh -l irigo -i /var/www/.ssh/id_rsa_www -o UserKnownHostsFile=/dev/null -o StrictHostKeyChecking=no $macip "perl -e 'print 1 if -e q{/mnt/stabile/node/$reguser/$restpath}'"`;
2343

    
2344
                } else {
2345
                    $postreply .= "Status=ERROR Unable to move $name (not enough space)\n";
2346
                }
2347
            } else {
2348
                $postreply .= "Status=ERROR Unable to move $name (no node)\n";
2349
            }
2350
    # Moving from node
2351
        } elsif ($regstoragepool == -1 && $istoragepool != -1 && $spools[$istoragepool]) {
2352
            if (index($privileges,"a")!=-1 || index($privileges,"n")!=-1 && $mac) { # Privilege "n" means user may use node storage
2353
                unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2354
                $macip = $nodereg{$mac}->{'ip'};
2355
                untie %nodereg;
2356
                $newpath = "$spools[$istoragepool]->{'path'}/$reguser/$restpath";
2357
                $newdirpath = $newpath;
2358
                $oldpath = "$macip:/mnt/stabile/node/$reguser/$restpath";
2359
                $newstoragepool = $istoragepool;
2360
        # Check if image already exists in target dir
2361
                $alreadyexists = -e $newpath;
2362
            } else {
2363
                $postreply .= "Status=ERROR Unable to move $name - select node\n";
2364
            }
2365
        } elsif ($spools[$istoragepool]) { # User has access to storagepool
2366
            $newpath = "$spools[$istoragepool]->{'path'}/$reguser/$restpath";
2367
            $newdirpath = $newpath;
2368
            $newstoragepool = $istoragepool;
2369
            $alreadyexists = -e $newpath && -s $newpath;
2370
        } else {
2371
            $postreply .= "Status=ERROR Cannot move image. This image is used as master by: $child\n";
2372
        }
2373
    } else {
2374
        $postreply .= "Status=ERROR Unable to move $path (bad status or pool $status, $reguser, $iuser, $regstoragepool, $istoragepool)\n" unless ($istoragepool eq '--' || $regstoragepool eq '--');
2375
    }
2376
    untie %userreg;
2377

    
2378
    if ($alreadyexists && !$force) {
2379
        $postreply = "Status=ERROR Image \"$name\" already exists in destination\n";
2380
        return $postreply;
2381
    }
2382
# Request actual move operation
2383
    elsif ($newpath) {
2384
        if ($newstoragepool == -1) {
2385
            my $diruser = $iuser || $reguser;
2386
            `ssh -l irigo -i /var/www/.ssh/id_rsa_www -o UserKnownHostsFile=/dev/null -o StrictHostKeyChecking=no $macip "/bin/mkdir -v /mnt/stabile/node/$diruser"`; # rsync will create the last dir if needed
2387
        }
2388
        if ($subdir && $istoragepool != -1) {
2389
            my $fulldir = "$spools[$istoragepool]->{'path'}/$reguser$subdir";
2390
            `/bin/mkdir -p "$fulldir"` unless -d $fulldir;
2391
        }
2392
        $uistatus = "moving";
2393
        my $ug = new Data::UUID;
2394
        my $tempuuid = $ug->create_str();
2395

    
2396
        $register{$path}->{'status'} = $uistatus;
2397
        $register{$newdirpath} = \%{$register{$path}}; # Clone db entry
2398

    
2399
        if ($bschedule eq 'daily7' || $bschedule eq 'daily14') {
2400
             $bschedule = "manually" if (!$spools[$regstoragepool]->{'rdiffenabled'} || !$spools[$regstoragepool]->{'lvm'});
2401
        } elsif ($bschedule ne 'manually') {
2402
            $bschedule = '';
2403
        }
2404

    
2405
        $register{$path}->{'uuid'} = $tempuuid; # Use new temp uuid for old image
2406
        $register{$newdirpath}->{'storagepool'} = $newstoragepool;
2407
        if ($newstoragepool == -1) {
2408
            $register{$newdirpath}->{'mac'} = $mac;
2409
        } else {
2410
            $register{$newdirpath}->{'mac'} = '';
2411
        }
2412
        $register{$newdirpath}->{'user'} = $newuser;
2413
        tied(%register)->commit;
2414
        my $domuuid = $register{$path}->{'domains'};
2415
        if ($status eq "used" || $status eq "paused" || $status eq "moving") {
2416
            my $dom = $domreg{$domuuid};
2417
            if ($dom->{'image'} eq $olddirpath) {
2418
                $dom->{'image'} = $newdirpath;
2419
            } elsif ($dom->{'image2'} eq $olddirpath) {
2420
                $dom->{'image2'} = $newdirpath;
2421
            } elsif ($dom->{'image3'} eq $olddirpath) {
2422
                $dom->{'image3'} = $newdirpath;
2423
            } elsif ($dom->{'image4'} eq $olddirpath) {
2424
                $dom->{'image4'} = $newdirpath;
2425
            }
2426
            $dom->{'mac'} = $mac if ($newstoragepool == -1);
2427
            if ($dom->{'system'} && $dom->{'system'} ne '--') {
2428
                unless (tie(%sysreg,'Tie::DBI', Hash::Merge::merge({table=>'systems'}, $Stabile::dbopts)) ) {$res .= qq|{"status": "Error": "message": "Unable to access systems register"}|; return $res;};
2429
                my $sys = $sysreg{$dom->{'system'}};
2430
                $sys->{'image'} = $newdirpath if ($sys->{'image'} eq $olddirpath);
2431
                untie %sysreg;
2432
            }
2433
        }
2434
        my $cmd = qq|/usr/local/bin/steamExec $user $uistatus $status "$oldpath" "$newpath"|;
2435
        `$cmd`;
2436
        $main::syslogit->($user, "info", "$uistatus $type image $name ($oldpath -> $newpath) ($regstoragepool -> $istoragepool) ($register{$newdirpath}->{uuid})");
2437
        return "$newdirpath\n";
2438
    } else {
2439
        return $postreply;
2440
    }
2441

    
2442
}
2443

    
2444
sub locateNode {
2445
    my ($virtualsize, $mac, $vcpu, $mem) = @_;
2446
    $vcpu = $vcpu || 1;
2447
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac'}, $Stabile::dbopts)) ) {return 0};
2448
    my $macip;
2449
    my $dmac;
2450
    my $dindex;
2451
    my $asleep;
2452
    my $identity;
2453
    my $node;
2454
    if ($mac && $mac ne "--") { # A node was specified
2455
        if (1024 * $nodestorageovercommission * $nodereg{$mac}->{'storfree'} > $virtualsize && $nodereg{$mac}->{'status'} eq 'running') {
2456
            $node = $nodereg{$mac};
2457
        }
2458
    } else { # Locate a node
2459
        require "$Stabile::basedir/cgi/servers.cgi";
2460
        $Stabile::Servers::console = 1;
2461
        my ($temp1, $temp2, $temp3, $temp4, $ahashref) = Stabile::Servers::locateTargetNode();
2462
        my @avalues = values %$ahashref;
2463
        my @sorted_values = (sort {$b->{'index'} <=> $a->{'index'}} @avalues);
2464
        foreach my $snode (@sorted_values) {
2465
            if (
2466
                (1024 * $nodestorageovercommission * $snode->{'storfree'} > $virtualsize)
2467
                && ($snode->{'cpuindex'} > $vcpu)
2468
                && ($snode->{'memfree'} > $mem+512*1024)
2469
                && !($snode->{'maintenance'})
2470
                && ($snode->{'status'} eq 'running' || $snode->{'status'} eq 'asleep' || $snode->{'status'} eq 'waking')
2471
                && ($snode->{'index'} > 0)
2472
            ) {
2473
                next if (!($mem) && $snode->{'identity'} eq 'local_kvm'); # Ugly hack - prevent moving images from default storage to local_kvm node
2474
                $node = $snode;
2475
                last;
2476
            }
2477
        }
2478
    }
2479
    $macip = $node->{'ip'};
2480
    $dmac = $node->{'mac'};
2481
    $dindex = $node->{'index'};
2482
    $asleep = ($node->{'status'} eq 'asleep' || $node->{'status'} eq 'waking');
2483
    $identity = $node->{'identity'};
2484
    untie %nodereg;
2485
    return ($dmac, $macip, $dindex, $asleep, $identity);
2486
}
2487

    
2488
sub do_getimagestatus {
2489
    my ($image, $action) = @_;
2490
    if ($help) {
2491
        return <<END
2492
GET:image:
2493
Check if image already exists. Pass image name including suffix.
2494
END
2495
    }
2496
    my $res;
2497
    $imagename = $params{'name'} || $image;
2498
    foreach my $spool (@spools) {
2499
        my $ipath = $spool->{'path'} . "/$user/$imagename";
2500
        if ($register{$ipath}) {
2501
            $res .= "Status=OK Image $ipath found with status $register{$ipath}->{'status'}\n";
2502
        } elsif (-f "$ipath" && -s "$ipath") {
2503
            $res .= "Status=OK Image $ipath found on disk, please wait for it to be updated in DB\n";
2504
        }
2505
    }
2506
    $res .= "Status=ERROR Image $image not found\n" unless ($res);
2507
    return $res;;
2508
}
2509

    
2510
# Check if image already exists.
2511
# Pass image name including suffix.
2512
sub imageExists {
2513
    my $imagename = shift;
2514
    foreach my $spool (@spools) {
2515
        my $ipath = $spool->{'path'} . "/$user/$imagename";
2516
        if ($register{$ipath}) {
2517
            return $register{$ipath}->{'status'} || 1;
2518
        } elsif (-e "$ipath") {
2519
            return 1
2520
        }
2521
    }
2522
    return '';
2523
}
2524

    
2525
# Pass image name including suffix.
2526
# Returns incremented name of an image which does not already exist.
2527
sub getValidName {
2528
    my $imagename = shift;
2529
    my $name = $imagename;
2530
    my $type;
2531
    if ($imagename =~ /(.+)\.(.+)/) {
2532
        $name = $1;
2533
        $type = $2;
2534
    }
2535
    if (imageExists($imagename)) {
2536
        my $i = 1;
2537
        while (imageExists("$name.$i.$type")) {$i++;};
2538
        $imagename = "$name.$i.$type";
2539
    }
2540
    return $imagename;
2541
}
2542

    
2543
# Print list of available actions on objects
2544
sub do_plainhelp {
2545
    my $res;
2546
    $res .= header('text/plain') unless $console;
2547
    $res .= <<END
2548
* new [size="size", name="name"]: Creates a new image
2549
* clone: Creates new clone of an image. A clone of a master image is a child of the master. A clone of a child or regular
2550
image is a regular copy.
2551
* convert: Creates a copy of a non-qcow2 image in qcow2 format
2552
* snapshot: Takes a qcow2 snapshot of the image. Server can not be running.
2553
* unsnap: Removes a qcow2 snapshot.
2554
* revert: Applies a snapshot, reverting the image to the state it was in, when the snapshot was taken.
2555
* master: Turns an image into a master image which child images may be cloned from. Image can not be in use.
2556
* unmaster: Turns a master image into a regular image, which can not be used to clone child images from.
2557
* backup: Backs up an image using rdiff-backup. Rdiff-backup must be enabled in admin server configuration. This is a
2558
very expensive operation, since typically the entire image must be read.
2559
* buildsystem [master="master image"]: Constructs one or optionally multiple servers, images and networks and assembles
2560
them in one app.
2561
* restore [backup="backup"]: Restores an image from a backup. The restore is named after the backup.
2562
* delete: Deletes an image. Use with care. Image can not be in use.
2563
* mount: Mounts an image for restorefiles and listfiles operations.
2564
* unmount: Unmounts an image
2565
END
2566
    ;
2567
    return $res;
2568
}
2569

    
2570
# Print list of images
2571
# Showing a single image is also handled by specifying uuid or path in $curuuid or $curimg
2572
# When showing a single image a single action may be performed on image
2573
sub do_list {
2574
    my ($img, $action, $obj) = @_;
2575
    if ($help) {
2576
        return <<END
2577
GET:image,uuid:
2578
Lists all the images a user has access to. This is also the default action for the endpoint, so if no action is specified this is what you get.
2579
The returned list may be filtered by specifying storagepool, type, name, path or uuid, like e.g.:
2580

    
2581
<a href="/stabile/images/type:user" target="_blank">/stabile/images/type:user</a>
2582
<a href="/stabile/images/name:test* AND storagepool:shared" target="_blank">/stabile/images/name:test* AND storagepool:shared</a>
2583
<a href="/stabile/images/storagepool:shared AND path:test*" target="_blank">/stabile/images/storagepool:shared AND path:test*</a>
2584
<a href="/stabile/images/name:* AND storagepool:all AND type:usercdroms" target="_blank">/stabile/images/name:* AND storagepool:all AND type:usercdroms</a>
2585
<a href="/stabile/images/[uuid]" target="_blank">/stabile/images/[uuid]</a>
2586

    
2587
storagepool may be either of: all, node, shared
2588
type may be either of: user, usermasters, commonmasters, usercdroms
2589

    
2590
May also be called as tablelist or tablelistall, for use by stash.
2591

    
2592
END
2593
    }
2594
    my $res;
2595
    my $filter;
2596
    my $storagepoolfilter;
2597
    my $typefilter;
2598
    my $pathfilter;
2599
    my $uuidfilter;
2600
    $curimg = $img if ($img);
2601
    my $regimg = $register{$curimg};
2602
#    if ($curimg && ($isadmin || $regimg->{'user'} eq $user || $regimg->{'user'} eq 'common') ) {
2603
    if ($curimg) { # security is enforced below, we hope...
2604
        $pathfilter = $curimg;
2605
    } elsif ($uripath =~ /images(\.cgi)?\/(\?|)(name|storagepool|type|path)/) {
2606
        $filter = $3 if ($uripath =~ /images(\.cgi)?\/.*name(:|=)(.+)/);
2607
        $filter = $1 if ($filter =~ /(.*) AND storagepool/);
2608
        $filter = $1 if ($filter =~ /(.*) AND type/);
2609
        $filter = $1 if ($filter =~ /(.*)\*$/);
2610
        $storagepoolfilter = $2 if ($uripath =~ /images(\.cgi)?\/.*storagepool:(\w+)/);
2611
        $typefilter = $2 if ($uripath =~ /images(\.cgi)?\/.*type:(\w+)/);
2612
        $typefilter = $2 if ($uripath =~ /images(\.cgi)?\/.*type=(\w+)/);
2613
        $pathfilter = $2 if ($uripath =~ /images(\.cgi)?\/.*path:(.+)/);
2614
        $pathfilter = $2 if ($uripath =~ /images(\.cgi)?\/.*path=(.+)/);
2615
    } elsif ($uripath =~ /images(\.cgi)?\/(\w{8}-\w{4}-\w{4}-\w{4}-\w{12})\/?(\w*)/) {
2616
        $uuidfilter = $2;
2617
        $curaction = lc $3;
2618
    }
2619
    $uuidfilter = $options{u} unless $uuidfilter;
2620

    
2621
    if ($uuidfilter && $curaction) {
2622
        if ($imagereg{$uuidfilter}) {
2623
            $curuuid = $uuidfilter;
2624
            my $obj = getObj(%params);
2625
            # Now perform the requested action
2626
            my $objfunc = "obj_$curaction";
2627
            if (defined &$objfunc) { # If a function named objfunc exists, call it
2628
                $res = $objfunc->($obj);
2629
                chomp $postreply;
2630
                unless ($res) {
2631
                    $res .= qq|{"status": "OK", "message": "$postreply"}|;
2632
                    $res = join(", ", split("\n", $res));
2633
                }
2634
                unless ($curaction eq 'download') {
2635
                    $res = header('application/json; charset=UTF8') . $res unless ($console);
2636
                }
2637
            } else {
2638
                $res .= header('application/json') unless $console;
2639
                $res .= qq|{"status": "Error", "message": "Unknown image action: $curaction"}|;
2640
            }
2641
        } else {
2642
            $res .= header('application/json') unless $console;
2643
            $res .= qq|{"status": "Error", "message": "Unknown image $uuidfilter"}|;
2644
        }
2645
        return $res;
2646
    }
2647

    
2648

    
2649
    my %userregister; # User specific register
2650

    
2651
    $res .= header('application/json; charset=UTF8') unless $console;
2652
    unless (tie(%userreg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {$res .= qq|{"status": "Error": "message": "Unable to access user register"}|; return $res;};
2653

    
2654
    my @busers = @users;
2655
    my @billusers = (tied %userreg)->select_where("billto = '$user'");
2656
    push (@busers, $billto) if ($billto && $billto ne '--'); # We include images from 'parent' user
2657
    push (@busers, @billusers) if (@billusers); # We include images from 'child' users
2658
    untie %userreg;
2659
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2660
    foreach my $u (@busers) {
2661
        my @regkeys = (tied %register)->select_where("user = '$u'");
2662
        foreach my $k (@regkeys) {
2663
            my $valref = $register{$k};
2664
            # Only update info for images the user has access to.
2665
            if ($valref->{'user'} eq $u && (defined $spools[$valref->{'storagepool'}]->{'id'} || $valref->{'storagepool'}==-1)) {
2666
                # Only list installable master images from billto account
2667
                next if ($billto && $u eq $billto && ($valref->{'type'} ne 'qcow2' || $valref->{'installable'} ne 'true'));
2668
                my $path = $valref->{'path'};
2669
                my %val = %{$valref}; # Deference and assign to new array, effectively cloning object
2670
                my $spool = $spools[$val{'storagepool'}];
2671
                # Skip images which are in DB e.g. because of change of storage pool difinitions
2672
                next unless ($val{'storagepool'}==-1 || $val{'path'} =~ /$spool->{'path'}/);
2673
                $val{'virtualsize'} += 0;
2674
                $val{'realsize'} += 0;
2675
                $val{'size'} += 0;
2676
                #$val{'lvm'} = 0+( (($spools[$val{'storagepool'}]->{"hostpath"} eq "local") && $spools[$val{'storagepool'}]->{"rdiffenabled"}) || $val{'storagepool'}==-1);
2677
                if ($val{'storagepool'}==-1) {
2678
                    my $node = $nodereg{$val{'mac'}};
2679
                    $val{'lvm'} = 0+($node->{stor} eq 'lvm');
2680
                } else {
2681
                    $val{'lvm'} = 0+$spool->{"lvm"};
2682
                }
2683
                # If image has a master, update the master with child info.
2684
                # This info is specific to each user, so we don't store it in the db
2685
                if ($valref->{'master'} && $register{$valref->{'master'}} && ((grep $_ eq $valref->{'user'}, @users))) {
2686
                    $register{$valref->{'master'}}->{'status'} = 'used';
2687
                    unless ($userregister{$val{'master'}}) { # If we have not yet parsed master, it is not yet in userregister, so put it there
2688
                        my %mval = %{$register{$val{'master'}}};
2689
                        $userregister{$val{'master'}} = \%mval;
2690
                    }
2691
                    #   $userregister{$val{'master'}}->{'user'} = $u;
2692
                    $userregister{$val{'master'}}->{'status'} = 'used';
2693
                    if ($val{'domains'}) {
2694
                        $userregister{$val{'master'}}->{'domainnames'} .= ", " if ($userregister{$val{'master'}}->{'domainnames'});
2695
                        $userregister{$val{'master'}}->{'domainnames'} .= $val{'domainnames'};
2696
                        $userregister{$val{'master'}}->{'domainnames'} .= " (".$val{'user'}.")" if (index($privileges,"a")!=-1);
2697

    
2698
                        $userregister{$val{'master'}}->{'domains'} .= ", " if ($userregister{$val{'master'}}->{'domains'});
2699
                        $userregister{$val{'master'}}->{'domains'} .= $val{'domains'};
2700
                    }
2701
                }
2702
                my $status = $valref->{'status'};
2703
                if ($rdiffenabled && ($userrdiffenabled || index($privileges,"a")!=-1) &&
2704
                    ( ($spools[$valref->{'storagepool'}]->{'rdiffenabled'} &&
2705
                        ($spools[$valref->{'storagepool'}]->{'lvm'} || $status eq 'unused' || $status eq 'used' || $status eq 'paused') )
2706
                        || $valref->{'storagepool'}==-1 )
2707
                ) {
2708
                    $val{'backup'} = "" ;
2709
                } else {
2710
                    $val{'backup'} = "disabled" ;
2711
                }
2712
                $val{'status'} = 'backingup' if ($status =~ /backingup/);
2713
                $userregister{$path} = \%val unless ($userregister{$path});
2714
            }
2715
        }
2716
    }
2717
    untie(%nodereg);
2718

    
2719
    my @uservalues;
2720
    if ($filter || $storagepoolfilter || $typefilter || $pathfilter || $uuidfilter) { # List filtered images
2721
        foreach $uvalref (values %userregister) {
2722
            my $fmatch;
2723
            my $smatch;
2724
            my $tmatch;
2725
            my $pmatch;
2726
            my $umatch;
2727
            $fmatch = 1 if (!$filter || $uvalref->{'name'}=~/$filter/i);
2728
            $smatch = 1 if (!$storagepoolfilter || $storagepoolfilter eq 'all'
2729
                || ($storagepoolfilter eq 'node' && $uvalref->{'storagepool'}==-1)
2730
                || ($storagepoolfilter eq 'shared' && $uvalref->{'storagepool'}>=0)
2731
            );
2732
            $tmatch = 1 if (!$typefilter || $typefilter eq 'all'
2733
                || ($typefilter eq 'user' && $uvalref->{'user'} eq $user
2734
                # && $uvalref->{'type'} ne 'iso'
2735
                # && $uvalref->{'path'} !~ /\.master\.qcow2$/
2736
                    )
2737
                || ($typefilter eq 'usermasters' && $uvalref->{'user'} eq $user && $uvalref->{'path'} =~ /\.master\.qcow2$/)
2738
                || ($typefilter eq 'usercdroms' && $uvalref->{'user'} eq $user && $uvalref->{'type'} eq 'iso')
2739
                || ($typefilter eq 'commonmasters' && $uvalref->{'user'} ne $user && $uvalref->{'path'} =~ /\.master\.qcow2$/)
2740
                || ($typefilter eq 'commoncdroms' && $uvalref->{'user'} ne $user && $uvalref->{'type'} eq 'iso')
2741
            );
2742
            $pmatch = 1 if ($pathfilter && $uvalref->{'path'}=~/$pathfilter/i);
2743
            $umatch = 1 if ($uvalref->{'uuid'} eq $uuidfilter);
2744
            if ((!$pathfilter &&!$uuidfilter && $fmatch && $smatch && $tmatch) || $pmatch) {
2745
                push @uservalues,$uvalref if ($uvalref->{'uuid'});
2746
            } elsif ($umatch && $uvalref->{'uuid'}) {
2747
                push @uservalues,$uvalref;
2748
                last;
2749
            }
2750
        }
2751
    } else {
2752
        @uservalues = values %userregister;
2753
    }
2754

    
2755
    # Sort @uservalues
2756
    @uservalues = (sort {$a->{'name'} cmp $b->{'name'}} @uservalues); # Always sort by name first
2757
    my $sort = 'status';
2758
    $sort = $2 if ($uripath =~ /sort\((\+|\-)(\S+)\)/);
2759
    my $reverse;
2760
    $reverse = 1 if ($1 eq '-');
2761
    if ($reverse) { # sort reverse
2762
        if ($sort =~ /realsize|virtualsize|size/) {
2763
            @uservalues = (sort {$b->{$sort} <=> $a->{$sort}} @uservalues); # Sort as number
2764
        } else {
2765
            @uservalues = (sort {$b->{$sort} cmp $a->{$sort}} @uservalues); # Sort as string
2766
        }
2767
    } else {
2768
        if ($sort =~ /realsize|virtualsize|size/) {
2769
            @uservalues = (sort {$a->{$sort} <=> $b->{$sort}} @uservalues); # Sort as number
2770
        } else {
2771
            @uservalues = (sort {$a->{$sort} cmp $b->{$sort}} @uservalues); # Sort as string
2772
        }
2773
    }
2774

    
2775
    if ($uuidfilter || $curimg) {
2776
        if (scalar @uservalues > 1) { # prioritize user's own images
2777
            foreach my $val (@uservalues) {
2778
                if ($val->{'user'} eq 'common') {
2779
                    next;
2780
                } else {
2781
                    $json_text = to_json($val, {pretty => 1});
2782
                }
2783
            }
2784
        } else {
2785
            $json_text = to_json($uservalues[0], {pretty => 1}) if (@uservalues);
2786
        }
2787
    } else {
2788
    #    $json_text = JSON->new->canonical(1)->pretty(1)->encode(\@uservalues) if (@uservalues);
2789
        $json_text = to_json(\@uservalues, {pretty => 1}) if (@uservalues);
2790
    }
2791
    $json_text = "{}" unless $json_text;
2792
    $json_text =~ s/""/"--"/g;
2793
    $json_text =~ s/null/"--"/g;
2794
    $json_text =~ s/"notes" {0,1}: {0,1}"--"/"notes":""/g;
2795
    $json_text =~ s/"installable" {0,1}: {0,1}"(true|false)"/"installable":$1/g;
2796

    
2797
    if ($action eq 'tablelist' || $action eq 'tablelistall') {
2798
        my $t2 = Text::SimpleTable->new(36,26,5,20,14,10,7);
2799
        $t2->row('uuid', 'name', 'type', 'domainnames', 'virtualsize', 'user', 'status');
2800
        $t2->hr;
2801
        my $pattern = $options{m};
2802
        foreach $rowref (@uservalues){
2803
            next unless ($action eq 'tablelistall' || $rowref->{'user'} eq $user);
2804
            if ($pattern) {
2805
                my $rowtext = $rowref->{'uuid'} . " " . $rowref->{'name'} . " " . $rowref->{'type'} . " " . $rowref->{'domainnames'}
2806
                    . " " .  $rowref->{'virtualsize'} . " " . $rowref->{'user'} . " " . $rowref->{'status'};
2807
                $rowtext .= " " . $rowref->{'mac'} if ($isadmin);
2808
                next unless ($rowtext =~ /$pattern/i);
2809
            }
2810
            $t2->row($rowref->{'uuid'}, $rowref->{'name'}, $rowref->{'type'}, $rowref->{'domainnames'}||'--',
2811
                $rowref->{'virtualsize'}, $rowref->{'user'}, $rowref->{'status'});
2812
        }
2813
        $res .= $t2->draw;
2814
    } elsif ($console) {
2815
        $res .= Dumper(\@uservalues);
2816
    } else {
2817
        $res .= $json_text;
2818
    }
2819
    return $res;
2820
}
2821

    
2822
# Internal action for looking up a uuid or part of a uuid and returning the complete uuid
2823
sub do_uuidlookup {
2824
    my ($img, $action) = @_;
2825
    if ($help) {
2826
        return <<END
2827
GET:image,path:
2828
END
2829
    }
2830
    my $res;
2831
    $res .= header('text/plain') unless $console;
2832
    my $u = $options{u};
2833
    $u = $curuuid unless ($u || $u eq '0');
2834
    my $ruuid;
2835
    if ($u || $u eq '0') {
2836
        foreach my $uuid (keys %register) {
2837
            if (($register{$uuid}->{'user'} eq $user || $register{$uuid}->{'user'} eq 'common' || $fulllist)
2838
                && ($register{$uuid}->{'uuid'} =~ /^$u/ || $register{$uuid}->{'name'} =~ /^$u/)) {
2839
                $ruuid = $register{$uuid}->{'uuid'};
2840
                last;
2841
            }
2842
        }
2843
        if (!$ruuid && $isadmin) { # If no match and user is admin, do comprehensive lookup
2844
            foreach $uuid (keys %register) {
2845
                if ($register{$uuid}->{'uuid'} =~ /^$u/ || $register{$uuid}->{'name'} =~ /^$u/) {
2846
                    $ruuid = $register{$uuid}->{'uuid'};
2847
                    last;
2848
                }
2849
            }
2850
        }
2851
    }
2852
    $res .= "$ruuid\n" if ($ruuid);
2853
    return $res;
2854
}
2855

    
2856
# Internal action for showing a single image
2857
sub do_uuidshow {
2858
    my ($img, $action) = @_;
2859
    if ($help) {
2860
        return <<END
2861
GET:image,path:
2862
END
2863
    }
2864
    my $res;
2865
    $res .= header('text/plain') unless $console;
2866
    my $u = $options{u};
2867
    $u = $curuuid unless ($u || $u eq '0');
2868
    if ($u || $u eq '0') {
2869
        foreach my $uuid (keys %register) {
2870
            if (($register{$uuid}->{'user'} eq $user || $register{$uuid}->{'user'} eq 'common' || index($privileges,"a")!=-1)
2871
                && $register{$uuid}->{'uuid'} =~ /^$u/) {
2872
                my %hash = %{$register{$uuid}};
2873
                delete $hash{'action'};
2874
                my $dump = Dumper(\%hash);
2875
                $dump =~ s/undef/"--"/g;
2876
                $res .= $dump;
2877
                last;
2878
            }
2879
        }
2880
    }
2881
    return $res;
2882
}
2883

    
2884
sub do_updatebilling {
2885
    my ($img, $action) = @_;
2886
    if ($help) {
2887
        return <<END
2888
GET:image,path:
2889
END
2890
    }
2891
    my $res;
2892
    $res .= header('text/plain') unless ($console);
2893
    updateBilling($params{"event"});
2894
    $res .= "Status=OK Updated billing for $user\n";
2895
    return $res;
2896
}
2897

    
2898
# If used with the -f switch ($fulllist) from console, all users images are updated in the db
2899
# If used with the -p switch ($fullupdate), also updates status information (ressource intensive - runs through all domains)
2900
sub dont_updateregister {
2901
    my ($img, $action) = @_;
2902
    my $res;
2903
    if ($help) {
2904
        return <<END
2905
GET:image,path:
2906
END
2907
    }
2908
    return "Status=ERROR You must be an admin to do this!\n" unless ($isadmin);
2909
    $fullupdate = 1 if ((!$fullupdate && $params{'fullupdate'}) || $action eq 'fullupdateregister');
2910
    my $force = $params{'force'};
2911
    Updateregister($force);
2912
    $res .= "Status=OK Updated image register for " . join(', ', @users) . "\n";
2913
}
2914

    
2915
sub do_urlupload {
2916
    my ($img, $action) = @_;
2917
    if ($help) {
2918
        return <<END
2919
GET:image,path:
2920
END
2921
    }
2922
    my $res;
2923
    $res .= header('application/json') unless ($console);
2924
    if ($params{'probe'} && $params{'url'}) {
2925
        my $url = $params{'url'};
2926
        my $cmd = qq!curl --http1.1 -kIL "$url" 2>&1!;
2927
        my $headers = `$cmd`;
2928
        my $filename;
2929
        my $filesize = 0;
2930
        $filename = $1 if ($headers =~ /content-disposition: .+filename="(.+)"/i);
2931
        $filesize = $1 if ($headers =~ /content-length: (\d+)/i);
2932
        my $ok;
2933
        if (!$filename) {
2934
            my $cmd = qq[curl --http1.1 -kIL "$url" 2>&1 | grep -i " 200 OK"];
2935
            $ok =  `$cmd`; chomp $ok;
2936
            $filename = `basename "$url"` if ($ok);
2937
            chomp $filename;
2938
        }
2939
        if ($filename =~ /\S+\.(vmdk|img|vhd|qcow|qcow2|vdi|iso)$/) {
2940
            $filename = $2 if ($filename =~ /(=|\?)(.+)/);
2941
            $filename = $2 if ($filename =~ /(=|\?)(.+)/);
2942
            $filename = getValidName($filename);
2943
            my $filepath = $spools[0]->{'path'} . "/$user/$filename";
2944
            $res .= qq|{"status": "OK", "name": "$filename", "message": "200 OK", "size": $filesize, "path": "$filepath"}|;
2945
        } else {
2946
            $res .= qq|{"status": "ERROR", "message": "An image file cannot be downloaded from this URL.", "url": "$url", "filename": "$filename"}|;
2947
        }
2948
    } elsif ($params{'path'} && $params{'url'} && $params{'name'} && defined $params{'size'}) {
2949
        my $imagepath = $params{'path'};
2950
        my $imagename = $params{'name'};
2951
        my $imagesize = $params{'size'};
2952
        my $imageurl = $params{'url'};
2953
        if (-e "$imagepath.meta" && $imagepath =~ /\.master\.qcow2$/) { # This image is being downloaded by pressurecontrol
2954
            $res .= qq|{"status": "OK", "name": "$imagename", "message": "Now downloading master", "path": "$imagepath"}|;
2955
        } elsif (-e $imagepath) {
2956
            $res .= qq|{"status": "ERROR", "message": "An image file with this name already exists on the server.", "name": "$imagename"}|;
2957
        } elsif ($imagepath !~ /^$spools[0]->{'path'}\/$user\/.+/) {
2958
            $res .= qq|{"status": "ERROR", "message": "Invalid path"}|;
2959
        } elsif (overQuotas($virtualsize)) {
2960
            $res .= qq|{"status": "ERROR", "message": "Over quota (". overQuotas($virtualsize) . ") uploading: $imagename"}|;
2961
        } elsif (overStorage($imagesize, 0)) {
2962
            $res .= qq|{"status": "ERROR", "message": "Out of storage in destination pool uploading: $imagename"}|;
2963
        } elsif ($imagepath =~ /^$spools[0]->{'path'}.+\.(vmdk|img|vhd|qcow|qcow2|vdi|iso)$/) {
2964
            my $imagetype = $1;
2965
            my $ug = new Data::UUID;
2966
            my $newuuid = $ug->create_str();
2967
            my $name = $imagename;
2968
            $name = $1 if ($name =~ /(.+)\.(vmdk|img|vhd|qcow|qcow2|vdi|iso)$/);
2969
            $register{$imagepath} = {
2970
                uuid => $newuuid,
2971
                path => $imagepath,
2972
                name => $name,
2973
                user => $user,
2974
                type => $imagetype,
2975
                virtualsize => $imagesize,
2976
                realsize => $imagesize,
2977
                size => $imagesize,
2978
                storagepool => 0,
2979
                status => 'uploading'
2980
            };
2981
            `/bin/echo uploading > "$imagepath.meta"`;
2982
            eval {
2983
                my $daemon = Proc::Daemon->new(
2984
                    work_dir => '/usr/local/bin',
2985
                    exec_command => "perl -U steamExec $user urluploading unused \"$imagepath\" \"$imageurl\""
2986
                ) or do {$postreply .= "Status=ERROR $@\n";};
2987
                my $pid = $daemon->Init();
2988
                $main::syslogit->($user, "info", "urlupload $imageurl, $imagepath");
2989
                1;
2990
            } or do {$res .= qq|{"status": "ERROR", "message": "ERROR $@"}|;};
2991
            $res .= qq|{"status": "OK", "name": "$imagename", "message": "Now uploading", "path": "$imagepath"}|;
2992
        }
2993
    } elsif ($params{'path'} && $params{'getsize'}) {
2994
        my $imagepath = $params{'path'};
2995
        if (!(-e $imagepath)) {
2996
            $res .= qq|{"status": "ERROR", "message": "Image not found.", "path": "$imagepath"}|;
2997
        } elsif ($imagepath !~ /^$spools[0]->{'path'}\/$user\/.+/  && $imagepath !~ /^$spools[0]->{'path'}\/common\/.+/) {
2998
            $res .= qq|{"status": "ERROR", "message": "Invalid path"}|;
2999
        } else {
3000
            my @stat = stat($imagepath);
3001
            my $imagesize = $stat[7];
3002
            $res .= qq|{"status": "OK", "size": $imagesize, "path": "$imagepath"}|;
3003
        }
3004
    }
3005
    return $res;
3006
}
3007

    
3008
sub do_upload {
3009
    my ($img, $action) = @_;
3010
    if ($help) {
3011
        return <<END
3012
POST:image,path:
3013
END
3014
    }
3015
    my $res;
3016
    $res .= header("text/html") unless ($console);
3017

    
3018
    my $uname = $params{'name'};
3019

    
3020
    my($name, $dirpath, $suffix) = fileparse($uname, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
3021

    
3022
    $name = $1 if ($name =~ /^\.+(.*)/); # Don't allow hidden files
3023
    #        my $f = lc $name;
3024
    my $f = $name;
3025
    $f = $spools[0]->{'path'} . "/$user/$f$suffix";
3026

    
3027
    my $chunk = int($params{'chunk'});
3028
    my $chunks = int($params{'chunks'});
3029

    
3030
    if ($chunk == 0 && -e $f) {
3031
        $res .= qq|Error: File $f already exists $name|;
3032
    } else {
3033
        open (FILE, ">>$f");
3034

    
3035
        if ($params{'file'}) {
3036
            my $uh = $Stabile::q->upload("file");
3037
            while ( <$uh> ) {
3038
                print FILE;
3039
            }
3040
            close FILE;
3041

    
3042
            if ($chunk == 0) {
3043
                `/usr/local/bin/steamExec updateimagestatus "$f" uploading`;
3044
            }
3045
            if ($chunk >= ($chunks - 1) ) { # Done
3046
                unlink("$f.meta");
3047
                `/usr/local/bin/steamExec updateimagestatus "$f" unused`;
3048
            } else {
3049
                my $upload_meta_data = "status=uploading&chunk=$chunk&chunks=$chunks";
3050
                `echo "$upload_meta_data" > "$f.meta"`;
3051
            }
3052
            $res .= qq|OK: Chunk $chunk uploaded of $name|;
3053
        } else {
3054
            $res .= qq|OK: No file $name.|;
3055
        }
3056
    }
3057
    return $res;
3058
}
3059

    
3060
# .htaccess files are created hourly, giving the image user access
3061
# when download is clicked by another user (in @users, so with permission), this user is also given access until .htaccess is rewritten
3062
sub Download {
3063
    my ($f, $action, $argref) = @_;
3064
    #    my ($name, $managementlink, $upgradelink, $terminallink, $version) = @{$argref};
3065
    if ($help) {
3066
        return <<END
3067
GET:image,console:
3068
Returns http redirection with URL to download image
3069
END
3070
    }
3071
    $baseurl = $argref->{baseurl} || $baseurl;
3072
    my %uargs = %{$argref};
3073
    $f = $uargs{'image'} unless ($f);
3074
    $baseurl = $uargs{'baseurl'} || $baseurl;
3075
    $console = $console || $uargs{'console'};
3076
    my $res;
3077
    my $uf =  URI::Escape::uri_unescape($f);
3078
    if (! $f) {
3079
        $res .= header('text/html', '500 Internal Server Error') unless ($console);
3080
        $res .= "Status=ERROR You must specify an image.\n";
3081
    }
3082
    my $txt = <<EOT
3083
order deny,allow
3084
AuthName "Download"
3085
AuthType None
3086
TKTAuthLoginURL $baseurl/login/
3087
TKTAuthIgnoreIP on
3088
deny from all
3089
Satisfy any
3090
require user $user
3091
require user $tktuser
3092
Options -Indexes
3093
EOT
3094
    ;
3095
    my $fid;
3096
    my $fpath;
3097
    foreach my $p (@spools) {
3098
        foreach my $suser (@users) {
3099
            my $dir = $p->{'path'};
3100
            my $id = $p->{'id'};
3101
            if (-d "$dir/$suser" && $uf =~ /\/$suser\//) {
3102
                if ($uf =~ /$dir\/(.+)\/(.+)/) {
3103
                    my $filename = $2;
3104
                    utf8::encode($filename);
3105
                    utf8::decode($filename);
3106
                    $fpath = "$1/" . URI::Escape::uri_escape($filename);
3107
                    #$fpath = "$1/" . $filename;
3108
                    `chmod o+rw "$uf"`;
3109
                    `/bin/echo "$txt" > "$dir/$suser/.htaccess"`;
3110
                    `chmod 644 "$dir/$suser/.htaccess"`;
3111
                    `/bin/mkdir "$Stabile::basedir/download"` unless (-e "$Stabile::basedir/download");
3112
                    `/bin/ln -s "$dir" "$Stabile::basedir/download/$id"` unless (-e "$Stabile::basedir/download/$id");
3113
                    $fid = $id;
3114
                    last;
3115
                }
3116
            }
3117
        }
3118
    }
3119
    if (($fid || $fid eq '0') && $fpath && -e "$f") {
3120
        my $fileurl = "$baseurl/download/$fid/$fpath";
3121
        if ($console) {
3122
            $res .= header(). $fileurl;
3123
        } else {
3124
            $res .= "Status: 302 Moved\nLocation: $fileurl\n\n";
3125
            $res .= "$fileurl\n";
3126
        }
3127
    } else {
3128
        $res .= header('text/html', '500 Internal Server Error') unless ($console);
3129
        $res .= "Status=ERROR File not found $f, $fid, $fpath, $uargs{image}\n";
3130
    }
3131
    return $res;
3132
}
3133

    
3134

    
3135
sub Liststoragedevices {
3136
    my ($image, $action, $obj) = @_;
3137
    if ($help) {
3138
        return <<END
3139
GET::
3140
Returns available physical disks and partitions.
3141
Partitions currently used for holding backup and primary images directories are marked as such.
3142
May also be called as 'getimagesdevice', 'getbackupdevice', 'listimagesdevices' or 'listbackupdevices'.
3143
END
3144
    }
3145
    unless ($isadmin || ($user eq $engineuser)) {
3146
        return '' if ($action eq 'getimagesdevice' || $action eq 'getbackupdevice');
3147
        return qq|[]|;
3148
    }
3149
    my %devs;
3150
    # Check if we have unmounted ZFS file systems
3151
#    if (`grep "stabile-images" /etc/stabile/config.cfg` && !(`df` =~ /stabile-images/)) {
3152
    if (!(`df` =~ /stabile-images/)) {
3153
        `zpool import stabile-images`;
3154
        `zfs mount stabile-images`;
3155
        `zfs mount stabile-images/images`;
3156
    }
3157
    if (!(`df` =~ /stabile-backup/)) {
3158
        `zpool import stabile-backup`;
3159
        `zfs mount stabile-backup`;
3160
        `zfs mount stabile-backup/images`;
3161
        `zfs mount stabile-backup/backup`;
3162
    }
3163
    # Add active and mounted filesystems
3164
    my %filesystems;
3165
    $cmd = q/LANG=en df -hT | tr -s ' ' ',' | jq -nR '[( input | split(",") ) as $keys | ( inputs | split(",") ) as $vals | [ [$keys, $vals] | transpose[] | {key:.[0],value:.[1]} ] | from_entries ]'/;
3166
    my $json = `$cmd`;
3167
    my $jobj = JSON::from_json($json);
3168
    my $rootdev;
3169
    my $backupdev;
3170
    my $imagesdev;
3171
    foreach my $fs (sort {$a->{'Filesystem'} cmp $b->{'Filesystem'}} @{$jobj}) {
3172
        # Note that physical disk devicess in general may be either disks, partitions with regular file systems (like ext4) or zfs pools, which may contain many file systems
3173
        if ($fs->{Filesystem} =~ /\/dev\/(.+)/) {
3174
            next if ($fs->{Type} eq 'squashfs');
3175
            next if ($fs->{Filesystem} =~ /\/dev\/loop/);
3176
            my $name = $1;
3177
            if ($name =~ /mapper\/(\w+-)(.+)/) {
3178
                $name = "$1$2";
3179
            }
3180
            $fs->{Name} = $name;
3181
            delete $fs->{on};
3182
            my $mp = $fs->{Mounted};
3183
            if ($fs->{Mounted} eq '/') {
3184
                $rootdev = $name;
3185
            } else {
3186
                if ($backupdir =~ /^$fs->{Mounted}/) {
3187
                    next if ($action eq 'listimagesdevices'); # Current backup dev is not available as images dev
3188
                    $fs->{isbackupdev} = 1;
3189
                    $backupdev = $name;
3190
                    return $name if ($action eq 'getbackupdevice');
3191
                }
3192
                if ($tenderpathslist[0] =~ /^$fs->{Mounted}/) {
3193
                    next if ($action eq 'listbackupdevices'); # Current images dev is not available as backup dev
3194
                    $fs->{isimagesdev} = 1;
3195
                    $imagesdev = $name;
3196
                    return $name if ($action eq 'getimagesdevice');
3197
                }
3198
            }
3199
            $fs->{dev} = $name;
3200
            $fs->{nametype} = "$name ($fs->{Type} - " .  ($mp?$mp:"not mounted") . " $fs->{Size})";
3201
            $filesystems{$name} = $fs;
3202
        } elsif ( $fs->{Type} eq 'zfs') {
3203
            my $name = $fs->{Filesystem};
3204
            # only include zfs pools but look for use as backup and images, exclude shapshots
3205
            if ($name =~ /(.+)\/(.+)/
3206
                && !($name =~ /SNAPSHOT/)
3207
                && !($name =~ /stabile-backup\/images/)
3208
                && !($name =~ /stabile-backup\/node/)
3209
            ) {
3210
                $name = $1;
3211
                if ($fs->{Mounted} eq $backupdir) {
3212
                    if ($action eq 'listimagesdevices') {
3213
                        delete $filesystems{$name}; # not available for images - used for backup
3214
                    } else {
3215
                        $filesystems{$name}->{isbackupdev} = 1;
3216
                        $fs->{isbackupdev} = 1;
3217
                        $backupdev = $name;
3218
                    }
3219
                    return $name if ($action eq 'getbackupdevice');
3220
                } elsif ($fs->{Mounted} eq $tenderpathslist[0]) {
3221
                    if ($action eq 'listbackupdevices') {
3222
                        delete $filesystems{$name}; # not available for backup - used for images
3223
                    } else {
3224
                        $filesystems{$name}->{isimagesdev} = 1;
3225
                        $fs->{isimagesdev} = 1;
3226
                        $imagesdev = $name;
3227
                    }
3228
                    return $name if ($action eq 'getimagesdevice');
3229
                }
3230
                $fs->{Name} = $name;
3231
                $fs->{nametype} = "$name ($fs->{Type} $fs->{Size})";
3232
                delete $fs->{on};
3233
                $filesystems{$name} = $fs;
3234
            }
3235
        }
3236
    }
3237
    if ($action eq 'getbackupdevice' || $action eq 'getimagesdevice') {
3238
        return $rootdev;
3239
    }
3240
    $filesystems{$rootdev}->{isbackupdev} = 1 unless ($backupdev || $action eq 'listimagesdevices');
3241
    $filesystems{$rootdev}->{isimagesdev} = 1 unless ($imagesdev || $action eq 'listbackupdevices');
3242
    # Lowercase keys
3243
    foreach my $k (keys %filesystems) {
3244
        my %hash = %{$filesystems{$k}};
3245
        %hash = map { lc $_ => $hash{$_} } keys %hash;
3246
        $filesystems{$k} = \%hash;
3247
    }
3248
    # Identify physical devices used for zfs
3249
    $cmd = "zpool list -vH";
3250
    my $zpools = `$cmd`;
3251
    my $zdev;
3252
    my %zdevs;
3253

    
3254
    # Now parse the rather strange output with every other line representing physical dev
3255
    foreach my $line (split "\n", $zpools) {
3256
        my ($zname, $zsize, $zalloc) = split "\t", $line;
3257
        if (!$zdev) {
3258
            if ($zname =~ /stabile-/) {
3259
                $zdev = {
3260
                    name=>$zname,
3261
                    size=>$zsize,
3262
                    alloc=>$zalloc
3263
                }
3264
            }
3265
        } else {
3266
            my $dev = $zsize;
3267
            $zdev->{dev} = $dev;
3268
            if ( $filesystems{$zdev->{name}}) {
3269
                if (
3270
                    ($action eq 'listimagesdevices' && $zdev->{name} =~ /backup/) ||
3271
                        ($action eq 'listbackupdevices' && $zdev->{name} =~ /images/)
3272
                ) {
3273
                    delete $filesystems{$zdev->{name}}; # Don't include backup devs in images listing and vice-versa
3274
                } else {
3275
                    if ($filesystems{$zdev->{name}}->{dev}) {
3276
                        $filesystems{$zdev->{name}}->{dev} .= " $dev";
3277
                    } else {
3278
                        $filesystems{$zdev->{name}}->{dev} = $dev;
3279
                    }
3280
        #            $filesystems{$zdev->{name}}->{nametype} =~ s/zfs/zfs pool/;
3281
                }
3282
            }
3283
            $zdevs{$dev} = $zdev->{name};
3284
        #    $zdev = '';
3285
        }
3286
    }
3287

    
3288
    # Add blockdevices
3289
    $cmd = q|lsblk --json|;
3290
    my $json2 = `$cmd`;
3291
    my $jobj2 = JSON::from_json($json2);
3292
    foreach my $fs (@{$jobj2->{blockdevices}}) {
3293
        my $rootdev = $1 if ($fs->{name} =~ /([A-Za-z]+)\d*/);
3294
        if ($fs->{children}) {
3295
            foreach my $fs2 (@{$fs->{children}}) {
3296
                next if ($fs2->{type} eq 'loop');
3297
                next if ($fs2->{type} eq 'squashfs');
3298
                next if ($fs2->{size} =~ /K$/);
3299
                if ($filesystems{$fs2->{name}}) {
3300
                    $filesystems{$fs2->{name}}->{blocksize} = $fs2->{size};
3301
                } elsif (!$zdevs{$fs2->{name}} && !$zdevs{$rootdev}) { # Don't add partitions already used for ZFS
3302
                    next if (($action eq 'listimagesdevices' || $action eq 'listbackupdevices') && $fs2->{mountpoint} eq '/');
3303
                    my $mp = $fs2->{mountpoint};
3304
                    $filesystems{$fs2->{name}} = {
3305
                        name=>$fs2->{name},
3306
                        blocksize=>$fs2->{size},
3307
                        mountpoint=>$mp,
3308
                        type=>$fs2->{type},
3309
                        nametype=> "$fs2->{name} ($fs2->{type} - " . ($mp?$mp:"not mounted") . " $fs2->{size})",
3310
                        dev=>$fs2->{name}
3311
                    }
3312
                }
3313
            }
3314
        } elsif (!$zdevs{$fs->{name}}) { # Don't add disks already used for ZFS
3315
            next if ($fs->{type} eq 'loop');
3316
            next if ($fs->{type} eq 'squashfs');
3317
            my $mp = $fs->{mountpoint};
3318
            next if ($fs->{type} eq 'rom');
3319
            $filesystems{$fs->{name}} = {
3320
                name=>$fs->{name},
3321
                blocksize=>$fs->{size},
3322
                mountpoint=>$fs->{mountpoint},
3323
                type=>$fs->{type},
3324
                nametype=> "$fs->{name} ($fs->{type} - " . ($mp?$mp:"not mounted") . " $fs->{size})",
3325
            }
3326
        }
3327
    }
3328

    
3329
    # Identify physical devices used for lvm
3330
    $cmd = "pvdisplay -c";
3331
    my $pvs = `$cmd`;
3332
    my @backupdevs; my @imagesdevs;
3333
    foreach my $line (split "\n", $pvs) {
3334
        my ($pvdev, $vgname) = split ":", $line;
3335
        $pvdev = $1 if ($pvdev =~ /\s+(\S+)/);
3336
        $pvdev = $1 if ($pvdev =~ /\/dev\/(\S+)/);
3337
        if ($filesystems{"$vgname-backupvol"}) {
3338
            push @backupdevs, $pvdev unless ($action eq 'listimagesdevices');
3339
        } elsif ($filesystems{"$vgname-imagesvol"}) {
3340
            push @imagesdevs, $pvdev unless ($action eq 'listbackupdevices');
3341
        }
3342
        if (@backupdevs) {
3343
            $filesystems{"$vgname-backupvol"}->{dev} = join(" ", @backupdevs);
3344
            $filesystems{"$vgname-backupvol"}->{nametype} = $filesystems{"$vgname-backupvol"}->{name} . " (lvm with " . $filesystems{"$vgname-backupvol"}->{type} . " on " . join(" ", @backupdevs) . " " . $filesystems{"$vgname-backupvol"}->{size} . ")";
3345
        }
3346
        if (@imagesdevs) {
3347
            $filesystems{"$vgname-imagesvol"}->{dev} = join(" ", @imagesdevs);
3348
            $filesystems{"$vgname-imagesvol"}->{nametype} = $filesystems{"$vgname-imagesvol"}->{name} . " (lvm with " . $filesystems{"$vgname-imagesvol"}->{type} . " on " . join(" ", @imagesdevs) . " " . $filesystems{"$vgname-imagesvol"}->{size} . ")";
3349
        }
3350
        delete $filesystems{$pvdev} if ($filesystems{$pvdev}); # Don't also list as physical device
3351
    }
3352
    my $jsonreply;
3353
    if ($action eq 'getbackupdevice' || $action eq 'getimagesdevice') {
3354
        return ''; # We should not get here
3355
    } elsif ($action eq 'getstoragedevices') {
3356
        return \%filesystems;
3357
    } elsif ($action eq 'listimagesdevices') {
3358
        $jsonreply .= qq|{"identifier": "name", "label": "nametype", "action": "$action", "items": |;
3359
        my @vals = sort {$b->{'isimagesdev'} cmp $a->{'isimagesdev'}} values %filesystems;
3360
        $jsonreply .= JSON->new->canonical(1)->pretty(1)->encode(\@vals);
3361
        $jsonreply .= "}";
3362
    } elsif ($action eq 'listbackupdevices') {
3363
        $jsonreply .= qq|{"identifier": "name", "label": "nametype", "action": "$action", "items": |;
3364
        my @vals = sort {$b->{'isbackupdev'} cmp $a->{'isbackupdev'}} values %filesystems;
3365
        $jsonreply .= JSON->new->canonical(1)->pretty(1)->encode(\@vals);
3366
        $jsonreply .= "}";
3367
    } else {
3368
        $jsonreply .= JSON->new->canonical(1)->pretty(1)->encode(\%filesystems);
3369
    }
3370
    return $jsonreply;
3371
}
3372

    
3373
sub do_liststoragepools {
3374
    my ($image, $action) = @_;
3375
    if ($help) {
3376
        return <<END
3377
GET:dojo:
3378
Returns available storage pools. If parameter dojo is set, JSON is padded for Dojo use.
3379
END
3380
    }
3381
    my %npool = (
3382
        "hostpath", "node",
3383
        "path", "--",
3384
        "name", "On node",
3385
        "rdiffenabled", 1,
3386
        "id", "-1");
3387
    my @p = @spools;
3388
    # Present node storage pool if user has sufficient privileges
3389
    if (index($privileges,"a")!=-1 || index($privileges,"n")!=-1) {
3390
        @p = (\%npool);
3391
        push @p, @spools;
3392
    }
3393

    
3394
    my $jsonreply;
3395
    $jsonreply .= "{\"identifier\": \"id\", \"label\": \"name\", \"items\":" if ($params{'dojo'});
3396
    $jsonreply .= to_json(\@p, {pretty=>1});
3397
    $jsonreply .= "}" if ($params{'dojo'});
3398
    return $jsonreply;
3399
}
3400

    
3401
# List images available for attaching to server
3402
sub do_listimages {
3403
    my ($img, $action) = @_;
3404
    if ($help) {
3405
        return <<END
3406
GET:image,image1:
3407
List images available for attaching to server. This is different from [list] since images must be unused and e.g. master images cannot be attached to a server.
3408
An image may be passed as parameter. This image is assumed to be already attached to the server, so it is included, even though it is not unused.
3409
If image1 is passed, we assume user is selecting an optional second image for the server, and an empty entry is included in the response, in order for the user to select "no image".
3410
END
3411
    }
3412
    my $res;
3413
    $res .= header('application/json') unless ($console);
3414
    my $curimg1 = URI::Escape::uri_unescape($params{'image1'});
3415
    my @filteredfiles;
3416
    my @curusers = @users;
3417
    # If an admin user is looking at a server not belonging to him, allow him to see the server
3418
    # users images
3419
    if ($isadmin && $img && $img ne '--' && $register{$img} && $register{$img}->{'user'} ne $user) {
3420
        @curusers = ($register{$img}->{'user'}, "common");
3421
    }
3422

    
3423
    foreach my $u (@curusers) {
3424
        my @regkeys = (tied %register)->select_where("user = '$u'");
3425
        foreach my $k (@regkeys) {
3426
            my $val = $register{$k};
3427
            if ($val->{'user'} eq $u && (defined $spools[$val->{'storagepool'}]->{'id'} || $val->{'storagepool'}==-1)) {
3428
                my $f = $val->{'path'};
3429
                next if ($f =~ /\/images\/dummy.qcow2/);
3430
                my $itype = $val->{'type'};
3431
                if ($itype eq "vmdk" || $itype eq "img" || $itype eq "vhd" || $itype eq "qcow" || $itype eq "qcow2" || $itype eq "vdi") {
3432
                    my $hit = 0;
3433
                    if ($f =~ /(.+)\.master\.$itype/) {$hit = 1;} # don't list master images for user selections
3434
                    if ($f =~ /(.+)\/common\//) {$hit = 1;} # don't list common images for user selections
3435
                    my $dbstatus = $val->{'status'};
3436
                    if ($dbstatus ne "unused") {$hit = 1;} # Image is in a transitional state - do not use
3437
                    if ($hit == 0 || $img eq $f) {
3438
                        my $hypervisor = ($itype eq "vmdk" || $itype eq "vhd" || $itype eq "vdi")?"vbox":"kvm";
3439
                        my $notes = $val->{'notes'};
3440
                        $notes = "" if $notes eq "--";
3441
                        my %img = ("path", $f, "name", $val->{'name'}, "hypervisor", $hypervisor, "notes", $notes,
3442
                            "uuid", $val->{'uuid'}, "master", $val->{'master'}, "managementlink", $val->{'managementlink'}||"",
3443
                            "upgradelink", $val->{'upgradelink'}||"", "terminallink", $val->{'terminallink'}||"", "version", $val->{'version'}||"",
3444
                            "appid", $val->{'appid'}||"");
3445
                        push @filteredfiles, \%img;
3446
                    }
3447
                }
3448
            }
3449
        }
3450
    }
3451
    my %img = ("path", "--", "name", "--", "hypervisor", "kvm,vbox");
3452
    if ($curimg1) {
3453
        push @filteredfiles, \%img;
3454
    }
3455
    my $json_text = to_json(\@filteredfiles, {pretty=>1});
3456
    $res .= qq/{"identifier": "path", "label": "name", "items": $json_text }/;
3457
    return $res;
3458
}
3459

    
3460
sub Listcdroms {
3461
    my ($image, $action) = @_;
3462
    if ($help) {
3463
        return <<END
3464
GET::
3465
Lists the CD roms a user has access to.
3466
END
3467
    }
3468
    my $res;
3469
    $res .= header('application/json') unless ($console);
3470
    my @filteredfiles;
3471
    foreach my $u (@users) {
3472
        my @regkeys = (tied %register)->select_where("user = '$u'");
3473
        foreach my $k (@regkeys) {
3474
            my $val = $register{$k};
3475
            my $f = $val->{'path'};
3476
            if ($val->{'user'} eq $u && (defined $spools[$val->{'storagepool'}]->{'id'} || $val->{'storagepool'}==-1)) {
3477
                my $itype = $val->{'type'};
3478
                if ($itype eq "iso" || $itype eq "toast") {
3479
                    $notes = $val->{'notes'} || '';
3480
                    if ($u eq $user) {
3481
                        $installable = "true";
3482
                    #    $notes = "This CD/DVD may work just fine, however it has not been tested to work with Irigo Servers.";
3483
                    } else {
3484
                        $installable = $val->{'installable'} || 'false';
3485
                    #    $notes = "This CD/DVD has been tested to work with Irigo Servers." unless $notes;
3486
                    }
3487
                    my %img = ("path", $f, "name", $val->{'name'}, "installable", $installable, "notes", $notes);
3488
                    push @filteredfiles, \%img;
3489
                }
3490
            }
3491
        }
3492
    }
3493
    my %ioimg = ("path", "virtio", "name", "-- VirtIO disk (dummy) --");
3494
    push @filteredfiles, \%ioimg;
3495
    my %dummyimg = ("path", "--", "name", "-- No CD --");
3496
    push @filteredfiles, \%dummyimg;
3497
    #        @filteredfiles = (sort {$a->{'name'} cmp $b->{'name'}} @filteredfiles); # Sort by status
3498
    my $json_text = to_json(\@filteredfiles, {pretty=>1});
3499
    $res .= qq/{"identifier": "path", "label": "name", "items": $json_text }/;
3500
    return $res;
3501
}
3502

    
3503
sub do_listmasterimages {
3504
    my ($image, $action) = @_;
3505
    if ($help) {
3506
        return <<END
3507
GET::
3508
Lists master images available to the current user.
3509
END
3510
    }
3511
    my $res;
3512
    $res .= header('application/json') unless ($console);
3513

    
3514
    my @filteredfiles;
3515
    my @busers = @users;
3516
    push (@busers, $billto) if ($billto); # We include images from 'parent' user
3517

    
3518
    foreach my $u (@busers) {
3519
        my @regkeys = (tied %register)->select_where("user = '$u'");
3520
        foreach my $k (@regkeys) {
3521
            my $valref = $register{$k};
3522
            my $f = $valref->{'path'};
3523
            if ($valref->{'user'} eq $u && (defined $spools[$valref->{'storagepool'}]->{'id'} || $valref->{'storagepool'}==-1)) {
3524
                # Only list installable master images from billto account
3525
                next if ($billto && $u eq $billto && $valref->{'installable'} ne 'true');
3526

    
3527
                my $itype = $valref->{'type'};
3528
                if ($itype eq "qcow2" && $f =~ /(.+)\.master\.$itype/) {
3529
                    my $installable;
3530
                    my $status = $valref->{'status'};
3531
                    my $notes;
3532
                    if ($u eq $user) {
3533
                        $installable = "true";
3534
                        $notes = "This master image may work just fine, however it has not been tested to work with Stabile.";
3535
                    } else {
3536
                        $installable = $valref->{'installable'};
3537
                        $notes = $valref->{'notes'};
3538
                        $notes = "This master image has been tested to work with Irigo Servers." unless $notes;
3539
                    }
3540
                    my %img = (
3541
                        "path", $f,
3542
                        "name", $valref->{'name'},
3543
                        "installable", $installable,
3544
                        "notes", $notes,
3545
                        "managementlink", $valref->{'managementlink'}||"",
3546
                        "upgradelink", $valref->{'upgradelink'}||"",
3547
                        "terminallink", $valref->{'terminallink'}||"",
3548
                        "image2", $valref->{'image2'}||"",
3549
                        "version", $valref->{'version'}||"",
3550
                        "appid", $valref->{'appid'}||"",
3551
                        "status", $status,
3552
                        "user", $valref->{'user'}
3553
                    );
3554
                    push @filteredfiles, \%img;
3555
                }
3556
            }
3557
        }
3558
    }
3559
    my %img = ("path", "--", "name", "--", "installable", "true", "status", "unused");
3560
    push @filteredfiles, \%img;
3561
    my $json_text = to_json(\@filteredfiles);
3562
    $res .= qq/{"identifier": "path", "label": "name", "items": $json_text }/;
3563
    return $res;
3564
}
3565

    
3566
sub Updatebtime {
3567
    my ($img, $action, $obj) = @_;
3568
    if ($help) {
3569
        return <<END
3570
GET:image:
3571
END
3572
    }
3573
    my $res;
3574
    $curimg = $curimg || $img;
3575
    my $imguser = $register{$curimg}->{'user'};
3576
    if ($isadmin || $imguser eq $user) {
3577
        my $btime;
3578
        $btime = getBtime($curimg, $imguser) if ($imguser);
3579
        if ($btime) {
3580
            $register{$curimg}->{'btime'} = $btime ;
3581
            $res .= "Status=OK $curimg has btime: " . scalar localtime( $btime ) . "\n";
3582
        } else {
3583
            $register{$curimg}->{'btime'} = '' ;
3584
            $res .= "Status=OK $curimg has no btime\n";
3585
        }
3586
    } else {
3587
        $res .= "Status=Error no access to $curimg\n";
3588
    }
3589
    return $res;
3590
}
3591

    
3592
sub Updateallbtimes {
3593
    my ($img, $action) = @_;
3594
    if ($help) {
3595
        return <<END
3596
GET::
3597
END
3598
    }
3599
    if ($isadmin) {
3600
        foreach my $path (keys %register) {
3601
            my $imguser = $register{$path}->{'user'};
3602
            my $btime = getBtime($path, $imguser);
3603
            if ($btime) {
3604
                $register{$path}->{'btime'} = $btime ;
3605
                $postreply .= "Status=OK $register{$path}->{'name'} ($path) has btime: " . scalar localtime( $btime ) . "\n";
3606
            } else {
3607
                $postreply .= "Status=OK $register{$path}->{'name'} ($path) has no btime\n";
3608
            }
3609
        }
3610
    } else {
3611
        $postreply .= "Status=ERROR you are not allowed to do this.\n";
3612
    }
3613
    return $postreply;
3614
}
3615

    
3616
# Activate image from fuel
3617
sub Activate {
3618
    my ($curimg, $action, $argref) = @_;
3619
    if ($help) {
3620
        return <<END
3621
GET:image, name, managementlink, upgradelink, terminallink, force:
3622
Activate an image from fuel storage, making it available for regular use.
3623
END
3624
    }
3625
    my %uargs = %{$argref};
3626
    my $name = URI::Escape::uri_unescape($uargs{'name'});
3627
    my $managementlink = URI::Escape::uri_unescape($uargs{'managementlink'});
3628
    my $upgradelink = URI::Escape::uri_unescape($uargs{'upgradelink'});
3629
    my $terminallink = URI::Escape::uri_unescape($uargs{'terminallink'});
3630
    my $version = URI::Escape::uri_unescape($uargs{'version'}) || '1.0b';
3631
    my $image2 =  URI::Escape::uri_unescape($uargs{'image2'});
3632
    my $force = $uargs{'force'};
3633

    
3634
    return "Status=ERROR image must be in fuel storage ($curimg)\n" unless ($curimg =~ /^\/mnt\/fuel\/pool(\d+)\/(.+)/);
3635
    my $pool = $1;
3636
    my $ipath = $2;
3637
    return "Status=ERROR image is not a qcow2 image ($curimg, $ipath)\n" unless ($ipath =~ /(.+\.qcow2$)/);
3638
    my $npath = $1;
3639
    my $ppath = '';
3640
    if ($npath =~ /(.*\/)(.+\.qcow2$)/) {
3641
        $npath = $2;
3642
        $ppath = $1;
3643
    }
3644
    my $imagepath = $tenderpathslist[$pool] . "/$user/fuel/$ipath";
3645
    my $newpath = $tenderpathslist[$pool] . "/$user/$npath";
3646
    return "Status=ERROR image not found ($imagepath)\n" unless (-e $imagepath);
3647
    return "Status=ERROR image already exists in destination ($newpath)\n" if (-e $newpath && !$force);
3648
    return "Status=ERROR image is in use ($newpath)\n" if (-e $newpath && $register{$newpath} && $register{$newpath}->{'status'} ne 'unused');
3649

    
3650
    my $virtualsize = `qemu-img info --force-share "$imagepath" | sed -n -e 's/^virtual size: .*(//p' | sed -n -e 's/ bytes)//p'`;
3651
    chomp $virtualsize;
3652
#    my $master = `qemu-img info --force-share "$imagepath" | sed -n -e 's/^backing file: //p' | sed -n -e 's/ (actual path:.*)\$//p'`;
3653
    my $master = `qemu-img info --force-share "$imagepath" | sed -n -e 's/^backing file: //p'`;
3654
    chomp $master;
3655

    
3656
    # Now deal with image2
3657
    my $newpath2 = '';
3658
    if ($image2) {
3659
        $image2 = "/mnt/fuel/pool$pool/$ppath$image2" unless ($image2 =~ /^\//);
3660
        return "Status=ERROR image2 must be in fuel storage ($image2)\n" unless ($image2 =~ /^\/mnt\/fuel\/pool$pool\/(.+)/);
3661
        $ipath = $1;
3662
        return "Status=ERROR image is not a qcow2 image\n" unless ($ipath =~ /(.+\.qcow2$)/);
3663
        $npath = $1;
3664
        $npath = $1 if ($npath =~ /.*\/(.+\.qcow2$)/);
3665
        my $image2path = $tenderpathslist[$pool] . "/$user/fuel/$ipath";
3666
        $newpath2 = $tenderpathslist[$pool] . "/$user/$npath";
3667
        return "Status=ERROR image2 not found ($image2path)\n" unless (-e $image2path);
3668
        return "Status=ERROR image2 already exists in destination ($newpath2)\n" if (-e $newpath2 && !$force);
3669
        return "Status=ERROR image2 is in use ($newpath2)\n" if (-e $newpath2 && $register{$newpath2} && $register{$newpath2}->{'status'} ne 'unused');
3670

    
3671
        my $virtualsize2 = `qemu-img info --force-share "$image2path" | sed -n -e 's/^virtual size: .*(//p' | sed -n -e 's/ bytes)//p'`;
3672
        chomp $virtualsize2;
3673
#        my $master2 = `qemu-img info --force-share "$image2path" | sed -n -e 's/^backing file: //p' | sed -n -e 's/ (actual path:.*)\$//p'`;
3674
        my $master2 = `qemu-img info --force-share "$image2path" | sed -n -e 's/^backing file: //p'`;
3675
        chomp $master2;
3676
        if ($register{$master2}) {
3677
            $register{$master2}->{'status'} = 'used';
3678
        }
3679
        `mv "$image2path" "$newpath2"`;
3680
        if (-e $newpath2) {
3681
            my $ug = new Data::UUID;
3682
            my $newuuid = $ug->create_str();
3683
            unless ($name) {
3684
                $name = $npath if ($npath);
3685
                $name = $1 if ($name =~ /(.+)\.(qcow2)$/);
3686
            }
3687
            $register{$newpath2} = {
3688
                uuid => $newuuid,
3689
                path => $newpath2,
3690
                master => $master2,
3691
                name => "$name (data)",
3692
                user => $user,
3693
                storagepool => $pool,
3694
                type => 'qcow2',
3695
                status => 'unused',
3696
                version => $version,
3697
                virtualsize => $virtualsize2
3698
            };
3699
            $postreply .= "Status=OK Activated data image $newpath2, $name (data), $newuuid\n";
3700
        } else {
3701
            $postreply .=  "Status=ERROR Unable to activate $image2path, $newpath2\n";
3702
        }
3703
    }
3704

    
3705
    # Finish up primary image
3706
    if ($register{$master}) {
3707
        $register{$master}->{'status'} = 'used';
3708
    }
3709
    `mv "$imagepath" "$newpath"`;
3710
    if (-e $newpath) {
3711
        my $ug = new Data::UUID;
3712
        my $newuuid = $ug->create_str();
3713
        unless ($name) {
3714
            $name = $npath if ($npath);
3715
            $name = $1 if ($name =~ /(.+)\.(qcow2)$/);
3716
        }
3717
        $register{$newpath} = {
3718
            uuid => $newuuid,
3719
            path => $newpath,
3720
            master => $master,
3721
            name => $name,
3722
            user => $user,
3723
            storagepool => $pool,
3724
            image2 => $newpath2,
3725
            type => 'qcow2',
3726
            status => 'unused',
3727
            installable => 'true',
3728
            managementlink => $managementlink || '/stabile/pipe/http://{uuid}:10000/stabile/',
3729
            upgradelink => $upgradelink,
3730
            terminallink => $terminallink,
3731
            version => $version,
3732
            virtualsize => $virtualsize
3733
        };
3734
        $postreply .=  "Status=OK Activated $newpath, $name, $newuuid\n";
3735
    } else {
3736
        $postreply .=  "Status=ERROR Unable to activate $imagepath to $newpath\n";
3737
    }
3738
    return $postreply;
3739
}
3740

    
3741
sub Uploadtoregistry {
3742
    my ($path, $action, $obj) = @_;
3743
    if ($help) {
3744
        return <<END
3745
GET:image, force:
3746
Upload an image to the registry. Set [force] if you want to force overwrite images in registry - use with caution.
3747
END
3748
    }
3749
    $force = $obj->{'force'};
3750
    if (-e $path && ($register{$path}->{'user'} eq $user || $isadmin)) {
3751
        $postreply .= $main::uploadToOrigo->($engineid, $path, $force);
3752
    } else {
3753
        $postreply .= "Status=Error Not allowed\n";
3754
    }
3755
    return $postreply;
3756
}
3757

    
3758
sub Publish {
3759
    my ($uuid, $action, $parms) = @_;
3760
    if ($help) {
3761
        return <<END
3762
GET:image,appid,appstore,force:
3763
Publish a stack to registry. Set [force] if you want to force overwrite images in registry - use with caution.
3764
END
3765
    }
3766
    my $res;
3767
    $uuid = $parms->{'uuid'} if ($uuid =~ /^\// || !$uuid);
3768
    my $force = $parms->{'force'};
3769
    my $freshen = $parms->{'freshen'};
3770

    
3771
    if ($isreadonly) {
3772
        $res .= "Status=ERROR Your account does not have the necessary privilege.s\n";
3773
    } elsif (!$uuid || !$imagereg{$uuid}) {
3774
        $res .= "Status=ERROR At least specify activated master image uuid [uuid or path] to publish.\n";
3775
    } elsif ($imagereg{$uuid}->{'user'} ne $user && !$isadmin) {
3776
        $res .= "Status=ERROR Your account does not have the necessary privileges.\n";
3777
    } elsif ($imagereg{$uuid}->{'path'} =~ /.+\.master\.qcow2$/) {
3778
        if ($engineid eq $valve001id) { # On valve001 - check if meta file exists
3779
            if (-e $imagereg{$uuid}->{'path'} . ".meta") {
3780
                $res .= "On valve001. Found meta file $imagereg{$uuid}->{'path'}.meta\n";
3781
                my $appid = `cat $imagereg{$uuid}->{'path'}.meta | sed -n -e 's/^APPID=//p'`;
3782
                chomp $appid;
3783
                if ($appid) {
3784
                    $parms->{'appid'} = $appid;
3785
                    $register{$imagereg{$uuid}->{'path'}}->{'appid'} = $appid;
3786
                    tied(%register)->commit;
3787
                }
3788
            }
3789
        # On valve001 - move image to stacks
3790
            if ($imagereg{$uuid}->{'storagepool'} ne '0') {
3791
                $res .= "Status=OK Moving image: " . Move($imagereg{$uuid}->{'path'}, $user, 0) . "\n";
3792
            } else {
3793
                $res .= "Status=OK Image is already available in registry\n";
3794
            }
3795
        } else {
3796
        #    $console = 1;
3797
        #    my $link = Download($imagereg{$uuid}->{'path'});
3798
        #    chomp $link;
3799
        #    $parms->{'downloadlink'} = $link; # We now upload instead
3800
        #    $res .= "Status=OK Asking registry to download $parms->{'APPID'} image: $link\n";
3801
            if ($appstores) {
3802
                $parms->{'appstore'} = $appstores;
3803
            } elsif ($appstoreurl =~ /www\.(.+)\//) {
3804
                $parms->{'appstore'} = $1;
3805
                $res .= "Status=OK Adding registry: $1\n";
3806
            }
3807
        }
3808
#        $parms->{'appstore'} = 1 if ($freshen);
3809

    
3810
        my %imgref = %{$imagereg{$uuid}};
3811
        $parms = Hash::Merge::merge($parms, \%imgref);
3812
        my $postdata = to_json($parms);
3813
        my $postres = $main::postToOrigo->($engineid, 'publishapp', $postdata);
3814
        $res .= $postres;
3815
        my $appid;
3816
        $appid = $1 if ($postres =~ /appid: (\d+)/);
3817
        my $path = $imagereg{$uuid}->{'path'};
3818
        if ($freshen && $appid) {
3819
            $res .= "Status=OK Freshened the stack description\n";
3820
        } elsif ($appid) {
3821
            $register{$path}->{'appid'} = $appid if ($register{$path});
3822
            $res .= "Status=OK Received appid $appid for $path, uploading image to registry, hang on...\n";
3823
            my $upres .= $main::uploadToOrigo->($engineid, $path, $force);
3824
            $res .= $upres;
3825
            my $image2 = $register{$path}->{'image2'} if ($register{$path});
3826
            if ($upres =~ /Status=OK/ && $image2 && $image2 ne '--') { # Stack has a data image
3827
                $res .= $main::uploadToOrigo->($engineid, $image2, $force);
3828
            }
3829
        } else {
3830
            $res .= "Status=Error Did not get an appid\n";
3831
        }
3832
    } else {
3833
        $res .= "Status=ERROR You can only publish a master image.\n";
3834
    }
3835
    return $res;
3836
}
3837

    
3838
sub Release {
3839
    my ($uuid, $action, $parms) = @_;
3840
    if ($help) {
3841
        return <<END
3842
GET:image,appid,appstore,force,unrelease:
3843
Releases a stack in the registry, i.e. moves it from being a private stack only owner and owner's users can see and use to being a public stack, everyone can use. Set [force] if you want to force overwrite images in registry - use with caution.
3844
END
3845
    }
3846
    my $res;
3847
    $uuid = $parms->{'uuid'} if ($uuid =~ /^\// || !$uuid);
3848
    my $force = $parms->{'force'};
3849
    my $unrelease = $parms->{'unrelease'};
3850

    
3851
    if (!$uuid || !$imagereg{$uuid}) {
3852
        $res .= "Status=ERROR At least specify master image uuid [uuid or path] to release.\n";
3853
    } elsif (!$isadmin) {
3854
        $res .= "Status=ERROR Your account does not have the necessary privileges.\n";
3855
    } elsif ($imagereg{$uuid}->{'path'} =~ /.+\.master\.qcow2$/ && $imagereg{$uuid}->{'appid'}) {
3856
        my $action = 'release';
3857
        my $targetuser = 'common';
3858
        if ($unrelease) {
3859
            $action = 'unrelease';
3860
            $targetuser = $user;
3861
        }
3862
        if ($appstores) {
3863
            $parms->{'appstore'} = $appstores;
3864
        } elsif ($appstoreurl =~ /www\.(.+)\//) {
3865
            $parms->{'appstore'} = $1;
3866
            $res .= "Status=OK Adding registry: $1\n";
3867
        }
3868
        $parms->{'appid'} = $imagereg{$uuid}->{'appid'};
3869
        $parms->{'force'} = $force if ($force);
3870
        $parms->{'unrelease'} = $unrelease if ($unrelease);
3871
        my $postdata = to_json($parms);
3872
        my $postres = $main::postToOrigo->($engineid, 'releaseapp', $postdata);
3873
        $res .= $postres;
3874
        my $appid;
3875
        $appid = $1 if ($postres =~ /Status=OK Moved (\d+)/);
3876
        my $path = $imagereg{$uuid}->{'path'};
3877
        if ($appid) {
3878
            $res.= "Now moving local stack to $targetuser\n";
3879
            # First move data image
3880
            my $image2 = $register{$path}->{'image2'} if ($register{$path});
3881
            my $newimage2 = $image2;
3882
            if ($image2 && $image2 ne '--' && $register{$image2}) { # Stack has a data image
3883
                if ($unrelease) {
3884
                    $newimage2 =~ s/common/$register{$image2}->{'user'}/;
3885
                } else {
3886
                    $newimage2 =~ s/$register{$image2}->{'user'}/common/;
3887
                }
3888
                $register{$path}->{'image2'} = $newimage2;
3889
                tied(%register)->commit;
3890
                $res .= Move($image2, $targetuser, '', '', 1);
3891
            }
3892
            # Move image
3893
            $res .= Move($path, $targetuser, '', '', 1);
3894
            $res .= "Status=OK $action $appid\n";
3895
        } else {
3896
            $res .= "Status=Error $action failed\n";
3897
        }
3898
    } else {
3899
        $res .= "Status=ERROR You can only $action a master image that has been published.\n";
3900
    }
3901
    return $res;
3902
}
3903

    
3904
sub do_unlinkmaster {
3905
    my ($img, $action) = @_;
3906
    if ($help) {
3907
        return <<END
3908
GET:image,path:
3909
END
3910
    }
3911
    my $res;
3912
    $res .= header('text/html') unless ($console);
3913
    if ($isreadonly) {
3914
        $res .= "Your account does not have the necessary privileges\n";
3915
    } elsif ($curimg) {
3916
        $res .= unlinkMaster($curimg) . "\n";
3917
    } else {
3918
        $res .= "Please specify master image to link\n";
3919
    }
3920
    return $res;
3921
}
3922

    
3923
# Simple action for unmounting all images
3924
sub do_unmountall {
3925
    my ($img, $action) = @_;
3926
    if ($help) {
3927
        return <<END
3928
GET:image,path:
3929
END
3930
    }
3931
    return "Your account does not have the necessary privileges\n" if ($isreadonly);
3932
    my $res;
3933
    $res .= header('text/plain') unless ($console);
3934
    $res .= "Unmounting all images for $user\n";
3935
    unmountAll();
3936
    $res .= "\n$postreply" if ($postreply);
3937
    return $res;
3938
}
3939

    
3940
sub Updatedownloads {
3941
    my ($img, $action) = @_;
3942
    if ($help) {
3943
        return <<END
3944
GET:image,path:
3945
END
3946
    }
3947
    my $res;
3948
    $res .= header('text/html') unless ($console);
3949
    my $txt1 = <<EOT
3950
Options -Indexes
3951
EOT
3952
    ;
3953
    `/bin/mkdir "$Stabile::basedir/download"` unless (-e "$Stabile::basedir/download");
3954
    $res .= "Writing .htaccess: -> $Stabile::basedir/download/.htaccess\n";
3955
    unlink("$Stabile::basedir/download/.htaccess");
3956
    `chown www-data:www-data "$Stabile::basedir/download"`;
3957
    `/bin/echo "$txt1" | sudo -u www-data tee "$Stabile::basedir/download/.htaccess"`; #This ugliness is needed because of ownership issues with Synology NFS
3958
    `chmod 644 "$Stabile::basedir/download/.htaccess"`;
3959
    foreach my $p (@spools) {
3960
        my $dir = $p->{'path'};
3961
        my $id = $p->{'id'};
3962
        `/bin/rm "$Stabile::basedir/download/$id"; /bin/ln -s "$dir" "$Stabile::basedir/download/$id"`;
3963
        $res .= "Writing .htaccess: $id -> $dir/.htaccess\n";
3964
        unlink("$dir/.htaccess");
3965
        `/bin/echo "$txt1" | tee "$dir/.htaccess"`;
3966
        `chown www-data:www-data "$dir/.htaccess"`;
3967
        `chmod 644 "$dir/.htaccess"`;
3968
    }
3969

    
3970
    unless ( tie(%userreg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
3971

    
3972
    foreach my $username (keys %userreg) {
3973
        my $require = '';
3974
        my $txt = <<EOT
3975
order deny,allow
3976
AuthName "Download"
3977
AuthType None
3978
TKTAuthLoginURL $baseurl/auth/login.cgi
3979
TKTAuthIgnoreIP on
3980
deny from all
3981
Satisfy any
3982
require user $username
3983
Options -Indexes
3984
EOT
3985
        ;
3986
        foreach my $p (@spools) {
3987
            my $dir = $p->{'path'};
3988
            my $id = $p->{'id'};
3989
            if (-d "$dir/$username") {
3990
                $res .= "Writing .htaccess: $id -> $dir/$username/.htaccess\n";
3991
                unlink("$dir/$username/.htaccess");
3992
                `/bin/echo "$txt1" | sudo -u www-data tee $dir/$username/.htaccess`;
3993
                if ($tenderlist[$p->{'id'}] eq 'local') {
3994
                    if (!(-e "$dir/$username/fuel") && -e "$dir/$username") {
3995
                        `mkdir "$dir/$username/fuel"`;
3996
                        `chmod 777 "$dir/$username/fuel"`;
3997
                    }
3998
                }
3999
            }
4000
        }
4001
    }
4002
    untie %userreg;
4003
    return $res;
4004
}
4005

    
4006
sub do_listpackages($action) {
4007
    my ($image, $action) = @_;
4008
    if ($help) {
4009
        return <<END
4010
GET:image:
4011
Tries to mount and list software packages installed on the operating system on an image. The image must be mountable and contain a valid operating system.
4012
END
4013
    }
4014
    my $res;
4015
    $res .= header('text/plain') unless ($console);
4016

    
4017
    my $mac = $register{$image}->{'mac'};
4018
    my $macip;
4019
    if ($mac && $mac ne '--') {
4020
        unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4021
        $macip = $nodereg{$mac}->{'ip'};
4022
        untie %nodereg;
4023
    }
4024
    $image =~ /(.+)/; $image = $1;
4025
    my $apps;
4026

    
4027
    if ($macip && $macip ne '--') {
4028
        my $cmd = qq[eval \$(/usr/bin/guestfish --ro -a "$image" --i --listen); ]; # sets $GUESTFISH_PID shell var
4029
        $cmd .= qq[root="\$(/usr/bin/guestfish --remote inspect-get-roots)"; ];
4030
        $cmd .= qq[guestfish --remote inspect-list-applications "\$root"; ];
4031
        $cmd .= qq[guestfish --remote inspect-get-product-name "\$root"; ];
4032
        $cmd .= qq[guestfish --remote exit];
4033
        $cmd = "$sshcmd $macip '$cmd'";
4034
        $apps = `$cmd`;
4035
    } else {
4036
        my $cmd;
4037
        #        my $pid = open my $cmdpipe, "-|",qq[/usr/bin/guestfish --ro -a "$image" --i --listen];
4038
        $cmd .= qq[eval \$(/usr/bin/guestfish --ro -a "$image" --i --listen); ];
4039
        # Start listening guestfish
4040
        my $daemon = Proc::Daemon->new(
4041
            work_dir => '/usr/local/bin',
4042
            setuid => 'www-data',
4043
            exec_command => $cmd
4044
        ) or do {$postreply .= "Status=ERROR $@\n";};
4045
        my $pid = $daemon->Init();
4046
        while ($daemon->Status($pid)) {
4047
            sleep 1;
4048
        }
4049
        # Find pid of the listening guestfish
4050
        my $pid2;
4051
        my $t = new Proc::ProcessTable;
4052
        foreach $p ( @{$t->table} ){
4053
            my $pcmd = $p->cmndline;
4054
            if ($pcmd =~ /guestfish.+$image/) {
4055
                $pid2 = $p->pid;
4056
                last;
4057
            }
4058
        }
4059

    
4060
        my $cmd2;
4061
        if ($pid2) {
4062
            $cmd2 .= qq[root="\$(/usr/bin/guestfish --remote=$pid2 inspect-get-roots)"; ];
4063
            $cmd2 .= qq[guestfish --remote=$pid2 inspect-list-applications "\$root"; ];
4064
            $cmd2 .= qq[guestfish --remote=$pid2 inspect-get-product-name "\$root"; ];
4065
            $cmd2 .= qq[guestfish --remote=$pid2 exit];
4066
        }
4067
        $apps = `$cmd2`;
4068
    }
4069
    if ($console) {
4070
        $res .= $apps;
4071
    } else {
4072
        my @packages;
4073
        my @packages2;
4074
        open my $fh, '<', \$apps or die $!;
4075
        my $i;
4076
        while (<$fh>) {
4077
            if ($_ =~ /\[(\d+)\]/) {
4078
                push @packages2, $packages[$i];
4079
                $i = $1;
4080
            } elsif ($_ =~ /(\S+): (.+)/ && $2) {
4081
                $packages[$i]->{$1} = $2;
4082
            }
4083
        }
4084
        close $fh or die $!;
4085
        $res .= to_json(\@packages, {pretty => 1});
4086
    }
4087
    return $res;
4088
}
4089

    
4090
sub Inject {
4091
    my ($image, $action, $obj) = @_;
4092
    if ($help) {
4093
        return <<END
4094
GET:image:
4095
Tries to inject drivers into a qcow2 image with a Windows OS installed on it. Image must not be in use.
4096
END
4097
    }
4098
    $uistatus = "injecting";
4099
    my $path = $obj->{path} || $curimg;
4100
    my $status = $obj->{status};
4101
    my $esc_localpath = shell_esc_chars($path);
4102

    
4103
    # Find out if we are dealing with a Windows image
4104
    my $xml = `bash -c '/usr/bin/virt-inspector -a "$esc_localpath"'`;
4105
    #my $xml = `bash -c '/usr/bin/virt-inspector -a "$esc_localpath"' 2>&1`;
4106
    # $res .= $xml . "\n";
4107
    my $xmlref;
4108
    my $osname;
4109
    $xmlref = XMLin($xml) if ($xml =~ /^<\?xml/);
4110
    $osname = $xmlref->{operatingsystem}->{name} if ($xmlref);
4111
    if ($xmlref && $osname eq 'windows') {
4112
        my $upath = $esc_localpath;
4113
        # We need write privileges
4114
        $res .= `chmod 666 "$upath"`;
4115
        # First try to merge storage registry keys into Windows registry. If not a windows vm it simply fails.
4116
        $res .= `bash -c 'cat /usr/share/stabile/mergeide.reg | /usr/bin/virt-win-reg --merge "$upath"' 2>&1`;
4117
        # Then try to merge the critical device keys. This has been removed in win8 and 2012, so will simply fail for these.
4118
        $res .= `bash -c 'cat /usr/share/stabile/mergeide-CDDB.reg | /usr/bin/virt-win-reg --merge "$upath"' 2>&1`;
4119
        if ($res) { debuglog($res); $res = ''; }
4120

    
4121
        # Try to copy viostor.sys into image
4122
        my @winpaths = (
4123
            '/Windows/System32/drivers',
4124
            '/WINDOWS/system32/drivers/viostor.sys',
4125
            '/WINDOWS/System32/drivers/viostor.sys',
4126
            '/WINNT/system32/drivers/viostor.sys'
4127
        );
4128
        foreach my $winpath (@winpaths) {
4129
            my $lscmd = qq|bash -c 'virt-ls -a "$upath" "$winpath"'|;
4130
            my $drivers = `$lscmd`;
4131
            if ($drivers =~ /viostor/i) {
4132
                $postreply .= "Status=OK viostor already installed in $winpath in $upath\n";
4133
                $main::syslogit->($user, "info", "viostor already installed in $winpath in $upath");
4134
                last;
4135
            } elsif ($drivers) {
4136
                my $cmd = qq|bash -c 'guestfish -i -a "$upath" upload /usr/share/stabile/VIOSTOR.SYS $winpath/viostor.sys' 2>&1|;
4137
                my $error = `$cmd`;
4138
                if ($error) {
4139
                    $postreply .= "Status=ERROR Problem injecting virtio drivers into $upath: $error\n";
4140
                    $main::syslogit->($user, "info", "Error injecting virtio drivers into $upath: $error");
4141
                } else {
4142
                    $postreply .= "Status=$status Injected virtio drivers into $upath";
4143
                    $main::syslogit->($user, "info", "Injected virtio drivers into $upath");
4144
                }
4145
                last;
4146
            } else {
4147
                $postreply .= "Status=ERROR No drivers found in $winpath\n";
4148
            }
4149
        }
4150

    
4151
    } else {
4152
        $postreply .= "Status=ERROR No Windows OS found in $osname image, not injecting drivers.\n";
4153
        $main::syslogit->($user, "info", "No Windows OS found ($osname) in image, not injecting drivers.");
4154
    }
4155
    my $msg = $postreply;
4156
    $msg = $1 if ($msg =~ /\w+=\w+ (.+)/);
4157
    chomp $msg;
4158
    $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status, message=>$msg});
4159
    $postreply .=  "Status=OK $uistatus $obj->{type} image: $obj->{name}\n";
4160
    $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4161
    return $postreply;
4162
}
4163

    
4164
sub Convert {
4165
    my ($image, $action, $obj) = @_;
4166
    if ($help) {
4167
        return <<END
4168
GET:image:
4169
Converts an image to qcow2 format. Image must not be in use.
4170
END
4171
    }
4172
    my $path = $obj->{path};
4173
    $uistatus = "converting";
4174
    $uipath = $path;
4175
    if ($obj->{status} ne "unused" && $obj->{status} ne "used" && $obj->{status} ne "paused") {
4176
        $postreply .= "Status=ERROR Problem $uistatus $obj->{type} image: $obj->{name}\n";
4177
    } elsif ($obj->{type} eq "img" || $obj->{type} eq "vmdk" || $obj->{type} eq "vhd") {
4178
        my $oldpath = $path;
4179
        my $newpath = "$path.qcow2";
4180
        if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
4181
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4182
            $macip = $nodereg{$obj->{mac}}->{'ip'};
4183
            untie %nodereg;
4184
            $oldpath = "$macip:$path";
4185
        } else { # We are not on a node - check that image is not on a read-only filesystem
4186
            my ($fname, $destfolder) = fileparse($path);
4187
            my $ro = `touch "$destfolder/test.tmp" && { rm "$destfolder/test.tmp"; } || echo "read-only" 2>/dev/null`;
4188
            if ($ro) { # Destinationfolder is not writable
4189
                my $npath = "$spools[0]->{'path'}/$register{$path}->{'user'}/$fname.qcow2";
4190
                $newpath = $npath;
4191
            }
4192
            if (-e $newpath) { # Don't overwrite existing file
4193
                my $subpath = substr($newpath,0,-6);
4194
                my $i = 1;
4195
                if ($newpath =~ /(.+)\.(\d+)\.qcow2/) {
4196
                    $i = $2;
4197
                    $subpath = $1;
4198
                }
4199
                while (-e $newpath) {
4200
                    $newpath = $subpath . ".$i.qcow2";
4201
                    $i++;
4202
                }
4203
            }
4204
        }
4205
        eval {
4206
            my $ug = new Data::UUID;
4207
            my $newuuid = $ug->create_str();
4208

    
4209
            $register{$newpath} = {
4210
                uuid=>$newuuid,
4211
                name=>"$obj->{name} (converted)",
4212
                notes=>$obj->{notes},
4213
                image2=>$obj->{image2},
4214
                managementlink=>$obj->{managementlink},
4215
                upgradelink=>$obj->{managementlink},
4216
                terminallink=>$obj->{terminallink},
4217
                storagepool=>$obj->{regstoragepool},
4218
                status=>$uistatus,
4219
                mac=>($obj->{regstoragepool} == -1)?$obj->{mac}:"",
4220
                size=>0,
4221
                realsize=>0,
4222
                virtualsize=>$obj->{virtualsize},
4223
                type=>"qcow2",
4224
                user=>$user
4225
            };
4226
            $register{$path}->{'status'} = $uistatus;
4227

    
4228
            my $daemon = Proc::Daemon->new(
4229
                work_dir => '/usr/local/bin',
4230
                exec_command => "perl -U steamExec $user $uistatus $obj->{status} \"$oldpath\" \"$newpath\""
4231
            ) or do {$postreply .= "Status=ERROR $@\n";};
4232
            my $pid = $daemon->Init() or do {$postreply .= "Status=ERROR $@\n";};
4233
            $postreply .=  "Status=OK $uistatus $obj->{type} image: $obj->{name}\n";
4234
            $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4235
        } or do {$postreply .= "Status=ERROR $@\n";};
4236
        $main::updateUI->({tab=>"images", user=>$user, type=>"update"});
4237
    } else {
4238
        $postreply .= "Status=ERROR Only img and vmdk images can be converted\n";
4239
    }
4240
    return $postreply;
4241
}
4242

    
4243
sub Snapshot {
4244
    my ($image, $action, $obj) = @_;
4245
    if ($help) {
4246
        return <<END
4247
GET:image:
4248
Adds a snapshot to a qcow2 image. Image can not be in use by a running server.
4249
END
4250
    }
4251
    my $status = $obj->{status};
4252
    my $path = $obj->{path};
4253
    my $macip;
4254
    $uistatus = "snapshotting";
4255
    $uiuuid = $obj->{uuid};
4256
    if ($status ne "unused" && $status ne "used") {
4257
        $postreply .= "Status=ERROR Problem $uistatus $obj->{type} image: $obj->{name}\n";
4258
    } elsif ($obj->{type} eq "qcow2") {
4259
        my $newpath = $path;
4260
        my $hassnap;
4261
        my $snaptime = time;
4262
        if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
4263
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4264
            $macip = $nodereg{$obj->{mac}}->{'ip'};
4265
            untie %nodereg;
4266
            $newpath = "$macip:$path";
4267
            my $esc_path = $path;
4268
            $esc_path =~ s/([ ])/\\$1/g;
4269
            my $qinfo = `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -l $esc_path"`;
4270
            $hassnap = ($qinfo =~ /snap1/g);
4271
            $postreply .= `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -d snap1 $esc_path"` if ($hassnap);
4272
        } else {
4273
            my $qinfo = `/usr/bin/qemu-img snapshot -l "$path"`;
4274
            $hassnap = ($qinfo =~ /snap1/g);
4275
            $postreply .= `/usr/bin/qemu-img snapshot -d snap1 "$path\n"` if ($hassnap);
4276
        }
4277
        eval {
4278
            if ($hassnap) {
4279
                $postreply .= "Status=Error Only one snapshot per image is supported for $obj->{type} image: $obj->{name} ";
4280
            } else {
4281
                $register{$path}->{'status'} = $uistatus;
4282
                $register{$path}->{'snap1'} = $snaptime;
4283

    
4284
                if ($macip) {
4285
                    my $esc_localpath = shell_esc_chars($path);
4286
                    $res .= `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -c snap1 $esc_localpath"`;
4287
                } else {
4288
                    $res .= `/usr/bin/qemu-img snapshot -c snap1 "$path"`;
4289
                }
4290
                $register{$path}->{'status'} = $status;
4291
                $postreply .=  "Status=$uistatus OK $uistatus $obj->{type} image: $obj->{name}\n";
4292
                $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4293
            }
4294
            1;
4295
        } or do {$postreply .= "Status=ERROR $@\n";};
4296
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status, snap1=>$snaptime});
4297
    } else {
4298
        $postreply .= "Status=ERROR Only qcow2 images can be snapshotted\n";
4299
    }
4300
    return $postreply;
4301
}
4302

    
4303
sub Unsnap {
4304
    my ($image, $action, $obj) = @_;
4305
    if ($help) {
4306
        return <<END
4307
GET:image:
4308
Removes a snapshot from a qcow2 image. Image can not be in use by a running server.
4309
END
4310
    }
4311
    my $status = $obj->{status};
4312
    my $path = $obj->{path};
4313
    $uistatus = "unsnapping";
4314
    $uiuuid = $obj->{uuid};
4315
    my $macip;
4316

    
4317
    if ($status ne "unused" && $status ne "used") {
4318
        $postreply .= "Status=ERROR Problem $uistatus $obj->{type} image: $obj->{name}\n";
4319
    } elsif ($obj->{type} eq "qcow2") {
4320
        my $newpath = $path;
4321
        my $hassnap;
4322
        my $qinfo;
4323
        my $esc_path;
4324
        if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
4325
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4326
            $macip = $nodereg{$obj->{mac}}->{'ip'};
4327
            untie %nodereg;
4328
            $newpath = "$macip:$path";
4329
            $esc_path = $path;
4330
            $esc_path =~ s/([ ])/\\$1/g;
4331
            $qinfo = `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -l $esc_path"`;
4332
            $hassnap = ($qinfo =~ /snap1/g);
4333
        } else {
4334
            $qinfo = `/usr/bin/qemu-img snapshot -l "$path"`;
4335
            $hassnap = ($qinfo =~ /snap1/g);
4336
        }
4337
        eval {
4338
            my $snaptime = time;
4339
            if ($hassnap) {
4340
                delete $register{$path}->{'snap1'};
4341
                $register{$path}->{'status'} = $uistatus;
4342
                if ($macip) {
4343
                    my $esc_localpath = shell_esc_chars($path);
4344
                    $res .= `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -d snap1 $esc_localpath"`;
4345
                } else {
4346
                    $res .= `/usr/bin/qemu-img snapshot -d snap1 "$path"`;
4347
                }
4348
                $register{$path}->{'status'} = $status;
4349
                $postreply .=  "Status=$uistatus OK $uistatus $obj->{type} image: $obj->{name}\n";
4350
                $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4351
            } else {
4352
                $postreply .= "Status=ERROR No snapshot found in $obj->{name}\n";
4353
                delete $register{$path}->{'snap1'};
4354
                $uistatus = $status;
4355
            }
4356
            1;
4357
        } or do {$postreply .= "Status=ERROR $@\n";};
4358
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status, snap1=>'--'});
4359
    } else {
4360
        $postreply .= "Status=ERROR Only qcow2 images can be unsnapped\n";
4361
    }
4362
    return $postreply;
4363
}
4364

    
4365
sub Revert {
4366
    my ($image, $action, $obj) = @_;
4367
    if ($help) {
4368
        return <<END
4369
GET:image:
4370
Applies a snapshot to a qcow2 image, i.e. the image is reverted to the state it was in when the snapshot was taken. Image can not be in use by a running server.
4371
END
4372
    }
4373
    my $status = $obj->{status};
4374
    my $path = $obj->{path};
4375
    $uistatus = "reverting";
4376
    $uipath = $path;
4377
    my $macip;
4378
    if ($status ne "used" && $status ne "unused") {
4379
        $postreply .= "Status=ERROR Please shut down or pause your virtual machine before reverting\n";
4380
    } elsif ($obj->{type} eq "qcow2") {
4381
        my $newpath = $path;
4382
        my $hassnap;
4383
        if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
4384
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4385
            $macip = $nodereg{$obj->{mac}}->{'ip'};
4386
            untie %nodereg;
4387
            $newpath = "$macip:$path";
4388
            my $esc_path = $path;
4389
            $esc_path =~ s/([ ])/\\$1/g;
4390
            my $qinfo = `ssh -l irigo -i /var/www/.ssh/id_rsa_www -o UserKnownHostsFile=/dev/null -o StrictHostKeyChecking=no $macip "/usr/bin/qemu-img snapshot -l $esc_path"`;
4391
            $hassnap = ($qinfo =~ /snap1/g);
4392
        } else {
4393
            my $qinfo = `/usr/bin/qemu-img snapshot -l "$path"`;
4394
            $hassnap = ($qinfo =~ /snap1/g);
4395
        }
4396
        eval {
4397
            if ($hassnap) {
4398
                $register{$path}->{'status'} = $uistatus;
4399
                if ($macip) {
4400
                    my $esc_localpath = shell_esc_chars($path);
4401
                    $res .= `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -a snap1 $esc_localpath"`;
4402
                } else {
4403
                    $res .= `/usr/bin/qemu-img snapshot -a snap1 "$path1"`;
4404
                }
4405
                $register{$path}->{'status'} = $status;
4406
                $postreply .=  "Status=OK $uistatus $obj->{type} image: $obj->{name}\n";
4407
                $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4408
            } else {
4409
                $postreply .= "Status=ERROR no snapshot found\n";
4410
                $uistatus = $status;
4411
            }
4412
            1;
4413
        } or do {$postreply .= "Status=ERROR $@\n";};
4414
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status, snap1=>'--'});
4415
    } else {
4416
        $postreply .= "Status=ERROR Only qcow2 images can be reverted\n";
4417
    }
4418
    return;
4419
}
4420

    
4421
sub Zbackup {
4422
    my ($image, $action, $obj) = @_;
4423
    if ($help) {
4424
        return <<END
4425
GET:mac, storagepool, synconly, snaponly, imageretention, backupretention:
4426
Backs all images on ZFS storage up by taking a storage snapshot. By default all shared storagepools are backed up.
4427
If storagepool -1 is specified, all ZFS node storages is backed up. If "mac" is specified, only specific node is backed up.
4428
If "synconly" is set, no new snapshots are taken - only syncing of snapshots is performed.
4429
If "snaponly" is set, only local active storage snapshot is taken - no sending to backup storage is done.
4430
"xretention" can be either simply number of snapshots to keep, or max age of snapshot to keep in seconds [s], hours [h] or days [d],
4431
e.g. "imageretention=10" will keep 10 image snapshots, "imageretention=600s" will purte image snapshots older than 600 seconds if possible, or "backretention=14d" will purge backup snapshots older than 14 days.
4432
END
4433
    }
4434
    if ($isadmin) {
4435
        my $synconly = $obj->{'synconly'};
4436
        my $snaponly = $obj->{'snaponly'};
4437
        my $mac = $obj->{'mac'};
4438
        my $storagepool = $obj->{'storagepool'};
4439
        $storagepool = -1 if ($mac);
4440
        my $imageretention = $obj->{'imageretention'} || $imageretention;
4441
        my $backupretention = $obj->{'backupretention'} || $backupretention;
4442

    
4443
        my $basepath = "stabile-backup";
4444
        my $bpath = $basepath;
4445
        my $mounts = `/bin/cat /proc/mounts`;
4446
        my $zbackupavailable = (($mounts =~ /$bpath (\S+) zfs/)?$1:'');
4447
        unless ($zbackupavailable) {$postreply .= "Status=OK ZFS backup not available, only doing local snapshots\n";}
4448
        my $zfscmd = "zfs";
4449
        my $macip;
4450
        my $ipath = $spools[0]->{'zfs'} || 'stabile-images/images';
4451
        my @nspools = @spools;
4452
        if (!(defined $obj->{'storagepool'}) || $storagepool == -1) {
4453
            @nspools = () if ($storagepool == -1); # Only do node backups
4454
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4455
#            my $nipath = $ipath;
4456
#            $nipath = "$1/node" if ($nipath =~ /(.+)\/(.+)/);
4457
            my $nipath = 'stabile-node/node';
4458
            foreach my $node (values %nodereg) {
4459
                push @nspools, {
4460
                    mac=>$node->{'mac'},
4461
                    macip=>$node->{'ip'},
4462
                    zfs=>$nipath,
4463
                    id=>-1
4464
                } if ($node->{'stor'} eq 'zfs' && (!$mac || $node->{'mac'} eq $mac))
4465
            }
4466
            untie %nodereg;
4467
        }
4468
        if (`pgrep zfs`) {
4469
            $postreply .= "Status=ERROR Another ZFS backup is running. Please wait a minute...\n";
4470
            $postmsg = "ERROR ERROR Another ZFS backup is running. Please wait a minute...";
4471
            return $postreply;
4472
        }
4473
        $postreply .= "Status=OK Performing ZFS backup on " . (scalar @nspools) . " storage pools with image retention $imageretention, backup retention $backupretention\n";
4474

    
4475
        foreach my $spool (@nspools) {
4476
            $ipath = $spool->{'zfs'};
4477
            if ($spool->{'id'} == -1) { # We're doing a node backup
4478
                $mac = $spool->{'mac'};
4479
                $macip = $spool->{'macip'};
4480
                $bpath = "$basepath/node-$mac";
4481
            } else {
4482
                next unless ($ipath);
4483
                next if (($storagepool || $storagepool eq '0') && $storagepool ne $spool->{'id'});
4484
                $bpath = "$basepath/$1" if ($ipath =~ /.+\/(.+)/);
4485
                $mac = '';
4486
                $macip = '';
4487
            }
4488
            if ($macip) {$zfscmd = "$sshcmd $macip sudo zfs";}
4489
            else {$zfscmd = "zfs";}
4490

    
4491
            $postreply .= "Status=OK Commencing ZFS backup of $ipath $macip\n";
4492
            my $res;
4493
            my $cmd;
4494
            my @imagesnaps;
4495
            my @backupsnaps;
4496

    
4497
            # example: stabile-images/images@SNAPSHOT-20200524172901
4498
            $cmd = qq/$zfscmd list -t snapshot | grep '$ipath'/;
4499
            my $snaplist = `$cmd`;
4500
            my @snaplines = split("\n", $snaplist);
4501
            foreach my $snap (@snaplines) {
4502
                push @imagesnaps, $2 if ($snap =~ /(.*)\@SNAPSHOT-(\d+)/);
4503
            }
4504
            if ($zbackupavailable) {
4505
                $cmd = qq/zfs list -t snapshot | grep '$bpath'/;
4506
                $snaplist = `$cmd`;
4507
                @snaplines = split("\n", $snaplist);
4508
                foreach my $snap (@snaplines) {
4509
                    push @backupsnaps, $2 if ($snap =~ /(.*)\@SNAPSHOT-(\d+)/);
4510
                }
4511
            }
4512
        # Find matching snapshots
4513
            my $matches=0;
4514
            my $matchbase = 0;
4515
            foreach my $bsnap (@backupsnaps) {
4516
                if ($bsnap eq $imagesnaps[$matchbase + $matches]) { # matching snapshot found
4517
                    $matches++;
4518
                } elsif ($matches) { # backup snapshots are ahead of image snapshots - correct manually, i.e. delete them.
4519
                    $postreply .= "Status=ERROR Snapshots are out of sync.\n";
4520
                    $postmsg = "ERROR Snapshots are out of sync";
4521
                    $main::syslogit->($user, 'info', "ERROR snapshots of $ipath and $bpath are out of sync.");
4522
                    return $postreply;
4523
                } elsif (!$matchbase) { # Possibly there are image snapshots older than there are backup snapshots, find the match base i.e. first match in @imagesnaps
4524
                    my $mb=0;
4525
                    foreach my $isnap (@imagesnaps) {
4526
                        if ($bsnap eq $isnap) { # matching snapshot found
4527
                            $matchbase = $mb;
4528
                            $matches++;
4529
                            last;
4530
                        }
4531
                        $mb++;
4532
                    }
4533
                }
4534
            }
4535

    
4536
            my $lastisnap = $imagesnaps[scalar @imagesnaps -1];
4537
            my $lastisnaptime = timelocal($6,$5,$4,$3,$2-1,$1) if ($lastisnap =~ /(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/);
4538
            my $td = ($current_time - $lastisnaptime);
4539
            if ($td<=5) {
4540
                $postreply .= "Status=ERROR Last backup was taken $td seconds ago. Please wait a minute...\n";
4541
                $postmsg = "ERROR ERROR Last backup was taken $td seconds ago. Please wait a minute...";
4542
                return $postreply;
4543
            }
4544
            my $ni = scalar @imagesnaps;
4545
            my $nb = scalar @backupsnaps;
4546
        # If there are unsynced image snaps - sync them
4547
            if ($zbackupavailable && !$snaponly) {
4548
                if (scalar @imagesnaps > $matches+$matchbase) {
4549
                    for (my $j=$matches+$matchbase; $j < scalar @imagesnaps; $j++) {
4550
                        if ($macip) {
4551
                            $cmd = qq[$zfscmd "send -i $ipath\@SNAPSHOT-$imagesnaps[$j-1] $ipath\@SNAPSHOT-$imagesnaps[$j] | ssh 10.0.0.1 sudo zfs receive $bpath"]; # -R
4552
                        } else {
4553
                            $cmd = qq[zfs send -i $ipath\@SNAPSHOT-$imagesnaps[$j-1] $ipath\@SNAPSHOT-$imagesnaps[$j] | zfs receive $bpath]; # -R
4554
                        }
4555
                        $res = `$cmd 2>&1`;
4556
                        unless ($res && !$macip) { # ssh will warn about adding to list of known hosts
4557
                            $matches++;
4558
                            $nb++;
4559
                        }
4560
                        $postreply .= "Status=OK Sending ZFS snapshot $imagesnaps[$j-1]->$imagesnaps[$j] of $macip $ipath to $bpath $res\n";
4561
                        $main::syslogit->($user, 'info', "OK Sending ZFS snapshot $imagesnaps[$j-1]->$imagesnaps[$j] of $macip $ipath to $bpath $res");
4562
                    }
4563
                }
4564
            }
4565
            $res = '';
4566

    
4567
            if ($matches && !$synconly) { # snapshots are in sync
4568
        # Then perform the actual snapshot
4569
                my $snap1 = sprintf "%4d%02d%02d%02d%02d%02d",$year,$mon+1,$mday,$hour,$min,$sec;
4570
                my $oldsnap = $imagesnaps[$matches+$matchbase-1];
4571
                $cmd = qq|$zfscmd snapshot -r $ipath\@SNAPSHOT-$snap1|;
4572
                $postreply .= "Status=OK Performing ZFS snapshot with $matches matches and base $matchbase $res\n";
4573
                $res = `$cmd 2>&1`;
4574
                unless ($res && !$macip) {
4575
                    $ni++;
4576
                    push @imagesnaps, $snap1;
4577
                }
4578
        # Send it to backup if asked to
4579
                unless ($snaponly || !$zbackupavailable) {
4580
                    if ($macip) {
4581
                        $cmd = qq[$zfscmd "send -i $ipath\@SNAPSHOT-$oldsnap $ipath\@SNAPSHOT-$snap1 | ssh 10.0.0.1 sudo zfs receive $bpath"];
4582
                    } else {
4583
                        $cmd = qq[zfs send -i $ipath\@SNAPSHOT-$oldsnap $ipath\@SNAPSHOT-$snap1 | zfs receive $bpath]; # -R
4584
                    }
4585
                    $res .= `$cmd 2>&1`;
4586
                    unless ($res && !$macip) {
4587
                        $matches++;
4588
                        $nb++;
4589
                        push @backupsnaps, $snap1;
4590
                    }
4591
                    $postreply .= "Status=OK Sending ZFS snapshot of $macip $ipath $oldsnap->$snap1 to $bpath $res\n";
4592
                    $main::syslogit->($user, 'info', "OK Sending ZFS snapshot of $macip $ipath $oldsnap->$snap1 to $bpath $res");
4593
                }
4594
                $postreply .= "Status=OK Synced $matches ZFS snapshots. There are now $ni image snapshots, $nb backup snapshots.\n";
4595
            } elsif ($matches) {
4596
                $postreply .= "Status=OK Synced $matches ZFS snapshots. There are $ni image snapshots, $nb backup snapshots.\n";
4597
#            } elsif ($ni==0 && $nb==0) { # We start from a blank slate
4598
            } elsif ($nb==0) { # We start from a blank slate
4599
                my $snap1 = sprintf "%4d%02d%02d%02d%02d%02d",$year,$mon+1,$mday,$hour,$min,$sec;
4600
                $cmd = qq|$zfscmd snapshot -r $ipath\@SNAPSHOT-$snap1|;
4601
                $res = `$cmd 2>&1`;
4602
                $postreply .= "Status=OK Performing ZFS snapshot $res $macip\n";
4603
        # Send it to backup by creating new filesystem
4604
                unless ($snaponly || !$zbackupavailable) {
4605
                    if ($macip) {
4606
                        $cmd = qq[$zfscmd "send $ipath\@SNAPSHOT-$snap1 | ssh 10.0.0.1 sudo zfs receive $bpath"];
4607
                        $res .= `$cmd 2>&1`;
4608
                        $cmd = qq|zfs set readonly=on $bpath|;
4609
                        $res .= `$cmd 2>&1`;
4610
                        $cmd = qq|zfs mount $bpath|;
4611
                        $res .= `$cmd 2>&1`;
4612
                    } else {
4613
                        $cmd = qq[zfs send -R $ipath\@SNAPSHOT-$snap1 | zfs receive $bpath];
4614
                        $res .= `$cmd 2>&1`;
4615
                        $cmd = qq|zfs set readonly=on $bpath|;
4616
                        $res .= `$cmd 2>&1`;
4617
                    }
4618
                    $postreply .= "Status=OK Sending complete ZFS snapshot of $macip:$ipath\@$snap1 to $bpath $res\n";
4619
                    $main::syslogit->($user, 'info', "OK Sending complete ZFS snapshot of $macip:$ipath\@$snap1 to $bpath $res");
4620
                    $matches++;
4621
                    $nb++;
4622
                }
4623
                $ni++;
4624
                $postreply .= "Status=OK Synced ZFS snapshots. There are $ni image snapshots, $nb backup snapshots.\n";
4625
            } else {
4626
                $postreply .= "Status=ERROR Unable to sync snapshots.\n";
4627
                $postmsg = "ERROR Unable to sync snapshots";
4628
            }
4629
            my $i=0;
4630
        # Purge image snapshots if asked to
4631
            if ($imageretention && $matches>1) {
4632
                my $rtime;
4633
                if ($imageretention =~ /(\d+)(s|h|d)/) {
4634
                    $rtime = $1;
4635
                    $rtime = $1*60*60 if ($2 eq 'h');
4636
                    $rtime = $1*60*60*24 if ($2 eq 'd');
4637
                    $postreply .= "Status=OK Keeping image snapshots newer than $imageretention out of $ni.\n";
4638
                } elsif ($imageretention =~ /(\d+)$/) {
4639
                    $postreply .= "Status=OK Keeping " . (($imageretention>$ni)?$ni:$imageretention) . " image snapshots out of $ni.\n";
4640
                } else {
4641
                    $imageretention = 0;
4642
                }
4643
                if ($imageretention) {
4644
                    foreach my $isnap (@imagesnaps) {
4645
                        my $purge;
4646
                        if ($rtime) {
4647
                            my $snaptime = timelocal($6,$5,$4,$3,$2-1,$1) if ($isnap =~ /(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/);
4648
                            my $tdiff = ($current_time - $snaptime);
4649
                            if ( $matches>1 && $tdiff>$rtime )
4650
                                {$purge = 1;}
4651
                            else
4652
                                {last;}
4653
                        } else { # a simple number was specified
4654
#                            if ( $matches>1 && $matches+$matchbase>$imageretention )
4655
                            if ( $matches>1 && $ni>$imageretention )
4656
                                {$purge = 1;}
4657
                            else
4658
                                {last;}
4659
                        }
4660
                        if ($purge) {
4661
                            $cmd = qq|$zfscmd destroy $ipath\@SNAPSHOT-$isnap|;
4662
                            $res = `$cmd 2>&1`;
4663
                            $postreply .= "Status=OK Purging image snapshot $isnap from $ipath.\n";
4664
                            $main::syslogit->($user, 'info', "OK Purging image snapshot $isnap from $ipath");
4665
                            $matches-- if ($i>=$matchbase);
4666
                            $ni--;
4667
                        }
4668
                        $i++;
4669
                    }
4670
                }
4671
            }
4672
            # Purge backup snapshots if asked to
4673
            if ($backupretention && $matches) {
4674
                my $rtime;
4675
                if ($backupretention =~ /(\d+)(s|h|d)/) {
4676
                    $rtime = $1;
4677
                    $rtime = $1*60*60 if ($2 eq 'h');
4678
                    $rtime = $1*60*60*24 if ($2 eq 'd');
4679
                    $postreply .= "Status=OK Keeping backup snapshots newer than $backupretention out of $nb.\n";
4680
                } elsif ($backupretention =~ /(\d+)$/) {
4681
                    $postreply .= "Status=OK Keeping " . (($backupretention>$nb)?$nb:$backupretention) . " backup snapshots out of $nb.\n";
4682
                } else {
4683
                    $backupretention = 0;
4684
                }
4685
                if ($backupretention && $zbackupavailable) {
4686
                    foreach my $bsnap (@backupsnaps) {
4687
                        my $purge;
4688
                        if ($bsnap eq $imagesnaps[$matchbase+$matches-1]) { # We need to keep the last snapshot synced
4689
                            $postreply .= "Status=OK Not purging backup snapshot $matchbase $bsnap.\n";
4690
                            last;
4691
                        } else {
4692
                            if ($rtime) {
4693
                                my $snaptime = timelocal($6,$5,$4,$3,$2-1,$1) if ($bsnap =~ /(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/);
4694
                                my $tdiff = ($current_time - $snaptime);
4695
                                if ( $matches>1 && $tdiff>$rtime )
4696
                                    {$purge = 1;}
4697
                            } else {
4698
                                if ( $nb>$backupretention )
4699
                                    {$purge = 1;}
4700
                            }
4701
                            if ($purge) {
4702
                                $cmd = qq|zfs destroy $bpath\@SNAPSHOT-$bsnap|;
4703
                                $res = `$cmd 2>&1`;
4704
                                $postreply .= "Status=OK Purging backup snapshot $bsnap from $bpath.\n";
4705
                                $main::syslogit->($user, 'info', "OK Purging backup snapshot $bsnap from $bpath");
4706
                                $nb--;
4707
                            } else {
4708
                                last;
4709
                            }
4710
                        }
4711
                    }
4712
                }
4713
            }
4714
            $postmsg .= "OK Performing ZFS backup of $bpath. There are $ni image snapshots and $nb backup snapshots. ";
4715
        }
4716
        $postreply .= "Status=OK Updating all btimes\n";
4717
        Updateallbtimes();
4718
    } else {
4719
        $postreply .= "Status=ERROR Not allowed\n";
4720
        $postmsg = "ERROR Not allowed";
4721
    }
4722
    $main::updateUI->({tab=>"images", user=>$user, type=>"message", message=>$postmsg});
4723
    return $postreply;
4724
}
4725

    
4726
sub Backupfuel {
4727
    my ($image, $action, $obj) = @_;
4728
    if ($help) {
4729
        return <<END
4730
GET:username, dozfs:
4731
Backs up a user's fuel storage. If [dozfs] is set, fuel on ZFS volumes is backed up, even if it should be handled by regular ZFS backups.
4732
END
4733
    }
4734
    my $username = $obj->{'username'} || $user;
4735
    return "Status=Error Not allowed\n" unless ($isadmin || $username eq $user);
4736

    
4737
    my $remolder = "14D";
4738
    my $stordevs = Liststoragedevices('', 'getstoragedevices');
4739
    my $backupdev = Getbackupdevice('', 'getbackupdevice');
4740
    my $backupdevtype = $stordevs->{$backupdev}->{type};
4741
    foreach my $spool (@spools) {
4742
        my $ppath = $spool->{"path"};
4743
        my $pid = $spool->{"id"};
4744
        if (($spool->{"zfs"} && $backupdevtype eq 'zfs') && !$obj->{'dozfs'}) {
4745
            $postreply .= "Status=OK Skipping fuel on ZFS storage: $ppath/$username/fuel\n";
4746
        } elsif ($pid eq '-1') {
4747
            ;
4748
        } elsif (!$backupdir || !(-d $backupdir)) {
4749
            $postreply .= "Status=OK Backup dir $backupdir does not exist\n";
4750
        } elsif (-d "$ppath/$username/fuel" && !is_folder_empty("$ppath/$username/fuel")) {
4751
            my $srcdir = "$ppath/$username/fuel";
4752
            my $destdir = "$backupdir/$username/fuel/$pid";
4753

    
4754
            `mkdir -p "$destdir"` unless (-e "$destdir");
4755
            # Do the backup
4756
            my $cmd = qq|/usr/bin/rdiff-backup --print-statistics "$srcdir" "$destdir"|;
4757
            my $res = `$cmd`;
4758
            $cmd = qq|/usr/bin/rdiff-backup --print-statistics --force --remove-older-than $remolder "$destdir"|;
4759
            $res .= `$cmd`;
4760
            if ($res =~ /Errors 0/) {
4761
                my $change = $1 if ($res =~ /TotalDestinationSizeChange \d+ \((.+)\)/);
4762
                $postreply .= "Status=OK Backed up $change, $srcdir -> $destdir\n";
4763
                $main::syslogit->($user, "info", "OK backed up $change, $srcdir -> $destdir") if ($change);
4764
            } else {
4765
                $res =~ s/\n/ /g;
4766
                $postreply .= "Status=Error There was a problem backup up $srcdir -> $destdir: $res\n";
4767
                $main::syslogit->($user, "there was a problem backup up $srcdir -> $destdir");
4768
            }
4769
        } else {
4770
            $postreply .= "Status=OK Skipping empty fuel on: $ppath/$username/fuel\n";
4771
        }
4772
    }
4773
    return $postreply;
4774
}
4775

    
4776
sub is_folder_empty {
4777
    my $dirname = shift;
4778
    opendir(my $dh, $dirname) or die "Not a directory";
4779
    return scalar(grep { $_ ne "." && $_ ne ".." } readdir($dh)) == 0;
4780
}
4781

    
4782
sub Backup {
4783
    my ($image, $action, $obj) = @_;
4784
    if ($help) {
4785
        return <<END
4786
GET:image, skipzfs:
4787
Backs an image up. Set [skipzfs] if ZFS backup is configured, and you do not want to skip images on ZFS storage.
4788
END
4789
    }
4790
    my $path = $obj->{path} || $image;
4791
    my $status = $obj->{status};
4792
    my $skipzfs = $obj->{skipzfs};
4793
    $uistatus = "backingup";
4794
    $uipath = $path;
4795
    my $remolder;
4796
    $remolder = "14D" if ($obj->{bschedule} eq "daily14");;
4797
    $remolder = "7D" if ($obj->{bschedule} eq "daily7");
4798

    
4799
    my $stordevs = Liststoragedevices('', 'getstoragedevices');
4800
    my $backupdev = Getbackupdevice('', 'getbackupdevice');
4801
    my $backupdevtype = $stordevs->{$backupdev}->{type};
4802
    # Nodes are assumed to alwasy use ZFS
4803
    if ($backupdevtype eq 'zfs' && $skipzfs && ($obj->{regstoragepool} == -1 || $spools[$obj->{regstoragepool}]->{'zfs'})) {
4804
        return "Status=OK Skipping image on ZFS $path\n";
4805
    }
4806
    if ($status eq "snapshotting" || $status eq "unsnapping" || $status eq "reverting" || $status eq "cloning" ||
4807
        $status eq "moving" || $status eq "converting") {
4808
        $postreply .= "Status=ERROR Problem backing up $obj->{type} image: $obj->{name}\n";
4809
    } elsif ($obj->{regstoragepool} == -1) {
4810
        if (createNodeTask($obj->{mac}, "BACKUP $user $uistatus $status \"$path\" \"$backupdir\" $remolder")) {
4811
            $postreply .= "OK not backingup image: $obj->{name} (on node, node probably asleep)\n";
4812
        } else {
4813
            $register{$path}->{'status'} = $uistatus;
4814
            $uistatus = "lbackingup" if ($status eq "active"); # Do lvm snapshot before backing up
4815
            $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4816
            $postreply .= "Status=backingup OK backingup image: $obj->{name} (on node)\n";
4817
        }
4818
    } elsif (!$spools[$obj->{regstoragepool}]->{'rdiffenabled'}) {
4819
        $postreply .= "Status=ERROR Rdiff-backup has not been enabled for this storagepool ($spools[$obj->{regstoragepool}]->{'name'})\n";
4820
    } else {
4821
        if ($spools[$obj->{regstoragepool}]->{'hostpath'} eq "local" && $status eq "active") {
4822
            my $poolpath = $spools[$obj->{regstoragepool}]->{'path'};
4823
            # We only need to worry about taking an LVM snapshot if the image is in active use
4824
            # We also check if the images is actually on an LVM partition
4825
            my $qi = `/bin/cat /proc/mounts | grep "$poolpath"`; # Find the lvm volume mounted on /mnt/images
4826
            ($qi =~ m/\/dev\/mapper\/(\S+)-(\S+) $pool.+/g)[-1]; # Select last match
4827
            my $lvolgroup = $1;
4828
            my $lvol = $2;
4829
            if ($lvolgroup && $lvol) {
4830
                $uistatus = "lbackingup";
4831
            }
4832
        }
4833
        if ($uistatus ne "lbackingup" && $status eq "active") {
4834
            $postreply .= "Status=ERROR Image is not on an LVM partition - suspend before backing up.\n";
4835
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", path=>$path, status=>$uistatus, message=>"Image is not on an LVM partition - suspend before backing up"});
4836
        } else {
4837
            my $buser;
4838
            my $bname;
4839
            if ($path =~ /.*\/(common|$user)\/(.+)/) {
4840
                $buser = $1;
4841
                $bname = $2;
4842
            }
4843
            if ($buser && $bname) {
4844
                my $dirpath = $spools[$obj->{regstoragepool}]->{'path'};
4845
                #chop $dirpath; # Remove last /
4846
                eval {
4847
                    $register{$path}->{'status'} = $uistatus;
4848
                    my $daemon = Proc::Daemon->new(
4849
                        work_dir => '/usr/local/bin',
4850
                        exec_command => "perl -U steamExec $buser $uistatus $status \"$bname\" \"$dirpath\" \"$backupdir\" $remolder"
4851
                    ) or do {$postreply .= "Status=ERROR $@\n";};
4852
                    my $pid = $daemon->Init();
4853
                    $postreply .=  "Status=backingup OK backingup image: $obj->{name}\n";
4854
                    $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $bname");
4855
                    1;
4856
                } or do {$postreply .= "Status=ERROR $@\n";}
4857
            } else {
4858
                $postreply .= "Status=ERROR Problem backing up $path\n";
4859
            }
4860
        }
4861
    }
4862
    return $postreply;
4863
}
4864

    
4865
sub Restore {
4866
    my ($image, $action, $obj) = @_;
4867
    if ($help) {
4868
        return <<END
4869
GET:image:
4870
Backs an image up.
4871
END
4872
    }
4873
    my $path = $obj->{path};
4874
    my $status = $obj->{status};
4875
    $uistatus = "restoring";
4876
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
4877
    my $backup = $params{"backup"} || $obj->{backup};
4878
    my $pool = $register{$path}->{'storagepool'};
4879
    $pool = "0" if ($pool == -1);
4880
    my $poolpath = $spools[$pool]->{'path'};
4881
    my $restorefromdir = $backupdir;
4882
    my $inc = $backup;
4883
    my $subdir; # 1 level of subdirs supported
4884
    $subdir = $1 if ($dirpath =~ /.+\/$obj->{user}(\/.+)?\//);
4885

    
4886
    if ($backup =~ /^SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/) { # We are dealing with a zfs restore
4887
        $inc = "$1-$2-$3-$4-$5-$6";
4888
        foreach my $spool (@spools) {
4889
            my $ppath = $spool->{"path"};
4890
            if (-e "$ppath/.zfs/snapshot/$backup/$obj->{user}$subdir/$bname$suffix") {
4891
                $restorefromdir = "$ppath/.zfs/snapshot/$backup";
4892
                last;
4893
            }
4894
        }
4895
    } else {
4896
        if ($backup eq "mirror") {
4897
            my $mir = `/bin/ls "$backupdir/$obj->{user}/$bname$suffix/rdiff-backup-data" | grep current_mirror`;
4898
            if ($mir =~ /current_mirror\.(\S+)\.data/) {
4899
                $inc = $1;
4900
            }
4901
        }
4902
        $inc =~ tr/:T/-/; # qemu-img does not like colons in file names - go figure...
4903
        $inc = substr($inc,0,-6);
4904
    }
4905
    $uipath = "$poolpath/$obj->{user}$subdir/$bname.$inc$suffix";
4906
    my $i;
4907
    if (-e $uipath) {
4908
        $i = 1;
4909
        while (-e "$poolpath/$obj->{user}$subdir/$bname.$inc.$i$suffix") {$i++;}
4910
        $uipath = "$poolpath/$obj->{user}$subdir/$bname.$inc.$i$suffix";
4911
    }
4912

    
4913
    if (-e $uipath) {
4914
        $postreply .= "Status=ERROR This image is already being restored\n";
4915
    } elsif ($obj->{user} ne $user && !$isadmin) {
4916
        $postreply .= "Status=ERROR No restore privs\n";
4917
    } elsif (!$backup || $backup eq "--") {
4918
        $postreply .= "Status=ERROR No backup selected\n";
4919
    } elsif (overQuotas($obj->{virtualsize})) {
4920
        $postreply .= "Status=ERROR Over quota (". overQuotas($obj->{virtualsize}) . ") restoring: $obj->{name}\n";
4921
    } elsif (overStorage($obj->{ksize}*1024, $pool+0)) {
4922
        $postreply .= "Status=ERROR Out of storage in destination pool restoring: $obj->{name}\n";
4923
    } else {
4924
        my $ug = new Data::UUID;
4925
        my $newuuid = $ug->create_str();
4926
        $register{$uipath} = {
4927
            uuid=>$newuuid,
4928
            status=>"restoring",
4929
            name=>"$obj->{name} ($inc)" . (($i)?" $i":''),
4930
            notes=>$obj->{notes},
4931
            image2=>$obj->{image2},
4932
            managementlink=>$obj->{managementlink},
4933
            upgradelink=>$obj->{upgradelink},
4934
            terminallink=>$obj->{terminallink},
4935
            size=>0,
4936
            realsize=>0,
4937
            virtualsize=>$obj->{virtualsize},
4938
            type=>$obj->{type},
4939
            user=>$user
4940
        };
4941
        eval {
4942
            $register{$path}->{'status'} = $uistatus;
4943
            my $daemon = Proc::Daemon->new(
4944
                work_dir => '/usr/local/bin',
4945
                exec_command => "perl -U steamExec $obj->{user} $uistatus $status \"$path\" \"$restorefromdir\" \"$backup\" \"$uipath\""
4946
            ) or do {$postreply .= "Status=ERROR $@\n";};
4947
            my $pid = $daemon->Init();
4948
            $postreply .=  "Status=$uistatus OK $uistatus $obj->{type} image: $obj->{name} ($inc)". ($console?", $newuuid\n":"\n");
4949
            $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name} ($inc), $uipath, $newuuid: $uuid");
4950
            1;
4951
        } or do {$postreply .= "Status=ERROR $@\n";};
4952
        $main::updateUI->({tab=>"images", user=>$user, type=>"update"});
4953
    }
4954
    return $postreply;
4955
}
4956

    
4957
sub Master {
4958
    my ($image, $action, $obj) = @_;
4959
    if ($help) {
4960
        return <<END
4961
GET:image:
4962
Converts an image to a master image. Image must not be in use.
4963
END
4964
    }
4965
    my $path = $obj->{path};
4966
    my $status = $register{$path}->{status};
4967
    $path =~ /(.+)\.$obj->{type}$/;
4968
    my $namepath = $1;
4969
    my $uiname;
4970
    if (!$register{$path}) {
4971
        $postreply .= "Status=ERROR Image $path not found\n";
4972
    } elsif ($status ne "unused") {
4973
        $postreply .= "Status=ERROR Only unused images may be mastered\n";
4974
#    } elsif ($namepath =~ /(.+)\.master/ || $register{$path}->{'master'}) {
4975
#        $postreply .= "Status=ERROR Only one level of mastering is supported\n";
4976
    } elsif ($obj->{istoragepool} == -1 || $obj->{regstoragepool} == -1) {
4977
        $postreply .= "Status=ERROR Unable to master $obj->{name} (master images are not supported on node storage)\n";
4978
    } elsif ($obj->{type} eq "qcow2") {
4979
        # Promoting a regular image to master
4980
        # First find an unused path
4981
        if (-e "$namepath.master.$obj->{type}") {
4982
            my $i = 1;
4983
            while ($register{"$namepath.$i.master.$obj->{type}"} || -e "$namepath.$i.master.$obj->{type}") {$i++;};
4984
            $uinewpath = "$namepath.$i.master.$obj->{type}";
4985
        } else {
4986
            $uinewpath = "$namepath.master.$obj->{type}";
4987
        }
4988

    
4989
        $uipath = $path;
4990
        $uiname = "$obj->{name}";
4991
        eval {
4992
            my $qinfo = `/bin/mv -iv "$path" "$uinewpath"`;
4993
            $register{$path}->{'name'} = $uiname;
4994
            $register{$uinewpath} = $register{$path};
4995
            delete $register{$path};
4996
            $postreply .= "Status=$status Mastered $obj->{type} image: $obj->{name}\n";
4997
            chop $qinfo;
4998
            $main::syslogit->($user, "info", $qinfo);
4999
            1;
5000
        } or do {$postreply .= "Status=ERROR $@\n";};
5001
        sleep 1;
5002
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, newpath=>$uinewpath, status=>$status, name=>$uiname});
5003
    } else {
5004
        $postreply .= "Status=ERROR Only qcow2 images may be mastered\n";
5005
    }
5006
    return $postreply;
5007
}
5008

    
5009
sub Unmaster {
5010
    my ($image, $action, $obj) = @_;
5011
    if ($help) {
5012
        return <<END
5013
GET:image:
5014
Converts a master image to a regular image. Image must not be in use.
5015
END
5016
    }
5017
    my $path = $obj->{path};
5018
    my $status = $register{$path}->{status};
5019
    $path =~ /(.+)\.$obj->{type}$/;
5020
    my $namepath = $1;
5021
    my $haschildren = 0;
5022
    my $child;
5023
    my $uinewpath;
5024
    my $iname;
5025
    my @regvalues = values %register;
5026
    foreach my $val (@regvalues) {
5027
        if ($val->{'master'} eq $path) {
5028
            $haschildren = 1;
5029
            $child = $val->{'name'};
5030
            last;
5031
        }
5032
    }
5033
    if (!$register{$path}) {
5034
        $postreply .= "Status=ERROR Image $path not found\n";
5035
    } elsif ($haschildren) {
5036
        $postreply .= "Status=Error Cannot unmaster image. This image is used as master by: $child\n";
5037
    } elsif ($status ne "unused" && $status ne "used") {
5038
        $postreply .= "Status=ERROR Only used and unused images may be unmastered\n";
5039
    } elsif (!( ($namepath =~ /(.+)\.master/) || ($obj->{master} && $obj->{master} ne "--")) ) {
5040
        $postreply .= "Status=ERROR You can only unmaster master or child images\n";
5041
    } elsif (($obj->{istoragepool} == -1 || $obj->{regstoragepool} == -1) && $namepath =~ /(.+)\.master/) {
5042
        $postreply .= "Status=ERROR Unable to unmaster $obj->{name} (master images are not supported on node storage)\n";
5043
    } elsif ($obj->{type} eq "qcow2") {
5044
        # Demoting a master to regular image
5045
        if ($action eq 'unmaster' && $namepath =~ /(.+)\.master$/) {
5046
            $namepath = $1;
5047
            $uipath = $path;
5048
            # First find an unused path
5049
            if (-e "$namepath.$obj->{type}") {
5050
                my $i = 1;
5051
                while ($register{"$namepath.$i.$obj->{type}"} || -e "$namepath.$i.$obj->{type}") {$i++;};
5052
                $uinewpath = "$namepath.$i.$obj->{type}";
5053
            } else {
5054
                $uinewpath = "$namepath.$obj->{type}";
5055
            }
5056

    
5057
            $iname = $obj->{name};
5058
            $iname =~ /(.+)( \(master\))/;
5059
            $iname = $1 if $2;
5060
            eval {
5061
                my $qinfo = `/bin/mv -iv "$path" "$uinewpath"`;
5062
                $register{$path}->{'name'} = $iname;
5063
                $register{$uinewpath} = $register{$path};
5064
                delete $register{$path};
5065
                $postreply .=  "Status=$status Unmastered $obj->{type} image: $obj->{name}\n";
5066
                chomp $qinfo;
5067
                $main::syslogit->($user, "info", $qinfo);
5068
                1;
5069
            } or do {$postreply .= "Status=ERROR $@\n";}
5070
    # Rebasing a child image
5071
        } elsif ($action eq 'rebase' && $obj->{master} && $obj->{master} ne "--") {
5072
            $uistatus = "rebasing";
5073
            $uipath = $path;
5074
            $iname = $obj->{name};
5075
            $iname =~ /(.+)( \(child\d*\))/;
5076
            $iname = $1 if $2;
5077
            my $temppath = "$path.temp";
5078
            $uipath = $path;
5079
            $uimaster = "--";
5080
            my $macip;
5081

    
5082
            if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
5083
                unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
5084
                $macip = $nodereg{$obj->{mac}}->{'ip'};
5085
                untie %nodereg;
5086
            }
5087
            eval {
5088
                my $master = $register{$path}->{'master'};
5089
                my $usedmaster = '';
5090
#                @regvalues = values %register;
5091
                if ($master && $master ne '--') {
5092
                    foreach my $valref (@regvalues) {
5093
                        $usedmaster = 1 if ($valref->{'master'} eq $master && $valref->{'path'} ne $path); # Check if another image is also using this master
5094
                    }
5095
                }
5096
                $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$uistatus});
5097
                $register{$path} = {
5098
                    master=>"",
5099
                    name=>"$iname",
5100
                    notes=>$obj->{notes},
5101
                    status=>$uistatus,
5102
                    snap1=>$obj->{snap1},
5103
                    managementlink=>$obj->{managementlink},
5104
                    upgradelink=>$obj->{upgradelink},
5105
                    terminallink=>$obj->{terminallink},
5106
                    image2=>$obj->{image2},
5107
                    storagepool=>$obj->{istoragepool},
5108
                    status=>$uistatus
5109
                };
5110

    
5111
                if ($macip) {
5112
                    my $esc_localpath = shell_esc_chars($path);
5113
                    my $esc_localpath2 = shell_esc_chars($temppath);
5114
                    $res .= `$sshcmd $macip "/usr/bin/qemu-img convert $esc_localpath -O qcow2 $esc_localpath2"`;
5115
                    $res .= `$sshcmd $macip "if [ -f $esc_localpath2 ]; then /bin/mv -v $esc_localpath2 $esc_localpath; fi"`;
5116
                } else {
5117
                    $res .= `/usr/bin/qemu-img convert -O qcow2 "$path" "$temppath"`;
5118
                    $res .= `if [ -f "$temppath" ]; then /bin/mv -v "$temppath" "$path"; fi`;
5119
                }
5120
                if ($master && !$usedmaster) {
5121
                    $register{$master}->{'status'} = 'unused';
5122
                    $main::syslogit->('info', "Freeing master $master");
5123
                }
5124
                $register{$path}->{'master'} = '';
5125
                $register{$path}->{'status'} = $status;
5126

    
5127
                $postreply .= "Status=OK $uistatus $obj->{type} image: $obj->{name}\n";
5128
                $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status});
5129
                $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
5130
                1;
5131
            } or do {$postreply .= "Status=ERROR $@\n";}
5132
        } else {
5133
            $postreply .= "Status=ERROR Not a master, not a child \"$obj->{name}\"\n";
5134
        }
5135
        sleep 1;
5136
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, newpath=>$uinewpath, name=>$iname, status=>$status});
5137
    } else {
5138
        $postreply .= "Status=ERROR Only qcow2 images may be unmastered\n";
5139
    }
5140
    return $postreply;
5141
}
5142

    
5143
# Save or create new image
5144
sub Save {
5145
    my ($img, $action, $obj) = @_;
5146
    if ($help) {
5147
        return <<END
5148
POST:path, uuid, name, type, virtualsize, storagepool, user:
5149
To save a collection of images you either PUT or POST a JSON array to the main endpoint with objects representing the images with the changes you want.
5150
Depending on your privileges not all changes are permitted. If you save without specifying a uuid or path, a new image is created.
5151
END
5152
    }
5153
    my $path = $obj->{path};
5154
    my $uuid = $obj->{uuid};
5155
    my $status = $obj->{status};
5156
    if ($status eq "new") {
5157
        # Create new image
5158
        my $ug = new Data::UUID;
5159
        if (!$uuid || $uuid eq '--') {
5160
            $uuid = $ug->create_str();
5161
        } else { # Validate
5162
            my $valuuid  = $ug->from_string($uuid);
5163
            if ($ug->to_string($valuuid) eq $uuid) {
5164
                ;
5165
            } else {
5166
                $uuid = $ug->create_str();
5167
            }
5168
        }
5169
        my $newuuid = $uuid;
5170
        my $pooldir = $spools[$obj->{storagepool}]->{'path'};
5171
        my $cmd;
5172
        my $name = $obj->{name};
5173
        $name =~ s/\./_/g; # Remove unwanted chars
5174
        $name =~ s/\//_/g;
5175
        eval {
5176
            my $ipath = "$pooldir/$user/$name.$obj->{type}";
5177
            $obj->{type} = "qcow2" unless ($obj->{type});
5178
            # Find an unused path
5179
            if ($register{$ipath} || -e "$ipath") {
5180
                my $i = 1;
5181
                while ($register{"$pooldir/$user/$name.$i.$obj->{type}"} || -e "$pooldir/$user/$name.$i.$obj->{type}") {$i++;};
5182
                $ipath = "$pooldir/$user/$name.$i.$obj->{type}";
5183
                $name = "$name.$i";
5184
            }
5185

    
5186
            if ($obj->{type} eq 'qcow2' || $obj->{type} eq 'vmdk') {
5187
                my $size = ($obj->{msize})."M";
5188
                my $format = "qcow2";
5189
                $format = "vmdk" if ($path1 =~ /\.vmdk$/);
5190
                $cmd = qq|/usr/bin/qemu-img create -f $format "$ipath" "$size"|;
5191
            } elsif ($obj->{type} eq 'img') {
5192
                my $size = ($obj->{msize})."M";
5193
                $cmd = qq|/usr/bin/qemu-img create -f raw "$ipath" "$size"|;
5194
            } elsif ($obj->{type} eq 'vdi') {
5195
                my $size = $obj->{msize};
5196
                $cmd = qq|/usr/bin/VBoxManage createhd --filename "$ipath" --size "$size" --format VDI|;
5197
            }
5198
            $obj->{name} = 'New Image' if (!$obj->{name} || $obj->{name} eq '--' || $obj->{name} =~ /^\./ || $obj->{name} =~ /\//);
5199
            if (-e $ipath) {
5200
                $postreply .= "Status=ERROR Image already exists: \"$obj->{name}\" in \"$ipath\”\n";
5201
            } elsif (overQuotas($obj->{ksize}*1024)) {
5202
                $postreply .= "Status=ERROR Over quota (". overQuotas($obj->{ksize}*1024) . ") creating: $obj->{name}\n";
5203
                $main::updateUI->({tab=>"images", user=>$user, type=>"message", message=>"Over quota in storage pool $obj->{storagepool}"});
5204
                $main::syslogit->($user, "info", "Over quota in storage pool $obj->{storagepool}, not creating $obj->{type} image $obj->{name}");
5205
            } elsif (overStorage($obj->{ksize}*1024, $obj->{storagepool}+0)) {
5206
                $postreply .= "Status=ERROR Out of storage in destination pool creating: $obj->{name}\n";
5207
                $main::updateUI->({tab=>"images", user=>$user, type=>"update", message=>"Out of storage in storage pool $obj->{storagepool}"});
5208
                $main::syslogit->($user, "info", "Out of storage in storage pool $obj->{storagepool}, not creating $obj->{type} image $obj->{name}");
5209
            } elsif ($obj->{virtualsize} > 10*1024*1024 && $obj->{name} && $obj->{name} ne '--') {
5210
                $register{$ipath} = {
5211
                    uuid=>$newuuid,
5212
                    name=>$obj->{name},
5213
                    user=>$user,
5214
                    notes=>$obj->{notes},
5215
                    type=>$obj->{type},
5216
                    size=>0,
5217
                    realsize=>0,
5218
                    virtualsize=>$obj->{virtualsize},