Project

General

Profile

Download (254 KB) Statistics
| Branch: | Revision:
1 95b003ff Origo
#!/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 2a63870a Christian Orellana
use String::Escape;
21 95b003ff Origo
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 27512919 Origo
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 95b003ff Origo
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 991e7f1b hq
    $isadmin = $isadmin || $Stabile::isadmin;
96 95b003ff Origo
    $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 3657de20 Origo
    *Rebase = \&Unmaster;
107 95b003ff Origo
108
    *do_save = \&privileged_action_async;
109
    *do_sync_save = \&privileged_action;
110 2a63870a Christian Orellana
    *do_sync_backup = \&privileged_action;
111 95b003ff Origo
    *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 2a63870a Christian Orellana
    *Sync_backup = \&Backup;
118 95b003ff Origo
    *Sync_clone = \&Clone;
119
    *do_help = \&action;
120
121
    *do_mount = \&privileged_action;
122
    *do_unmount = \&privileged_action;
123 2a63870a Christian Orellana
    *do_convert = \&privileged_action;
124 95b003ff Origo
    *do_activate = \&privileged_action;
125
    *do_publish = \&privileged_action;
126 2a63870a Christian Orellana
    *do_uploadtoregistry = \&privileged_action;
127 48fcda6b Origo
    *do_release = \&privileged_action;
128 95b003ff Origo
    *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 3657de20 Origo
    *do_rebase = \&privileged_action_async;
143 95b003ff Origo
    *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 2a63870a Christian Orellana
    *do_backupfuel = \&privileged_action;
162 95b003ff Origo
163
    *do_gear_save = \&do_gear_action;
164
    *do_gear_sync_save = \&do_gear_action;
165 2a63870a Christian Orellana
    *do_gear_sync_backup = \&do_gear_action;
166 95b003ff Origo
    *do_gear_sync_clone = \&do_gear_action;
167
    *do_gear_mount = \&do_gear_action;
168
    *do_gear_unmount = \&do_gear_action;
169 2a63870a Christian Orellana
    *do_gear_convert = \&do_gear_action;
170 95b003ff Origo
    *do_gear_activate = \&do_gear_action;
171
    *do_gear_publish = \&do_gear_action;
172 2a63870a Christian Orellana
    *do_gear_uploadtoregistry = \&do_gear_action;
173 48fcda6b Origo
    *do_gear_release = \&do_gear_action;
174 95b003ff Origo
    *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 3657de20 Origo
    *do_gear_rebase = \&do_gear_action;
187 95b003ff Origo
    *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 2a63870a Christian Orellana
    *do_gear_backupfuel = \&do_gear_action;
206 95b003ff Origo
207
    *Fullupdateregister = \&Updateregister;
208
209 48fcda6b Origo
    @users; # global
210 95b003ff Origo
    if ($fulllist) {
211
        @users = keys %userreg;
212 48fcda6b Origo
        push @users, "common";
213 95b003ff Origo
    } else {
214 48fcda6b Origo
        @users = ($user, "common");
215 95b003ff Origo
    }
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 8d7785ff Origo
            my $rd = (defined $rdiffenabledlist[$p])?$rdiffenabledlist[$p]:"$rdiffenabledlist[0]";
229 95b003ff Origo
            my %pool = ("hostpath", $tenderlist[$p],
230
                "path", $tenderpathslist[$p],
231
                "name", $tendernameslist[$p],
232 8d7785ff Origo
                "rdiffenabled", $rd,
233 95b003ff Origo
                "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 e9af6c24 Origo
            unless (-d $tenderpathslist[$p]) {return "Status=Error $tenderpathslist[$p] could not be accessed"};
241 95b003ff Origo
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 c899e439 Origo
                    1;
257
                } or {return "Status=Error $tenderpathslist[$p] could not be mounted"};
258 95b003ff Origo
            }
259
260
            # Create user dir if it does not exist
261
            unless(-d "$tenderpathslist[$p]/$user"){
262
                umask "0000";
263 e9af6c24 Origo
                mkdir "$tenderpathslist[$p]/$user" or {return "Status=Cannot create user dir for $user in  $tenderpathslist[$p]"};
264 95b003ff Origo
            }
265
            unless(-d "$tenderpathslist[$p]/common"){
266
                umask "0000";
267 e9af6c24 Origo
                mkdir "$tenderpathslist[$p]/common" or {return "Status=Cannot create common dir for $user in $tenderpathslist[$p]"};
268 95b003ff Origo
            }
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 9d03439e hq
    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 95b003ff Origo
        $obj = \%h;
294
        return $obj;
295
    }
296
    my $uuid = $h{"uuid"};
297 2a63870a Christian Orellana
    if ($uuid && $uuid =~ /^\// ) { # Ugly clutch
298
        $uuid = $register{$uuid}->{'uuid'};
299
    }
300 95b003ff Origo
    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 2a63870a Christian Orellana
    # For backup
387
    $obj->{'skipzfs'} = 1 if ($h{'skipzfs'});
388 95b003ff Origo
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 54401133 hq
    my ($mac, $newtask, $status, $wake) = @_;
420 95b003ff Origo
    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 54401133 hq
    if ($status eq "active" && $nodereg{$mac}->{'stor'} ne 'lvm') {
424
        $postreply .= "Status=Error Node $mac is not using LVM, unable to backup active image\n";
425
        return "node is is not using LVM, unable to backup active image.";
426
    } elsif ($nodereg{$mac}->{'status'} =~ /asleep|inactive/  && !$wake) {
427 95b003ff Origo
        $postreply .= "Status=Error Node $mac is asleep, not waking\n";
428 54401133 hq
        return "node is asleep, please wake first!";
429 95b003ff Origo
    } else {
430
        my $tasks = $nodereg{$mac}->{'tasks'};
431
        $nodereg{$mac}->{'tasks'} = $tasks . "$newtask\n";
432
        tied(%nodereg)->commit;
433
    }
434
    untie %nodereg;
435
    return 0;
436
}
437
438
sub Recurse {
439
	my($path) = shift; # @_;
440
	my @files;
441
	## append a trailing / if it's not there
442
	$path .= '/' if($path !~ /\/$/);
443
	## loop through the files contained in the directory
444
	for my $eachFile (bsd_glob($path.'*')) {
445
	    next if ($eachFile =~ /\/fuel$/);
446
		## if the file is a directory
447
		if( -d $eachFile) {
448
			## pass the directory to the routine ( recursion )
449
			push(@files,Recurse($eachFile));
450
		} else {
451
			push(@files,$eachFile);
452
		}
453
	}
454
	return @files;
455
}
456
457
# If used with the -f switch ($fulllist) from console, all users images are updated in the db
458
# If used with the -p switch ($fullupdate), also updates status information (ressource intensive - runs through all domains)
459
sub Updateregister {
460
    my ($spath, $action) = @_;
461
    if ($help) {
462
        return <<END
463
GET:image,uuid:
464
If used with the -f switch ($fulllist) from console, all users images are updated in the db.
465
If used with the -p switch ($fullupdate), also updates status information (ressource intensive - runs through all domains)
466 8d7785ff Origo
Only images on shared storage are updated, images on node storage are handled on the node.
467 95b003ff Origo
END
468
    }
469
    return "Status=ERROR You must be an admin to do this!\n" unless ($isadmin);
470
    $fullupdate = 1 if ((!$fullupdate && $params{'fullupdate'}) || $action eq 'fullupdateregister');
471
    my $force = $params{'force'};
472
    my %userregister;
473
    my $res;
474
    # Update size information in db
475
    foreach my $u (@users) {
476
        foreach my $spool (@spools) {
477
            my $pooldir = $spool->{"path"};
478
            my $dir = "$pooldir/$u";
479
            my @thefiles = Recurse($dir);
480
            foreach my $f (@thefiles) {
481
                next if ($spath && $spath ne $f); # Only specific image being updated
482
                if ($f =~ /(.+)(-s\d\d\d\.vmdk$)/) {
483 2a63870a Christian Orellana
                #   `touch "$1.vmdk" 2>/dev/null` unless -e "$1.vmdk";
484 95b003ff Origo
                } elsif ($f =~ /(.+)(-flat\.vmdk$)/) {
485 2a63870a Christian Orellana
                #    `touch "$1.vmdk" 2>/dev/null` unless -e "$1.vmdk";
486 95b003ff Origo
                } elsif(-s $f && $f =~ /(\.vmdk$)|(\.img$)|(\.vhd$)|(\.qcow$)|(\.qcow2$)|(\.vdi$)|(\.iso$)/i) {
487
                    my($fname, $dirpath, $suffix) = fileparse($f, ("vmdk", "img", "vhd", "qcow", "qcow2", "vdi", "iso"));
488
                    my $uuid;
489
                    my $img = $register{$f};
490
                    $uuid = $img->{'uuid'};
491
            # Create a new uuid if we are dealing with a new file in the file-system
492
                    if (!$uuid) {
493
                        my $ug = new Data::UUID;
494
                        $uuid = $ug->create_str();
495
                    }
496
                    my $storagepool = $spool->{"id"};
497
            # Deal with sizes
498
                    my ($newmtime, $newbackupsize, $newsize, $newrealsize, $newvirtualsize) =
499 8d7785ff Origo
                        getSizes($f, $img->{'mtime'}, $img->{'status'}, $u, $force);
500 95b003ff Origo
                    my $size = $newsize || $img->{'size'};
501
                    my $realsize = $newrealsize || $img->{'realsize'};
502
                    my $virtualsize = $newvirtualsize || $img->{'virtualsize'};
503
                    my $mtime = $newmtime || $img->{'mtime'};
504
                    my $created = $img->{'created'} || $mtime;
505
                    my $name = $img->{'name'} || substr($fname,0,-1);
506
                    $register{$f} = {
507
                        path=>$f,
508
                        user=>$u,
509
                        type=>$suffix,
510
                        size=>$size,
511
                        realsize=>$realsize,
512
                        virtualsize=>$virtualsize,
513
                        backupsize=>$newbackupsize,
514
                        name=>$name,
515
                        uuid=>$uuid,
516
                    #    domains=>$domains,
517
                    #    domainnames=>$domainnames,
518
                        storagepool=>$storagepool,
519
                        backup=>"", # Only set in uservalues at runtime
520
                        created=>$created,
521
                        mtime=>$mtime
522 8d7785ff Origo
                    };
523
                #    $postreply .= "Status=OK $f, $size, $newbackupsize\n" if ($console);
524 95b003ff Origo
                }
525
            }
526
        }
527
    }
528
    # Update status information in db
529
#    my $mounts = decode('ascii-escape', `/bin/cat /proc/mounts`);
530
    my $mounts = `/bin/cat /proc/mounts`;
531
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
532
    foreach my $u (@users) {
533
        my @regkeys = (tied %register)->select_where("user = '$u'");
534
        foreach my $k (@regkeys) {
535
            my $valref = $register{$k};
536
            my $path = $valref->{'path'};
537
# Only update info for images the user has access to.
538
# Remove DB entries for images on removed nodes
539
            if ($valref->{'storagepool'}==-1 && $valref->{'mac'} && $valref->{'mac'} ne '--' && !$nodereg{$valref->{'mac'}}) {
540
                delete $register{$path}; # Clean up database, remove rows which don't have corresponding file
541
                $main::updateUI->({tab=>'images', user=>$u}) unless ($u eq 'common');
542
            } elsif ($valref->{'user'} eq $u && (defined $spools[$valref->{'storagepool'}]->{'id'} || $valref->{'storagepool'}==-1)) {
543
                my $path = $valref->{'path'};
544
                next if ($spath && $spath ne $path); # Only specific image being updated
545
                my $mounted = ($mounts =~ /$path/);
546
                my $domains;
547
                my $domainnames;
548
                my $regstatus = $valref->{'status'};
549
                my $status = $regstatus;
550
                if (!$status || $status eq '--') {
551
                    $status = 'unused';
552
                }
553
                if (-e $path || $valref->{'storagepool'}==-1 || -s "$path.meta") {
554
                # Deal with status
555
                    if ($valref->{'storagepool'}!=-1 && -s "$path.meta") {
556
                        my $metastatus;
557
                        $metastatus = `/bin/cat "$path.meta" 2>/dev/null`;
558
                        chomp $metastatus;
559
560
                        if ($metastatus =~ /status=(.+)&chunk=/) {
561
                            $status = $1;
562
                        } elsif ($metastatus =~ /status=(.+)&path2:(.+)=(.+)/) {
563
                        # A move operation has been completed - update status of both involved
564
                            $status = $1;
565
                            $register{$2}->{'status'} = $3;
566
                            unless ($userregister{$2}) { # If we have not yet parsed image, it is not yet in userregister, so put it there
567
                                my %mval = %{$register{$2}};
568
                                $userregister{$2} = \%mval;
569
                            }
570
                            $userregister{$2}->{'status'} = $3;
571
                        } elsif ($metastatus =~ /status=(\w+)/) {
572
                            $status = $1;
573
                        } else {
574
                        #    $status = $metastatus; # Do nothing - this meta file contains no status info
575
                        }
576
                    } elsif (
577
                            $status eq "restoring"
578
                            || $status eq "frestoring"
579
                            || ($status eq "mounted" && $mounted)
580
                            || $status eq "snapshotting"
581
                            || $status eq "unsnapping"
582
                            || $status eq "reverting"
583
                            || $status eq "moving"
584
                            || $status eq "converting"
585
                            || $status eq "cloning"
586
                            || $status eq "copying"
587
                            || $status eq "rebasing"
588
                            || $status eq "creating"
589
                            || $status eq "resizing"
590
                        ) { # When operation is done, status is updated by piston.cgi
591
                        ; # Do nothing
592
                    } elsif ($status =~ /.(backingup)/) { # When backup is done, status is updated by steamExec
593
                        if ($valref->{'storagepool'}==-1) {
594
                        #    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
595
                            if ($nodereg{$valref->{'mac'}}) {
596
                                my $nodestatus = $nodereg{$valref->{'mac'}}->{status};
597
                                # If node is not available, it cannot be backing up...
598
                                if ($nodestatus eq 'inactive'
599
                                    || $nodestatus eq 'asleep'
600
                                    || $nodestatus eq 'shutoff'
601
                                ) {
602
                                    $valref->{'status'} = 'unused'; # Make sure we don't end here again in endless loop
603
                                    $rstatus = Updateregister(0, $path);
604
                                    $status = $rstatus if ($rstatus);
605
                                    $main::syslogit->($user, 'info', "Updated image status for aborted backup - $user, $path, $rstatus");
606
                                }
607
                            }
608
                            #untie %nodereg;
609
                        }
610
611
                    } elsif ($status eq 'uploading') {
612
                        $status = 'unused' unless (-s "$path.meta");
613
614
                    } elsif (!$status || $status eq 'unused' || $status eq 'active') {
615
                        if ($fullupdate) {
616
                            $status = "unused";
617
                            my @domregkeys;
618
                            if ($fulllist) {@domregkeys = keys %domreg;}
619
                            else {@domregkeys = (tied %domreg)->select_where("user = '$u'");}
620
                            foreach my $domkey (@domregkeys) {
621
                                my $dom = $domreg{$domkey};
622
                                my $img = $dom->{'image'};
623
                                my $img2 = $dom->{'image2'};
624
                                my $img3 = $dom->{'image3'};
625
                                my $img4 = $dom->{'image4'};
626
                                if ($path eq $img || $path eq $img2 || $path eq $img3 || $path eq $img4) {
627
                                    $status = "active";
628
                                    my $domstatus = $dom->{'status'};
629
                                    if ($domstatus eq "shutoff" || $domstatus eq "inactive") {$status = "used";}
630
                                    elsif ($domstatus eq "paused") {$status = "paused";}
631
                                    $domains = $dom->{'uuid'};
632
                                    $domainnames = $dom->{'name'};
633
                                };
634
                            }
635
                            $valref->{'domains'} = $domains ;
636
                            $valref->{'domainnames'} = $domainnames ;
637
                        } elsif ($valref->{'domains'} && $valref->{'domains'} ne '--'){
638
                            my $dom = $domreg{$valref->{'domains'}};
639
                            if ($dom) {
640
                                my $img = $dom->{'image'};
641
                                my $img2 = $dom->{'image2'};
642
                                my $img3 = $dom->{'image3'};
643
                                my $img4 = $dom->{'image4'};
644
                                if ($path eq $img || $path eq $img2 || $path eq $img3 || $path eq $img4) {
645
                                    $status = "active";
646
                                    my $domstatus = $dom->{'status'};
647
                                    if ($domstatus eq "shutoff" || $domstatus eq "inactive") {$status = "used";}
648
                                    elsif ($domstatus eq "paused") {$status = "paused";}
649
                                    $valref->{'domainnames'} = $dom->{'name'};
650
                                };
651
                            };
652
                        }
653
                    }
654
                    # Update info in db
655
                    $valref->{'status'} = $status ;
656
                    $res .= $status if ($spath);
657
                } else {
658
                    delete $register{$path}; # Clean up database, remove rows which don't have corresponding file
659
                    $main::updateUI->({tab=>'images', user=>$u}) unless ($u eq 'common');
660
                }
661
            }
662
        }
663
    }
664
    untie %nodereg;
665
    tied(%register)->commit;
666
    $res .= "Status=OK Updated image register for " . join(', ', @users) . "\n";
667 8d7785ff Origo
    $res .= $postreply;
668 95b003ff Origo
    return $res if ($res);
669
}
670
671
sub getVirtualSize {
672
    my $vpath = shift;
673
    my $macip = shift;
674
    my $qinfo;
675
    my($bname, $dirpath, $suffix) = fileparse($vpath, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
676
    if ($suffix eq ".qcow2") {
677
        if ($macip) {
678 3657de20 Origo
            $qinfo = `$sshcmd $macip /usr/bin/qemu-img info --force-share "$vpath"`;
679 95b003ff Origo
        } else {
680 3657de20 Origo
            $qinfo = `/usr/bin/qemu-img info --force-share "$vpath"`;
681 95b003ff Origo
        }
682
        $qinfo =~ /virtual size:.*\((.+) bytes\)/g;
683
        return(int($1)); # report size of new image for billing purposes
684
    } elsif ($status eq ".vdi") {
685
        if ($macip) {
686
            $qinfo = `$sshcmd $macip /usr/bin/VBoxManage showhdinfo "$vpath"`;
687
        } else {
688
            $qinfo = `/usr/bin/VBoxManage showhdinfo "$vpath"`;
689
        }
690
        $qinfo =~ /Logical size:\s*(\d+) MBytes/g;
691
        return(int($1) * 1024 * 1024); # report size of new image for billing purposes
692
    } else {
693
        if ($macip) {
694
            return `$sshcmd $macip perl -e 'my @stat=stat("$vpath"); print $stat[7];'`;
695
        } else {
696
            my @stat = stat($vpath);
697
            return($stat[7]); # report size of new image for billing purposes
698
        }
699
    }
700
}
701
702
sub getSizes {
703 8d7785ff Origo
    my ($f, $lmtime, $status, $buser, $force) = @_;
704 95b003ff Origo
705
    my @stat = stat($f);
706
    my $size = $stat[7];
707
    my $realsize = $stat[12] * 512;
708
    my $virtualsize = $size;
709
    my $backupsize = 0;
710
    my $mtime = $stat[9];
711
    my($fname, $dirpath, $suffix) = fileparse($f, ("vmdk", "img", "vhd", "qcow", "qcow2", "vdi", "iso"));
712
    my $subdir = "";
713 27512919 Origo
    if ($dirpath =~ /.+\/$buser(\/.+)?\//) {
714 95b003ff Origo
        $subdir = $1;
715
    }
716 8d7785ff Origo
    $backupsize = getBackupSize($subdir, "$fname$suffix", $buser);
717 95b003ff Origo
    my $ps = `/bin/ps ax`;
718
719
# Only fire up qemu-img etc. if image has been modified and is not being used
720
    if ((
721
        ($mtime - $lmtime)>300 &&
722
        ($status ne 'active' && $status ne 'downloading') &&
723
        !($ps =~ /$f/)) || $force
724
    ) {
725
726
# Special handling of vmdk's
727
        if ($suffix eq "vmdk") {
728 3657de20 Origo
            my $qinfo = `/usr/bin/qemu-img info --force-share "$f"`;
729 95b003ff Origo
            $qinfo =~ /virtual size:.*\((.+) bytes\)/g;
730
            $virtualsize = int($1);
731
            if ( -s ($dirpath . substr($fname,0,-1) . "-flat." . $suffix)) {
732
                my @fstatus = stat($dirpath . substr($fname,0,-1) . "-flat." . $suffix);
733
                my $fsize = $fstatus[7];
734
                my $frealsize = $fstatus[12] * 512;
735
                $size += $fsize;
736
                $virtualsize += $fsize;
737
                $realsize += $frealsize;
738
            } else {
739
#                $main::syslogit->($user, "info", "VMDK " . $dirpath . substr($fname,0,-1) . "-flat." . $suffix . " does not exist");
740
            }
741
            my $i = 1;
742
            while (@fstatus = stat($dirpath . substr($fname,0,-1) . "-s00$i." . $suffix)) {
743
                my $fsize = $fstatus[7];
744
                my $frealsize = $fstatus[12] * 512;
745
                $size += $fsize;
746
                #$virtualsize += $fsize;
747
                $realsize += $frealsize;
748
749
                my $cmdpath = $dirpath . substr($fname,0,-1) . "-s00$i." . $suffix;
750 3657de20 Origo
                my $qinfo = `/usr/bin/qemu-img info --force-share "$cmdpath"`;
751 95b003ff Origo
                $qinfo =~ /virtual size:.*\((.+) bytes\)/g;
752
                $virtualsize += int($1);
753
754
                $i++;
755
            }
756
# Get virtual size of qcow2 auto-grow volumes
757
        } elsif ($suffix eq "qcow2") {
758 3657de20 Origo
            my $qinfo = `/usr/bin/qemu-img info --force-share "$f"`;
759 95b003ff Origo
            $qinfo =~ /virtual size:.*\((.+) bytes\)/g;
760
            $virtualsize = int($1);
761
# Get virtual size of vdi auto-grow volumes
762
        } elsif ($suffix eq "vdi") {
763
            my $qinfo = `/usr/bin/VBoxManage showhdinfo "$f"`;
764
            $qinfo =~ /Logical size:\s*(\d+) MBytes/g;
765
            $virtualsize = int($1) * 1024 * 1024;
766
        }
767
# Actual used blocks times block size on disk, i.e. $realsize may be bigger than the
768
# logical size of the image file $size and the logical provisioned size of the disk $virtualsize
769
# in order to minimize confusion, we set $realsize to $size if this is the case
770
        $realsize = $size if ($realsize > $size);
771
772
        return ($mtime, $backupsize, $size, $realsize, $virtualsize);
773
    } else {
774
        return (0, $backupsize, $size, $realsize);
775
    }
776
777
}
778
779
sub getHypervisor {
780
	my $image = shift;
781
	# Produce a mapping of image file suffixes to hypervisors
782
	my %idreg;
783
    unless ( tie(%idreg,'Tie::DBI', Hash::Merge::merge({table=>'nodeidentities', key=>'identity'}, $Stabile::dbopts)) )
784
        {$postreply .= "Status=Error identity register could not be accessed"};
785
786
	my @idvalues = values %idreg;
787
	my %formats;
788
	foreach my $val (@idvalues) {
789
		my %h = %$val;
790
		foreach (split(/,/,$h{'formats'})) {
791
			$formats{lc $_} = $h{'hypervisor'}
792
		}
793
	}
794
	untie %idreg;
795
796
	# and then determine the hypervisor in question
797
	my $hypervisor = "vbox";
798
	my ($pathname, $path, $suffix) = fileparse($image, '\.[^\.]*');
799
	$suffix = substr $suffix, 1;
800
	my $hypervisor = $formats{lc $suffix};
801
	return $hypervisor;
802
}
803
804
sub Getserverbackups {
805
    my ($domuuid, $action) = @_;
806
    if ($help) {
807
        return <<END
808
GET:uuid:
809
Lists the image backups associated with a server, i.e. the backups of all the images attached to a server.
810
A server UUID should be passed as parameter. A JSON object is returned. May be called as <b>getserverbackups</b>, in
811
which case a JSON object is returned, or as <b>listserverbackups</b>, in which case a string is returned.
812
END
813
    }
814
    my $res;
815
    my @sbackups;
816
    my $backuplist;
817
818
    if ($domreg{$domuuid} && (($domreg{$domuuid}->{'user'} eq $user) || $isadmin)) {
819
        push @sbackups, Listbackups($domreg{$domuuid}->{'image'}, 'getbackups');
820
        push @sbackups, Listbackups($domreg{$domuuid}->{'image2'}, 'getbackups') if ($domreg{$domuuid}->{'image2'} && $domreg{$domuuid}->{'image2'} ne '--');
821
        push @sbackups, Listbackups($domreg{$domuuid}->{'image3'}, 'getbackups') if ($domreg{$domuuid}->{'image3'} && $domreg{$domuuid}->{'image3'} ne '--');
822
        push @sbackups, Listbackups($domreg{$domuuid}->{'image4'}, 'getbackups') if ($domreg{$domuuid}->{'image4'} && $domreg{$domuuid}->{'image4'} ne '--');
823
    }
824
    foreach my $sbackup (@sbackups) {
825
        my @back = @{$sbackup};
826
        my $t = $back[0]->{time};
827
        my $epoch;
828
        my $z;
829
        if ($t eq '--') {
830
            $epoch = $t;
831
        } elsif ($t =~ /(z)/) {
832
#            my $time = Time::Piece->strptime($t, "%Y-%m-%d-%H-%M-%S (z)");
833
            my $time = Time::Piece->strptime($t, "%b %d %T %Y (z)");
834
            $epoch = $time->epoch;
835
            $z = ' (z)';
836
        } else {
837
            $t = $1 if ($t =~ /\* (.*)/);
838
            my $time = Time::Piece->strptime($t, "%b %d %T %Y");
839
            $epoch = $time->epoch;
840
        }
841
        $backuplist .= "$back[-1]->{name}$z/$epoch, " if (@back && $epoch);
842
    }
843
    $backuplist = substr($backuplist,0,-2);
844
845
    if ($action eq 'getserverbackups') {
846
        $res .= to_json(\@sbackups, {pretty=>1});
847
    } else {
848
        $res .= header() unless ($console);
849
        $res .= $backuplist;
850
    }
851
    return $res;
852
853
}
854
855
sub Listbackups {
856
    my ($curimg, $action) = @_;
857
    if ($help) {
858
        return <<END
859
GET:image:
860
List backups on file for the give image, which may be specified as path or uuid.
861
END
862
    }
863
864
    my $res;
865
    my $buser = $user;
866
    $curimg = '' unless ($register{$curimg}); # Image must exist
867
    $buser = $register{$curimg}->{'user'} if ($isadmin && $curimg);
868
    my @backups;
869
    my $subdir = "";
870
    if ($curimg && $curimg ne '--') {
871
        my($bname, $dirpath) = fileparse($curimg);
872 27512919 Origo
        if ($dirpath =~ /.+\/$buser(\/.+)?\//) {
873 95b003ff Origo
            $subdir = $1;
874
        }
875
        my $sbname = "$subdir/$bname";
876 2a63870a Christian Orellana
        $sbname =~ s/ /\\ /g;
877 95b003ff Origo
        $sbname = $1 if ($sbname =~ /(.+)/); # untaint
878
        foreach my $spool (@spools) {
879
            my $imgbasedir = $spool->{"path"};
880
            if (-d "$imgbasedir/.zfs/snapshot") {
881
                my $snaps = `/bin/ls -l --time-style=full-iso $imgbasedir/.zfs/snapshot/*/$buser$sbname 2> /dev/null`;
882
                my @snaplines = split("\n", $snaps);
883
                # -rw-r--r-- 1 root root 216174592 2012-02-19 17:51 /mnt/stabile/images/.zfs/snapshot/SNAPSHOT-20120106002116/cabo/Outlook2007.iso
884
                foreach $line (@snaplines) {
885
                    if ($line =~ /$imgbasedir\/.zfs\/snapshot\/SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})\/$buser$subdir\/$bname$/) {
886
                        my $timestamp = timelocal($6,$5,$4,$3,$2-1,$1); #$sec,$min,$hour,$mday,$mon,$year
887
                        my $t = localtime($timestamp)->strftime("%b %e %H:%M:%S %Y");
888
                        # my %incr = ("increment", "SNAPSHOT-$1$2$3$4$5$6", "time", "$1-$2-$3-$4-$5-$6 (z)", "pool", $imgbasedir);
889
                        my %incr = ("increment", "SNAPSHOT-$1$2$3$4$5$6", "time", "$t (z)", "pool", $imgbasedir);
890
                        unshift (@backups, \%incr);
891
                    };
892
                }
893
            }
894
        }
895
        # Also include ZFS snapshots transferred from nodes
896 27512919 Origo
        $imgbasedir = "/stabile-backup";
897 95b003ff Origo
        my $snaps = `/bin/ls -l --time-style=full-iso $imgbasedir/node-*/.zfs/snapshot/*/$buser$sbname 2> /dev/null`;
898
        my @snaplines = split("\n", $snaps);
899
        foreach $line (@snaplines) {
900
            if ($line =~ /($imgbasedir\/node-.+)\/.zfs\/snapshot\/SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})\/$buser$subdir\/$bname$/) {
901
                my $timestamp = timelocal($7,$6,$5,$4,$3-1,$2); #$sec,$min,$hour,$mday,$mon,$year
902
                my $t = localtime($timestamp)->strftime("%b %e %H:%M:%S %Y");
903
                # my %incr = ("increment", "SNAPSHOT-$2$3$4$5$6$7", "time", "$2-$3-$4-$5-$6-$7 (z)", "pool", $1);
904
                my %incr = ("increment", "SNAPSHOT-$2$3$4$5$6$7", "time", "$t (z)", "pool", $1);
905
                unshift (@backups, \%incr);
906
            };
907
        }
908
        my $bpath = "$backupdir/$buser$subdir/$bname";
909
        $bpath = $1 if ($bpath =~ /(.+)/); # untaint
910
        if (-d "$bpath") {
911
            my $rdiffs = `/usr/bin/rdiff-backup -l "$bpath"`;
912
            my @mlines = split("\n", $rdiffs);
913
            my $curmirror;
914
            foreach my $line (@mlines) {
915
                if ($line =~ /\s+increments\.(\S+)\.dir\s+\S\S\S (.+)$/) {
916
                    my %incr = ("increment", $1, "time", $2);
917
                    if (-e "$bpath/rdiff-backup-data/increments/$bname.$1.diff.gz"
918
                    ) {
919
                        unshift (@backups, \%incr);
920
                    }
921
                };
922
                if ($line =~ /Current mirror: \S\S\S (.+)$/) {
923
                    $curmirror = $1;
924
                };
925
            }
926
            if ($curmirror) {
927
                my %incr = ("increment", "mirror", "time", "* $curmirror");
928
                unshift @backups, \%incr;
929
            }
930
            my %incr = ("increment", "--", "time", "--", "name", $bname);
931
            push @backups, \%incr;
932
        } else {
933
            my %incr = ("increment", "--", "time", "--", "name", $bname);
934
            push @backups, \%incr;
935
        }
936
    }
937
938
    if ($action eq 'getbackups') {
939
        return \@backups;
940
    } elsif ($console) {
941
        my $t2 = Text::SimpleTable->new(28,28);
942
        $t2->row('increment', 'time');
943
        $t2->hr;
944
        foreach my $fref (@backups) {
945
            $t2->row($fref->{'increment'}, scalar localtime( $fref->{'time'} )) unless ($fref->{'increment'} eq '--');
946
        }
947
        return $t2->draw;
948
    } else {
949
        $res .= header('application/json');
950
        my $json_text = to_json(\@backups, {pretty=>1});
951
        $res .= qq|{"identifier": "increment", "label": "time", "items": $json_text }|;
952
        return $res;
953
    }
954
}
955
956
# Get the timestamp of latest backup of an image
957
sub getBtime {
958
    my $curimg = shift;
959
    my $buser = shift || $user;
960
    return unless ($buser eq $user || $isadmin);
961
    $buser = 'common' if ($register{$curimg}->{user} eq 'common' && $isadmin);
962
    my $subdir = "";
963
    my $lastbtimestamp;
964
    my($bname, $dirpath) = fileparse($curimg);
965 27512919 Origo
    if ($dirpath =~ /.+\/$buser(\/.+)?\//) {
966 95b003ff Origo
        $subdir = $1;
967
    }
968
969
    #require File::Spec;
970
    #my $devnull = File::Spec->devnull();
971
972
    foreach my $spool (@spools) {
973
        my $imgbasedir = $spool->{"path"};
974
        if (-d "$imgbasedir/.zfs/snapshot") {
975
            my $sbname = "$subdir/$bname";
976 2a63870a Christian Orellana
            $sbname =~ s/ /\\ /g;
977 95b003ff Origo
            my $cmd = qq|/bin/ls -l --time-style=full-iso $imgbasedir/.zfs/snapshot/*/$buser$sbname 2>/dev/null|;
978
            my $snaps = `$cmd`;
979
            my @snaplines = split("\n", $snaps);
980
            foreach $line (@snaplines) {
981
                if ($line =~ /$imgbasedir\/.zfs\/snapshot\/SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})\/$buser$subdir\/$bname$/) {
982
                    my $timestamp = timelocal($6,$5,$4,$3,$2-1,$1); #$sec,$min,$hour,$mday,$mon,$year
983
                    $lastbtimestamp = $timestamp if ($timestamp > $lastbtimestamp);
984
                };
985
            }
986
        }
987
    }
988
    # Also include ZFS snapshots transferred from nodes
989 27512919 Origo
    $imgbasedir = "/stabile-backup";
990 95b003ff Origo
    my $snaps = `/bin/ls -l --time-style=full-iso $imgbasedir/node-*/.zfs/snapshot/*/$buser/$bname 2> /dev/null`;
991
    my @snaplines = split("\n", $snaps);
992
    foreach $line (@snaplines) {
993
        if ($line =~ /$imgbasedir\/node-.+\/.zfs\/snapshot\/SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})\/$buser$subdir\/$bname$/) {
994
            my $timestamp = timelocal($6,$5,$4,$3,$2-1,$1); #$sec,$min,$hour,$mday,$mon,$year
995
            $lastbtimestamp = $timestamp if ($timestamp > $lastbtimestamp);
996
        };
997
    }
998
    my $bpath = "$backupdir/$buser$subdir/$bname";
999
    $bpath = $1 if ($bpath =~ /(.+)/);
1000
    if (-d "$bpath") {
1001
        my $rdiffs = `/usr/bin/rdiff-backup --parsable-output -l "$bpath"`;
1002
        my @mlines = split("\n", $rdiffs);
1003
        foreach my $line (@mlines) {
1004
            if ($line =~ /(\d+) (\S+)$/) {
1005
                my $timestamp = $1;
1006
                $lastbtimestamp = $timestamp if ($timestamp > $lastbtimestamp);
1007
            };
1008
        }
1009
    }
1010
    return $lastbtimestamp;
1011
}
1012
1013
sub Unmount {
1014
    my $path = shift;
1015
	my $action = shift;
1016
    if ($help) {
1017
        return <<END
1018
GET:image: Unmounts a previously mounted image.
1019
END
1020
    }
1021
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1022
    my $mountpath = "$dirpath.$bname$suffix";
1023
#    my $mounts = decode('ascii-escape', `/bin/cat /proc/mounts`);
1024
    my $mounts = `/bin/cat /proc/mounts`;
1025
    my $mounted = ($mounts =~ /$mountpath/);
1026
1027
#    eval {`/bin/umount "$mountpath"` if ($mounted); 1;}
1028
#    eval {`/bin/fusermount -u "$mountpath"` if ($mounted); 1;}
1029
#        or do {$postreply .= "Status=ERROR Problem mounting image $@\n";};
1030
1031
    if ($mounted) {
1032
        $cmd = qq|/bin/fusermount -u "$mountpath" 2>&1|;
1033
        my $mes = qx($cmd);
1034
        my $xc = $? >> 8;
1035
        $main::syslogit->($user, 'info', "Unmounted $curimg $xc");
1036
        if ($xc) {
1037
            $postreply .= "Status=ERROR Problem unmounting image ($mes). ";
1038
            return $postreply;
1039
        }
1040
    }
1041
#    my $mounts2 = decode('ascii-escape', `/bin/cat /proc/mounts`);
1042
    my $mounts2 = `/bin/cat /proc/mounts`;
1043 2a63870a Christian Orellana
    $mounts2 = String::Escape::unbackslash($mounts2);
1044 95b003ff Origo
    my $mounted2 = ($mounts2 =~ /$mountpath/);
1045
    eval {`/bin/rmdir "$mountpath"` if (!$mounted2 && -e $mountpath); 1;}
1046
        or do {$postreply .= "Status=ERROR Problem removing mount point $@\n";};
1047
1048
    if ($mounted) {
1049
        if ($mounted2) {
1050
            $postreply .= "Status=ERROR Unable to unmount $register{$path}->{'name'}\n";
1051
            return $postreply;
1052
        } else {
1053
            $postreply .= "Status=OK Unmounted image $register{$path}->{'name'}\n";
1054
            return $postreply;
1055
        }
1056
    } else {
1057 2a63870a Christian Orellana
        $postreply .= "Status=OK Image $path not mounted\n";
1058 95b003ff Origo
        return $postreply;
1059
    }
1060
}
1061
1062
sub unmountAll {
1063
    my @mounts = split(/\n/, `/bin/cat /proc/mounts`);
1064
    foreach my $mount (@mounts) {
1065
        foreach my $spool (@spools) {
1066
            my $pooldir = $spool->{"path"};
1067
            if ($mount =~ /($pooldir\/$user\/\S+) / || ($mount =~ /($pooldir\/common\/\S+) / && $isadmin)) {
1068
#                $mountpath = decode('ascii-escape', $1);
1069
                $mountpath =  $1;
1070
                $rpath = $mountpath;
1071
                $rpath =~ s/\/\./\//;
1072
                my $processes = `/bin/ps`;
1073
#                if ($register{$rpath} && !($processes =~ /steamExec.+$rpath/)) {
1074
                    $postreply .= "Status=OK Unmounting $rpath\n";
1075
                    Unmount($rpath);
1076
#                }
1077
            }
1078
        }
1079
    }
1080
    return;
1081
}
1082
1083
sub Mount {
1084
    my $path = shift;
1085
	my $action = shift;
1086
    if ($help) {
1087
        return <<END
1088
GET:image:
1089
Tries to mount an image on admin server for listfiles/restorefiles operations.
1090
END
1091
    }
1092
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1093
    my $mountpath = "$dirpath.$bname$suffix";
1094
    my $mounts = `/bin/cat /proc/mounts`;
1095 2a63870a Christian Orellana
    $mounts = String::Escape::unbackslash($mounts);
1096 95b003ff Origo
    my $mounted = ($mounts =~ /$mountpath/);
1097
    if ($mounted) {
1098
        unless (`ls "$mountpath"`) { # Check if really mounted
1099 2a63870a Christian Orellana
            Unmount($mountpath);
1100 95b003ff Origo
            $mounted = 0;
1101
        }
1102
    }
1103
1104
    if ($mounted) {
1105
        $postreply .= "Status=OK Image $register{$path}->{'name'} already mounted\n";
1106
        return $postreply;
1107
    } else {
1108
        `/bin/mkdir "$mountpath"` unless (-e "$mountpath");
1109
        `/bin/chown www-data:www-data  "$mountpath"`;
1110
        my $cmd;
1111
1112
        if (lc $suffix eq '.iso') {
1113
            #eval {`/bin/mount -o allow_other,ro,loop "$path" "$mountpath"`; 1;}
1114
            #eval {`/usr/bin/fuseiso -n "$path" "$mountpath" -o user=www-data`; 1;}
1115
            eval {`/usr/bin/fuseiso -n "$path" "$mountpath" -o allow_other`; 1;}
1116
            or do {
1117
                $postreply .= header('text/html', '500 Internal Server Error') unless ($console);
1118
                $postreply .= "Status=ERROR Problem mounting image $@\n";
1119
                return $postreply;
1120
            };
1121
        } else {
1122 705b5366 hq
            # First try to mount using autodiscover -i. If that fails, try to mount /dev/sda1
1123 95b003ff Origo
            $cmd = qq|/usr/bin/guestmount --ro -o allow_other -a "$path" "$mountpath" -i 2>&1|;
1124
            my $mes = qx($cmd);
1125
            my $xc = $? >> 8;
1126 705b5366 hq
            $main::syslogit->($user, 'info', "Trying to mount $curimg $xc");
1127 95b003ff Origo
            if ($xc) {
1128 705b5366 hq
                $cmd = qq|/usr/bin/guestmount --ro -o allow_other -a "$path" "$mountpath"  -m /dev/sda1:/ 2>&1|;
1129
                $mes = qx($cmd);
1130
                $xc = $? >> 8;
1131
                $main::syslogit->($user, 'info', "Trying to mount $curimg $xc");
1132
                if ($xc) {
1133
                    $postreply = header('text/html', '500 Internal Server Error') . $postreply unless ($console);
1134
                    chomp $mes;
1135
                    $postreply .= "Status=Error Problem mounting image ($mes).\n$cmd\n";
1136
                    return $postreply;
1137
                }
1138 95b003ff Origo
            }
1139
        }
1140
1141
        my $mounts2;
1142
        for (my $i=0; $i<5; $i++) {
1143
            $mounts2 = `/bin/cat /proc/mounts`;
1144 2a63870a Christian Orellana
            $mounts2 = String::Escape::unbackslash($mounts2);
1145 95b003ff Origo
            next if ( $mounts2 =~ /$mountpath/);
1146
            sleep 2;
1147
        }
1148
        if ( $mounts2 =~ /$mountpath/) {
1149
            $postreply .= "Status=OK Mounted image $register{$path}->{'name'}\n";
1150
            return $postreply;
1151
        } else {
1152
            $postreply .= header('text/html', '500 Internal Server Error') unless ($console);
1153
            $postreply .= "Status=ERROR Giving up mounting image $register{$path}->{'name'}\n";
1154
            return $postreply;
1155
        }
1156
    }
1157
}
1158
1159
sub Updatebackingfile {
1160
    my ($img, $action) = @_;
1161
    if ($help) {
1162
        return <<END
1163
GET:image:
1164
END
1165
    }
1166
    my $f = $img || $curimg;
1167
    return "Status=Error Image $f not found\n" unless (-e $f);
1168 3657de20 Origo
    my $vinfo = `qemu-img info --force-share "$f"`;
1169 95b003ff Origo
    my $master = $1 if ($vinfo =~ /backing file: (.+)/);
1170
    (my $fname, my $fdir) = fileparse($f);
1171 3657de20 Origo
    if (!$master) {
1172
        $register{$f}->{'master'} = '';
1173
        $postreply .=  "Status=OK Image $f does not use a backing file\n";
1174
    } elsif (-e $master){ # Master OK
1175
        $register{$f}->{'master'} = $master;
1176
        $postreply .=  "Status=OK $master exists, no changes to $f.\n";
1177
    } elsif (-e "$fdir/$master") { # Master OK
1178
        $register{$f}->{'master'} = "$fdir/$master";
1179
        $postreply .=  "Status=OK $master exists in $fdir. No changes to $f.\n"
1180
    } else {
1181
        # Master not immediately found, look for it
1182
        (my $master, my $mdir) = fileparse($master);
1183
        my @busers = @users;
1184
        push (@busers, $billto) if ($billto); # We include images from 'parent' user
1185
        foreach my $u (@busers) {
1186
            foreach my $spool (@spools) {
1187
                my $pooldir = $spool->{"path"};
1188
                my $masterpath = "$pooldir/$u/$master";
1189
                if (-e $masterpath) {
1190
                    my $cmd = qq|qemu-img rebase -f qcow2 -u -b "$masterpath" "$f"|;
1191
                    $register{$f}->{'master'} = $masterpath;
1192
                    $postreply .= "Status=OK found $masterpath, rebasing from $mdir to $pooldir/$u ";
1193
                    $postreply .= `$cmd` . "\n";
1194
                    last;
1195
                }
1196 95b003ff Origo
            }
1197
        }
1198 3657de20 Origo
        $postreply .= "Status=Error $master not found in any user dir. You must provide this backing file to use this image.\n" unless ($postreply);
1199 95b003ff Origo
    }
1200 3657de20 Origo
    tied(%register)->commit;
1201 95b003ff Origo
    return $postreply;
1202
}
1203
1204
# List files in a mounted image. Mount image if not mounted.
1205
sub Listfiles {
1206
    my ($curimg, $action, $obj) = @_;
1207
    if ($help) {
1208
        return <<END
1209
GET:image,path:
1210
Try to mount the file system on the given image, and list the files from the given path in the mounted file system.
1211
The image must contain a bootable file system, in order to locate a mount point.
1212
END
1213
    }
1214
    my $res;
1215
    my $curpath = $obj->{'restorepath'};
1216
    $res .= header('application/json') unless ($console);
1217
1218
    my($bname, $dirpath, $suffix) = fileparse($curimg, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1219
    my $mountpath = "$dirpath.$bname$suffix";
1220
	my @files;
1221
	my @dirs;
1222
    my $mounted = (Mount($curimg) =~ /\w=OK/);
1223
1224
    if ($mounted) {
1225
        my @patterns = ('');
1226
        $curpath .= '/' unless ($curpath =~ /\/$/);
1227
        $mountpath .= "$curpath";
1228
        if (-d $mountpath) { # We are listing a directory
1229
            # loop through the files contained in the directory
1230
            @patterns = ('*', '.*');
1231
        }
1232
        foreach $pat (@patterns) {
1233
            for my $f (bsd_glob($mountpath.$pat)) {
1234
                my %fhash;
1235
                ($bname, $dirpath) = fileparse($f);
1236
                my @stat = stat($f);
1237
                my $size = $stat[7];
1238
                my $realsize = $stat[12] * 512;
1239
                my $mtime = $stat[9];
1240
1241
                $fhash{'name'} = $bname;
1242
                $fhash{'mtime'} = $mtime;
1243
                ## if the file is a directory
1244
                if( -d $f) {
1245
                    $fhash{'size'} = 0;
1246
                    $fhash{'fullpath'} = $f . '/';
1247
                    $fhash{'path'} = $curpath . $bname . '/';
1248
                    push(@dirs, \%fhash) unless ($bname eq '.' || $bname eq '..');
1249
                } else {
1250
                    $fhash{'size'} = $size;
1251
                    $fhash{'fullpath'} = $f;
1252
                    $fhash{'path'} = $curpath . $bname;
1253
                    push(@files, \%fhash);
1254
                }
1255
            }
1256
        }
1257
1258
        if ($console) {
1259
            my $t2 = Text::SimpleTable->new(48,16,28);
1260
            $t2->row('name', 'size', 'mtime');
1261
            $t2->hr;
1262
            foreach my $fref (@dirs) {
1263
                $t2->row($fref->{'name'}, $fref->{'size'}, scalar localtime( $fref->{'mtime'} )) unless ($bname eq '.' || $bname eq '..');
1264
            }
1265
            foreach my $fref (@files) {
1266
                $t2->row($fref->{'name'}, $fref->{'size'}, scalar localtime( $fref->{'mtime'} ) ) unless ($bname eq '.' || $bname eq '..');
1267
            }
1268
            return $t2->draw;
1269
        } else {
1270
            my @comb = (@dirs, @files);
1271
            $res .= to_json(\@comb, {pretty => 1});
1272
        }
1273
    } else {
1274 2a63870a Christian Orellana
        $res .= qq|{"status": "Error", "message": "Image $curimg not mounted. Mount first."}|;
1275 95b003ff Origo
    }
1276
    return $res;
1277
}
1278
1279
sub Restorefiles {
1280
    my ($path, $action, $obj) = @_;
1281
    if ($help) {
1282
        return <<END
1283
GET:image,files:
1284
Restores files from the given path in the given image to a newly created ISO image. The given image must be mountable.
1285
END
1286
    }
1287
    my $res;
1288
    $curfiles = $obj->{'files'};
1289
    $path = $path || $curimg;
1290
1291
    return "Status=ERROR Your account does not have the necessary privileges\n" if ($isreadonly);
1292
    return "Status=ERROR You must specify which files you want to restore\n" unless ($curfiles);
1293
1294
    my $name = $register{$path}->{'name'};
1295
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1296
    my $mountpath = "$dirpath.$bname$suffix";
1297
#    my $mounts = decode('ascii-escape', `/bin/cat /proc/mounts`);
1298
    my $mounts = `/bin/cat /proc/mounts`;
1299
    my $mmounts = `/bin/df`;
1300
    my $mounted = ($mounts =~ /$mountpath/ && $mmounts =~ /$mountpath/);
1301
    my $restorepath = "$dirpath$bname.iso";
1302
1303
    if (-e $restorepath) {
1304
        my $i = 1;
1305
        while (-e "$dirpath$bname.$i.iso") {$i++;}
1306
        $restorepath = "$dirpath$bname.$i.iso";
1307
    }
1308
1309
    my $uistatus = "frestoring";
1310
    if ($mounted && $curfiles) {
1311
        my $ug = new Data::UUID;
1312
        my $newuuid = $ug->create_str();
1313
        $register{$restorepath} = {
1314
                            uuid=>$newuuid,
1315
                            status=>$uistatus,
1316
                            name=>"Files from: $name",
1317
                            size=>0,
1318
                            realsize=>0,
1319
                            virtualsize=>0,
1320
                            type=>"iso",
1321
                            user=>$user
1322
                        };
1323
1324
        eval {
1325
                my $oldstatus = $register{$path}->{'status'};
1326
#                my $cmd = qq|steamExec $user $uistatus $oldstatus "$path" "$curfiles"|;
1327
#                my $cmdres = `$cmd`;
1328
            if ($mounted) {
1329
                $res .= "Restoring files to: /tmp/restore/$user/$bname$suffix -> $restorepath\n";
1330
                $res .= `/bin/echo $status > "$restorepath.meta"`;
1331
1332
                `/bin/mkdir -p "/tmp/restore/$user/$bname$suffix"` unless (-e "/tmp/restore/$user/$bname$suffix");
1333
                my @files = split(/:/, uri_unescape($curfiles));
1334
                foreach $f (@files) {
1335
                    if (-e "$mountpath$f" && chdir($mountpath)) {
1336
                        $f = substr($f,1) if ($f =~ /^\//);
1337
                        eval {`/usr/bin/rsync -aR --sparse "$f" /tmp/restore/$user/$bname$suffix`; 1;}
1338
                            or do {$e=1; $res .= "ERROR Problem restoring files $@\n";};
1339
                    } else {
1340
                        $res .= "Status=Error $f not found in $mountpath\n";
1341
                    }
1342
                }
1343
                if (chdir "/tmp/restore/$user/$bname$suffix") {
1344
                    eval {$res .= `/usr/bin/genisoimage -o "$restorepath" -iso-level 4 .`; 1;}
1345
                        or do {$e=1; $res .= "Status=ERROR Problem restoring files $@\n";};
1346
                    $res .= `/bin/rm -rf /tmp/restore/$user/$bname$suffix`;
1347
                    $res .= "Status=OK Restored files from /tmp/restore/$user/$bname$suffix to $restorepath\n";
1348
                } else {
1349
                    $res .= "Status=ERROR Unable to chdir to /tmp/restore/$user/$bname$suffix\n";
1350
                }
1351
                $main::updateUI->({tab=>"images", user=>$user, type=>"update"});
1352
1353
                # Update billing
1354
                my $newvirtualsize = getVirtualSize($restorepath);
1355
                unlink "$restorepath.meta";
1356
                $res .= Unmount($path);
1357
                $register{$restorepath}->{'status'} = 'unused';
1358
                $register{$restorepath}->{'virtualsize'} = $newvirtualsize;
1359
                $register{$restorepath}->{'realsize'} = $newvirtualsize;
1360
                $register{$restorepath}->{'size'} = $newvirtualsize;
1361
                $postmsg = "OK - restored your files into a new ISO.";
1362
            } else {
1363
                $res .= "Status=Error You must mount image on $mountpath before restoring\n";
1364
            }
1365
            $res .=  "Status=OK $uistatus files from $name to iso, $newuuid, $cmd\n";
1366
            $main::syslogit->($user, "info", "$uistatus files from $path to iso, $newuuid");
1367
            1;
1368
        } or do {$res .= "Status=ERROR $@\n";}
1369
1370
    } else {
1371
        $res .= "Status=ERROR Image not mounted, mount before restoring: ". $curfiles ."\n";
1372
    }
1373
    return $res;
1374
}
1375
1376
sub trim{
1377
   my $string = shift;
1378
   $string =~ s/^\s+|\s+$//g;
1379
   return $string;
1380
}
1381
1382
sub overQuotas {
1383
    my $inc = shift;
1384
    my $onnode = shift;
1385
	my $usedstorage = 0;
1386
	my $overquota = 0;
1387
    return $overquota if ($Stabile::userprivileges =~ /a/); # Don't enforce quotas for admins
1388
1389
	my $storagequota = ($onnode)?$Stabile::usernodestoragequota:$Stabile::userstoragequota;
1390
	if (!$storagequota) { # 0 or empty quota means use defaults
1391
        $storagequota = (($onnode)?$Stabile::config->get('NODESTORAGE_QUOTA'):$Stabile::config->get('STORAGE_QUOTA')) + 0;
1392
	}
1393
    return $overquota if ($storagequota == -1); # -1 means no quota
1394
1395
    my @regkeys = (tied %register)->select_where("user = '$user'");
1396
    foreach my $k (@regkeys) {
1397
        my $val = $register{$k};
1398
		if ($val->{'user'} eq $user) {
1399
		    $usedstorage += $val->{'virtualsize'} if ((!$onnode &&  $val->{'storagepool'}!=-1) || ($onnode &&  $val->{'storagepool'}==-1));
1400
		}
1401
	}
1402
    #print header(), "$package, $Stabile::Systems::userstoragequota, $onnode, $usedstorage, $inc, $storagequota, " . $storagequota*1024*1024; exit;
1403
	return $overquota;
1404
}
1405
1406
sub overStorage {
1407
    my ($reqstor, $spool, $mac) = @_;
1408
    my $storfree;
1409
    if ($spool == -1) {
1410
        if ($mac) {
1411
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
1412
            $storfree = $nodereg{$mac}->{'storfree'};
1413
            $storfree = $storfree *1024 * $nodestorageovercommission;
1414
            untie %nodereg;
1415
        } else {
1416
            return 1;
1417
        }
1418
    } else {
1419
        my $storpath = $spools[$spool]->{'path'};
1420
        $storfree = `df $storpath`;
1421
        $storfree =~ m/(\d\d\d\d+)(\s+)(\d\d*)(\s+)(\d\d+)(\s+)(\S+)/i;
1422
        my $stortotal = $1;
1423
        my $storused = $3;
1424
        $storfree = $5 *1024;
1425
    }
1426
    return ($reqstor > $storfree);
1427
}
1428
1429
sub updateBilling {
1430
    my $event = shift;
1431
    my %billing;
1432
1433
    my @regkeys = (tied %register)->select_where("user = '$user'");
1434
    foreach my $k (@regkeys) {
1435
        my $valref = $register{$k};
1436
        my %val = %{$valref}; # Deference and assign to new array, effectively cloning object
1437
        $val{'virtualsize'} += 0;
1438
        $val{'realsize'} += 0;
1439
        $val{'backupsize'} += 0;
1440
1441
        if ($val{'user'} eq $user && (defined $spools[$val{'storagepool'}]->{'id'} || $val{'storagepool'}==-1)) {
1442
            $billing{$val{'storagepool'}}->{'virtualsize'} += $val{'virtualsize'};
1443
            $billing{$val{'storagepool'}}->{'realsize'} += $val{'realsize'};
1444
            $billing{$val{'storagepool'}}->{'backupsize'} += $val{'backupsize'};
1445
        }
1446
    }
1447
1448
    my %billingreg;
1449
1450
    unless (tie %billingreg,'Tie::DBI', {
1451
            db=>'mysql:steamregister',
1452
            table=>'billing_images',
1453
            key=>'userstoragepooltime',
1454
            autocommit=>0,
1455
            CLOBBER=>3,
1456
            user=>$dbiuser,
1457
            password=>$dbipasswd}) {throw Error::Simple("Stroke=Error Billing register (images) could not be accessed")};
1458
1459
    my $monthtimestamp = timelocal(0,0,0,1,$mon,$year); #$sec,$min,$hour,$mday,$mon,$year
1460
1461
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'billing_images', key=>'userstoragepooltime'}, $Stabile::dbopts)) )
1462
        {throw Error::Simple("Status=Error Billing register could not be accessed")};
1463
1464
    my %pool = ("hostpath", "--",
1465
                "path", "--",
1466
                "name", "local",
1467
                "rdiffenabled", 1,
1468
                "id", -1);
1469
    my @bspools = @spools;
1470
    push @bspools, \%pool;
1471
1472
    foreach my $spool (@bspools) {
1473
        my $storagepool = $spool->{"id"};
1474
        my $b = $billing{$storagepool};
1475
        my $virtualsize = $b->{'virtualsize'} +0;
1476
        my $realsize = $b->{'realsize'} +0;
1477
        my $backupsize = $b->{'backupsize'} +0;
1478
1479
# Setting default start averages for use when no row found under the assumption that we entered a new month
1480
        my $startvirtualsizeavg = 0;
1481
        my $virtualsizeavg = 0;
1482
        my $startrealsizeavg = 0;
1483
        my $realsizeavg = 0;
1484
        my $startbackupsizeavg = 0;
1485
        my $backupsizeavg = 0;
1486
        my $starttimestamp = $current_time;
1487
# We have proably entered a new month if less than 4 hours since change of month, since this is run hourly
1488
        if ($current_time - $monthtimestamp < 4*3600) {
1489
            $starttimestamp = $monthtimestamp;
1490
            $startvirtualsizeavg = $virtualsizeavg = $virtualsize;
1491
            $startrealsizeavg = $realsizeavg = $realsize;
1492
            $startbackupsizeavg = $backupsizeavg = $backupsize;
1493
        }
1494
        # Update existing row
1495
        if ($billingreg{"$user-$storagepool-$year-$month"}) {
1496
            if (
1497
                ($virtualsize != $billingreg{"$user-$storagepool-$year-$month"}->{'virtualsize'})
1498
                || ($realsize != $billingreg{"$user-$storagepool-$year-$month"}->{'realsize'})
1499
                || ($backupsize != $billingreg{"$user-$storagepool-$year-$month"}->{'backupsize'})
1500
            )
1501
            {
1502
            # Sizes changed, update start averages and time, i.e. move the marker
1503
            # Averages and start averages are the same when a change has occurred
1504
                $startvirtualsizeavg = $virtualsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'virtualsizeavg'};
1505
                $startrealsizeavg = $realsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'realsizeavg'};
1506
                $startbackupsizeavg = $backupsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'backupsizeavg'};
1507
                $starttimestamp = $current_time;
1508
            } else {
1509
            # Update averages and timestamp when no change on existing row
1510
                $startvirtualsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'startvirtualsizeavg'};
1511
                $startrealsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'startrealsizeavg'};
1512
                $startbackupsizeavg = $billingreg{"$user-$storagepool-$year-$month"}->{'startbackupsizeavg'};
1513
                $starttimestamp = $billingreg{"$user-$storagepool-$year-$month"}->{'starttimestamp'};
1514
1515
                $virtualsizeavg = ($startvirtualsizeavg*($starttimestamp - $monthtimestamp) + $virtualsize*($current_time - $starttimestamp)) /
1516
                                ($current_time - $monthtimestamp);
1517
                $realsizeavg = ($startrealsizeavg*($starttimestamp - $monthtimestamp) + $realsize*($current_time - $starttimestamp)) /
1518
                                ($current_time - $monthtimestamp);
1519
                $backupsizeavg = ($startbackupsizeavg*($starttimestamp - $monthtimestamp) + $backupsize*($current_time - $starttimestamp)) /
1520
                                ($current_time - $monthtimestamp);
1521
            }
1522
            # Update sizes in DB
1523
                $billingreg{"$user-$storagepool-$year-$month"}->{'virtualsize'} = $virtualsize;
1524
                $billingreg{"$user-$storagepool-$year-$month"}->{'realsize'} = $realsize;
1525
                $billingreg{"$user-$storagepool-$year-$month"}->{'backupsize'} = $backupsize;
1526
            # Update start averages
1527
                $billingreg{"$user-$storagepool-$year-$month"}->{'startvirtualsizeavg'} = $startvirtualsizeavg;
1528
                $billingreg{"$user-$storagepool-$year-$month"}->{'startrealsizeavg'} = $startrealsizeavg;
1529
                $billingreg{"$user-$storagepool-$year-$month"}->{'startbackupsizeavg'} = $startbackupsizeavg;
1530
            # Update current averages with values just calculated
1531
                $billingreg{"$user-$storagepool-$year-$month"}->{'virtualsizeavg'} = $virtualsizeavg;
1532
                $billingreg{"$user-$storagepool-$year-$month"}->{'realsizeavg'} = $realsizeavg;
1533
                $billingreg{"$user-$storagepool-$year-$month"}->{'backupsizeavg'} = $backupsizeavg;
1534
            # Update time stamps and inc
1535
                $billingreg{"$user-$storagepool-$year-$month"}->{'timestamp'} = $current_time;
1536
                $billingreg{"$user-$storagepool-$year-$month"}->{'starttimestamp'} = $starttimestamp;
1537
                $billingreg{"$user-$storagepool-$year-$month"}->{'inc'}++;
1538
1539
        # Write new row
1540
        } else {
1541
            $billingreg{"$user-$storagepool-$year-$month"} = {
1542
                virtualsize=>$virtualsize+0,
1543
                realsize=>$realsize+0,
1544
                backupsize=>$backupsize+0,
1545
1546
                virtualsizeavg=>$virtualsizeavg,
1547
                realsizeavg=>$realsizeavg,
1548
                backupsizeavg=>$backupsizeavg,
1549
1550
                startvirtualsizeavg=>$startvirtualsizeavg,
1551
                startrealsizeavg=>$startrealsizeavg,
1552
                startbackupsizeavg=>$startbackupsizeavg,
1553
1554
                timestamp=>$current_time,
1555
                starttimestamp=>$starttimestamp,
1556
                event=>$event,
1557
                inc=>1,
1558
            };
1559
        }
1560
    }
1561
    tied(%billingreg)->commit;
1562
    untie %billingreg;
1563
}
1564
1565
sub Removeuserimages {
1566
    my ($path, $action, $obj) = @_;
1567
    if ($help) {
1568
        return <<END
1569
GET::
1570
Removes all images belonging to a user from storage, i.e. completely deletes the image and its backups (be careful).
1571
END
1572
    }
1573
1574
    $postreply = removeUserImages($user) unless ($isreadonly);
1575
    return $postreply;
1576
}
1577
1578
sub removeUserImages {
1579
    my $username = shift;
1580
    return unless ($username && ($isadmin || $user eq $username) && !$isreadonly);
1581
    $user = $username;
1582
    foreach my $path (keys %register) {
1583
        if ($register{$path}->{'user'} eq $user) {
1584
            $postreply .=  "Removing " . ($preserveimagesonremove?"(preserving) ":"") . " $username image $register{$path}->{'name'}, $uuid" . ($console?'':'<br>') . "\n";
1585
            Remove($path, 'remove', 0, $preserveimagesonremove);
1586
        }
1587
    }
1588
    $postreply .= "Status=Error No storage pools!\n" unless (@spools);
1589
    foreach my $spool (@spools) {
1590
        my $pooldir = $spool->{"path"};
1591
        unless (-e $pooldir) {
1592
            $postreply .= "Status=Error Storage $pooldir, $spool->{name} does not exist\n" unless (@spools);
1593
            next;
1594
        }
1595
1596
        $postreply .= "Status=OK Removing user dir $pooldir/$username ";
1597
        $postreply .= `/bin/rm "$pooldir/$username/.htaccess"` if (-e "$pooldir/$username/.htaccess");
1598
        $postreply .= `/bin/rmdir --ignore-fail-on-non-empty "$pooldir/$username/fuel"` if (-e "$pooldir/$username/fuel");
1599
        $postreply .= `/bin/rmdir --ignore-fail-on-non-empty "$pooldir/$username"` if (-e "$pooldir/$username");
1600
        $postreply .= "\n";
1601
    }
1602
1603
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
1604
1605
    foreach $mac (keys %nodereg) {
1606
        $macip = $nodereg{$mac}->{'ip'};
1607
        my $esc_path = "/mnt/stabile/node/$username";
1608
        $esc_path =~ s/([ ])/\\$1/g;
1609
        if (!$preserveimagesonremove) {
1610
            `$sshcmd $macip "/bin/rmdir $esc_path"`;
1611
            $postreply .= "Status=OK Removing node user dir /mnt/stabile/node/$username on node $mac\n";
1612
        }
1613
    }
1614
    untie %nodereg;
1615
1616
    return $postreply;
1617
}
1618
1619
sub Remove {
1620
    my ($path, $action, $obj, $preserve) = @_;
1621
    if ($help) {
1622
        return <<END
1623
DELETE:image:
1624
Removes an image from storage, i.e. completely deletes the image and its backups (be careful).
1625
END
1626
    }
1627
    $path = $imagereg{$path}->{'path'} if ($imagereg{$path}); # Check if we were passed a uuid
1628
    $path = $curimg if (!$path && $register{$curimg});
1629 d24d9a01 hq
    if (!$curimg && $path && !($path =~ /^\//)) {
1630
        $curimg = $path;
1631
        $path = '';
1632
    }
1633 95b003ff Origo
    if (!$path && $curimg && !($curimg =~ /\//) ) { # Allow passing only image name if we are deleting an app master
1634
        my $dspool = $stackspool;
1635
        $dspool = $spools[0]->{'path'} unless ($engineid eq $valve001id);
1636
        if ($curimg =~ /\.master.qcow2$/ && $register{"$dspool/$user/$curimg"}) {
1637
            $path = "$dspool/$user/$curimg";
1638
        } elsif ($isadmin && $curimg =~ /\.master.qcow2$/ && $register{"$dspool/common/$curimg"}) {
1639
            $path = "$dspool/common/$curimg";
1640
        }
1641
    }
1642
    utf8::decode($path);
1643
1644
    my $img = $register{$path};
1645
    my $status = $img->{'status'};
1646
    my $mac = $img->{'mac'};
1647
    my $name = $img->{'name'};
1648
    my $uuid = $img->{'uuid'};
1649
    utf8::decode($name);
1650
    my $type = $img->{'type'};
1651
    my $username = $img->{'user'};
1652
1653
    unless ($username && ($isadmin || $user eq $username) && !$isreadonly) {
1654
        return qq|[]|;
1655
#        $postmsg = "Cannot delete image";
1656
#        $postreply .= "Status=Error $postmsg\n";
1657
#        return $postreply;
1658
    }
1659
1660
    $uistatus = "deleting";
1661
    if ($status eq "unused" || $status eq "uploading" || $path =~ /(.+)\.master\.$type/) {
1662 3657de20 Origo
        my $haschildren;
1663
        my $child;
1664
        my $hasprimary;
1665
        my $primary;
1666 95b003ff Origo
        my $master = ($img->{'master'} && $img->{'master'} ne '--')?$img->{'master'}:'';
1667
        my $usedmaster = '';
1668
        my @regvalues = values %register;
1669
        foreach my $valref (@regvalues) {
1670
            if ($valref->{'master'} eq $path) {
1671
                $haschildren = 1;
1672
                $child = $valref->{'name'};
1673
            #    last;
1674
            }
1675
            if ($master) {
1676
                $usedmaster = 1 if ($valref->{'master'} eq $master && $valref->{'path'} ne $path); # Check if another image is also using this master
1677
            }
1678
        }
1679
        if ($master && !$usedmaster) {
1680
            $register{$master}->{'status'} = 'unused';
1681
            $main::syslogit->($user, "info", "Freeing master $master");
1682
        }
1683 3657de20 Origo
        if ($type eq "qcow2") {
1684
            my @regkeys = (tied %register)->select_where("image2 = '$path'");
1685
            foreach my $k (@regkeys) {
1686
                my $val = $register{$k};
1687
                if ($val->{'image2'} eq $path) {
1688
                    $hasprimary = 1;
1689
                    $primary = $val->{'name'};
1690
                    last;
1691
                }
1692
            }
1693
        }
1694 95b003ff Origo
1695
        if ($haschildren) {
1696
            $postmsg = "Cannot delete image. This image is used as master by: $child";
1697
            $postreply .= "Status=Error $postmsg\n";
1698 3657de20 Origo
#        } elsif ($hasprimary) {
1699
#            $postmsg = "Cannot delete image. This image is used as secondary image by: $primary";
1700
#            $postreply .= "Status=Error $postmsg\n";
1701 95b003ff Origo
        } else {
1702
            if ($mac && $path =~ /\/mnt\/stabile\/node\//) {
1703
                unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return "Status=Error Cannot connect to DB\n";};
1704
                $macip = $nodereg{$mac}->{'ip'};
1705
                my $wakenode = ($nodereg{$mac}->{'status'} eq 'asleep' || $nodereg{$mac}->{'status'} eq 'waking');
1706
1707
                if ($wakenode) {
1708
                    my $tasks = $nodereg{$mac}->{'tasks'};
1709
                    my $upath = URI::Escape::uri_escape($path);
1710
                    $tasks .= "REMOVE $upath $user\n";
1711
                    $nodereg{$mac}->{'tasks'} = $tasks;
1712
                    tied(%nodereg)->commit;
1713
                    $postmsg = "We are waking up the node your image $name is on - it will be removed shortly";
1714
                    if ($nodereg{$mac}->{'status'} eq 'asleep') {
1715
                        require "$Stabile::basedir/cgi/nodes.cgi";
1716
                        $Stabile::Nodes::console = 1;
1717
                        Stabile::Nodes::wake($mac);
1718
                    }
1719
                    $register{$path}->{'status'} = $uistatus;
1720
                } else {
1721
                    my $esc_path = $path;
1722
                    $esc_path =~ s/([ ])/\\$1/g;
1723
                    if ($preserve) {
1724
                        `$sshcmd $macip "/bin/mv $esc_path $esc_path.bak"`;
1725
                    } else {
1726
                        `$sshcmd $macip "/usr/bin/unlink $esc_path"`;
1727
                    }
1728
                    `$sshcmd $macip "/usr/bin/unlink $esc_path.meta"`;
1729
                    delete $register{$path};
1730
                }
1731
                untie %nodereg;
1732
1733
            } else {
1734
                if ($preserve) {
1735
                    `/bin/mv "$path" "$path.bak"`;
1736
                } else {
1737
                    unlink $path;
1738
                }
1739
                if (substr($path,-5) eq '.vmdk') {
1740
                    if ( -s (substr($path,0,-5) . "-flat.vmdk")) {
1741
                        my $flat = substr($path,0,-5) . "-flat.vmdk";
1742
                        if ($preserve) {
1743
                            `/bin/mv $flat "$flat.bak"`;
1744
                        } else {
1745
                            unlink($flat);
1746
                        }
1747
                    } elsif ( -e (substr($path,0,-5) . "-s001.vmdk")) {
1748
                        my $i = 1;
1749
                        my $rmpath = substr($path,0,-5);
1750
                        while (-e "$rmpath-s00$i.vmdk") {
1751
                            if ($preserve) {
1752
                                `/bin/mv "$rmpath-s00$i.vmdk" "$rmpath-s00$i.vmdk.bak"`;
1753
                            } else {
1754
                                unlink("$rmpath-s00$i.vmdk");
1755
                            }
1756
                            $i++;
1757
                        }
1758
                    }
1759
                }
1760
                unlink "$path.meta" if (-e "$path.meta");
1761
                delete $register{$path};
1762
            }
1763
1764
            my $subdir = "";
1765
            my($bname, $dirpath) = fileparse($path);
1766 27512919 Origo
            if ($dirpath =~ /.+\/$buser(\/.+)?\//) {
1767 95b003ff Origo
                $subdir = $1;
1768
            }
1769
            my $bpath = "$backupdir/$user$subdir/$bname";
1770
            $bpath = $1 if ($bpath =~ /(.+)/);
1771
            # Remove backup of image if it exists
1772
            if (-d "$bpath") {
1773
                `/bin/rm -rf "$bpath"`;
1774
            }
1775
1776
#            $postmsg = "Deleted image $name ($path, $uuid, $mac)";
1777
            $postreply =  "[]";
1778
#            $postreply .=  "Status=deleting OK $postmsg\n";
1779
            updateBilling("delete $path");
1780
            $main::syslogit->($user, "info", "$uistatus $type image: $name: $path");
1781
            if ($status eq 'downloading') {
1782
                my $daemon = Proc::Daemon->new(
1783
                    work_dir => '/usr/local/bin',
1784
                    exec_command => qq|pkill -f "$path"|
1785
                ) or do {$postreply .= "Status=ERROR $@\n";};
1786
                my $pid = $daemon->Init();
1787
            }
1788
            sleep 1;
1789
        }
1790
    } else {
1791
        $postmsg = "Cannot delete $type image with status: $status";
1792
        $postreply .= "Status=ERROR $postmsg\n";
1793
    }
1794
    return $postreply;
1795
}
1796
1797
# Clone image $path to destination storage pool $istoragepool, possibly changing backup schedule $bschedule
1798
sub Clone {
1799 c899e439 Origo
    my ($path, $action, $obj, $istoragepool, $imac, $name, $bschedule, $buildsystem, $managementlink, $appid, $wait, $vcpu, $mem) = @_;
1800 95b003ff Origo
    if ($help) {
1801
        return <<END
1802
GET:image,name,storagepool,wait:
1803
Clones an image. In the case of cloning a master image, a child is produced.
1804
Only cloning to same storagepool is supported, with the exception of cloning to nodes (storagepool -1).
1805
If you want to perform the clone synchronously, set wait to 1;
1806
END
1807
    }
1808
    $postreply = "" if ($buildsystem);
1809
    return "Status=Error no valid user\n" unless ($user);
1810
1811
    unless ($register{$path} && ($register{$path}->{'user'} eq $user
1812
                || $register{$path}->{'user'} eq 'common'
1813
                || $register{$path}->{'user'} eq $billto
1814
                || $isadmin)) {
1815
        $postreply .= "Status=ERROR Cannot clone!\n";
1816
        return;
1817
    }
1818
    $istoragepool = $istoragepool || $obj->{storagepool};
1819
    $name = $name || $obj->{name};
1820
    $wait = $wait || $obj->{wait};
1821
    my $status = $register{$path}->{'status'};
1822
    my $type = $register{$path}->{'type'};
1823
    my $master = $register{$path}->{'master'};
1824
    my $notes = $register{$path}->{'notes'};
1825
    my $image2 = $register{$path}->{'image2'};
1826
    my $snap1 = $register{$path}->{'snap1'};
1827
    $managementlink = $register{$path}->{'managementlink'} unless ($managementlink);
1828
    $appid = $register{$path}->{'appid'} unless ($appid);
1829
    my $upgradelink = $register{$path}->{'upgradelink'} || '';
1830
    my $terminallink = $register{$path}->{'terminallink'} || '';
1831
    my $version = $register{$path}->{'version'} || '';
1832
    my $regmac = $register{$path}->{'mac'};
1833
1834
    my $virtualsize = $register{$path}->{'virtualsize'};
1835
    my $dindex = 0;
1836
1837
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
1838
    $path =~ /(.+)\.$type/;
1839
    my $namepath = $1;
1840
    if ($namepath =~ /(.+)\.master/) {
1841
        $namepath = $1;
1842
    }
1843
    if ($namepath =~ /(.+)\.clone\d+/) {
1844
        $namepath = $1;
1845
    }
1846
    if ($namepath =~ /.+\/common\/(.+)/) { # Support one subdir
1847
        $namepath = $1;
1848
    } elsif ($namepath =~ /.+\/$user\/(.+)/) { # Support one subdir
1849
        $namepath = $1;
1850
    } elsif ($namepath =~ /.+\/(.+)/) { # Extract only the name
1851
        $namepath = $1;
1852
    }
1853
1854
    # Find unique path in DB across storage pools
1855
    my $upath;
1856
    my $npath = "/mnt/stabile/node/$user/$namepath"; # Also check for uniqueness on nodes
1857
    my $i = 1;
1858
    foreach my $spool (@spools) {
1859
        $upath = $spool->{'path'} . "/$user/$namepath";
1860
        while ($register{"$upath.clone$i.$type"} || $register{"$npath.clone$i.$type"}) {$i++;};
1861
    }
1862
    $upath = "$spools[$istoragepool]->{'path'}/$user/$namepath";
1863
1864
    my $iname = $register{$path}->{'name'};
1865
    $iname = "$name" if ($name); # Used when name supplied when building a system
1866
    $iname =~ /(.+)( \(master\))/;
1867
    $iname = $1 if $2;
1868
    $iname =~ /(.+)( \(clone\d*\))/;
1869
    $iname = $1 if $2;
1870
    $iname =~ /(.+)( \(child\d*\))/;
1871
    $iname = $1 if $2;
1872
    my $ippath = $path;
1873
    my $macip;
1874
    my $ug = new Data::UUID;
1875
    my $newuuid = $ug->create_str();
1876
    my $wakenode;
1877
    my $identity;
1878
1879
    # We only support cloning images to nodes - not the other way round
1880
    if ($imac && $regmac && $imac ne $regmac) {
1881
        $postreply .= "Status=ERROR Cloning from a node not supported\n";
1882
        return $postreply;
1883
    }
1884
1885
    if ($istoragepool==-1) {
1886
    # Find the ip address of target node
1887 c899e439 Origo
        ($imac, $macip, $dindex, $wakenode, $identity) = locateNode($virtualsize, $imac, $vcpu, $mem);
1888 95b003ff Origo
        if ($identity eq 'local_kvm') {
1889 c899e439 Origo
            $postreply .= "Status=OK Cloning to local node with index: $dindex\n";
1890 95b003ff Origo
            $istoragepool = 0; # cloning to local node
1891 3657de20 Origo
            $upath = "$spools[$istoragepool]->{'path'}/$user/$namepath";
1892 95b003ff Origo
        } elsif (!$macip) {
1893 c899e439 Origo
            $postreply .= "Status=ERROR Unable to locate node with sufficient ressources\n";
1894
            $postmsg = "Unable to locate node with sufficient ressources!";
1895 95b003ff Origo
            $main::updateUI->({tab=>"images", user=>$user, type=>"message", message=>$postmsg});
1896
            return $postreply;
1897
        } else {
1898 c899e439 Origo
            $postreply .= "Status=OK Cloning to $macip with index: $dindex\n";
1899 95b003ff Origo
            $ippath = "$macip:$path";
1900
            $upath = "/mnt/stabile/node/$user/$namepath";
1901
        }
1902
    }
1903
    my $ipath = "$upath.clone$i.$type";
1904
1905
    if ($bschedule eq 'daily7' || $bschedule eq 'daily14') {
1906
         $bschedule = "manually" if ($istoragepool!=-1 && (!$spools[$istoragepool]->{'rdiffenabled'} || !$spools[$istoragepool]->{'lvm'}));
1907
    } elsif ($bschedule ne 'manually') {
1908
        $bschedule = '';
1909
    }
1910
1911
# Find storage pool with space
1912
    my $foundstorage = 1;
1913
    if (overStorage($virtualsize, $istoragepool, $imac)) {
1914
        $foundstorage = 0;
1915
        foreach my $p (@spools) {
1916
            if (overStorage($virtualsize, $p->{'id'}, $imac)) {
1917
                ;
1918
            } else {
1919
                $istoragepool = $p->{'id'};
1920
                $foundstorage = 1;
1921
                last;
1922
            }
1923
        }
1924
    }
1925
1926
# We allow multiple clone operations on master images
1927
    if ($status ne "used" && $status ne "unused" && $status ne "paused" && $path !~ /(.+)\.master\.$type/) {
1928
        $postreply .= "Status=ERROR Please shut down your virtual machine before cloning\n";
1929
1930
    } elsif ($type eq 'vmdk' && (-e "$dirpath$bname-s001$suffix" || -e "$dirpath$bname-flat$suffix")) {
1931
        $postreply .= "Status=ERROR Cannot clone this image - please convert first!\n";
1932
1933
    } elsif (overQuotas($virtualsize, ($istoragepool==-1))) {
1934
        $postreply .= "Status=ERROR Over quota (". overQuotas($virtualsize, ($istoragepool==-1)) . ") cloning: $name\n";
1935
1936
    } elsif (!$foundstorage) {
1937
        $postreply .= "Status=ERROR Not enough storage ($virtualsize) in destination pool $istoragepool $imac cloning: $name\n";
1938
1939
    } elsif ($wakenode && !($path =~ /(.+)\.master\.$type/)) { # For now we dont support simply copying images on sleeping nodes
1940
        $postreply .= "Status=ERROR We are waking up the node your image $name is on, please try again later\n";
1941
        require "$Stabile::basedir/cgi/nodes.cgi";
1942
        $Stabile::Nodes::console = 1;
1943
        Stabile::Nodes::wake($imac);
1944
    } elsif ($type eq "img" || $type eq "qcow2" || $type eq "vmdk") {
1945
        my $masterimage2 = $register{"$path"}->{'image2'};
1946
    # Cloning a master produces a child
1947
        if ($type eq "qcow2" && $path =~ /(.+)\.master\.$type/) {
1948
            $uistatus = "cloning";
1949
    # VBoxManage probably does a more efficient job at cloning than simply copying
1950
        } elsif ($type eq "vdi" || $type eq "vhd") {
1951
            $uistatus = "vcloning";
1952
    # Cloning another child produces a sibling with the same master
1953
        } else {
1954
            $uistatus = "copying";
1955
        }
1956
        $uipath = $path;
1957
        eval {
1958
            $register{$ipath} = {
1959
                uuid=>$newuuid,
1960
                master=>($uistatus eq 'cloning')?$path:$master,
1961
                name=>"$iname (clone$i)",
1962
                notes=>$notes,
1963
                image2=>$image2,
1964
                snap1=>($uistatus eq 'copying')?$snap1:'',
1965
                storagepool=>$istoragepool,
1966
                status=>$uistatus,
1967
                mac=>($istoragepool == -1)?$imac:"",
1968
                size=>0,
1969
                realsize=>0,
1970
                virtualsize=>$virtualsize,
1971
                bschedule=>$bschedule,
1972
                type=>"qcow2",
1973
                created=>$current_time,
1974
                user=>$user
1975
            };
1976
            $register{$ipath}->{'managementlink'} = $managementlink if ($managementlink);
1977
            $register{$ipath}->{'appid'} = $appid if ($appid);
1978
            $register{$ipath}->{'upgradelink'} = $upgradelink if ($upgradelink);
1979
            $register{$ipath}->{'terminallink'} = $terminallink if ($terminallink);
1980
            $register{$ipath}->{'version'} = $version if ($version);
1981
            $register{$path}->{'status'} = $uistatus;
1982
            my $dstatus = ($buildsystem)?'bcloning':$uistatus;
1983
            if ($wakenode) { # We are waking a node for clone operation, so ask movepiston to do the work
1984
                unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
1985
                my $tasks = $nodereg{$imac}->{'tasks'};
1986
                $upath = URI::Escape::uri_escape($ipath);
1987
                $tasks .= "BCLONE $upath $user\n";
1988
                $nodereg{$imac}->{'tasks'} = $tasks;
1989
                tied(%nodereg)->commit;
1990
                untie %nodereg;
1991
            } elsif ($wait) {
1992
                my $cmd = qq|steamExec $user $dstatus $status "$ippath" "$ipath"|;
1993
                $cmd = $1 if ($cmd =~ /(.+)/);
1994
                `$cmd`;
1995
            } else {
1996
                my $daemon = Proc::Daemon->new(
1997
                        work_dir => '/usr/local/bin',
1998
                        exec_command => "perl -U steamExec $user $dstatus $status \"$ippath\" \"$ipath\""
1999
                    ) or do {$postreply .= "Status=ERROR $@\n";};
2000
                my $pid = $daemon->Init();
2001
            }
2002
            $postreply .= "Status=$uistatus OK $uistatus to: $iname (clone$i)" . ($isadmin? " -> $ipath ":"") . "\n";
2003
            $postreply .= "Status=OK uuid: $newuuid\n"; # if ($console || $api);
2004
            $postreply .= "Status=OK path: $ipath\n"; # if ($console || $api);
2005
            $postreply .= "Status=OK mac: $imac\n"; # if ($console || $api);
2006
            $postreply .= "Status=OK wakenode: $wakenode\n"; # if ($console || $api);
2007
            $main::syslogit->($user, "info", "$uistatus $wakenode $type image: $name $uuid to $ipath");
2008
            1;
2009
        } or do {$postreply .= "Status=ERROR $@\n";}
2010
2011
    } else {
2012
        $postreply .= "Status=ERROR Not a valid type: $type\n";
2013
    }
2014
    tied(%register)->commit;
2015
    $main::updateUI->({tab=>"images", user=>$user, type=>"update"});
2016
    return $postreply;
2017
}
2018
2019
2020
# Link master image to fuel
2021
sub Linkmaster {
2022
    my ($mpath, $action) = @_;
2023
    if ($help) {
2024
        return <<END
2025
GET:image:
2026
Link master image to fuel
2027
END
2028
    }
2029
    my $res;
2030
2031
    return "Your account does not have the necessary privileges\n" if ($isreadonly);
2032
    return "Please specify master image to link\n" unless ($mpath);
2033
2034
    unless ($mpath =~ /^\//) { # We did not get an absolute path, look for it in users storagepools
2035
        foreach my $p (@spools) {
2036
            my $dir = $p->{'path'};
2037
            my $cpath = "$dir/common/$mpath";
2038
            my $upath = "$dir/$user/$mpath";
2039
            if (-e $cpath) {
2040
                $mpath = $cpath;
2041
                last;
2042
            } elsif (-e $upath) {
2043
                $mpath = $upath;
2044
                last;
2045
            }
2046
        }
2047
    }
2048
    my $img = $register{$mpath};
2049
    $mpath = $img->{"path"};
2050
    $imguser = $img->{"user"};
2051
    if (!$mpath || ($imguser ne $user && $imguser ne 'common' && !$isadmin)) {
2052
        $postreply = qq|{"status": "Error", "message": "No privs. or not found @_[0]"}|;
2053
        return $postreply;
2054
    }
2055
    my $status = $img->{"status"};
2056
    my $type = $img->{"type"};
2057
    $mpath =~ /(.+)\/(.+)\.master\.$type$/;
2058
    my $namepath = $2;
2059
    my $msg;
2060
    if ($status ne "unused" && $status ne "used") {
2061
        $res .= qq|{"status": "Error", "message": "Only used and unused images may be linked ($status, $mpath)."}|;
2062
    } elsif (!( $mpath =~ /(.+)\.master\.$type$/ ) ) {
2063
        $res .= qq|{"status": "Error", "message": "You can only link master images"}|;
2064
    } elsif ($type eq "qcow2") {
2065
        my $pool = $img->{'storagepool'};
2066
        `chmod 444 "$mpath"`;
2067
        my $linkpath = $tenderpathslist[$pool] . "/$user/fuel/$namepath.link.master.$type";
2068
        my $fuellinkpath = "/mnt/fuel/pool$pool/$namepath.link.master.$type";
2069
        if (-e $tenderpathslist[$pool] . "/$user/fuel") { # master should be on fuel-enabled storage
2070
            unlink ($linkpath) if (-e $linkpath);
2071
            `ln "$mpath" "$linkpath"`;
2072
        } else {
2073
            foreach my $p (@spools) {
2074
                my $dir = $p->{'path'};
2075
                my $poolid = $p->{'id'};
2076
                if (-e "$dir/$user/fuel") {
2077
                    $linkpath = "$dir/$user/fuel/$namepath.copy.master.$type";
2078
                    $fuellinkpath = "/mnt/fuel/pool$poolid/$namepath.copy.master.$type";
2079
                    unlink ($linkpath) if (-e $linkpath);
2080
                    `cp "$mpath" "$linkpath"`;
2081
                    $msg = "Different file systems, master copied";
2082
                    last;
2083
                }
2084
            }
2085
        }
2086
        $res .= qq|{"status": "OK", "message": "$msg", "path": "$fuellinkpath", "linkpath": "$linkpath", "masterpath": "$mpath"}|;
2087
    } else {
2088
        $res .= qq|{"status": "Error", "message": "You can only link qcow2 images"}|;
2089
    }
2090
    $postreply = $res;
2091
    return $res;
2092
}
2093
2094
# Link master image to fuel
2095
sub unlinkMaster {
2096
    my $mpath = shift;
2097
    unless ($mpath =~ /^\//) { # We did not get an absolute path, look for it in users storagepools
2098
        foreach my $p (@spools) {
2099
            my $dir = $p->{'path'};
2100
            my $upath = "$dir/$user/fuel/$mpath";
2101
            if (-e $upath) {
2102
                $mpath = "/mnt/fuel/pool$p->{id}/$mpath";
2103
                last;
2104
            }
2105
        }
2106
    }
2107
2108
    $mpath =~ /\/pool(\d+)\/(.+)\.link\.master\.qcow2$/;
2109
    my $pool = $1;
2110
    my $namepath = $2;
2111
    if (!( $mpath =~ /\/pool(\d+)\/(.+)\.link\.master\.qcow2$/ ) ) {
2112
        $postreply = qq|{"status": "Error", "message": "You can only unlink linked master images ($mpath)"}|;
2113
    } else {
2114
        my $linkpath = $tenderpathslist[$pool] . "/$user/fuel/$namepath.link.master.qcow2";
2115
        if (-e $linkpath) {
2116
            `chmod 644 "$linkpath"`;
2117
            `rm "$linkpath"`;
2118
            $postreply = qq|{"status": "OK", "message": "Link removed", "path": "/mnt/fuel/pool$pool/$namepath.qcow2", "linkpath": "$linkpath"}|;
2119
        } else {
2120
            $postreply = qq|{"status": "Error", "message": "Link $linkpath does not exists."}|;
2121
        }
2122
    }
2123
}
2124
2125
#sub do_getstatus {
2126
#    my ($img, $action) = @_;
2127
#    if ($help) {
2128
#        return <<END
2129
#GET::
2130
#END
2131
#    }
2132
#    # Allow passing only image name if we are dealing with an app master
2133
#    my $dspool = $stackspool;
2134
#    my $masteruser = $params{'masteruser'};
2135
#    my $destuser = $params{'destuser'};
2136
#    my $destpath;
2137
#    $dspool = $spools[0]->{'path'} unless ($engineid eq $valve001id);
2138
#    if (!$register{$img} && $img && !($img =~ /\//) && $masteruser) {
2139
#        if ($img =~ /\.master\.qcow2$/ && $register{"$dspool/$masteruser/$img"}) {
2140
#            if ($ismanager || $isadmin
2141
#                || ($userreg{$masteruser}->{'billto'} eq $user)
2142
#            ) {
2143
#                $img = "$dspool/$masteruser/$img";
2144
#            }
2145
#        }
2146
#    }
2147
#    my $status = $register{$img}->{'status'};
2148
#    if ($status) {
2149
#        my $iuser = $register{$img}->{'user'};
2150
#        # First check if user is allowed to access image
2151
#        if ($iuser ne $user && $iuser ne 'common' && $userreg{$iuser}->{'billto'} ne $user) {
2152
#            $status = '' unless ($isadmin || $ismanager);
2153
#        }
2154
#        if ($destuser) { # User is OK, now check if destination exists
2155
#            my ($dest, $folder) = fileparse($img);
2156
#            $destpath = "$dspool/$destuser/$dest";
2157
#            $status = 'exists' if ($register{$destpath} || -e ($destpath));
2158
#        }
2159
#    }
2160
#    my $res;
2161
#    $res .= $Stabile::q->header('text/plain') unless ($console);
2162
#    $res .= "$status";
2163
#    return $res;
2164
#}
2165
2166
# sub do_move {
2167
#     my ($uuid, $action) = @_;
2168
#     if ($help) {
2169
#         return <<END
2170
# GET:image,destuser,masteruser:
2171
# Move image to a different storage pool or user
2172
# END
2173
#     }
2174
#     return "Your account does not have the necessary privileges\n" if ($isreadonly);
2175
#     Move($curimg, $params{'user'});
2176
#     return $postreply;
2177
# }
2178
2179
sub Move {
2180 48fcda6b Origo
    my ($path, $iuser, $istoragepool, $mac, $force) = @_;
2181 95b003ff Origo
    # Allow passing only image name if we are deleting an app master
2182
    my $dspool = $stackspool;
2183
    my $masteruser = $params{'masteruser'};
2184
    $dspool = $spools[0]->{'path'} unless ($engineid eq $valve001id);
2185
    unless ( tie(%userreg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2186
    if (!$register{$path} && $path && !($path =~ /\//) && $masteruser) {
2187
        if ($path =~ /\.master\.qcow2$/ && $register{"$dspool/$masteruser/$path"}) {
2188
            if ($ismanager || $isadmin
2189
                || ($userreg{$masteruser}->{'billto'} eq $user && $iuser eq $user)
2190
                || ($masteruser eq $user && $userreg{$iuser}->{'billto'} eq $user)
2191
            ) {
2192
                $path = "$dspool/$masteruser/$path";
2193
            }
2194
        }
2195
    }
2196 48fcda6b Origo
    my $regimg = $register{$path};
2197
    $istoragepool = ($istoragepool eq '0' || $istoragepool)? $istoragepool: $regimg->{'storagepool'};
2198
    $mac = $mac || $regimg->{'mac'};
2199
    my $bschedule = $regimg->{'bschedule'};
2200
    my $name = $regimg->{'name'};
2201
    my $status = $regimg->{'status'};
2202
    my $type = $regimg->{'type'};
2203
    my $reguser = $regimg->{'user'};
2204
    my $regstoragepool = $regimg->{'storagepool'};
2205
    my $virtualsize = $regimg->{'virtualsize'};
2206 95b003ff Origo
2207
    my $newpath;
2208
    my $newdirpath;
2209
    my $oldpath = $path;
2210 d24d9a01 hq
    my $olddirpath = $path;
2211 95b003ff Origo
    my $newuser = $reguser;
2212
    my $newstoragepool = $regstoragepool;
2213
    my $haschildren;
2214 3657de20 Origo
    my $hasprimary;
2215 95b003ff Origo
    my $child;
2216 3657de20 Origo
    my $primary;
2217 95b003ff Origo
    my $macip;
2218
    my $alreadyexists;
2219
    my $subdir;
2220 27512919 Origo
#    $subdir = $1 if ($path =~ /\/$reguser(\/.+)\//);
2221
    $subdir = $1 if ($path =~ /.+\/$reguser(\/.+)?\//);
2222 95b003ff Origo
    my $restpath;
2223 27512919 Origo
    $restpath = $1 if ($path =~ /.+\/$reguser\/(.+)/);
2224 95b003ff Origo
2225
    if ($type eq "qcow2" && $path =~ /(.+)\.master\.$type/) {
2226
        my @regkeys = (tied %register)->select_where("master = '$path'");
2227
        foreach my $k (@regkeys) {
2228
            my $val = $register{$k};
2229
            if ($val->{'master'} eq $path) {
2230
                $haschildren = 1;
2231
                $child = $val->{'name'};
2232
                last;
2233
            }
2234
        }
2235
    }
2236 3657de20 Origo
    if ($type eq "qcow2") {
2237
        my @regkeys = (tied %register)->select_where("image2 = '$path'");
2238
        foreach my $k (@regkeys) {
2239
            my $val = $register{$k};
2240
            if ($val->{'image2'} eq $path) {
2241
                $hasprimary = 1;
2242
                $primary = $val->{'name'};
2243
                last;
2244
            }
2245
        }
2246
    }
2247 95b003ff Origo
    if (!$register{$path}) {
2248
        $postreply .= "Status=ERROR Unable to move $path (invalid path, $path, $masteruser)\n" unless ($istoragepool eq '--' || $regstoragepool eq '--');
2249
    } elsif ($type eq 'vmdk' && -s (substr($path,0,-5) . "-flat.vmdk") || -s (substr($path,0,-5) . "-s001.vmdk")) {
2250
        $postreply .= "Status=Error Cannot move this image. Please convert before moving\n";
2251
# Moving an image to a different users dir
2252
    } elsif ($iuser ne $reguser && ($status eq "unused" || $status eq "used")) {
2253
        unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2254
        my @accounts = split(/,\s*/, $userreg{$tktuser}->{'accounts'});
2255
        my @accountsprivs = split(/,\s*/, $userreg{$tktuser}->{'accountsprivileges'});
2256
        %ahash = ($tktuser, $userreg{$tktuser}->{'privileges'} || 'r' ); # Include tktuser in accounts hash
2257
        for my $i (0 .. scalar @accounts)
2258
        {
2259
            next unless $accounts[$i];
2260
            $ahash{$accounts[$i]} = $accountsprivs[$i] || 'u';
2261
        }
2262
2263
        if ((($isadmin || $ismanager ) && $iuser eq 'common') # Check if user is allowed to access account
2264
                || ($isadmin && $userreg{$iuser})
2265
                || ($user eq $engineuser)
2266
                || ($userreg{$iuser}->{'billto'} eq $user)
2267
                || ($ahash{$iuser} && !($ahash{$iuser} =~ /r/))
2268
        ) {
2269
            if ($haschildren) {
2270 3657de20 Origo
                $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"});
2271 95b003ff Origo
                $postreply .= "Status=Error Cannot move image. This image is used as master by: $child\n";
2272 3657de20 Origo
            } elsif ($hasprimary) {
2273
                $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"});
2274
                $postreply .= "Status=Error Cannot move image. This image is used as secondary image by: $primary\n";
2275 95b003ff Origo
            } else {
2276
                if ($regstoragepool == -1) { # The image is located on a node
2277
                    my $uprivs = $userreg{$iuser}->{'privileges'};
2278
                    if ($uprivs =~ /[an]/) {
2279
                        unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2280
                        $macip = $nodereg{$mac}->{'ip'};
2281
                        untie %nodereg;
2282
                        $oldpath = "$macip:/mnt/stabile/node/$reguser/$restpath";
2283
                        $newdirpath = "/mnt/stabile/node/$iuser/$restpath";
2284
                        $newpath = "$macip:$newdirpath";
2285
                        $newuser = $iuser;
2286
                        $newstoragepool = $istoragepool;
2287
                # Check if image already exists in target dir
2288
                        $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}'"`;
2289
                    } else {
2290
                        $postreply .= "Status=Error Target account $iuser cannot use node storage\n";
2291
                    }
2292
                } else {
2293 48fcda6b Origo
                    my $reguser = $userreg{$iuser};
2294
                    my $upools = $reguser->{'storagepools'} || $Stabile::config->get('STORAGE_POOLS_DEFAULTS') || "0";
2295 95b003ff Origo
                    my @nspools = split(/, ?/, $upools);
2296
                    my %ispools = map {$_=>1} @nspools; # Build a hash with destination users storagepools
2297
                    if ($ispools{$regstoragepool}) { # Destination user has access to image's storagepool
2298
                        $newpath = "$spools[$regstoragepool]->{'path'}/$iuser/$restpath";
2299
                    } else {
2300
                        $newpath = "$spools[0]->{'path'}/$iuser/$restpath";
2301
                    }
2302
                    $newdirpath = $newpath;
2303
                    $newuser = $iuser;
2304
            # Check if image already exists in target dir
2305
                    $alreadyexists = -e $newpath;
2306
                }
2307
            }
2308
        } else {
2309
            $postreply .= "Status=Error Cannot move image to account $iuser $ahash{$iuser} - not allowed\n";
2310
        }
2311
# Moving an image to a different storage pool
2312
    } elsif ($istoragepool ne '--' &&  $regstoragepool ne '--' && $istoragepool ne $regstoragepool
2313
            && ($status eq "unused" || $status eq "used" || $status eq "paused")) {
2314
2315
        my $dindex;
2316
        my $wakenode;
2317
        if ($istoragepool == -1 && $regstoragepool != -1) {
2318
            ($mac, $macip, $dindex, $wakenode) = locateNode($virtualsize, $mac);
2319
        }
2320
2321
        $main::syslogit->($user, "info", "Moving $name from $regstoragepool to $istoragepool $macip $wakenode");
2322
2323
        if ($haschildren) {
2324 3657de20 Origo
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"ERROR Unable to move $name (has children)"});
2325 95b003ff Origo
            $postreply .= "Status=ERROR Unable to move $name (has children)\n";
2326 3657de20 Origo
        } elsif ($hasprimary) {
2327
            $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"});
2328
            $postreply .= "Status=Error Cannot move image. This image is used as secondary image by: $primary\n";
2329 95b003ff Origo
        } elsif ($wakenode) {
2330
            $postreply .= "Status=ERROR All available nodes are asleep moving $name, waking $mac, please try again later\n";
2331 3657de20 Origo
            $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"});
2332 95b003ff Origo
            require "$Stabile::basedir/cgi/nodes.cgi";
2333
            $Stabile::Nodes::console = 1;
2334
            Stabile::Nodes::wake($mac);
2335
        } elsif (overStorage($virtualsize, $istoragepool+0, $mac)) {
2336 3657de20 Origo
            $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"});
2337 95b003ff Origo
            $postreply .= "Status=ERROR Out of storage in destination pool $istoragepool $mac moving: $name\n";
2338
        } elsif (overQuotas($virtualsize, ($istoragepool==-1))) {
2339 3657de20 Origo
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$register{$path}->{'uuid'}, status=>$status, message=>"ERROR Over quota (". overQuotas($virtualsize, ($istoragepool==-1)) . ") moving: $name"});
2340 95b003ff Origo
            $postreply .= "Status=ERROR Over quota (". overQuotas($virtualsize, ($istoragepool==-1)) . ") moving: $name\n";
2341
        } elsif ($istoragepool == -1 && $regstoragepool != -1 && $path =~ /\.master\.$type/) {
2342
            $postreply .= "Status=ERROR Unable to move $name (master images are not supported on node storage)\n";
2343 3657de20 Origo
            $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)"});
2344 95b003ff Origo
    # Moving to node
2345
        } elsif ($istoragepool == -1 && $regstoragepool != -1) {
2346
            if (index($privileges,"a")!=-1 || index($privileges,"n")!=-1) { # Privilege "n" means user may use node storage
2347
                if ($macip) {
2348
                    $newdirpath = "/mnt/stabile/node/$reguser/$restpath";
2349
                    $newpath = "$macip:$newdirpath";
2350
                    $newstoragepool = $istoragepool;
2351
            # Check if image already exists in target dir
2352
                    $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}'"`;
2353 d24d9a01 hq
2354 95b003ff Origo
                } else {
2355
                    $postreply .= "Status=ERROR Unable to move $name (not enough space)\n";
2356
                }
2357
            } else {
2358
                $postreply .= "Status=ERROR Unable to move $name (no node)\n";
2359
            }
2360
    # Moving from node
2361
        } elsif ($regstoragepool == -1 && $istoragepool != -1 && $spools[$istoragepool]) {
2362
            if (index($privileges,"a")!=-1 || index($privileges,"n")!=-1 && $mac) { # Privilege "n" means user may use node storage
2363
                unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2364
                $macip = $nodereg{$mac}->{'ip'};
2365
                untie %nodereg;
2366
                $newpath = "$spools[$istoragepool]->{'path'}/$reguser/$restpath";
2367
                $newdirpath = $newpath;
2368
                $oldpath = "$macip:/mnt/stabile/node/$reguser/$restpath";
2369
                $newstoragepool = $istoragepool;
2370
        # Check if image already exists in target dir
2371
                $alreadyexists = -e $newpath;
2372
            } else {
2373
                $postreply .= "Status=ERROR Unable to move $name - select node\n";
2374
            }
2375
        } elsif ($spools[$istoragepool]) { # User has access to storagepool
2376
            $newpath = "$spools[$istoragepool]->{'path'}/$reguser/$restpath";
2377
            $newdirpath = $newpath;
2378
            $newstoragepool = $istoragepool;
2379
            $alreadyexists = -e $newpath && -s $newpath;
2380
        } else {
2381
            $postreply .= "Status=ERROR Cannot move image. This image is used as master by: $child\n";
2382
        }
2383
    } else {
2384
        $postreply .= "Status=ERROR Unable to move $path (bad status or pool $status, $reguser, $iuser, $regstoragepool, $istoragepool)\n" unless ($istoragepool eq '--' || $regstoragepool eq '--');
2385
    }
2386
    untie %userreg;
2387
2388 48fcda6b Origo
    if ($alreadyexists && !$force) {
2389
        $postreply = "Status=ERROR Image \"$name\" already exists in destination\n";
2390
        return $postreply;
2391 95b003ff Origo
    }
2392
# Request actual move operation
2393
    elsif ($newpath) {
2394
        if ($newstoragepool == -1) {
2395
            my $diruser = $iuser || $reguser;
2396
            `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
2397
        }
2398
        if ($subdir && $istoragepool != -1) {
2399
            my $fulldir = "$spools[$istoragepool]->{'path'}/$reguser$subdir";
2400
            `/bin/mkdir -p "$fulldir"` unless -d $fulldir;
2401
        }
2402
        $uistatus = "moving";
2403
        my $ug = new Data::UUID;
2404
        my $tempuuid = $ug->create_str();
2405
2406
        $register{$path}->{'status'} = $uistatus;
2407
        $register{$newdirpath} = \%{$register{$path}}; # Clone db entry
2408
2409
        if ($bschedule eq 'daily7' || $bschedule eq 'daily14') {
2410
             $bschedule = "manually" if (!$spools[$regstoragepool]->{'rdiffenabled'} || !$spools[$regstoragepool]->{'lvm'});
2411
        } elsif ($bschedule ne 'manually') {
2412
            $bschedule = '';
2413
        }
2414
2415
        $register{$path}->{'uuid'} = $tempuuid; # Use new temp uuid for old image
2416
        $register{$newdirpath}->{'storagepool'} = $newstoragepool;
2417
        if ($newstoragepool == -1) {
2418
            $register{$newdirpath}->{'mac'} = $mac;
2419
        } else {
2420
            $register{$newdirpath}->{'mac'} = '';
2421
        }
2422
        $register{$newdirpath}->{'user'} = $newuser;
2423
        tied(%register)->commit;
2424 d24d9a01 hq
        my $domuuid = $register{$path}->{'domains'};
2425
        if ($status eq "used" || $status eq "paused" || $status eq "moving") {
2426 95b003ff Origo
            my $dom = $domreg{$domuuid};
2427 d24d9a01 hq
            if ($dom->{'image'} eq $olddirpath) {
2428 48fcda6b Origo
                $dom->{'image'} = $newdirpath;
2429 d24d9a01 hq
            } elsif ($dom->{'image2'} eq $olddirpath) {
2430 48fcda6b Origo
                $dom->{'image2'} = $newdirpath;
2431 d24d9a01 hq
            } elsif ($dom->{'image3'} eq $olddirpath) {
2432 48fcda6b Origo
                $dom->{'image3'} = $newdirpath;
2433 d24d9a01 hq
            } elsif ($dom->{'image4'} eq $olddirpath) {
2434 48fcda6b Origo
                $dom->{'image4'} = $newdirpath;
2435
            }
2436 95b003ff Origo
            $dom->{'mac'} = $mac if ($newstoragepool == -1);
2437
            if ($dom->{'system'} && $dom->{'system'} ne '--') {
2438
                unless (tie(%sysreg,'Tie::DBI', Hash::Merge::merge({table=>'systems'}, $Stabile::dbopts)) ) {$res .= qq|{"status": "Error": "message": "Unable to access systems register"}|; return $res;};
2439
                my $sys = $sysreg{$dom->{'system'}};
2440 d24d9a01 hq
                $sys->{'image'} = $newdirpath if ($sys->{'image'} eq $olddirpath);
2441 95b003ff Origo
                untie %sysreg;
2442
            }
2443
        }
2444
        my $cmd = qq|/usr/local/bin/steamExec $user $uistatus $status "$oldpath" "$newpath"|;
2445 48fcda6b Origo
        `$cmd`;
2446 95b003ff Origo
        $main::syslogit->($user, "info", "$uistatus $type image $name ($oldpath -> $newpath) ($regstoragepool -> $istoragepool) ($register{$newdirpath}->{uuid})");
2447 48fcda6b Origo
        return "$newdirpath\n";
2448 95b003ff Origo
    } else {
2449 48fcda6b Origo
        return $postreply;
2450 95b003ff Origo
    }
2451
2452
}
2453
2454
sub locateNode {
2455 c899e439 Origo
    my ($virtualsize, $mac, $vcpu, $mem) = @_;
2456 95b003ff Origo
    $vcpu = $vcpu || 1;
2457
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac'}, $Stabile::dbopts)) ) {return 0};
2458
    my $macip;
2459
    my $dmac;
2460
    my $dindex;
2461
    my $asleep;
2462
    my $identity;
2463 c899e439 Origo
    my $node;
2464 95b003ff Origo
    if ($mac && $mac ne "--") { # A node was specified
2465
        if (1024 * $nodestorageovercommission * $nodereg{$mac}->{'storfree'} > $virtualsize && $nodereg{$mac}->{'status'} eq 'running') {
2466 c899e439 Origo
            $node = $nodereg{$mac};
2467 95b003ff Origo
        }
2468
    } else { # Locate a node
2469
        require "$Stabile::basedir/cgi/servers.cgi";
2470
        $Stabile::Servers::console = 1;
2471
        my ($temp1, $temp2, $temp3, $temp4, $ahashref) = Stabile::Servers::locateTargetNode();
2472
        my @avalues = values %$ahashref;
2473
        my @sorted_values = (sort {$b->{'index'} <=> $a->{'index'}} @avalues);
2474 c899e439 Origo
        foreach my $snode (@sorted_values) {
2475 95b003ff Origo
            if (
2476 c899e439 Origo
                (1024 * $nodestorageovercommission * $snode->{'storfree'} > $virtualsize)
2477
                && ($snode->{'cpuindex'} > $vcpu)
2478
                && ($snode->{'memfree'} > $mem+512*1024)
2479
                && !($snode->{'maintenance'})
2480
                && ($snode->{'status'} eq 'running' || $snode->{'status'} eq 'asleep' || $snode->{'status'} eq 'waking')
2481
                && ($snode->{'index'} > 0)
2482 95b003ff Origo
            ) {
2483 d24d9a01 hq
                next if (!($mem) && $snode->{'identity'} eq 'local_kvm'); # Ugly hack - prevent moving images from default storage to local_kvm node
2484 c899e439 Origo
                $node = $snode;
2485 95b003ff Origo
                last;
2486
            }
2487
        }
2488
    }
2489 c899e439 Origo
    $macip = $node->{'ip'};
2490
    $dmac = $node->{'mac'};
2491
    $dindex = $node->{'index'};
2492
    $asleep = ($node->{'status'} eq 'asleep' || $node->{'status'} eq 'waking');
2493
    $identity = $node->{'identity'};
2494 95b003ff Origo
    untie %nodereg;
2495
    return ($dmac, $macip, $dindex, $asleep, $identity);
2496
}
2497
2498
sub do_getimagestatus {
2499
    my ($image, $action) = @_;
2500
    if ($help) {
2501
        return <<END
2502
GET:image:
2503
Check if image already exists. Pass image name including suffix.
2504
END
2505
    }
2506
    my $res;
2507
    $imagename = $params{'name'} || $image;
2508
    foreach my $spool (@spools) {
2509
        my $ipath = $spool->{'path'} . "/$user/$imagename";
2510
        if ($register{$ipath}) {
2511
            $res .= "Status=OK Image $ipath found with status $register{$ipath}->{'status'}\n";
2512
        } elsif (-f "$ipath" && -s "$ipath") {
2513
            $res .= "Status=OK Image $ipath found on disk, please wait for it to be updated in DB\n";
2514
        }
2515
    }
2516
    $res .= "Status=ERROR Image $image not found\n" unless ($res);
2517
    return $res;;
2518
}
2519
2520
# Check if image already exists.
2521
# Pass image name including suffix.
2522
sub imageExists {
2523
    my $imagename = shift;
2524
    foreach my $spool (@spools) {
2525
        my $ipath = $spool->{'path'} . "/$user/$imagename";
2526
        if ($register{$ipath}) {
2527
            return $register{$ipath}->{'status'} || 1;
2528
        } elsif (-e "$ipath") {
2529
            return 1
2530
        }
2531
    }
2532
    return '';
2533
}
2534
2535
# Pass image name including suffix.
2536
# Returns incremented name of an image which does not already exist.
2537
sub getValidName {
2538
    my $imagename = shift;
2539
    my $name = $imagename;
2540
    my $type;
2541
    if ($imagename =~ /(.+)\.(.+)/) {
2542
        $name = $1;
2543
        $type = $2;
2544
    }
2545
    if (imageExists($imagename)) {
2546
        my $i = 1;
2547
        while (imageExists("$name.$i.$type")) {$i++;};
2548
        $imagename = "$name.$i.$type";
2549
    }
2550
    return $imagename;
2551
}
2552
2553
# Print list of available actions on objects
2554
sub do_plainhelp {
2555
    my $res;
2556
    $res .= header('text/plain') unless $console;
2557
    $res .= <<END
2558
* new [size="size", name="name"]: Creates a new image
2559
* 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
2560
image is a regular copy.
2561
* convert: Creates a copy of a non-qcow2 image in qcow2 format
2562
* snapshot: Takes a qcow2 snapshot of the image. Server can not be running.
2563
* unsnap: Removes a qcow2 snapshot.
2564
* revert: Applies a snapshot, reverting the image to the state it was in, when the snapshot was taken.
2565
* master: Turns an image into a master image which child images may be cloned from. Image can not be in use.
2566
* unmaster: Turns a master image into a regular image, which can not be used to clone child images from.
2567
* backup: Backs up an image using rdiff-backup. Rdiff-backup must be enabled in admin server configuration. This is a
2568
very expensive operation, since typically the entire image must be read.
2569
* buildsystem [master="master image"]: Constructs one or optionally multiple servers, images and networks and assembles
2570
them in one app.
2571
* restore [backup="backup"]: Restores an image from a backup. The restore is named after the backup.
2572
* delete: Deletes an image. Use with care. Image can not be in use.
2573
* mount: Mounts an image for restorefiles and listfiles operations.
2574
* unmount: Unmounts an image
2575
END
2576
    ;
2577
    return $res;
2578
}
2579
2580
# Print list of images
2581
# Showing a single image is also handled by specifying uuid or path in $curuuid or $curimg
2582
# When showing a single image a single action may be performed on image
2583
sub do_list {
2584
    my ($img, $action, $obj) = @_;
2585
    if ($help) {
2586
        return <<END
2587
GET:image,uuid:
2588
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.
2589
The returned list may be filtered by specifying storagepool, type, name, path or uuid, like e.g.:
2590
2591
<a href="/stabile/images/type:user" target="_blank">/stabile/images/type:user</a>
2592
<a href="/stabile/images/name:test* AND storagepool:shared" target="_blank">/stabile/images/name:test* AND storagepool:shared</a>
2593
<a href="/stabile/images/storagepool:shared AND path:test*" target="_blank">/stabile/images/storagepool:shared AND path:test*</a>
2594
<a href="/stabile/images/name:* AND storagepool:all AND type:usercdroms" target="_blank">/stabile/images/name:* AND storagepool:all AND type:usercdroms</a>
2595
<a href="/stabile/images/[uuid]" target="_blank">/stabile/images/[uuid]</a>
2596
2597
storagepool may be either of: all, node, shared
2598
type may be either of: user, usermasters, commonmasters, usercdroms
2599
2600
May also be called as tablelist or tablelistall, for use by stash.
2601
2602
END
2603
    }
2604
    my $res;
2605
    my $filter;
2606
    my $storagepoolfilter;
2607
    my $typefilter;
2608
    my $pathfilter;
2609
    my $uuidfilter;
2610
    $curimg = $img if ($img);
2611 c899e439 Origo
    my $regimg = $register{$curimg};
2612
#    if ($curimg && ($isadmin || $regimg->{'user'} eq $user || $regimg->{'user'} eq 'common') ) {
2613
    if ($curimg) { # security is enforced below, we hope...
2614 95b003ff Origo
        $pathfilter = $curimg;
2615
    } elsif ($uripath =~ /images(\.cgi)?\/(\?|)(name|storagepool|type|path)/) {
2616
        $filter = $3 if ($uripath =~ /images(\.cgi)?\/.*name(:|=)(.+)/);
2617
        $filter = $1 if ($filter =~ /(.*) AND storagepool/);
2618
        $filter = $1 if ($filter =~ /(.*) AND type/);
2619
        $filter = $1 if ($filter =~ /(.*)\*$/);
2620
        $storagepoolfilter = $2 if ($uripath =~ /images(\.cgi)?\/.*storagepool:(\w+)/);
2621
        $typefilter = $2 if ($uripath =~ /images(\.cgi)?\/.*type:(\w+)/);
2622
        $typefilter = $2 if ($uripath =~ /images(\.cgi)?\/.*type=(\w+)/);
2623
        $pathfilter = $2 if ($uripath =~ /images(\.cgi)?\/.*path:(.+)/);
2624
        $pathfilter = $2 if ($uripath =~ /images(\.cgi)?\/.*path=(.+)/);
2625
    } elsif ($uripath =~ /images(\.cgi)?\/(\w{8}-\w{4}-\w{4}-\w{4}-\w{12})\/?(\w*)/) {
2626
        $uuidfilter = $2;
2627
        $curaction = lc $3;
2628
    }
2629
    $uuidfilter = $options{u} unless $uuidfilter;
2630
2631
    if ($uuidfilter && $curaction) {
2632
        if ($imagereg{$uuidfilter}) {
2633
            $curuuid = $uuidfilter;
2634
            my $obj = getObj(%params);
2635
            # Now perform the requested action
2636
            my $objfunc = "obj_$curaction";
2637
            if (defined &$objfunc) { # If a function named objfunc exists, call it
2638
                $res = $objfunc->($obj);
2639
                chomp $postreply;
2640
                unless ($res) {
2641
                    $res .= qq|{"status": "OK", "message": "$postreply"}|;
2642
                    $res = join(", ", split("\n", $res));
2643
                }
2644
                unless ($curaction eq 'download') {
2645
                    $res = header('application/json; charset=UTF8') . $res unless ($console);
2646
                }
2647
            } else {
2648
                $res .= header('application/json') unless $console;
2649
                $res .= qq|{"status": "Error", "message": "Unknown image action: $curaction"}|;
2650
            }
2651
        } else {
2652
            $res .= header('application/json') unless $console;
2653
            $res .= qq|{"status": "Error", "message": "Unknown image $uuidfilter"}|;
2654
        }
2655
        return $res;
2656
    }
2657
2658
2659
    my %userregister; # User specific register
2660
2661
    $res .= header('application/json; charset=UTF8') unless $console;
2662
    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;};
2663
2664
    my @busers = @users;
2665
    my @billusers = (tied %userreg)->select_where("billto = '$user'");
2666
    push (@busers, $billto) if ($billto && $billto ne '--'); # We include images from 'parent' user
2667
    push (@busers, @billusers) if (@billusers); # We include images from 'child' users
2668
    untie %userreg;
2669
    unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
2670
    foreach my $u (@busers) {
2671
        my @regkeys = (tied %register)->select_where("user = '$u'");
2672
        foreach my $k (@regkeys) {
2673
            my $valref = $register{$k};
2674
            # Only update info for images the user has access to.
2675
            if ($valref->{'user'} eq $u && (defined $spools[$valref->{'storagepool'}]->{'id'} || $valref->{'storagepool'}==-1)) {
2676
                # Only list installable master images from billto account
2677
                next if ($billto && $u eq $billto && ($valref->{'type'} ne 'qcow2' || $valref->{'installable'} ne 'true'));
2678
                my $path = $valref->{'path'};
2679
                my %val = %{$valref}; # Deference and assign to new array, effectively cloning object
2680
                my $spool = $spools[$val{'storagepool'}];
2681
                # Skip images which are in DB e.g. because of change of storage pool difinitions
2682
                next unless ($val{'storagepool'}==-1 || $val{'path'} =~ /$spool->{'path'}/);
2683
                $val{'virtualsize'} += 0;
2684
                $val{'realsize'} += 0;
2685
                $val{'size'} += 0;
2686
                #$val{'lvm'} = 0+( (($spools[$val{'storagepool'}]->{"hostpath"} eq "local") && $spools[$val{'storagepool'}]->{"rdiffenabled"}) || $val{'storagepool'}==-1);
2687
                if ($val{'storagepool'}==-1) {
2688
                    my $node = $nodereg{$val{'mac'}};
2689
                    $val{'lvm'} = 0+($node->{stor} eq 'lvm');
2690
                } else {
2691
                    $val{'lvm'} = 0+$spool->{"lvm"};
2692
                }
2693
                # If image has a master, update the master with child info.
2694
                # This info is specific to each user, so we don't store it in the db
2695
                if ($valref->{'master'} && $register{$valref->{'master'}} && ((grep $_ eq $valref->{'user'}, @users))) {
2696
                    $register{$valref->{'master'}}->{'status'} = 'used';
2697
                    unless ($userregister{$val{'master'}}) { # If we have not yet parsed master, it is not yet in userregister, so put it there
2698
                        my %mval = %{$register{$val{'master'}}};
2699
                        $userregister{$val{'master'}} = \%mval;
2700
                    }
2701
                    #   $userregister{$val{'master'}}->{'user'} = $u;
2702
                    $userregister{$val{'master'}}->{'status'} = 'used';
2703
                    if ($val{'domains'}) {
2704
                        $userregister{$val{'master'}}->{'domainnames'} .= ", " if ($userregister{$val{'master'}}->{'domainnames'});
2705
                        $userregister{$val{'master'}}->{'domainnames'} .= $val{'domainnames'};
2706
                        $userregister{$val{'master'}}->{'domainnames'} .= " (".$val{'user'}.")" if (index($privileges,"a")!=-1);
2707
2708
                        $userregister{$val{'master'}}->{'domains'} .= ", " if ($userregister{$val{'master'}}->{'domains'});
2709
                        $userregister{$val{'master'}}->{'domains'} .= $val{'domains'};
2710
                    }
2711
                }
2712
                my $status = $valref->{'status'};
2713
                if ($rdiffenabled && ($userrdiffenabled || index($privileges,"a")!=-1) &&
2714
                    ( ($spools[$valref->{'storagepool'}]->{'rdiffenabled'} &&
2715
                        ($spools[$valref->{'storagepool'}]->{'lvm'} || $status eq 'unused' || $status eq 'used' || $status eq 'paused') )
2716
                        || $valref->{'storagepool'}==-1 )
2717
                ) {
2718
                    $val{'backup'} = "" ;
2719
                } else {
2720
                    $val{'backup'} = "disabled" ;
2721
                }
2722
                $val{'status'} = 'backingup' if ($status =~ /backingup/);
2723
                $userregister{$path} = \%val unless ($userregister{$path});
2724
            }
2725
        }
2726
    }
2727
    untie(%nodereg);
2728
2729
    my @uservalues;
2730
    if ($filter || $storagepoolfilter || $typefilter || $pathfilter || $uuidfilter) { # List filtered images
2731
        foreach $uvalref (values %userregister) {
2732
            my $fmatch;
2733
            my $smatch;
2734
            my $tmatch;
2735
            my $pmatch;
2736
            my $umatch;
2737
            $fmatch = 1 if (!$filter || $uvalref->{'name'}=~/$filter/i);
2738
            $smatch = 1 if (!$storagepoolfilter || $storagepoolfilter eq 'all'
2739
                || ($storagepoolfilter eq 'node' && $uvalref->{'storagepool'}==-1)
2740
                || ($storagepoolfilter eq 'shared' && $uvalref->{'storagepool'}>=0)
2741
            );
2742
            $tmatch = 1 if (!$typefilter || $typefilter eq 'all'
2743
                || ($typefilter eq 'user' && $uvalref->{'user'} eq $user
2744
                # && $uvalref->{'type'} ne 'iso'
2745
                # && $uvalref->{'path'} !~ /\.master\.qcow2$/
2746
                    )
2747
                || ($typefilter eq 'usermasters' && $uvalref->{'user'} eq $user && $uvalref->{'path'} =~ /\.master\.qcow2$/)
2748
                || ($typefilter eq 'usercdroms' && $uvalref->{'user'} eq $user && $uvalref->{'type'} eq 'iso')
2749
                || ($typefilter eq 'commonmasters' && $uvalref->{'user'} ne $user && $uvalref->{'path'} =~ /\.master\.qcow2$/)
2750
                || ($typefilter eq 'commoncdroms' && $uvalref->{'user'} ne $user && $uvalref->{'type'} eq 'iso')
2751
            );
2752
            $pmatch = 1 if ($pathfilter && $uvalref->{'path'}=~/$pathfilter/i);
2753
            $umatch = 1 if ($uvalref->{'uuid'} eq $uuidfilter);
2754
            if ((!$pathfilter &&!$uuidfilter && $fmatch && $smatch && $tmatch) || $pmatch) {
2755
                push @uservalues,$uvalref if ($uvalref->{'uuid'});
2756
            } elsif ($umatch && $uvalref->{'uuid'}) {
2757
                push @uservalues,$uvalref;
2758
                last;
2759
            }
2760
        }
2761
    } else {
2762
        @uservalues = values %userregister;
2763
    }
2764
2765
    # Sort @uservalues
2766 2a63870a Christian Orellana
    @uservalues = (sort {$a->{'name'} cmp $b->{'name'}} @uservalues); # Always sort by name first
2767 95b003ff Origo
    my $sort = 'status';
2768
    $sort = $2 if ($uripath =~ /sort\((\+|\-)(\S+)\)/);
2769
    my $reverse;
2770
    $reverse = 1 if ($1 eq '-');
2771
    if ($reverse) { # sort reverse
2772
        if ($sort =~ /realsize|virtualsize|size/) {
2773
            @uservalues = (sort {$b->{$sort} <=> $a->{$sort}} @uservalues); # Sort as number
2774
        } else {
2775
            @uservalues = (sort {$b->{$sort} cmp $a->{$sort}} @uservalues); # Sort as string
2776
        }
2777
    } else {
2778
        if ($sort =~ /realsize|virtualsize|size/) {
2779
            @uservalues = (sort {$a->{$sort} <=> $b->{$sort}} @uservalues); # Sort as number
2780
        } else {
2781
            @uservalues = (sort {$a->{$sort} cmp $b->{$sort}} @uservalues); # Sort as string
2782
        }
2783
    }
2784
2785
    if ($uuidfilter || $curimg) {
2786 48fcda6b Origo
        if (scalar @uservalues > 1) { # prioritize user's own images
2787
            foreach my $val (@uservalues) {
2788
                if ($val->{'user'} eq 'common') {
2789
                    next;
2790
                } else {
2791
                    $json_text = to_json($val, {pretty => 1});
2792
                }
2793
            }
2794
        } else {
2795
            $json_text = to_json($uservalues[0], {pretty => 1}) if (@uservalues);
2796
        }
2797 95b003ff Origo
    } else {
2798 2a63870a Christian Orellana
    #    $json_text = JSON->new->canonical(1)->pretty(1)->encode(\@uservalues) if (@uservalues);
2799 95b003ff Origo
        $json_text = to_json(\@uservalues, {pretty => 1}) if (@uservalues);
2800
    }
2801
    $json_text = "{}" unless $json_text;
2802
    $json_text =~ s/""/"--"/g;
2803
    $json_text =~ s/null/"--"/g;
2804
    $json_text =~ s/"notes" {0,1}: {0,1}"--"/"notes":""/g;
2805
    $json_text =~ s/"installable" {0,1}: {0,1}"(true|false)"/"installable":$1/g;
2806
2807
    if ($action eq 'tablelist' || $action eq 'tablelistall') {
2808
        my $t2 = Text::SimpleTable->new(36,26,5,20,14,10,7);
2809
        $t2->row('uuid', 'name', 'type', 'domainnames', 'virtualsize', 'user', 'status');
2810
        $t2->hr;
2811
        my $pattern = $options{m};
2812
        foreach $rowref (@uservalues){
2813
            next unless ($action eq 'tablelistall' || $rowref->{'user'} eq $user);
2814
            if ($pattern) {
2815
                my $rowtext = $rowref->{'uuid'} . " " . $rowref->{'name'} . " " . $rowref->{'type'} . " " . $rowref->{'domainnames'}
2816
                    . " " .  $rowref->{'virtualsize'} . " " . $rowref->{'user'} . " " . $rowref->{'status'};
2817
                $rowtext .= " " . $rowref->{'mac'} if ($isadmin);
2818
                next unless ($rowtext =~ /$pattern/i);
2819
            }
2820
            $t2->row($rowref->{'uuid'}, $rowref->{'name'}, $rowref->{'type'}, $rowref->{'domainnames'}||'--',
2821
                $rowref->{'virtualsize'}, $rowref->{'user'}, $rowref->{'status'});
2822
        }
2823
        $res .= $t2->draw;
2824
    } elsif ($console) {
2825
        $res .= Dumper(\@uservalues);
2826
    } else {
2827
        $res .= $json_text;
2828
    }
2829
    return $res;
2830
}
2831
2832
# Internal action for looking up a uuid or part of a uuid and returning the complete uuid
2833
sub do_uuidlookup {
2834
    my ($img, $action) = @_;
2835
    if ($help) {
2836
        return <<END
2837
GET:image,path:
2838
END
2839
    }
2840
    my $res;
2841
    $res .= header('text/plain') unless $console;
2842
    my $u = $options{u};
2843
    $u = $curuuid unless ($u || $u eq '0');
2844
    my $ruuid;
2845
    if ($u || $u eq '0') {
2846
        foreach my $uuid (keys %register) {
2847
            if (($register{$uuid}->{'user'} eq $user || $register{$uuid}->{'user'} eq 'common' || $fulllist)
2848
                && ($register{$uuid}->{'uuid'} =~ /^$u/ || $register{$uuid}->{'name'} =~ /^$u/)) {
2849
                $ruuid = $register{$uuid}->{'uuid'};
2850
                last;
2851
            }
2852
        }
2853
        if (!$ruuid && $isadmin) { # If no match and user is admin, do comprehensive lookup
2854
            foreach $uuid (keys %register) {
2855
                if ($register{$uuid}->{'uuid'} =~ /^$u/ || $register{$uuid}->{'name'} =~ /^$u/) {
2856
                    $ruuid = $register{$uuid}->{'uuid'};
2857
                    last;
2858
                }
2859
            }
2860
        }
2861
    }
2862
    $res .= "$ruuid\n" if ($ruuid);
2863
    return $res;
2864
}
2865
2866
# Internal action for showing a single image
2867
sub do_uuidshow {
2868
    my ($img, $action) = @_;
2869
    if ($help) {
2870
        return <<END
2871
GET:image,path:
2872
END
2873
    }
2874
    my $res;
2875
    $res .= header('text/plain') unless $console;
2876
    my $u = $options{u};
2877
    $u = $curuuid unless ($u || $u eq '0');
2878
    if ($u || $u eq '0') {
2879
        foreach my $uuid (keys %register) {
2880
            if (($register{$uuid}->{'user'} eq $user || $register{$uuid}->{'user'} eq 'common' || index($privileges,"a")!=-1)
2881
                && $register{$uuid}->{'uuid'} =~ /^$u/) {
2882
                my %hash = %{$register{$uuid}};
2883
                delete $hash{'action'};
2884
                my $dump = Dumper(\%hash);
2885
                $dump =~ s/undef/"--"/g;
2886
                $res .= $dump;
2887
                last;
2888
            }
2889
        }
2890
    }
2891
    return $res;
2892
}
2893
2894
sub do_updatebilling {
2895
    my ($img, $action) = @_;
2896
    if ($help) {
2897
        return <<END
2898
GET:image,path:
2899
END
2900
    }
2901
    my $res;
2902
    $res .= header('text/plain') unless ($console);
2903
    updateBilling($params{"event"});
2904
    $res .= "Status=OK Updated billing for $user\n";
2905
    return $res;
2906
}
2907
2908
# If used with the -f switch ($fulllist) from console, all users images are updated in the db
2909
# If used with the -p switch ($fullupdate), also updates status information (ressource intensive - runs through all domains)
2910
sub dont_updateregister {
2911
    my ($img, $action) = @_;
2912
    my $res;
2913
    if ($help) {
2914
        return <<END
2915
GET:image,path:
2916
END
2917
    }
2918
    return "Status=ERROR You must be an admin to do this!\n" unless ($isadmin);
2919
    $fullupdate = 1 if ((!$fullupdate && $params{'fullupdate'}) || $action eq 'fullupdateregister');
2920
    my $force = $params{'force'};
2921
    Updateregister($force);
2922
    $res .= "Status=OK Updated image register for " . join(', ', @users) . "\n";
2923
}
2924
2925
sub do_urlupload {
2926
    my ($img, $action) = @_;
2927
    if ($help) {
2928
        return <<END
2929
GET:image,path:
2930
END
2931
    }
2932
    my $res;
2933
    $res .= header('application/json') unless ($console);
2934
    if ($params{'probe'} && $params{'url'}) {
2935
        my $url = $params{'url'};
2936 2a63870a Christian Orellana
        my $cmd = qq!curl --http1.1 -kIL "$url" 2>&1!;
2937 95b003ff Origo
        my $headers = `$cmd`;
2938
        my $filename;
2939
        my $filesize = 0;
2940
        $filename = $1 if ($headers =~ /content-disposition: .+filename="(.+)"/i);
2941
        $filesize = $1 if ($headers =~ /content-length: (\d+)/i);
2942
        my $ok;
2943
        if (!$filename) {
2944 2a63870a Christian Orellana
            my $cmd = qq[curl --http1.1 -kIL "$url" 2>&1 | grep -i " 200 OK"];
2945 95b003ff Origo
            $ok =  `$cmd`; chomp $ok;
2946
            $filename = `basename "$url"` if ($ok);
2947
            chomp $filename;
2948
        }
2949
        if ($filename =~ /\S+\.(vmdk|img|vhd|qcow|qcow2|vdi|iso)$/) {
2950
            $filename = $2 if ($filename =~ /(=|\?)(.+)/);
2951
            $filename = $2 if ($filename =~ /(=|\?)(.+)/);
2952
            $filename = getValidName($filename);
2953
            my $filepath = $spools[0]->{'path'} . "/$user/$filename";
2954
            $res .= qq|{"status": "OK", "name": "$filename", "message": "200 OK", "size": $filesize, "path": "$filepath"}|;
2955
        } else {
2956 2a63870a Christian Orellana
            $res .= qq|{"status": "ERROR", "message": "An image file cannot be downloaded from this URL.", "url": "$url", "filename": "$filename"}|;
2957 95b003ff Origo
        }
2958
    } elsif ($params{'path'} && $params{'url'} && $params{'name'} && defined $params{'size'}) {
2959
        my $imagepath = $params{'path'};
2960
        my $imagename = $params{'name'};
2961
        my $imagesize = $params{'size'};
2962
        my $imageurl = $params{'url'};
2963 2a63870a Christian Orellana
        if (-e "$imagepath.meta" && $imagepath =~ /\.master\.qcow2$/) { # This image is being downloaded by pressurecontrol
2964
            $res .= qq|{"status": "OK", "name": "$imagename", "message": "Now downloading master", "path": "$imagepath"}|;
2965
        } elsif (-e $imagepath) {
2966 95b003ff Origo
            $res .= qq|{"status": "ERROR", "message": "An image file with this name already exists on the server.", "name": "$imagename"}|;
2967
        } elsif ($imagepath !~ /^$spools[0]->{'path'}\/$user\/.+/) {
2968
            $res .= qq|{"status": "ERROR", "message": "Invalid path"}|;
2969
        } elsif (overQuotas($virtualsize)) {
2970
            $res .= qq|{"status": "ERROR", "message": "Over quota (". overQuotas($virtualsize) . ") uploading: $imagename"}|;
2971
        } elsif (overStorage($imagesize, 0)) {
2972
            $res .= qq|{"status": "ERROR", "message": "Out of storage in destination pool uploading: $imagename"}|;
2973
        } elsif ($imagepath =~ /^$spools[0]->{'path'}.+\.(vmdk|img|vhd|qcow|qcow2|vdi|iso)$/) {
2974
            my $imagetype = $1;
2975
            my $ug = new Data::UUID;
2976
            my $newuuid = $ug->create_str();
2977
            my $name = $imagename;
2978
            $name = $1 if ($name =~ /(.+)\.(vmdk|img|vhd|qcow|qcow2|vdi|iso)$/);
2979
            $register{$imagepath} = {
2980
                uuid => $newuuid,
2981
                path => $imagepath,
2982
                name => $name,
2983
                user => $user,
2984
                type => $imagetype,
2985
                virtualsize => $imagesize,
2986
                realsize => $imagesize,
2987
                size => $imagesize,
2988
                storagepool => 0,
2989
                status => 'uploading'
2990
            };
2991
            `/bin/echo uploading > "$imagepath.meta"`;
2992
            eval {
2993
                my $daemon = Proc::Daemon->new(
2994
                    work_dir => '/usr/local/bin',
2995
                    exec_command => "perl -U steamExec $user urluploading unused \"$imagepath\" \"$imageurl\""
2996
                ) or do {$postreply .= "Status=ERROR $@\n";};
2997
                my $pid = $daemon->Init();
2998
                $main::syslogit->($user, "info", "urlupload $imageurl, $imagepath");
2999
                1;
3000
            } or do {$res .= qq|{"status": "ERROR", "message": "ERROR $@"}|;};
3001
            $res .= qq|{"status": "OK", "name": "$imagename", "message": "Now uploading", "path": "$imagepath"}|;
3002
        }
3003
    } elsif ($params{'path'} && $params{'getsize'}) {
3004
        my $imagepath = $params{'path'};
3005
        if (!(-e $imagepath)) {
3006
            $res .= qq|{"status": "ERROR", "message": "Image not found.", "path": "$imagepath"}|;
3007 2a63870a Christian Orellana
        } elsif ($imagepath !~ /^$spools[0]->{'path'}\/$user\/.+/  && $imagepath !~ /^$spools[0]->{'path'}\/common\/.+/) {
3008 95b003ff Origo
            $res .= qq|{"status": "ERROR", "message": "Invalid path"}|;
3009
        } else {
3010
            my @stat = stat($imagepath);
3011
            my $imagesize = $stat[7];
3012 2a63870a Christian Orellana
            $res .= qq|{"status": "OK", "size": $imagesize, "path": "$imagepath"}|;
3013 95b003ff Origo
        }
3014
    }
3015
    return $res;
3016
}
3017
3018
sub do_upload {
3019
    my ($img, $action) = @_;
3020
    if ($help) {
3021
        return <<END
3022
POST:image,path:
3023
END
3024
    }
3025
    my $res;
3026
    $res .= header("text/html") unless ($console);
3027
3028
    my $uname = $params{'name'};
3029
3030
    my($name, $dirpath, $suffix) = fileparse($uname, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
3031
3032
    $name = $1 if ($name =~ /^\.+(.*)/); # Don't allow hidden files
3033
    #        my $f = lc $name;
3034
    my $f = $name;
3035
    $f = $spools[0]->{'path'} . "/$user/$f$suffix";
3036
3037
    my $chunk = int($params{'chunk'});
3038
    my $chunks = int($params{'chunks'});
3039
3040
    if ($chunk == 0 && -e $f) {
3041 2a63870a Christian Orellana
        $res .= qq|Error: File $f already exists $name|;
3042 95b003ff Origo
    } else {
3043
        open (FILE, ">>$f");
3044
3045
        if ($params{'file'}) {
3046
            my $uh = $Stabile::q->upload("file");
3047
            while ( <$uh> ) {
3048
                print FILE;
3049
            }
3050
            close FILE;
3051
3052
            if ($chunk == 0) {
3053
                `/usr/local/bin/steamExec updateimagestatus "$f" uploading`;
3054
            }
3055
            if ($chunk >= ($chunks - 1) ) { # Done
3056
                unlink("$f.meta");
3057
                `/usr/local/bin/steamExec updateimagestatus "$f" unused`;
3058
            } else {
3059
                my $upload_meta_data = "status=uploading&chunk=$chunk&chunks=$chunks";
3060
                `echo "$upload_meta_data" > "$f.meta"`;
3061
            }
3062
            $res .= qq|OK: Chunk $chunk uploaded of $name|;
3063
        } else {
3064
            $res .= qq|OK: No file $name.|;
3065
        }
3066
    }
3067
    return $res;
3068
}
3069
3070
# .htaccess files are created hourly, giving the image user access
3071
# when download is clicked by another user (in @users, so with permission), this user is also given access until .htaccess is rewritten
3072
sub Download {
3073
    my ($f, $action, $argref) = @_;
3074
    #    my ($name, $managementlink, $upgradelink, $terminallink, $version) = @{$argref};
3075
    if ($help) {
3076
        return <<END
3077 2a63870a Christian Orellana
GET:image,console:
3078 95b003ff Origo
Returns http redirection with URL to download image
3079
END
3080
    }
3081 2a63870a Christian Orellana
    $baseurl = $argref->{baseurl} || $baseurl;
3082 95b003ff Origo
    my %uargs = %{$argref};
3083
    $f = $uargs{'image'} unless ($f);
3084
    $baseurl = $uargs{'baseurl'} || $baseurl;
3085 2a63870a Christian Orellana
    $console = $console || $uargs{'console'};
3086 95b003ff Origo
    my $res;
3087
    my $uf =  URI::Escape::uri_unescape($f);
3088
    if (! $f) {
3089
        $res .= header('text/html', '500 Internal Server Error') unless ($console);
3090
        $res .= "Status=ERROR You must specify an image.\n";
3091
    }
3092
    my $txt = <<EOT
3093
order deny,allow
3094
AuthName "Download"
3095
AuthType None
3096
TKTAuthLoginURL $baseurl/login/
3097
TKTAuthIgnoreIP on
3098
deny from all
3099
Satisfy any
3100
require user $user
3101
require user $tktuser
3102
Options -Indexes
3103
EOT
3104
    ;
3105
    my $fid;
3106
    my $fpath;
3107
    foreach my $p (@spools) {
3108
        foreach my $suser (@users) {
3109
            my $dir = $p->{'path'};
3110
            my $id = $p->{'id'};
3111
            if (-d "$dir/$suser" && $uf =~ /\/$suser\//) {
3112
                if ($uf =~ /$dir\/(.+)\/(.+)/) {
3113
                    my $filename = $2;
3114
                    utf8::encode($filename);
3115
                    utf8::decode($filename);
3116
                    $fpath = "$1/" . URI::Escape::uri_escape($filename);
3117
                    #$fpath = "$1/" . $filename;
3118
                    `chmod o+rw "$uf"`;
3119
                    `/bin/echo "$txt" > "$dir/$suser/.htaccess"`;
3120
                    `chmod 644 "$dir/$suser/.htaccess"`;
3121
                    `/bin/mkdir "$Stabile::basedir/download"` unless (-e "$Stabile::basedir/download");
3122
                    `/bin/ln -s "$dir" "$Stabile::basedir/download/$id"` unless (-e "$Stabile::basedir/download/$id");
3123
                    $fid = $id;
3124
                    last;
3125
                }
3126
            }
3127
        }
3128
    }
3129
    if (($fid || $fid eq '0') && $fpath && -e "$f") {
3130
        my $fileurl = "$baseurl/download/$fid/$fpath";
3131
        if ($console) {
3132 2a63870a Christian Orellana
            $res .= header(). $fileurl;
3133 95b003ff Origo
        } else {
3134
            $res .= "Status: 302 Moved\nLocation: $fileurl\n\n";
3135
            $res .= "$fileurl\n";
3136
        }
3137
    } else {
3138
        $res .= header('text/html', '500 Internal Server Error') unless ($console);
3139
        $res .= "Status=ERROR File not found $f, $fid, $fpath, $uargs{image}\n";
3140
    }
3141
    return $res;
3142
}
3143
3144
3145
sub Liststoragedevices {
3146 2a63870a Christian Orellana
    my ($image, $action, $obj) = @_;
3147 95b003ff Origo
    if ($help) {
3148
        return <<END
3149
GET::
3150
Returns available physical disks and partitions.
3151
Partitions currently used for holding backup and primary images directories are marked as such.
3152
May also be called as 'getimagesdevice', 'getbackupdevice', 'listimagesdevices' or 'listbackupdevices'.
3153
END
3154
    }
3155
    unless ($isadmin || ($user eq $engineuser)) {
3156
        return '' if ($action eq 'getimagesdevice' || $action eq 'getbackupdevice');
3157
        return qq|[]|;
3158
    }
3159
    my %devs;
3160
    # Check if we have unmounted ZFS file systems
3161
#    if (`grep "stabile-images" /etc/stabile/config.cfg` && !(`df` =~ /stabile-images/)) {
3162
    if (!(`df` =~ /stabile-images/)) {
3163
        `zpool import stabile-images`;
3164
        `zfs mount stabile-images`;
3165
        `zfs mount stabile-images/images`;
3166
    }
3167
    if (!(`df` =~ /stabile-backup/)) {
3168
        `zpool import stabile-backup`;
3169
        `zfs mount stabile-backup`;
3170
        `zfs mount stabile-backup/images`;
3171
        `zfs mount stabile-backup/backup`;
3172
    }
3173
    # Add active and mounted filesystems
3174
    my %filesystems;
3175
    $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 ]'/;
3176
    my $json = `$cmd`;
3177
    my $jobj = JSON::from_json($json);
3178
    my $rootdev;
3179
    my $backupdev;
3180
    my $imagesdev;
3181
    foreach my $fs (sort {$a->{'Filesystem'} cmp $b->{'Filesystem'}} @{$jobj}) {
3182
        # 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
3183
        if ($fs->{Filesystem} =~ /\/dev\/(.+)/) {
3184 2a63870a Christian Orellana
            next if ($fs->{Type} eq 'squashfs');
3185
            next if ($fs->{Filesystem} =~ /\/dev\/loop/);
3186 95b003ff Origo
            my $name = $1;
3187
            if ($name =~ /mapper\/(\w+-)(.+)/) {
3188
                $name = "$1$2";
3189
            }
3190
            $fs->{Name} = $name;
3191
            delete $fs->{on};
3192
            my $mp = $fs->{Mounted};
3193
            if ($fs->{Mounted} eq '/') {
3194
                $rootdev = $name;
3195
            } else {
3196
                if ($backupdir =~ /^$fs->{Mounted}/) {
3197
                    next if ($action eq 'listimagesdevices'); # Current backup dev is not available as images dev
3198
                    $fs->{isbackupdev} = 1;
3199
                    $backupdev = $name;
3200
                    return $name if ($action eq 'getbackupdevice');
3201
                }
3202
                if ($tenderpathslist[0] =~ /^$fs->{Mounted}/) {
3203
                    next if ($action eq 'listbackupdevices'); # Current images dev is not available as backup dev
3204
                    $fs->{isimagesdev} = 1;
3205
                    $imagesdev = $name;
3206
                    return $name if ($action eq 'getimagesdevice');
3207
                }
3208
            }
3209
            $fs->{dev} = $name;
3210
            $fs->{nametype} = "$name ($fs->{Type} - " .  ($mp?$mp:"not mounted") . " $fs->{Size})";
3211
            $filesystems{$name} = $fs;
3212
        } elsif ( $fs->{Type} eq 'zfs') {
3213
            my $name = $fs->{Filesystem};
3214 71b897d3 hq
            # only include zfs pools but look for use as backup and images, exclude shapshots
3215
            if ($name =~ /(.+)\/(.+)/
3216
                && !($name =~ /SNAPSHOT/)
3217
                && !($name =~ /stabile-backup\/images/)
3218
                && !($name =~ /stabile-backup\/node/)
3219
            ) {
3220 89cb0977 hq
                $name = $1;
3221 95b003ff Origo
                if ($fs->{Mounted} eq $backupdir) {
3222
                    if ($action eq 'listimagesdevices') {
3223 89cb0977 hq
                        delete $filesystems{$name}; # not available for images - used for backup
3224 95b003ff Origo
                    } else {
3225 89cb0977 hq
                        $filesystems{$name}->{isbackupdev} = 1;
3226
                        $fs->{isbackupdev} = 1;
3227 95b003ff Origo
                        $backupdev = $name;
3228
                    }
3229 89cb0977 hq
                    return $name if ($action eq 'getbackupdevice');
3230
                } elsif ($fs->{Mounted} eq $tenderpathslist[0]) {
3231 95b003ff Origo
                    if ($action eq 'listbackupdevices') {
3232 89cb0977 hq
                        delete $filesystems{$name}; # not available for backup - used for images
3233 95b003ff Origo
                    } else {
3234 89cb0977 hq
                        $filesystems{$name}->{isimagesdev} = 1;
3235
                        $fs->{isimagesdev} = 1;
3236 95b003ff Origo
                        $imagesdev = $name;
3237
                    }
3238 89cb0977 hq
                    return $name if ($action eq 'getimagesdevice');
3239 95b003ff Origo
                }
3240 71b897d3 hq
                $fs->{Name} = $name;
3241
                $fs->{nametype} = "$name ($fs->{Type} $fs->{Size})";
3242
                delete $fs->{on};
3243
                $filesystems{$name} = $fs;
3244 95b003ff Origo
            }
3245
        }
3246
    }
3247
    if ($action eq 'getbackupdevice' || $action eq 'getimagesdevice') {
3248
        return $rootdev;
3249
    }
3250 71b897d3 hq
    $filesystems{$rootdev}->{isbackupdev} = 1 unless ($backupdev || $action eq 'listimagesdevices');
3251
    $filesystems{$rootdev}->{isimagesdev} = 1 unless ($imagesdev || $action eq 'listbackupdevices');
3252 95b003ff Origo
    # Lowercase keys
3253
    foreach my $k (keys %filesystems) {
3254
        my %hash = %{$filesystems{$k}};
3255
        %hash = map { lc $_ => $hash{$_} } keys %hash;
3256
        $filesystems{$k} = \%hash;
3257
    }
3258
    # Identify physical devices used for zfs
3259
    $cmd = "zpool list -vH";
3260
    my $zpools = `$cmd`;
3261
    my $zdev;
3262
    my %zdevs;
3263 e9af6c24 Origo
3264 95b003ff Origo
    # Now parse the rather strange output with every other line representing physical dev
3265
    foreach my $line (split "\n", $zpools) {
3266
        my ($zname, $zsize, $zalloc) = split "\t", $line;
3267
        if (!$zdev) {
3268
            if ($zname =~ /stabile-/) {
3269
                $zdev = {
3270
                    name=>$zname,
3271
                    size=>$zsize,
3272
                    alloc=>$zalloc
3273
                }
3274
            }
3275
        } else {
3276
            my $dev = $zsize;
3277
            $zdev->{dev} = $dev;
3278
            if ( $filesystems{$zdev->{name}}) {
3279
                if (
3280
                    ($action eq 'listimagesdevices' && $zdev->{name} =~ /backup/) ||
3281
                        ($action eq 'listbackupdevices' && $zdev->{name} =~ /images/)
3282
                ) {
3283
                    delete $filesystems{$zdev->{name}}; # Don't include backup devs in images listing and vice-versa
3284
                } else {
3285 e9af6c24 Origo
                    if ($filesystems{$zdev->{name}}->{dev}) {
3286
                        $filesystems{$zdev->{name}}->{dev} .= " $dev";
3287
                    } else {
3288
                        $filesystems{$zdev->{name}}->{dev} = $dev;
3289
                    }
3290
        #            $filesystems{$zdev->{name}}->{nametype} =~ s/zfs/zfs pool/;
3291 95b003ff Origo
                }
3292
            }
3293
            $zdevs{$dev} = $zdev->{name};
3294 e9af6c24 Origo
        #    $zdev = '';
3295 95b003ff Origo
        }
3296
    }
3297
3298
    # Add blockdevices
3299
    $cmd = q|lsblk --json|;
3300
    my $json2 = `$cmd`;
3301
    my $jobj2 = JSON::from_json($json2);
3302
    foreach my $fs (@{$jobj2->{blockdevices}}) {
3303
        my $rootdev = $1 if ($fs->{name} =~ /([A-Za-z]+)\d*/);
3304
        if ($fs->{children}) {
3305
            foreach my $fs2 (@{$fs->{children}}) {
3306 2a63870a Christian Orellana
                next if ($fs2->{type} eq 'loop');
3307
                next if ($fs2->{type} eq 'squashfs');
3308 71b897d3 hq
                next if ($fs2->{size} =~ /K$/);
3309 95b003ff Origo
                if ($filesystems{$fs2->{name}}) {
3310
                    $filesystems{$fs2->{name}}->{blocksize} = $fs2->{size};
3311
                } elsif (!$zdevs{$fs2->{name}} && !$zdevs{$rootdev}) { # Don't add partitions already used for ZFS
3312
                    next if (($action eq 'listimagesdevices' || $action eq 'listbackupdevices') && $fs2->{mountpoint} eq '/');
3313
                    my $mp = $fs2->{mountpoint};
3314
                    $filesystems{$fs2->{name}} = {
3315
                        name=>$fs2->{name},
3316
                        blocksize=>$fs2->{size},
3317
                        mountpoint=>$mp,
3318
                        type=>$fs2->{type},
3319
                        nametype=> "$fs2->{name} ($fs2->{type} - " . ($mp?$mp:"not mounted") . " $fs2->{size})",
3320
                        dev=>$fs2->{name}
3321
                    }
3322
                }
3323
            }
3324
        } elsif (!$zdevs{$fs->{name}}) { # Don't add disks already used for ZFS
3325 2a63870a Christian Orellana
            next if ($fs->{type} eq 'loop');
3326
            next if ($fs->{type} eq 'squashfs');
3327 95b003ff Origo
            my $mp = $fs->{mountpoint};
3328
            next if ($fs->{type} eq 'rom');
3329
            $filesystems{$fs->{name}} = {
3330
                name=>$fs->{name},
3331
                blocksize=>$fs->{size},
3332
                mountpoint=>$fs->{mountpoint},
3333
                type=>$fs->{type},
3334
                nametype=> "$fs->{name} ($fs->{type} - " . ($mp?$mp:"not mounted") . " $fs->{size})",
3335
            }
3336
        }
3337
    }
3338
3339
    # Identify physical devices used for lvm
3340
    $cmd = "pvdisplay -c";
3341
    my $pvs = `$cmd`;
3342
    my @backupdevs; my @imagesdevs;
3343
    foreach my $line (split "\n", $pvs) {
3344
        my ($pvdev, $vgname) = split ":", $line;
3345
        $pvdev = $1 if ($pvdev =~ /\s+(\S+)/);
3346
        $pvdev = $1 if ($pvdev =~ /\/dev\/(\S+)/);
3347
        if ($filesystems{"$vgname-backupvol"}) {
3348
            push @backupdevs, $pvdev unless ($action eq 'listimagesdevices');
3349
        } elsif ($filesystems{"$vgname-imagesvol"}) {
3350
            push @imagesdevs, $pvdev unless ($action eq 'listbackupdevices');
3351
        }
3352
        if (@backupdevs) {
3353
            $filesystems{"$vgname-backupvol"}->{dev} = join(" ", @backupdevs);
3354
            $filesystems{"$vgname-backupvol"}->{nametype} = $filesystems{"$vgname-backupvol"}->{name} . " (lvm with " . $filesystems{"$vgname-backupvol"}->{type} . " on " . join(" ", @backupdevs) . " " . $filesystems{"$vgname-backupvol"}->{size} . ")";
3355
        }
3356
        if (@imagesdevs) {
3357
            $filesystems{"$vgname-imagesvol"}->{dev} = join(" ", @imagesdevs);
3358
            $filesystems{"$vgname-imagesvol"}->{nametype} = $filesystems{"$vgname-imagesvol"}->{name} . " (lvm with " . $filesystems{"$vgname-imagesvol"}->{type} . " on " . join(" ", @imagesdevs) . " " . $filesystems{"$vgname-imagesvol"}->{size} . ")";
3359
        }
3360
        delete $filesystems{$pvdev} if ($filesystems{$pvdev}); # Don't also list as physical device
3361
    }
3362
    my $jsonreply;
3363
    if ($action eq 'getbackupdevice' || $action eq 'getimagesdevice') {
3364
        return ''; # We should not get here
3365 2a63870a Christian Orellana
    } elsif ($action eq 'getstoragedevices') {
3366
        return \%filesystems;
3367 95b003ff Origo
    } elsif ($action eq 'listimagesdevices') {
3368
        $jsonreply .= qq|{"identifier": "name", "label": "nametype", "action": "$action", "items": |;
3369
        my @vals = sort {$b->{'isimagesdev'} cmp $a->{'isimagesdev'}} values %filesystems;
3370
        $jsonreply .= JSON->new->canonical(1)->pretty(1)->encode(\@vals);
3371
        $jsonreply .= "}";
3372
    } elsif ($action eq 'listbackupdevices') {
3373
        $jsonreply .= qq|{"identifier": "name", "label": "nametype", "action": "$action", "items": |;
3374
        my @vals = sort {$b->{'isbackupdev'} cmp $a->{'isbackupdev'}} values %filesystems;
3375
        $jsonreply .= JSON->new->canonical(1)->pretty(1)->encode(\@vals);
3376
        $jsonreply .= "}";
3377
    } else {
3378
        $jsonreply .= JSON->new->canonical(1)->pretty(1)->encode(\%filesystems);
3379
    }
3380
    return $jsonreply;
3381
}
3382
3383
sub do_liststoragepools {
3384
    my ($image, $action) = @_;
3385
    if ($help) {
3386
        return <<END
3387
GET:dojo:
3388
Returns available storage pools. If parameter dojo is set, JSON is padded for Dojo use.
3389
END
3390
    }
3391
    my %npool = (
3392
        "hostpath", "node",
3393
        "path", "--",
3394
        "name", "On node",
3395
        "rdiffenabled", 1,
3396
        "id", "-1");
3397
    my @p = @spools;
3398
    # Present node storage pool if user has sufficient privileges
3399
    if (index($privileges,"a")!=-1 || index($privileges,"n")!=-1) {
3400
        @p = (\%npool);
3401
        push @p, @spools;
3402
    }
3403
3404
    my $jsonreply;
3405
    $jsonreply .= "{\"identifier\": \"id\", \"label\": \"name\", \"items\":" if ($params{'dojo'});
3406
    $jsonreply .= to_json(\@p, {pretty=>1});
3407
    $jsonreply .= "}" if ($params{'dojo'});
3408
    return $jsonreply;
3409
}
3410
3411
# List images available for attaching to server
3412
sub do_listimages {
3413
    my ($img, $action) = @_;
3414
    if ($help) {
3415
        return <<END
3416
GET:image,image1:
3417
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.
3418
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.
3419
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".
3420
END
3421
    }
3422
    my $res;
3423
    $res .= header('application/json') unless ($console);
3424
    my $curimg1 = URI::Escape::uri_unescape($params{'image1'});
3425
    my @filteredfiles;
3426
    my @curusers = @users;
3427
    # If an admin user is looking at a server not belonging to him, allow him to see the server
3428
    # users images
3429
    if ($isadmin && $img && $img ne '--' && $register{$img} && $register{$img}->{'user'} ne $user) {
3430
        @curusers = ($register{$img}->{'user'}, "common");
3431
    }
3432
3433
    foreach my $u (@curusers) {
3434
        my @regkeys = (tied %register)->select_where("user = '$u'");
3435
        foreach my $k (@regkeys) {
3436
            my $val = $register{$k};
3437
            if ($val->{'user'} eq $u && (defined $spools[$val->{'storagepool'}]->{'id'} || $val->{'storagepool'}==-1)) {
3438
                my $f = $val->{'path'};
3439
                next if ($f =~ /\/images\/dummy.qcow2/);
3440
                my $itype = $val->{'type'};
3441
                if ($itype eq "vmdk" || $itype eq "img" || $itype eq "vhd" || $itype eq "qcow" || $itype eq "qcow2" || $itype eq "vdi") {
3442
                    my $hit = 0;
3443
                    if ($f =~ /(.+)\.master\.$itype/) {$hit = 1;} # don't list master images for user selections
3444
                    if ($f =~ /(.+)\/common\//) {$hit = 1;} # don't list common images for user selections
3445
                    my $dbstatus = $val->{'status'};
3446
                    if ($dbstatus ne "unused") {$hit = 1;} # Image is in a transitional state - do not use
3447
                    if ($hit == 0 || $img eq $f) {
3448
                        my $hypervisor = ($itype eq "vmdk" || $itype eq "vhd" || $itype eq "vdi")?"vbox":"kvm";
3449
                        my $notes = $val->{'notes'};
3450
                        $notes = "" if $notes eq "--";
3451
                        my %img = ("path", $f, "name", $val->{'name'}, "hypervisor", $hypervisor, "notes", $notes,
3452
                            "uuid", $val->{'uuid'}, "master", $val->{'master'}, "managementlink", $val->{'managementlink'}||"",
3453
                            "upgradelink", $val->{'upgradelink'}||"", "terminallink", $val->{'terminallink'}||"", "version", $val->{'version'}||"",
3454
                            "appid", $val->{'appid'}||"");
3455
                        push @filteredfiles, \%img;
3456
                    }
3457
                }
3458
            }
3459
        }
3460
    }
3461
    my %img = ("path", "--", "name", "--", "hypervisor", "kvm,vbox");
3462
    if ($curimg1) {
3463
        push @filteredfiles, \%img;
3464
    }
3465
    my $json_text = to_json(\@filteredfiles, {pretty=>1});
3466
    $res .= qq/{"identifier": "path", "label": "name", "items": $json_text }/;
3467
    return $res;
3468
}
3469
3470
sub Listcdroms {
3471
    my ($image, $action) = @_;
3472
    if ($help) {
3473
        return <<END
3474
GET::
3475
Lists the CD roms a user has access to.
3476
END
3477
    }
3478
    my $res;
3479
    $res .= header('application/json') unless ($console);
3480
    my @filteredfiles;
3481
    foreach my $u (@users) {
3482
        my @regkeys = (tied %register)->select_where("user = '$u'");
3483
        foreach my $k (@regkeys) {
3484
            my $val = $register{$k};
3485
            my $f = $val->{'path'};
3486
            if ($val->{'user'} eq $u && (defined $spools[$val->{'storagepool'}]->{'id'} || $val->{'storagepool'}==-1)) {
3487
                my $itype = $val->{'type'};
3488
                if ($itype eq "iso" || $itype eq "toast") {
3489
                    $notes = $val->{'notes'} || '';
3490
                    if ($u eq $user) {
3491
                        $installable = "true";
3492
                    #    $notes = "This CD/DVD may work just fine, however it has not been tested to work with Irigo Servers.";
3493
                    } else {
3494
                        $installable = $val->{'installable'} || 'false';
3495
                    #    $notes = "This CD/DVD has been tested to work with Irigo Servers." unless $notes;
3496
                    }
3497
                    my %img = ("path", $f, "name", $val->{'name'}, "installable", $installable, "notes", $notes);
3498
                    push @filteredfiles, \%img;
3499
                }
3500
            }
3501
        }
3502
    }
3503
    my %ioimg = ("path", "virtio", "name", "-- VirtIO disk (dummy) --");
3504
    push @filteredfiles, \%ioimg;
3505
    my %dummyimg = ("path", "--", "name", "-- No CD --");
3506
    push @filteredfiles, \%dummyimg;
3507
    #        @filteredfiles = (sort {$a->{'name'} cmp $b->{'name'}} @filteredfiles); # Sort by status
3508
    my $json_text = to_json(\@filteredfiles, {pretty=>1});
3509
    $res .= qq/{"identifier": "path", "label": "name", "items": $json_text }/;
3510
    return $res;
3511
}
3512
3513
sub do_listmasterimages {
3514
    my ($image, $action) = @_;
3515
    if ($help) {
3516
        return <<END
3517
GET::
3518
Lists master images available to the current user.
3519
END
3520
    }
3521
    my $res;
3522
    $res .= header('application/json') unless ($console);
3523
3524
    my @filteredfiles;
3525
    my @busers = @users;
3526
    push (@busers, $billto) if ($billto); # We include images from 'parent' user
3527
3528
    foreach my $u (@busers) {
3529
        my @regkeys = (tied %register)->select_where("user = '$u'");
3530
        foreach my $k (@regkeys) {
3531
            my $valref = $register{$k};
3532
            my $f = $valref->{'path'};
3533
            if ($valref->{'user'} eq $u && (defined $spools[$valref->{'storagepool'}]->{'id'} || $valref->{'storagepool'}==-1)) {
3534
                # Only list installable master images from billto account
3535
                next if ($billto && $u eq $billto && $valref->{'installable'} ne 'true');
3536
3537
                my $itype = $valref->{'type'};
3538
                if ($itype eq "qcow2" && $f =~ /(.+)\.master\.$itype/) {
3539
                    my $installable;
3540
                    my $status = $valref->{'status'};
3541
                    my $notes;
3542
                    if ($u eq $user) {
3543
                        $installable = "true";
3544
                        $notes = "This master image may work just fine, however it has not been tested to work with Stabile.";
3545
                    } else {
3546
                        $installable = $valref->{'installable'};
3547
                        $notes = $valref->{'notes'};
3548
                        $notes = "This master image has been tested to work with Irigo Servers." unless $notes;
3549
                    }
3550
                    my %img = (
3551
                        "path", $f,
3552
                        "name", $valref->{'name'},
3553
                        "installable", $installable,
3554
                        "notes", $notes,
3555
                        "managementlink", $valref->{'managementlink'}||"",
3556
                        "upgradelink", $valref->{'upgradelink'}||"",
3557
                        "terminallink", $valref->{'terminallink'}||"",
3558
                        "image2", $valref->{'image2'}||"",
3559
                        "version", $valref->{'version'}||"",
3560
                        "appid", $valref->{'appid'}||"",
3561
                        "status", $status,
3562
                        "user", $valref->{'user'}
3563
                    );
3564
                    push @filteredfiles, \%img;
3565
                }
3566
            }
3567
        }
3568
    }
3569
    my %img = ("path", "--", "name", "--", "installable", "true", "status", "unused");
3570
    push @filteredfiles, \%img;
3571
    my $json_text = to_json(\@filteredfiles);
3572
    $res .= qq/{"identifier": "path", "label": "name", "items": $json_text }/;
3573
    return $res;
3574
}
3575
3576
sub Updatebtime {
3577
    my ($img, $action, $obj) = @_;
3578
    if ($help) {
3579
        return <<END
3580
GET:image:
3581
END
3582
    }
3583
    my $res;
3584
    $curimg = $curimg || $img;
3585
    my $imguser = $register{$curimg}->{'user'};
3586
    if ($isadmin || $imguser eq $user) {
3587
        my $btime;
3588
        $btime = getBtime($curimg, $imguser) if ($imguser);
3589
        if ($btime) {
3590
            $register{$curimg}->{'btime'} = $btime ;
3591
            $res .= "Status=OK $curimg has btime: " . scalar localtime( $btime ) . "\n";
3592
        } else {
3593 2a63870a Christian Orellana
            $register{$curimg}->{'btime'} = '' ;
3594 95b003ff Origo
            $res .= "Status=OK $curimg has no btime\n";
3595
        }
3596
    } else {
3597
        $res .= "Status=Error no access to $curimg\n";
3598
    }
3599
    return $res;
3600
}
3601
3602
sub Updateallbtimes {
3603
    my ($img, $action) = @_;
3604
    if ($help) {
3605
        return <<END
3606
GET::
3607
END
3608
    }
3609
    if ($isadmin) {
3610
        foreach my $path (keys %register) {
3611
            my $imguser = $register{$path}->{'user'};
3612
            my $btime = getBtime($path, $imguser);
3613
            if ($btime) {
3614
                $register{$path}->{'btime'} = $btime ;
3615
                $postreply .= "Status=OK $register{$path}->{'name'} ($path) has btime: " . scalar localtime( $btime ) . "\n";
3616
            } else {
3617
                $postreply .= "Status=OK $register{$path}->{'name'} ($path) has no btime\n";
3618
            }
3619
        }
3620
    } else {
3621
        $postreply .= "Status=ERROR you are not allowed to do this.\n";
3622
    }
3623
    return $postreply;
3624
}
3625
3626
# Activate image from fuel
3627
sub Activate {
3628
    my ($curimg, $action, $argref) = @_;
3629
    if ($help) {
3630
        return <<END
3631 48fcda6b Origo
GET:image, name, managementlink, upgradelink, terminallink, force:
3632
Activate an image from fuel storage, making it available for regular use.
3633 95b003ff Origo
END
3634
    }
3635
    my %uargs = %{$argref};
3636
    my $name = URI::Escape::uri_unescape($uargs{'name'});
3637
    my $managementlink = URI::Escape::uri_unescape($uargs{'managementlink'});
3638
    my $upgradelink = URI::Escape::uri_unescape($uargs{'upgradelink'});
3639
    my $terminallink = URI::Escape::uri_unescape($uargs{'terminallink'});
3640
    my $version = URI::Escape::uri_unescape($uargs{'version'}) || '1.0b';
3641
    my $image2 =  URI::Escape::uri_unescape($uargs{'image2'});
3642 48fcda6b Origo
    my $force = $uargs{'force'};
3643 95b003ff Origo
3644
    return "Status=ERROR image must be in fuel storage ($curimg)\n" unless ($curimg =~ /^\/mnt\/fuel\/pool(\d+)\/(.+)/);
3645
    my $pool = $1;
3646
    my $ipath = $2;
3647
    return "Status=ERROR image is not a qcow2 image ($curimg, $ipath)\n" unless ($ipath =~ /(.+\.qcow2$)/);
3648
    my $npath = $1;
3649
    my $ppath = '';
3650
    if ($npath =~ /(.*\/)(.+\.qcow2$)/) {
3651
        $npath = $2;
3652
        $ppath = $1;
3653
    }
3654
    my $imagepath = $tenderpathslist[$pool] . "/$user/fuel/$ipath";
3655
    my $newpath = $tenderpathslist[$pool] . "/$user/$npath";
3656
    return "Status=ERROR image not found ($imagepath)\n" unless (-e $imagepath);
3657 48fcda6b Origo
    return "Status=ERROR image already exists in destination ($newpath)\n" if (-e $newpath && !$force);
3658
    return "Status=ERROR image is in use ($newpath)\n" if (-e $newpath && $register{$newpath} && $register{$newpath}->{'status'} ne 'unused');
3659 95b003ff Origo
3660 3657de20 Origo
    my $virtualsize = `qemu-img info --force-share "$imagepath" | sed -n -e 's/^virtual size: .*(//p' | sed -n -e 's/ bytes)//p'`;
3661 95b003ff Origo
    chomp $virtualsize;
3662 991e7f1b hq
#    my $master = `qemu-img info --force-share "$imagepath" | sed -n -e 's/^backing file: //p' | sed -n -e 's/ (actual path:.*)\$//p'`;
3663
    my $master = `qemu-img info --force-share "$imagepath" | sed -n -e 's/^backing file: //p'`;
3664 95b003ff Origo
    chomp $master;
3665
3666
    # Now deal with image2
3667
    my $newpath2 = '';
3668
    if ($image2) {
3669
        $image2 = "/mnt/fuel/pool$pool/$ppath$image2" unless ($image2 =~ /^\//);
3670
        return "Status=ERROR image2 must be in fuel storage ($image2)\n" unless ($image2 =~ /^\/mnt\/fuel\/pool$pool\/(.+)/);
3671
        $ipath = $1;
3672
        return "Status=ERROR image is not a qcow2 image\n" unless ($ipath =~ /(.+\.qcow2$)/);
3673
        $npath = $1;
3674
        $npath = $1 if ($npath =~ /.*\/(.+\.qcow2$)/);
3675
        my $image2path = $tenderpathslist[$pool] . "/$user/fuel/$ipath";
3676
        $newpath2 = $tenderpathslist[$pool] . "/$user/$npath";
3677
        return "Status=ERROR image2 not found ($image2path)\n" unless (-e $image2path);
3678 48fcda6b Origo
        return "Status=ERROR image2 already exists in destination ($newpath2)\n" if (-e $newpath2 && !$force);
3679
        return "Status=ERROR image2 is in use ($newpath2)\n" if (-e $newpath2 && $register{$newpath2} && $register{$newpath2}->{'status'} ne 'unused');
3680 95b003ff Origo
3681 3657de20 Origo
        my $virtualsize2 = `qemu-img info --force-share "$image2path" | sed -n -e 's/^virtual size: .*(//p' | sed -n -e 's/ bytes)//p'`;
3682 95b003ff Origo
        chomp $virtualsize2;
3683 991e7f1b hq
#        my $master2 = `qemu-img info --force-share "$image2path" | sed -n -e 's/^backing file: //p' | sed -n -e 's/ (actual path:.*)\$//p'`;
3684
        my $master2 = `qemu-img info --force-share "$image2path" | sed -n -e 's/^backing file: //p'`;
3685 95b003ff Origo
        chomp $master2;
3686
        if ($register{$master2}) {
3687
            $register{$master2}->{'status'} = 'used';
3688
        }
3689
        `mv "$image2path" "$newpath2"`;
3690
        if (-e $newpath2) {
3691
            my $ug = new Data::UUID;
3692
            my $newuuid = $ug->create_str();
3693
            unless ($name) {
3694
                $name = $npath if ($npath);
3695
                $name = $1 if ($name =~ /(.+)\.(qcow2)$/);
3696
            }
3697
            $register{$newpath2} = {
3698
                uuid => $newuuid,
3699
                path => $newpath2,
3700
                master => $master2,
3701
                name => "$name (data)",
3702
                user => $user,
3703
                storagepool => $pool,
3704
                type => 'qcow2',
3705
                status => 'unused',
3706
                version => $version,
3707
                virtualsize => $virtualsize2
3708
            };
3709
            $postreply .= "Status=OK Activated data image $newpath2, $name (data), $newuuid\n";
3710
        } else {
3711
            $postreply .=  "Status=ERROR Unable to activate $image2path, $newpath2\n";
3712
        }
3713
    }
3714
3715
    # Finish up primary image
3716
    if ($register{$master}) {
3717
        $register{$master}->{'status'} = 'used';
3718
    }
3719
    `mv "$imagepath" "$newpath"`;
3720
    if (-e $newpath) {
3721
        my $ug = new Data::UUID;
3722
        my $newuuid = $ug->create_str();
3723
        unless ($name) {
3724
            $name = $npath if ($npath);
3725
            $name = $1 if ($name =~ /(.+)\.(qcow2)$/);
3726
        }
3727
        $register{$newpath} = {
3728
            uuid => $newuuid,
3729
            path => $newpath,
3730
            master => $master,
3731
            name => $name,
3732
            user => $user,
3733
            storagepool => $pool,
3734
            image2 => $newpath2,
3735
            type => 'qcow2',
3736
            status => 'unused',
3737
            installable => 'true',
3738 48fcda6b Origo
            managementlink => $managementlink || '/stabile/pipe/http://{uuid}:10000/stabile/',
3739 95b003ff Origo
            upgradelink => $upgradelink,
3740
            terminallink => $terminallink,
3741
            version => $version,
3742
            virtualsize => $virtualsize
3743
        };
3744
        $postreply .=  "Status=OK Activated $newpath, $name, $newuuid\n";
3745
    } else {
3746
        $postreply .=  "Status=ERROR Unable to activate $imagepath to $newpath\n";
3747
    }
3748
    return $postreply;
3749
}
3750
3751 2a63870a Christian Orellana
sub Uploadtoregistry {
3752
    my ($path, $action, $obj) = @_;
3753
    if ($help) {
3754
        return <<END
3755
GET:image, force:
3756
Upload an image to the registry. Set [force] if you want to force overwrite images in registry - use with caution.
3757
END
3758
    }
3759
    $force = $obj->{'force'};
3760
    if (-e $path && ($register{$path}->{'user'} eq $user || $isadmin)) {
3761
        $postreply .= $main::uploadToOrigo->($engineid, $path, $force);
3762
    } else {
3763
        $postreply .= "Status=Error Not allowed\n";
3764
    }
3765
    return $postreply;
3766
}
3767
3768 95b003ff Origo
sub Publish {
3769
    my ($uuid, $action, $parms) = @_;
3770
    if ($help) {
3771
        return <<END
3772 48fcda6b Origo
GET:image,appid,appstore,force:
3773
Publish a stack to registry. Set [force] if you want to force overwrite images in registry - use with caution.
3774 95b003ff Origo
END
3775
    }
3776
    my $res;
3777
    $uuid = $parms->{'uuid'} if ($uuid =~ /^\// || !$uuid);
3778 48fcda6b Origo
    my $force = $parms->{'force'};
3779 d24d9a01 hq
    my $freshen = $parms->{'freshen'};
3780 95b003ff Origo
3781
    if ($isreadonly) {
3782
        $res .= "Status=ERROR Your account does not have the necessary privilege.s\n";
3783
    } elsif (!$uuid || !$imagereg{$uuid}) {
3784
        $res .= "Status=ERROR At least specify activated master image uuid [uuid or path] to publish.\n";
3785
    } elsif ($imagereg{$uuid}->{'user'} ne $user && !$isadmin) {
3786
        $res .= "Status=ERROR Your account does not have the necessary privileges.\n";
3787
    } elsif ($imagereg{$uuid}->{'path'} =~ /.+\.master\.qcow2$/) {
3788
        if ($engineid eq $valve001id) { # On valve001 - check if meta file exists
3789
            if (-e $imagereg{$uuid}->{'path'} . ".meta") {
3790
                $res .= "On valve001. Found meta file $imagereg{$uuid}->{'path'}.meta\n";
3791
                my $appid = `cat $imagereg{$uuid}->{'path'}.meta | sed -n -e 's/^APPID=//p'`;
3792
                chomp $appid;
3793
                if ($appid) {
3794
                    $parms->{'appid'} = $appid;
3795
                    $register{$imagereg{$uuid}->{'path'}}->{'appid'} = $appid;
3796
                    tied(%register)->commit;
3797
                }
3798
            }
3799
        # On valve001 - move image to stacks
3800
            if ($imagereg{$uuid}->{'storagepool'} ne '0') {
3801
                $res .= "Status=OK Moving image: " . Move($imagereg{$uuid}->{'path'}, $user, 0) . "\n";
3802
            } else {
3803 48fcda6b Origo
                $res .= "Status=OK Image is already available in registry\n";
3804 95b003ff Origo
            }
3805
        } else {
3806 48fcda6b Origo
        #    $console = 1;
3807
        #    my $link = Download($imagereg{$uuid}->{'path'});
3808
        #    chomp $link;
3809
        #    $parms->{'downloadlink'} = $link; # We now upload instead
3810
        #    $res .= "Status=OK Asking registry to download $parms->{'APPID'} image: $link\n";
3811 95b003ff Origo
            if ($appstores) {
3812
                $parms->{'appstore'} = $appstores;
3813
            } elsif ($appstoreurl =~ /www\.(.+)\//) {
3814
                $parms->{'appstore'} = $1;
3815 48fcda6b Origo
                $res .= "Status=OK Adding registry: $1\n";
3816 95b003ff Origo
            }
3817
        }
3818 6fdc8676 hq
#        $parms->{'appstore'} = 1 if ($freshen);
3819 95b003ff Origo
3820
        my %imgref = %{$imagereg{$uuid}};
3821
        $parms = Hash::Merge::merge($parms, \%imgref);
3822
        my $postdata = to_json($parms);
3823
        my $postres = $main::postToOrigo->($engineid, 'publishapp', $postdata);
3824 48fcda6b Origo
        $res .= $postres;
3825 95b003ff Origo
        my $appid;
3826
        $appid = $1 if ($postres =~ /appid: (\d+)/);
3827
        my $path = $imagereg{$uuid}->{'path'};
3828 d24d9a01 hq
        if ($freshen && $appid) {
3829
            $res .= "Status=OK Freshened the stack description\n";
3830
        } elsif ($appid) {
3831 48fcda6b Origo
            $register{$path}->{'appid'} = $appid if ($register{$path});
3832
            $res .= "Status=OK Received appid $appid for $path, uploading image to registry, hang on...\n";
3833
            my $upres .= $main::uploadToOrigo->($engineid, $path, $force);
3834
            $res .= $upres;
3835
            my $image2 = $register{$path}->{'image2'} if ($register{$path});
3836
            if ($upres =~ /Status=OK/ && $image2 && $image2 ne '--') { # Stack has a data image
3837
                $res .= $main::uploadToOrigo->($engineid, $image2, $force);
3838
            }
3839
        } else {
3840
            $res .= "Status=Error Did not get an appid\n";
3841
        }
3842 95b003ff Origo
    } else {
3843
        $res .= "Status=ERROR You can only publish a master image.\n";
3844
    }
3845
    return $res;
3846
}
3847
3848 48fcda6b Origo
sub Release {
3849
    my ($uuid, $action, $parms) = @_;
3850
    if ($help) {
3851
        return <<END
3852
GET:image,appid,appstore,force,unrelease:
3853
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.
3854
END
3855
    }
3856
    my $res;
3857
    $uuid = $parms->{'uuid'} if ($uuid =~ /^\// || !$uuid);
3858
    my $force = $parms->{'force'};
3859
    my $unrelease = $parms->{'unrelease'};
3860
3861
    if (!$uuid || !$imagereg{$uuid}) {
3862
        $res .= "Status=ERROR At least specify master image uuid [uuid or path] to release.\n";
3863
    } elsif (!$isadmin) {
3864
        $res .= "Status=ERROR Your account does not have the necessary privileges.\n";
3865
    } elsif ($imagereg{$uuid}->{'path'} =~ /.+\.master\.qcow2$/ && $imagereg{$uuid}->{'appid'}) {
3866
        my $action = 'release';
3867
        my $targetuser = 'common';
3868
        if ($unrelease) {
3869
            $action = 'unrelease';
3870
            $targetuser = $user;
3871
        }
3872
        if ($appstores) {
3873
            $parms->{'appstore'} = $appstores;
3874
        } elsif ($appstoreurl =~ /www\.(.+)\//) {
3875
            $parms->{'appstore'} = $1;
3876
            $res .= "Status=OK Adding registry: $1\n";
3877
        }
3878
        $parms->{'appid'} = $imagereg{$uuid}->{'appid'};
3879
        $parms->{'force'} = $force if ($force);
3880
        $parms->{'unrelease'} = $unrelease if ($unrelease);
3881
        my $postdata = to_json($parms);
3882
        my $postres = $main::postToOrigo->($engineid, 'releaseapp', $postdata);
3883
        $res .= $postres;
3884
        my $appid;
3885
        $appid = $1 if ($postres =~ /Status=OK Moved (\d+)/);
3886
        my $path = $imagereg{$uuid}->{'path'};
3887
        if ($appid) {
3888
            $res.= "Now moving local stack to $targetuser\n";
3889
            # First move data image
3890
            my $image2 = $register{$path}->{'image2'} if ($register{$path});
3891
            my $newimage2 = $image2;
3892
            if ($image2 && $image2 ne '--' && $register{$image2}) { # Stack has a data image
3893
                if ($unrelease) {
3894
                    $newimage2 =~ s/common/$register{$image2}->{'user'}/;
3895
                } else {
3896
                    $newimage2 =~ s/$register{$image2}->{'user'}/common/;
3897
                }
3898
                $register{$path}->{'image2'} = $newimage2;
3899
                tied(%register)->commit;
3900
                $res .= Move($image2, $targetuser, '', '', 1);
3901
            }
3902
            # Move image
3903
            $res .= Move($path, $targetuser, '', '', 1);
3904
            $res .= "Status=OK $action $appid\n";
3905
        } else {
3906
            $res .= "Status=Error $action failed\n";
3907
        }
3908
    } else {
3909
        $res .= "Status=ERROR You can only $action a master image that has been published.\n";
3910
    }
3911
    return $res;
3912
}
3913
3914 95b003ff Origo
sub do_unlinkmaster {
3915
    my ($img, $action) = @_;
3916
    if ($help) {
3917
        return <<END
3918
GET:image,path:
3919
END
3920
    }
3921
    my $res;
3922
    $res .= header('text/html') unless ($console);
3923
    if ($isreadonly) {
3924
        $res .= "Your account does not have the necessary privileges\n";
3925
    } elsif ($curimg) {
3926
        $res .= unlinkMaster($curimg) . "\n";
3927
    } else {
3928
        $res .= "Please specify master image to link\n";
3929
    }
3930
    return $res;
3931
}
3932
3933
# Simple action for unmounting all images
3934
sub do_unmountall {
3935
    my ($img, $action) = @_;
3936
    if ($help) {
3937
        return <<END
3938
GET:image,path:
3939
END
3940
    }
3941
    return "Your account does not have the necessary privileges\n" if ($isreadonly);
3942
    my $res;
3943
    $res .= header('text/plain') unless ($console);
3944 27512919 Origo
    $res .= "Unmounting all images for $user\n";
3945 95b003ff Origo
    unmountAll();
3946
    $res .= "\n$postreply" if ($postreply);
3947
    return $res;
3948
}
3949
3950
sub Updatedownloads {
3951
    my ($img, $action) = @_;
3952
    if ($help) {
3953
        return <<END
3954
GET:image,path:
3955
END
3956
    }
3957
    my $res;
3958
    $res .= header('text/html') unless ($console);
3959
    my $txt1 = <<EOT
3960
Options -Indexes
3961
EOT
3962
    ;
3963
    `/bin/mkdir "$Stabile::basedir/download"` unless (-e "$Stabile::basedir/download");
3964
    $res .= "Writing .htaccess: -> $Stabile::basedir/download/.htaccess\n";
3965
    unlink("$Stabile::basedir/download/.htaccess");
3966
    `chown www-data:www-data "$Stabile::basedir/download"`;
3967
    `/bin/echo "$txt1" | sudo -u www-data tee "$Stabile::basedir/download/.htaccess"`; #This ugliness is needed because of ownership issues with Synology NFS
3968
    `chmod 644 "$Stabile::basedir/download/.htaccess"`;
3969
    foreach my $p (@spools) {
3970
        my $dir = $p->{'path'};
3971
        my $id = $p->{'id'};
3972
        `/bin/rm "$Stabile::basedir/download/$id"; /bin/ln -s "$dir" "$Stabile::basedir/download/$id"`;
3973
        $res .= "Writing .htaccess: $id -> $dir/.htaccess\n";
3974
        unlink("$dir/.htaccess");
3975
        `/bin/echo "$txt1" | tee "$dir/.htaccess"`;
3976
        `chown www-data:www-data "$dir/.htaccess"`;
3977
        `chmod 644 "$dir/.htaccess"`;
3978
    }
3979
3980
    unless ( tie(%userreg,'Tie::DBI', Hash::Merge::merge({table=>'users', key=>'username', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
3981
3982
    foreach my $username (keys %userreg) {
3983
        my $require = '';
3984
        my $txt = <<EOT
3985
order deny,allow
3986
AuthName "Download"
3987
AuthType None
3988
TKTAuthLoginURL $baseurl/auth/login.cgi
3989
TKTAuthIgnoreIP on
3990
deny from all
3991
Satisfy any
3992
require user $username
3993
Options -Indexes
3994
EOT
3995
        ;
3996
        foreach my $p (@spools) {
3997
            my $dir = $p->{'path'};
3998
            my $id = $p->{'id'};
3999
            if (-d "$dir/$username") {
4000
                $res .= "Writing .htaccess: $id -> $dir/$username/.htaccess\n";
4001
                unlink("$dir/$username/.htaccess");
4002
                `/bin/echo "$txt1" | sudo -u www-data tee $dir/$username/.htaccess`;
4003 3657de20 Origo
                if ($tenderlist[$p->{'id'}] eq 'local') {
4004 d24d9a01 hq
                    if (!(-e "$dir/$username/fuel") && -e "$dir/$username") {
4005 3657de20 Origo
                        `mkdir "$dir/$username/fuel"`;
4006
                        `chmod 777 "$dir/$username/fuel"`;
4007
                    }
4008
                }
4009 95b003ff Origo
            }
4010
        }
4011
    }
4012
    untie %userreg;
4013
    return $res;
4014
}
4015
4016
sub do_listpackages($action) {
4017
    my ($image, $action) = @_;
4018
    if ($help) {
4019
        return <<END
4020
GET:image:
4021
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.
4022
END
4023
    }
4024
    my $res;
4025
    $res .= header('text/plain') unless ($console);
4026
4027
    my $mac = $register{$image}->{'mac'};
4028
    my $macip;
4029
    if ($mac && $mac ne '--') {
4030
        unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4031
        $macip = $nodereg{$mac}->{'ip'};
4032
        untie %nodereg;
4033
    }
4034
    $image =~ /(.+)/; $image = $1;
4035
    my $apps;
4036
4037
    if ($macip && $macip ne '--') {
4038
        my $cmd = qq[eval \$(/usr/bin/guestfish --ro -a "$image" --i --listen); ]; # sets $GUESTFISH_PID shell var
4039
        $cmd .= qq[root="\$(/usr/bin/guestfish --remote inspect-get-roots)"; ];
4040
        $cmd .= qq[guestfish --remote inspect-list-applications "\$root"; ];
4041
        $cmd .= qq[guestfish --remote inspect-get-product-name "\$root"; ];
4042
        $cmd .= qq[guestfish --remote exit];
4043
        $cmd = "$sshcmd $macip '$cmd'";
4044
        $apps = `$cmd`;
4045
    } else {
4046
        my $cmd;
4047
        #        my $pid = open my $cmdpipe, "-|",qq[/usr/bin/guestfish --ro -a "$image" --i --listen];
4048
        $cmd .= qq[eval \$(/usr/bin/guestfish --ro -a "$image" --i --listen); ];
4049
        # Start listening guestfish
4050
        my $daemon = Proc::Daemon->new(
4051
            work_dir => '/usr/local/bin',
4052
            setuid => 'www-data',
4053
            exec_command => $cmd
4054
        ) or do {$postreply .= "Status=ERROR $@\n";};
4055
        my $pid = $daemon->Init();
4056
        while ($daemon->Status($pid)) {
4057
            sleep 1;
4058
        }
4059
        # Find pid of the listening guestfish
4060
        my $pid2;
4061
        my $t = new Proc::ProcessTable;
4062
        foreach $p ( @{$t->table} ){
4063
            my $pcmd = $p->cmndline;
4064
            if ($pcmd =~ /guestfish.+$image/) {
4065
                $pid2 = $p->pid;
4066
                last;
4067
            }
4068
        }
4069
4070
        my $cmd2;
4071
        if ($pid2) {
4072
            $cmd2 .= qq[root="\$(/usr/bin/guestfish --remote=$pid2 inspect-get-roots)"; ];
4073
            $cmd2 .= qq[guestfish --remote=$pid2 inspect-list-applications "\$root"; ];
4074
            $cmd2 .= qq[guestfish --remote=$pid2 inspect-get-product-name "\$root"; ];
4075
            $cmd2 .= qq[guestfish --remote=$pid2 exit];
4076
        }
4077
        $apps = `$cmd2`;
4078
    }
4079
    if ($console) {
4080
        $res .= $apps;
4081
    } else {
4082
        my @packages;
4083
        my @packages2;
4084
        open my $fh, '<', \$apps or die $!;
4085
        my $i;
4086
        while (<$fh>) {
4087
            if ($_ =~ /\[(\d+)\]/) {
4088
                push @packages2, $packages[$i];
4089
                $i = $1;
4090
            } elsif ($_ =~ /(\S+): (.+)/ && $2) {
4091
                $packages[$i]->{$1} = $2;
4092
            }
4093
        }
4094
        close $fh or die $!;
4095
        $res .= to_json(\@packages, {pretty => 1});
4096
    }
4097
    return $res;
4098
}
4099
4100
sub Inject {
4101
    my ($image, $action, $obj) = @_;
4102
    if ($help) {
4103
        return <<END
4104
GET:image:
4105
Tries to inject drivers into a qcow2 image with a Windows OS installed on it. Image must not be in use.
4106
END
4107
    }
4108
    $uistatus = "injecting";
4109
    my $path = $obj->{path} || $curimg;
4110
    my $status = $obj->{status};
4111
    my $esc_localpath = shell_esc_chars($path);
4112
4113
    # Find out if we are dealing with a Windows image
4114
    my $xml = `bash -c '/usr/bin/virt-inspector -a "$esc_localpath"'`;
4115
    #my $xml = `bash -c '/usr/bin/virt-inspector -a "$esc_localpath"' 2>&1`;
4116
    # $res .= $xml . "\n";
4117
    my $xmlref;
4118
    my $osname;
4119
    $xmlref = XMLin($xml) if ($xml =~ /^<\?xml/);
4120
    $osname = $xmlref->{operatingsystem}->{name} if ($xmlref);
4121
    if ($xmlref && $osname eq 'windows') {
4122
        my $upath = $esc_localpath;
4123
        # We need write privileges
4124
        $res .= `chmod 666 "$upath"`;
4125
        # First try to merge storage registry keys into Windows registry. If not a windows vm it simply fails.
4126
        $res .= `bash -c 'cat /usr/share/stabile/mergeide.reg | /usr/bin/virt-win-reg --merge "$upath"' 2>&1`;
4127
        # Then try to merge the critical device keys. This has been removed in win8 and 2012, so will simply fail for these.
4128
        $res .= `bash -c 'cat /usr/share/stabile/mergeide-CDDB.reg | /usr/bin/virt-win-reg --merge "$upath"' 2>&1`;
4129
        if ($res) { debuglog($res); $res = ''; }
4130
4131
        # Try to copy viostor.sys into image
4132
        my @winpaths = (
4133
            '/Windows/System32/drivers',
4134
            '/WINDOWS/system32/drivers/viostor.sys',
4135
            '/WINDOWS/System32/drivers/viostor.sys',
4136
            '/WINNT/system32/drivers/viostor.sys'
4137
        );
4138
        foreach my $winpath (@winpaths) {
4139
            my $lscmd = qq|bash -c 'virt-ls -a "$upath" "$winpath"'|;
4140
            my $drivers = `$lscmd`;
4141
            if ($drivers =~ /viostor/i) {
4142
                $postreply .= "Status=OK viostor already installed in $winpath in $upath\n";
4143
                $main::syslogit->($user, "info", "viostor already installed in $winpath in $upath");
4144
                last;
4145
            } elsif ($drivers) {
4146
                my $cmd = qq|bash -c 'guestfish -i -a "$upath" upload /usr/share/stabile/VIOSTOR.SYS $winpath/viostor.sys' 2>&1|;
4147
                my $error = `$cmd`;
4148
                if ($error) {
4149
                    $postreply .= "Status=ERROR Problem injecting virtio drivers into $upath: $error\n";
4150
                    $main::syslogit->($user, "info", "Error injecting virtio drivers into $upath: $error");
4151
                } else {
4152
                    $postreply .= "Status=$status Injected virtio drivers into $upath";
4153
                    $main::syslogit->($user, "info", "Injected virtio drivers into $upath");
4154
                }
4155
                last;
4156
            } else {
4157
                $postreply .= "Status=ERROR No drivers found in $winpath\n";
4158
            }
4159
        }
4160
4161
    } else {
4162
        $postreply .= "Status=ERROR No Windows OS found in $osname image, not injecting drivers.\n";
4163
        $main::syslogit->($user, "info", "No Windows OS found ($osname) in image, not injecting drivers.");
4164
    }
4165
    my $msg = $postreply;
4166
    $msg = $1 if ($msg =~ /\w+=\w+ (.+)/);
4167
    chomp $msg;
4168
    $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status, message=>$msg});
4169
    $postreply .=  "Status=OK $uistatus $obj->{type} image: $obj->{name}\n";
4170
    $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4171
    return $postreply;
4172
}
4173
4174
sub Convert {
4175
    my ($image, $action, $obj) = @_;
4176
    if ($help) {
4177
        return <<END
4178
GET:image:
4179
Converts an image to qcow2 format. Image must not be in use.
4180
END
4181
    }
4182
    my $path = $obj->{path};
4183
    $uistatus = "converting";
4184
    $uipath = $path;
4185
    if ($obj->{status} ne "unused" && $obj->{status} ne "used" && $obj->{status} ne "paused") {
4186
        $postreply .= "Status=ERROR Problem $uistatus $obj->{type} image: $obj->{name}\n";
4187
    } elsif ($obj->{type} eq "img" || $obj->{type} eq "vmdk" || $obj->{type} eq "vhd") {
4188
        my $oldpath = $path;
4189
        my $newpath = "$path.qcow2";
4190
        if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
4191
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4192
            $macip = $nodereg{$obj->{mac}}->{'ip'};
4193
            untie %nodereg;
4194
            $oldpath = "$macip:$path";
4195
        } else { # We are not on a node - check that image is not on a read-only filesystem
4196
            my ($fname, $destfolder) = fileparse($path);
4197
            my $ro = `touch "$destfolder/test.tmp" && { rm "$destfolder/test.tmp"; } || echo "read-only" 2>/dev/null`;
4198
            if ($ro) { # Destinationfolder is not writable
4199
                my $npath = "$spools[0]->{'path'}/$register{$path}->{'user'}/$fname.qcow2";
4200
                $newpath = $npath;
4201
            }
4202
            if (-e $newpath) { # Don't overwrite existing file
4203
                my $subpath = substr($newpath,0,-6);
4204
                my $i = 1;
4205
                if ($newpath =~ /(.+)\.(\d+)\.qcow2/) {
4206
                    $i = $2;
4207
                    $subpath = $1;
4208
                }
4209
                while (-e $newpath) {
4210
                    $newpath = $subpath . ".$i.qcow2";
4211
                    $i++;
4212
                }
4213
            }
4214
        }
4215
        eval {
4216
            my $ug = new Data::UUID;
4217
            my $newuuid = $ug->create_str();
4218
4219
            $register{$newpath} = {
4220
                uuid=>$newuuid,
4221
                name=>"$obj->{name} (converted)",
4222
                notes=>$obj->{notes},
4223
                image2=>$obj->{image2},
4224
                managementlink=>$obj->{managementlink},
4225
                upgradelink=>$obj->{managementlink},
4226
                terminallink=>$obj->{terminallink},
4227
                storagepool=>$obj->{regstoragepool},
4228
                status=>$uistatus,
4229
                mac=>($obj->{regstoragepool} == -1)?$obj->{mac}:"",
4230
                size=>0,
4231
                realsize=>0,
4232
                virtualsize=>$obj->{virtualsize},
4233
                type=>"qcow2",
4234
                user=>$user
4235
            };
4236
            $register{$path}->{'status'} = $uistatus;
4237
4238
            my $daemon = Proc::Daemon->new(
4239
                work_dir => '/usr/local/bin',
4240
                exec_command => "perl -U steamExec $user $uistatus $obj->{status} \"$oldpath\" \"$newpath\""
4241
            ) or do {$postreply .= "Status=ERROR $@\n";};
4242
            my $pid = $daemon->Init() or do {$postreply .= "Status=ERROR $@\n";};
4243
            $postreply .=  "Status=OK $uistatus $obj->{type} image: $obj->{name}\n";
4244
            $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4245
        } or do {$postreply .= "Status=ERROR $@\n";};
4246
        $main::updateUI->({tab=>"images", user=>$user, type=>"update"});
4247
    } else {
4248
        $postreply .= "Status=ERROR Only img and vmdk images can be converted\n";
4249
    }
4250 2a63870a Christian Orellana
    return $postreply;
4251 95b003ff Origo
}
4252
4253
sub Snapshot {
4254
    my ($image, $action, $obj) = @_;
4255
    if ($help) {
4256
        return <<END
4257
GET:image:
4258
Adds a snapshot to a qcow2 image. Image can not be in use by a running server.
4259
END
4260
    }
4261
    my $status = $obj->{status};
4262
    my $path = $obj->{path};
4263
    my $macip;
4264
    $uistatus = "snapshotting";
4265
    $uiuuid = $obj->{uuid};
4266
    if ($status ne "unused" && $status ne "used") {
4267
        $postreply .= "Status=ERROR Problem $uistatus $obj->{type} image: $obj->{name}\n";
4268
    } elsif ($obj->{type} eq "qcow2") {
4269
        my $newpath = $path;
4270
        my $hassnap;
4271
        my $snaptime = time;
4272
        if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
4273
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4274
            $macip = $nodereg{$obj->{mac}}->{'ip'};
4275
            untie %nodereg;
4276
            $newpath = "$macip:$path";
4277
            my $esc_path = $path;
4278
            $esc_path =~ s/([ ])/\\$1/g;
4279
            my $qinfo = `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -l $esc_path"`;
4280
            $hassnap = ($qinfo =~ /snap1/g);
4281
            $postreply .= `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -d snap1 $esc_path"` if ($hassnap);
4282
        } else {
4283
            my $qinfo = `/usr/bin/qemu-img snapshot -l "$path"`;
4284
            $hassnap = ($qinfo =~ /snap1/g);
4285
            $postreply .= `/usr/bin/qemu-img snapshot -d snap1 "$path\n"` if ($hassnap);
4286
        }
4287
        eval {
4288
            if ($hassnap) {
4289
                $postreply .= "Status=Error Only one snapshot per image is supported for $obj->{type} image: $obj->{name} ";
4290
            } else {
4291
                $register{$path}->{'status'} = $uistatus;
4292
                $register{$path}->{'snap1'} = $snaptime;
4293
4294
                if ($macip) {
4295
                    my $esc_localpath = shell_esc_chars($path);
4296
                    $res .= `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -c snap1 $esc_localpath"`;
4297
                } else {
4298
                    $res .= `/usr/bin/qemu-img snapshot -c snap1 "$path"`;
4299
                }
4300
                $register{$path}->{'status'} = $status;
4301
                $postreply .=  "Status=$uistatus OK $uistatus $obj->{type} image: $obj->{name}\n";
4302
                $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4303
            }
4304
            1;
4305
        } or do {$postreply .= "Status=ERROR $@\n";};
4306
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status, snap1=>$snaptime});
4307
    } else {
4308
        $postreply .= "Status=ERROR Only qcow2 images can be snapshotted\n";
4309
    }
4310
    return $postreply;
4311
}
4312
4313
sub Unsnap {
4314
    my ($image, $action, $obj) = @_;
4315
    if ($help) {
4316
        return <<END
4317
GET:image:
4318
Removes a snapshot from a qcow2 image. Image can not be in use by a running server.
4319
END
4320
    }
4321
    my $status = $obj->{status};
4322
    my $path = $obj->{path};
4323
    $uistatus = "unsnapping";
4324
    $uiuuid = $obj->{uuid};
4325
    my $macip;
4326
4327
    if ($status ne "unused" && $status ne "used") {
4328
        $postreply .= "Status=ERROR Problem $uistatus $obj->{type} image: $obj->{name}\n";
4329
    } elsif ($obj->{type} eq "qcow2") {
4330
        my $newpath = $path;
4331
        my $hassnap;
4332
        my $qinfo;
4333
        my $esc_path;
4334
        if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
4335
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4336
            $macip = $nodereg{$obj->{mac}}->{'ip'};
4337
            untie %nodereg;
4338
            $newpath = "$macip:$path";
4339
            $esc_path = $path;
4340
            $esc_path =~ s/([ ])/\\$1/g;
4341
            $qinfo = `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -l $esc_path"`;
4342
            $hassnap = ($qinfo =~ /snap1/g);
4343
        } else {
4344
            $qinfo = `/usr/bin/qemu-img snapshot -l "$path"`;
4345
            $hassnap = ($qinfo =~ /snap1/g);
4346
        }
4347
        eval {
4348
            my $snaptime = time;
4349
            if ($hassnap) {
4350
                delete $register{$path}->{'snap1'};
4351
                $register{$path}->{'status'} = $uistatus;
4352
                if ($macip) {
4353
                    my $esc_localpath = shell_esc_chars($path);
4354
                    $res .= `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -d snap1 $esc_localpath"`;
4355
                } else {
4356
                    $res .= `/usr/bin/qemu-img snapshot -d snap1 "$path"`;
4357
                }
4358
                $register{$path}->{'status'} = $status;
4359
                $postreply .=  "Status=$uistatus OK $uistatus $obj->{type} image: $obj->{name}\n";
4360
                $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4361
            } else {
4362
                $postreply .= "Status=ERROR No snapshot found in $obj->{name}\n";
4363
                delete $register{$path}->{'snap1'};
4364
                $uistatus = $status;
4365
            }
4366
            1;
4367
        } or do {$postreply .= "Status=ERROR $@\n";};
4368
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status, snap1=>'--'});
4369
    } else {
4370
        $postreply .= "Status=ERROR Only qcow2 images can be unsnapped\n";
4371
    }
4372
    return $postreply;
4373
}
4374
4375
sub Revert {
4376
    my ($image, $action, $obj) = @_;
4377
    if ($help) {
4378
        return <<END
4379
GET:image:
4380
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.
4381
END
4382
    }
4383
    my $status = $obj->{status};
4384
    my $path = $obj->{path};
4385
    $uistatus = "reverting";
4386
    $uipath = $path;
4387
    my $macip;
4388
    if ($status ne "used" && $status ne "unused") {
4389
        $postreply .= "Status=ERROR Please shut down or pause your virtual machine before reverting\n";
4390
    } elsif ($obj->{type} eq "qcow2") {
4391
        my $newpath = $path;
4392
        my $hassnap;
4393
        if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
4394
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4395
            $macip = $nodereg{$obj->{mac}}->{'ip'};
4396
            untie %nodereg;
4397
            $newpath = "$macip:$path";
4398
            my $esc_path = $path;
4399
            $esc_path =~ s/([ ])/\\$1/g;
4400
            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"`;
4401
            $hassnap = ($qinfo =~ /snap1/g);
4402
        } else {
4403
            my $qinfo = `/usr/bin/qemu-img snapshot -l "$path"`;
4404
            $hassnap = ($qinfo =~ /snap1/g);
4405
        }
4406
        eval {
4407
            if ($hassnap) {
4408
                $register{$path}->{'status'} = $uistatus;
4409
                if ($macip) {
4410
                    my $esc_localpath = shell_esc_chars($path);
4411
                    $res .= `$sshcmd $macip "sudo /usr/bin/qemu-img snapshot -a snap1 $esc_localpath"`;
4412
                } else {
4413
                    $res .= `/usr/bin/qemu-img snapshot -a snap1 "$path1"`;
4414
                }
4415
                $register{$path}->{'status'} = $status;
4416
                $postreply .=  "Status=OK $uistatus $obj->{type} image: $obj->{name}\n";
4417
                $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4418
            } else {
4419
                $postreply .= "Status=ERROR no snapshot found\n";
4420
                $uistatus = $status;
4421
            }
4422
            1;
4423
        } or do {$postreply .= "Status=ERROR $@\n";};
4424
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status, snap1=>'--'});
4425
    } else {
4426
        $postreply .= "Status=ERROR Only qcow2 images can be reverted\n";
4427
    }
4428
    return;
4429
}
4430
4431
sub Zbackup {
4432
    my ($image, $action, $obj) = @_;
4433
    if ($help) {
4434
        return <<END
4435 c899e439 Origo
GET:mac, storagepool, synconly, snaponly, imageretention, backupretention:
4436 95b003ff Origo
Backs all images on ZFS storage up by taking a storage snapshot. By default all shared storagepools are backed up.
4437
If storagepool -1 is specified, all ZFS node storages is backed up. If "mac" is specified, only specific node is backed up.
4438
If "synconly" is set, no new snapshots are taken - only syncing of snapshots is performed.
4439
If "snaponly" is set, only local active storage snapshot is taken - no sending to backup storage is done.
4440
"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],
4441
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.
4442
END
4443
    }
4444
    if ($isadmin) {
4445
        my $synconly = $obj->{'synconly'};
4446
        my $snaponly = $obj->{'snaponly'};
4447
        my $mac = $obj->{'mac'};
4448
        my $storagepool = $obj->{'storagepool'};
4449
        $storagepool = -1 if ($mac);
4450
        my $imageretention = $obj->{'imageretention'} || $imageretention;
4451
        my $backupretention = $obj->{'backupretention'} || $backupretention;
4452
4453
        my $basepath = "stabile-backup";
4454
        my $bpath = $basepath;
4455
        my $mounts = `/bin/cat /proc/mounts`;
4456
        my $zbackupavailable = (($mounts =~ /$bpath (\S+) zfs/)?$1:'');
4457
        unless ($zbackupavailable) {$postreply .= "Status=OK ZFS backup not available, only doing local snapshots\n";}
4458
        my $zfscmd = "zfs";
4459
        my $macip;
4460
        my $ipath = $spools[0]->{'zfs'} || 'stabile-images/images';
4461
        my @nspools = @spools;
4462
        if (!(defined $obj->{'storagepool'}) || $storagepool == -1) {
4463
            @nspools = () if ($storagepool == -1); # Only do node backups
4464
            unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
4465 27512919 Origo
#            my $nipath = $ipath;
4466
#            $nipath = "$1/node" if ($nipath =~ /(.+)\/(.+)/);
4467
            my $nipath = 'stabile-node/node';
4468 95b003ff Origo
            foreach my $node (values %nodereg) {
4469
                push @nspools, {
4470
                    mac=>$node->{'mac'},
4471
                    macip=>$node->{'ip'},
4472
                    zfs=>$nipath,
4473
                    id=>-1
4474
                } if ($node->{'stor'} eq 'zfs' && (!$mac || $node->{'mac'} eq $mac))
4475
            }
4476
            untie %nodereg;
4477
        }
4478
        if (`pgrep zfs`) {
4479
            $postreply .= "Status=ERROR Another ZFS backup is running. Please wait a minute...\n";
4480
            $postmsg = "ERROR ERROR Another ZFS backup is running. Please wait a minute...";
4481
            return $postreply;
4482
        }
4483
        $postreply .= "Status=OK Performing ZFS backup on " . (scalar @nspools) . " storage pools with image retention $imageretention, backup retention $backupretention\n";
4484
4485
        foreach my $spool (@nspools) {
4486
            $ipath = $spool->{'zfs'};
4487
            if ($spool->{'id'} == -1) { # We're doing a node backup
4488
                $mac = $spool->{'mac'};
4489
                $macip = $spool->{'macip'};
4490
                $bpath = "$basepath/node-$mac";
4491
            } else {
4492
                next unless ($ipath);
4493
                next if (($storagepool || $storagepool eq '0') && $storagepool ne $spool->{'id'});
4494
                $bpath = "$basepath/$1" if ($ipath =~ /.+\/(.+)/);
4495
                $mac = '';
4496
                $macip = '';
4497
            }
4498 27512919 Origo
            if ($macip) {$zfscmd = "$sshcmd $macip sudo zfs";}
4499 95b003ff Origo
            else {$zfscmd = "zfs";}
4500
4501 27512919 Origo
            $postreply .= "Status=OK Commencing ZFS backup of $ipath $macip\n";
4502 95b003ff Origo
            my $res;
4503
            my $cmd;
4504
            my @imagesnaps;
4505
            my @backupsnaps;
4506
4507
            # example: stabile-images/images@SNAPSHOT-20200524172901
4508
            $cmd = qq/$zfscmd list -t snapshot | grep '$ipath'/;
4509
            my $snaplist = `$cmd`;
4510
            my @snaplines = split("\n", $snaplist);
4511
            foreach my $snap (@snaplines) {
4512
                push @imagesnaps, $2 if ($snap =~ /(.*)\@SNAPSHOT-(\d+)/);
4513
            }
4514
            if ($zbackupavailable) {
4515
                $cmd = qq/zfs list -t snapshot | grep '$bpath'/;
4516
                $snaplist = `$cmd`;
4517
                @snaplines = split("\n", $snaplist);
4518
                foreach my $snap (@snaplines) {
4519
                    push @backupsnaps, $2 if ($snap =~ /(.*)\@SNAPSHOT-(\d+)/);
4520
                }
4521
            }
4522
        # Find matching snapshots
4523
            my $matches=0;
4524
            my $matchbase = 0;
4525
            foreach my $bsnap (@backupsnaps) {
4526
                if ($bsnap eq $imagesnaps[$matchbase + $matches]) { # matching snapshot found
4527
                    $matches++;
4528
                } elsif ($matches) { # backup snapshots are ahead of image snapshots - correct manually, i.e. delete them.
4529
                    $postreply .= "Status=ERROR Snapshots are out of sync.\n";
4530
                    $postmsg = "ERROR Snapshots are out of sync";
4531
                    $main::syslogit->($user, 'info', "ERROR snapshots of $ipath and $bpath are out of sync.");
4532
                    return $postreply;
4533
                } elsif (!$matchbase) { # Possibly there are image snapshots older than there are backup snapshots, find the match base i.e. first match in @imagesnaps
4534
                    my $mb=0;
4535
                    foreach my $isnap (@imagesnaps) {
4536
                        if ($bsnap eq $isnap) { # matching snapshot found
4537
                            $matchbase = $mb;
4538
                            $matches++;
4539
                            last;
4540
                        }
4541
                        $mb++;
4542
                    }
4543
                }
4544
            }
4545 27512919 Origo
4546 95b003ff Origo
            my $lastisnap = $imagesnaps[scalar @imagesnaps -1];
4547
            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)/);
4548
            my $td = ($current_time - $lastisnaptime);
4549
            if ($td<=5) {
4550
                $postreply .= "Status=ERROR Last backup was taken $td seconds ago. Please wait a minute...\n";
4551
                $postmsg = "ERROR ERROR Last backup was taken $td seconds ago. Please wait a minute...";
4552
                return $postreply;
4553
            }
4554
            my $ni = scalar @imagesnaps;
4555
            my $nb = scalar @backupsnaps;
4556
        # If there are unsynced image snaps - sync them
4557
            if ($zbackupavailable && !$snaponly) {
4558
                if (scalar @imagesnaps > $matches+$matchbase) {
4559
                    for (my $j=$matches+$matchbase; $j < scalar @imagesnaps; $j++) {
4560
                        if ($macip) {
4561 27512919 Origo
                            $cmd = qq[$zfscmd "send -i $ipath\@SNAPSHOT-$imagesnaps[$j-1] $ipath\@SNAPSHOT-$imagesnaps[$j] | ssh 10.0.0.1 sudo zfs receive $bpath"]; # -R
4562 95b003ff Origo
                        } else {
4563
                            $cmd = qq[zfs send -i $ipath\@SNAPSHOT-$imagesnaps[$j-1] $ipath\@SNAPSHOT-$imagesnaps[$j] | zfs receive $bpath]; # -R
4564
                        }
4565
                        $res = `$cmd 2>&1`;
4566
                        unless ($res && !$macip) { # ssh will warn about adding to list of known hosts
4567
                            $matches++;
4568
                            $nb++;
4569
                        }
4570
                        $postreply .= "Status=OK Sending ZFS snapshot $imagesnaps[$j-1]->$imagesnaps[$j] of $macip $ipath to $bpath $res\n";
4571
                        $main::syslogit->($user, 'info', "OK Sending ZFS snapshot $imagesnaps[$j-1]->$imagesnaps[$j] of $macip $ipath to $bpath $res");
4572
                    }
4573
                }
4574
            }
4575
            $res = '';
4576 27512919 Origo
4577 95b003ff Origo
            if ($matches && !$synconly) { # snapshots are in sync
4578
        # Then perform the actual snapshot
4579
                my $snap1 = sprintf "%4d%02d%02d%02d%02d%02d",$year,$mon+1,$mday,$hour,$min,$sec;
4580
                my $oldsnap = $imagesnaps[$matches+$matchbase-1];
4581
                $cmd = qq|$zfscmd snapshot -r $ipath\@SNAPSHOT-$snap1|;
4582
                $postreply .= "Status=OK Performing ZFS snapshot with $matches matches and base $matchbase $res\n";
4583
                $res = `$cmd 2>&1`;
4584
                unless ($res && !$macip) {
4585
                    $ni++;
4586
                    push @imagesnaps, $snap1;
4587
                }
4588
        # Send it to backup if asked to
4589
                unless ($snaponly || !$zbackupavailable) {
4590
                    if ($macip) {
4591 27512919 Origo
                        $cmd = qq[$zfscmd "send -i $ipath\@SNAPSHOT-$oldsnap $ipath\@SNAPSHOT-$snap1 | ssh 10.0.0.1 sudo zfs receive $bpath"];
4592 95b003ff Origo
                    } else {
4593
                        $cmd = qq[zfs send -i $ipath\@SNAPSHOT-$oldsnap $ipath\@SNAPSHOT-$snap1 | zfs receive $bpath]; # -R
4594
                    }
4595
                    $res .= `$cmd 2>&1`;
4596
                    unless ($res && !$macip) {
4597
                        $matches++;
4598
                        $nb++;
4599
                        push @backupsnaps, $snap1;
4600
                    }
4601
                    $postreply .= "Status=OK Sending ZFS snapshot of $macip $ipath $oldsnap->$snap1 to $bpath $res\n";
4602
                    $main::syslogit->($user, 'info', "OK Sending ZFS snapshot of $macip $ipath $oldsnap->$snap1 to $bpath $res");
4603
                }
4604 27512919 Origo
                $postreply .= "Status=OK Synced $matches ZFS snapshots. There are now $ni image snapshots, $nb backup snapshots.\n";
4605 95b003ff Origo
            } elsif ($matches) {
4606 27512919 Origo
                $postreply .= "Status=OK Synced $matches ZFS snapshots. There are $ni image snapshots, $nb backup snapshots.\n";
4607 95b003ff Origo
#            } elsif ($ni==0 && $nb==0) { # We start from a blank slate
4608
            } elsif ($nb==0) { # We start from a blank slate
4609
                my $snap1 = sprintf "%4d%02d%02d%02d%02d%02d",$year,$mon+1,$mday,$hour,$min,$sec;
4610
                $cmd = qq|$zfscmd snapshot -r $ipath\@SNAPSHOT-$snap1|;
4611
                $res = `$cmd 2>&1`;
4612 27512919 Origo
                $postreply .= "Status=OK Performing ZFS snapshot $res $macip\n";
4613 95b003ff Origo
        # Send it to backup by creating new filesystem
4614
                unless ($snaponly || !$zbackupavailable) {
4615
                    if ($macip) {
4616 27512919 Origo
                        $cmd = qq[$zfscmd "send $ipath\@SNAPSHOT-$snap1 | ssh 10.0.0.1 sudo zfs receive $bpath"];
4617 95b003ff Origo
                        $res .= `$cmd 2>&1`;
4618
                        $cmd = qq|zfs set readonly=on $bpath|;
4619
                        $res .= `$cmd 2>&1`;
4620
                        $cmd = qq|zfs mount $bpath|;
4621
                        $res .= `$cmd 2>&1`;
4622
                    } else {
4623
                        $cmd = qq[zfs send -R $ipath\@SNAPSHOT-$snap1 | zfs receive $bpath];
4624
                        $res .= `$cmd 2>&1`;
4625 2a63870a Christian Orellana
                        $cmd = qq|zfs set readonly=on $bpath|;
4626
                        $res .= `$cmd 2>&1`;
4627 95b003ff Origo
                    }
4628
                    $postreply .= "Status=OK Sending complete ZFS snapshot of $macip:$ipath\@$snap1 to $bpath $res\n";
4629
                    $main::syslogit->($user, 'info', "OK Sending complete ZFS snapshot of $macip:$ipath\@$snap1 to $bpath $res");
4630
                    $matches++;
4631
                    $nb++;
4632
                }
4633
                $ni++;
4634 27512919 Origo
                $postreply .= "Status=OK Synced ZFS snapshots. There are $ni image snapshots, $nb backup snapshots.\n";
4635 95b003ff Origo
            } else {
4636
                $postreply .= "Status=ERROR Unable to sync snapshots.\n";
4637
                $postmsg = "ERROR Unable to sync snapshots";
4638
            }
4639
            my $i=0;
4640
        # Purge image snapshots if asked to
4641
            if ($imageretention && $matches>1) {
4642
                my $rtime;
4643
                if ($imageretention =~ /(\d+)(s|h|d)/) {
4644
                    $rtime = $1;
4645
                    $rtime = $1*60*60 if ($2 eq 'h');
4646
                    $rtime = $1*60*60*24 if ($2 eq 'd');
4647
                    $postreply .= "Status=OK Keeping image snapshots newer than $imageretention out of $ni.\n";
4648
                } elsif ($imageretention =~ /(\d+)$/) {
4649
                    $postreply .= "Status=OK Keeping " . (($imageretention>$ni)?$ni:$imageretention) . " image snapshots out of $ni.\n";
4650
                } else {
4651
                    $imageretention = 0;
4652
                }
4653
                if ($imageretention) {
4654
                    foreach my $isnap (@imagesnaps) {
4655
                        my $purge;
4656
                        if ($rtime) {
4657
                            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)/);
4658
                            my $tdiff = ($current_time - $snaptime);
4659
                            if ( $matches>1 && $tdiff>$rtime )
4660
                                {$purge = 1;}
4661
                            else
4662
                                {last;}
4663
                        } else { # a simple number was specified
4664
#                            if ( $matches>1 && $matches+$matchbase>$imageretention )
4665
                            if ( $matches>1 && $ni>$imageretention )
4666
                                {$purge = 1;}
4667
                            else
4668
                                {last;}
4669
                        }
4670
                        if ($purge) {
4671
                            $cmd = qq|$zfscmd destroy $ipath\@SNAPSHOT-$isnap|;
4672
                            $res = `$cmd 2>&1`;
4673
                            $postreply .= "Status=OK Purging image snapshot $isnap from $ipath.\n";
4674
                            $main::syslogit->($user, 'info', "OK Purging image snapshot $isnap from $ipath");
4675
                            $matches-- if ($i>=$matchbase);
4676
                            $ni--;
4677
                        }
4678
                        $i++;
4679
                    }
4680
                }
4681
            }
4682
            # Purge backup snapshots if asked to
4683
            if ($backupretention && $matches) {
4684
                my $rtime;
4685
                if ($backupretention =~ /(\d+)(s|h|d)/) {
4686
                    $rtime = $1;
4687
                    $rtime = $1*60*60 if ($2 eq 'h');
4688
                    $rtime = $1*60*60*24 if ($2 eq 'd');
4689
                    $postreply .= "Status=OK Keeping backup snapshots newer than $backupretention out of $nb.\n";
4690
                } elsif ($backupretention =~ /(\d+)$/) {
4691
                    $postreply .= "Status=OK Keeping " . (($backupretention>$nb)?$nb:$backupretention) . " backup snapshots out of $nb.\n";
4692
                } else {
4693
                    $backupretention = 0;
4694
                }
4695
                if ($backupretention && $zbackupavailable) {
4696
                    foreach my $bsnap (@backupsnaps) {
4697
                        my $purge;
4698
                        if ($bsnap eq $imagesnaps[$matchbase+$matches-1]) { # We need to keep the last snapshot synced
4699
                            $postreply .= "Status=OK Not purging backup snapshot $matchbase $bsnap.\n";
4700
                            last;
4701
                        } else {
4702
                            if ($rtime) {
4703
                                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)/);
4704
                                my $tdiff = ($current_time - $snaptime);
4705
                                if ( $matches>1 && $tdiff>$rtime )
4706
                                    {$purge = 1;}
4707
                            } else {
4708
                                if ( $nb>$backupretention )
4709
                                    {$purge = 1;}
4710
                            }
4711
                            if ($purge) {
4712
                                $cmd = qq|zfs destroy $bpath\@SNAPSHOT-$bsnap|;
4713
                                $res = `$cmd 2>&1`;
4714
                                $postreply .= "Status=OK Purging backup snapshot $bsnap from $bpath.\n";
4715
                                $main::syslogit->($user, 'info', "OK Purging backup snapshot $bsnap from $bpath");
4716
                                $nb--;
4717
                            } else {
4718
                                last;
4719
                            }
4720
                        }
4721
                    }
4722
                }
4723
            }
4724 27512919 Origo
            $postmsg .= "OK Performing ZFS backup of $bpath. There are $ni image snapshots and $nb backup snapshots. ";
4725 95b003ff Origo
        }
4726 27512919 Origo
        $postreply .= "Status=OK Updating all btimes\n";
4727
        Updateallbtimes();
4728 95b003ff Origo
    } else {
4729
        $postreply .= "Status=ERROR Not allowed\n";
4730
        $postmsg = "ERROR Not allowed";
4731
    }
4732
    $main::updateUI->({tab=>"images", user=>$user, type=>"message", message=>$postmsg});
4733
    return $postreply;
4734
}
4735
4736 2a63870a Christian Orellana
sub Backupfuel {
4737
    my ($image, $action, $obj) = @_;
4738
    if ($help) {
4739
        return <<END
4740
GET:username, dozfs:
4741
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.
4742
END
4743
    }
4744
    my $username = $obj->{'username'} || $user;
4745
    return "Status=Error Not allowed\n" unless ($isadmin || $username eq $user);
4746
4747
    my $remolder = "14D";
4748
    my $stordevs = Liststoragedevices('', 'getstoragedevices');
4749
    my $backupdev = Getbackupdevice('', 'getbackupdevice');
4750
    my $backupdevtype = $stordevs->{$backupdev}->{type};
4751
    foreach my $spool (@spools) {
4752
        my $ppath = $spool->{"path"};
4753
        my $pid = $spool->{"id"};
4754
        if (($spool->{"zfs"} && $backupdevtype eq 'zfs') && !$obj->{'dozfs'}) {
4755
            $postreply .= "Status=OK Skipping fuel on ZFS storage: $ppath/$username/fuel\n";
4756
        } elsif ($pid eq '-1') {
4757
            ;
4758
        } elsif (!$backupdir || !(-d $backupdir)) {
4759
            $postreply .= "Status=OK Backup dir $backupdir does not exist\n";
4760
        } elsif (-d "$ppath/$username/fuel" && !is_folder_empty("$ppath/$username/fuel")) {
4761
            my $srcdir = "$ppath/$username/fuel";
4762
            my $destdir = "$backupdir/$username/fuel/$pid";
4763
4764
            `mkdir -p "$destdir"` unless (-e "$destdir");
4765
            # Do the backup
4766
            my $cmd = qq|/usr/bin/rdiff-backup --print-statistics "$srcdir" "$destdir"|;
4767
            my $res = `$cmd`;
4768
            $cmd = qq|/usr/bin/rdiff-backup --print-statistics --force --remove-older-than $remolder "$destdir"|;
4769
            $res .= `$cmd`;
4770
            if ($res =~ /Errors 0/) {
4771
                my $change = $1 if ($res =~ /TotalDestinationSizeChange \d+ \((.+)\)/);
4772
                $postreply .= "Status=OK Backed up $change, $srcdir -> $destdir\n";
4773
                $main::syslogit->($user, "info", "OK backed up $change, $srcdir -> $destdir") if ($change);
4774
            } else {
4775
                $res =~ s/\n/ /g;
4776
                $postreply .= "Status=Error There was a problem backup up $srcdir -> $destdir: $res\n";
4777
                $main::syslogit->($user, "there was a problem backup up $srcdir -> $destdir");
4778
            }
4779
        } else {
4780
            $postreply .= "Status=OK Skipping empty fuel on: $ppath/$username/fuel\n";
4781
        }
4782
    }
4783
    return $postreply;
4784
}
4785
4786
sub is_folder_empty {
4787
    my $dirname = shift;
4788
    opendir(my $dh, $dirname) or die "Not a directory";
4789
    return scalar(grep { $_ ne "." && $_ ne ".." } readdir($dh)) == 0;
4790
}
4791
4792 95b003ff Origo
sub Backup {
4793
    my ($image, $action, $obj) = @_;
4794
    if ($help) {
4795
        return <<END
4796 2a63870a Christian Orellana
GET:image, skipzfs:
4797
Backs an image up. Set [skipzfs] if ZFS backup is configured, and you do not want to skip images on ZFS storage.
4798 95b003ff Origo
END
4799
    }
4800 2a63870a Christian Orellana
    my $path = $obj->{path} || $image;
4801 95b003ff Origo
    my $status = $obj->{status};
4802 2a63870a Christian Orellana
    my $skipzfs = $obj->{skipzfs};
4803 95b003ff Origo
    $uistatus = "backingup";
4804
    $uipath = $path;
4805
    my $remolder;
4806
    $remolder = "14D" if ($obj->{bschedule} eq "daily14");;
4807
    $remolder = "7D" if ($obj->{bschedule} eq "daily7");
4808 2a63870a Christian Orellana
4809
    my $stordevs = Liststoragedevices('', 'getstoragedevices');
4810
    my $backupdev = Getbackupdevice('', 'getbackupdevice');
4811
    my $backupdevtype = $stordevs->{$backupdev}->{type};
4812
    # Nodes are assumed to alwasy use ZFS
4813
    if ($backupdevtype eq 'zfs' && $skipzfs && ($obj->{regstoragepool} == -1 || $spools[$obj->{regstoragepool}]->{'zfs'})) {
4814
        return "Status=OK Skipping image on ZFS $path\n";
4815
    }
4816 95b003ff Origo
    if ($status eq "snapshotting" || $status eq "unsnapping" || $status eq "reverting" || $status eq "cloning" ||
4817
        $status eq "moving" || $status eq "converting") {
4818
        $postreply .= "Status=ERROR Problem backing up $obj->{type} image: $obj->{name}\n";
4819
    } elsif ($obj->{regstoragepool} == -1) {
4820 54401133 hq
        my $res = createNodeTask($obj->{mac}, "BACKUP $user $uistatus $status \"$path\" \"$backupdir\" $remolder", $status);
4821
        if ($res) {
4822
            $postreply .= "OK not backingup image: $obj->{name} (on node, $res)\n";
4823 95b003ff Origo
        } else {
4824
            $register{$path}->{'status'} = $uistatus;
4825
            $uistatus = "lbackingup" if ($status eq "active"); # Do lvm snapshot before backing up
4826
            $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
4827
            $postreply .= "Status=backingup OK backingup image: $obj->{name} (on node)\n";
4828
        }
4829
    } elsif (!$spools[$obj->{regstoragepool}]->{'rdiffenabled'}) {
4830
        $postreply .= "Status=ERROR Rdiff-backup has not been enabled for this storagepool ($spools[$obj->{regstoragepool}]->{'name'})\n";
4831
    } else {
4832
        if ($spools[$obj->{regstoragepool}]->{'hostpath'} eq "local" && $status eq "active") {
4833
            my $poolpath = $spools[$obj->{regstoragepool}]->{'path'};
4834
            # We only need to worry about taking an LVM snapshot if the image is in active use
4835
            # We also check if the images is actually on an LVM partition
4836
            my $qi = `/bin/cat /proc/mounts | grep "$poolpath"`; # Find the lvm volume mounted on /mnt/images
4837
            ($qi =~ m/\/dev\/mapper\/(\S+)-(\S+) $pool.+/g)[-1]; # Select last match
4838
            my $lvolgroup = $1;
4839
            my $lvol = $2;
4840
            if ($lvolgroup && $lvol) {
4841
                $uistatus = "lbackingup";
4842
            }
4843
        }
4844
        if ($uistatus ne "lbackingup" && $status eq "active") {
4845
            $postreply .= "Status=ERROR Image is not on an LVM partition - suspend before backing up.\n";
4846
            $main::updateUI->({tab=>"images", user=>$user, type=>"update", path=>$path, status=>$uistatus, message=>"Image is not on an LVM partition - suspend before backing up"});
4847
        } else {
4848
            my $buser;
4849
            my $bname;
4850
            if ($path =~ /.*\/(common|$user)\/(.+)/) {
4851
                $buser = $1;
4852
                $bname = $2;
4853
            }
4854
            if ($buser && $bname) {
4855
                my $dirpath = $spools[$obj->{regstoragepool}]->{'path'};
4856
                #chop $dirpath; # Remove last /
4857
                eval {
4858
                    $register{$path}->{'status'} = $uistatus;
4859
                    my $daemon = Proc::Daemon->new(
4860
                        work_dir => '/usr/local/bin',
4861
                        exec_command => "perl -U steamExec $buser $uistatus $status \"$bname\" \"$dirpath\" \"$backupdir\" $remolder"
4862
                    ) or do {$postreply .= "Status=ERROR $@\n";};
4863
                    my $pid = $daemon->Init();
4864
                    $postreply .=  "Status=backingup OK backingup image: $obj->{name}\n";
4865
                    $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $bname");
4866
                    1;
4867
                } or do {$postreply .= "Status=ERROR $@\n";}
4868
            } else {
4869
                $postreply .= "Status=ERROR Problem backing up $path\n";
4870
            }
4871
        }
4872
    }
4873
    return $postreply;
4874
}
4875
4876
sub Restore {
4877
    my ($image, $action, $obj) = @_;
4878
    if ($help) {
4879
        return <<END
4880
GET:image:
4881
Backs an image up.
4882
END
4883
    }
4884
    my $path = $obj->{path};
4885
    my $status = $obj->{status};
4886
    $uistatus = "restoring";
4887
    my($bname, $dirpath, $suffix) = fileparse($path, (".vmdk", ".img", ".vhd", ".qcow", ".qcow2", ".vdi", ".iso"));
4888
    my $backup = $params{"backup"} || $obj->{backup};
4889
    my $pool = $register{$path}->{'storagepool'};
4890
    $pool = "0" if ($pool == -1);
4891
    my $poolpath = $spools[$pool]->{'path'};
4892
    my $restorefromdir = $backupdir;
4893
    my $inc = $backup;
4894
    my $subdir; # 1 level of subdirs supported
4895 27512919 Origo
    $subdir = $1 if ($dirpath =~ /.+\/$obj->{user}(\/.+)?\//);
4896 95b003ff Origo
4897
    if ($backup =~ /^SNAPSHOT-(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/) { # We are dealing with a zfs restore
4898
        $inc = "$1-$2-$3-$4-$5-$6";
4899
        foreach my $spool (@spools) {
4900
            my $ppath = $spool->{"path"};
4901
            if (-e "$ppath/.zfs/snapshot/$backup/$obj->{user}$subdir/$bname$suffix") {
4902
                $restorefromdir = "$ppath/.zfs/snapshot/$backup";
4903
                last;
4904
            }
4905
        }
4906
    } else {
4907
        if ($backup eq "mirror") {
4908
            my $mir = `/bin/ls "$backupdir/$obj->{user}/$bname$suffix/rdiff-backup-data" | grep current_mirror`;
4909
            if ($mir =~ /current_mirror\.(\S+)\.data/) {
4910
                $inc = $1;
4911
            }
4912
        }
4913
        $inc =~ tr/:T/-/; # qemu-img does not like colons in file names - go figure...
4914
        $inc = substr($inc,0,-6);
4915
    }
4916
    $uipath = "$poolpath/$obj->{user}$subdir/$bname.$inc$suffix";
4917
    my $i;
4918
    if (-e $uipath) {
4919
        $i = 1;
4920
        while (-e "$poolpath/$obj->{user}$subdir/$bname.$inc.$i$suffix") {$i++;}
4921
        $uipath = "$poolpath/$obj->{user}$subdir/$bname.$inc.$i$suffix";
4922
    }
4923
4924
    if (-e $uipath) {
4925
        $postreply .= "Status=ERROR This image is already being restored\n";
4926
    } elsif ($obj->{user} ne $user && !$isadmin) {
4927
        $postreply .= "Status=ERROR No restore privs\n";
4928
    } elsif (!$backup || $backup eq "--") {
4929
        $postreply .= "Status=ERROR No backup selected\n";
4930
    } elsif (overQuotas($obj->{virtualsize})) {
4931
        $postreply .= "Status=ERROR Over quota (". overQuotas($obj->{virtualsize}) . ") restoring: $obj->{name}\n";
4932
    } elsif (overStorage($obj->{ksize}*1024, $pool+0)) {
4933
        $postreply .= "Status=ERROR Out of storage in destination pool restoring: $obj->{name}\n";
4934
    } else {
4935
        my $ug = new Data::UUID;
4936
        my $newuuid = $ug->create_str();
4937
        $register{$uipath} = {
4938
            uuid=>$newuuid,
4939
            status=>"restoring",
4940
            name=>"$obj->{name} ($inc)" . (($i)?" $i":''),
4941
            notes=>$obj->{notes},
4942
            image2=>$obj->{image2},
4943
            managementlink=>$obj->{managementlink},
4944
            upgradelink=>$obj->{upgradelink},
4945
            terminallink=>$obj->{terminallink},
4946
            size=>0,
4947
            realsize=>0,
4948
            virtualsize=>$obj->{virtualsize},
4949
            type=>$obj->{type},
4950
            user=>$user
4951
        };
4952
        eval {
4953
            $register{$path}->{'status'} = $uistatus;
4954
            my $daemon = Proc::Daemon->new(
4955
                work_dir => '/usr/local/bin',
4956
                exec_command => "perl -U steamExec $obj->{user} $uistatus $status \"$path\" \"$restorefromdir\" \"$backup\" \"$uipath\""
4957
            ) or do {$postreply .= "Status=ERROR $@\n";};
4958
            my $pid = $daemon->Init();
4959
            $postreply .=  "Status=$uistatus OK $uistatus $obj->{type} image: $obj->{name} ($inc)". ($console?", $newuuid\n":"\n");
4960
            $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name} ($inc), $uipath, $newuuid: $uuid");
4961
            1;
4962
        } or do {$postreply .= "Status=ERROR $@\n";};
4963
        $main::updateUI->({tab=>"images", user=>$user, type=>"update"});
4964
    }
4965
    return $postreply;
4966
}
4967
4968
sub Master {
4969
    my ($image, $action, $obj) = @_;
4970
    if ($help) {
4971
        return <<END
4972
GET:image:
4973
Converts an image to a master image. Image must not be in use.
4974
END
4975
    }
4976
    my $path = $obj->{path};
4977
    my $status = $register{$path}->{status};
4978
    $path =~ /(.+)\.$obj->{type}$/;
4979
    my $namepath = $1;
4980
    my $uiname;
4981
    if (!$register{$path}) {
4982
        $postreply .= "Status=ERROR Image $path not found\n";
4983
    } elsif ($status ne "unused") {
4984
        $postreply .= "Status=ERROR Only unused images may be mastered\n";
4985 3657de20 Origo
#    } elsif ($namepath =~ /(.+)\.master/ || $register{$path}->{'master'}) {
4986
#        $postreply .= "Status=ERROR Only one level of mastering is supported\n";
4987 95b003ff Origo
    } elsif ($obj->{istoragepool} == -1 || $obj->{regstoragepool} == -1) {
4988
        $postreply .= "Status=ERROR Unable to master $obj->{name} (master images are not supported on node storage)\n";
4989
    } elsif ($obj->{type} eq "qcow2") {
4990
        # Promoting a regular image to master
4991
        # First find an unused path
4992
        if (-e "$namepath.master.$obj->{type}") {
4993
            my $i = 1;
4994
            while ($register{"$namepath.$i.master.$obj->{type}"} || -e "$namepath.$i.master.$obj->{type}") {$i++;};
4995
            $uinewpath = "$namepath.$i.master.$obj->{type}";
4996
        } else {
4997
            $uinewpath = "$namepath.master.$obj->{type}";
4998
        }
4999
5000
        $uipath = $path;
5001
        $uiname = "$obj->{name}";
5002
        eval {
5003
            my $qinfo = `/bin/mv -iv "$path" "$uinewpath"`;
5004
            $register{$path}->{'name'} = $uiname;
5005
            $register{$uinewpath} = $register{$path};
5006
            delete $register{$path};
5007
            $postreply .= "Status=$status Mastered $obj->{type} image: $obj->{name}\n";
5008
            chop $qinfo;
5009
            $main::syslogit->($user, "info", $qinfo);
5010
            1;
5011
        } or do {$postreply .= "Status=ERROR $@\n";};
5012
        sleep 1;
5013
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, newpath=>$uinewpath, status=>$status, name=>$uiname});
5014
    } else {
5015
        $postreply .= "Status=ERROR Only qcow2 images may be mastered\n";
5016
    }
5017
    return $postreply;
5018
}
5019
5020
sub Unmaster {
5021
    my ($image, $action, $obj) = @_;
5022
    if ($help) {
5023
        return <<END
5024
GET:image:
5025
Converts a master image to a regular image. Image must not be in use.
5026
END
5027
    }
5028
    my $path = $obj->{path};
5029
    my $status = $register{$path}->{status};
5030
    $path =~ /(.+)\.$obj->{type}$/;
5031
    my $namepath = $1;
5032
    my $haschildren = 0;
5033
    my $child;
5034
    my $uinewpath;
5035
    my $iname;
5036
    my @regvalues = values %register;
5037
    foreach my $val (@regvalues) {
5038
        if ($val->{'master'} eq $path) {
5039
            $haschildren = 1;
5040
            $child = $val->{'name'};
5041
            last;
5042
        }
5043
    }
5044
    if (!$register{$path}) {
5045
        $postreply .= "Status=ERROR Image $path not found\n";
5046
    } elsif ($haschildren) {
5047
        $postreply .= "Status=Error Cannot unmaster image. This image is used as master by: $child\n";
5048
    } elsif ($status ne "unused" && $status ne "used") {
5049
        $postreply .= "Status=ERROR Only used and unused images may be unmastered\n";
5050
    } elsif (!( ($namepath =~ /(.+)\.master/) || ($obj->{master} && $obj->{master} ne "--")) ) {
5051
        $postreply .= "Status=ERROR You can only unmaster master or child images\n";
5052
    } elsif (($obj->{istoragepool} == -1 || $obj->{regstoragepool} == -1) && $namepath =~ /(.+)\.master/) {
5053
        $postreply .= "Status=ERROR Unable to unmaster $obj->{name} (master images are not supported on node storage)\n";
5054
    } elsif ($obj->{type} eq "qcow2") {
5055
        # Demoting a master to regular image
5056 3657de20 Origo
        if ($action eq 'unmaster' && $namepath =~ /(.+)\.master$/) {
5057 95b003ff Origo
            $namepath = $1;
5058
            $uipath = $path;
5059
            # First find an unused path
5060
            if (-e "$namepath.$obj->{type}") {
5061
                my $i = 1;
5062
                while ($register{"$namepath.$i.$obj->{type}"} || -e "$namepath.$i.$obj->{type}") {$i++;};
5063
                $uinewpath = "$namepath.$i.$obj->{type}";
5064
            } else {
5065
                $uinewpath = "$namepath.$obj->{type}";
5066
            }
5067
5068
            $iname = $obj->{name};
5069
            $iname =~ /(.+)( \(master\))/;
5070
            $iname = $1 if $2;
5071
            eval {
5072
                my $qinfo = `/bin/mv -iv "$path" "$uinewpath"`;
5073
                $register{$path}->{'name'} = $iname;
5074
                $register{$uinewpath} = $register{$path};
5075
                delete $register{$path};
5076
                $postreply .=  "Status=$status Unmastered $obj->{type} image: $obj->{name}\n";
5077
                chomp $qinfo;
5078
                $main::syslogit->($user, "info", $qinfo);
5079
                1;
5080
            } or do {$postreply .= "Status=ERROR $@\n";}
5081
    # Rebasing a child image
5082 3657de20 Origo
        } elsif ($action eq 'rebase' && $obj->{master} && $obj->{master} ne "--") {
5083 95b003ff Origo
            $uistatus = "rebasing";
5084
            $uipath = $path;
5085
            $iname = $obj->{name};
5086
            $iname =~ /(.+)( \(child\d*\))/;
5087
            $iname = $1 if $2;
5088
            my $temppath = "$path.temp";
5089
            $uipath = $path;
5090
            $uimaster = "--";
5091
            my $macip;
5092
5093
            if ($obj->{mac} && $path =~ /\/mnt\/stabile\/node\//) {
5094
                unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
5095
                $macip = $nodereg{$obj->{mac}}->{'ip'};
5096
                untie %nodereg;
5097
            }
5098
            eval {
5099
                my $master = $register{$path}->{'master'};
5100
                my $usedmaster = '';
5101
#                @regvalues = values %register;
5102
                if ($master && $master ne '--') {
5103
                    foreach my $valref (@regvalues) {
5104
                        $usedmaster = 1 if ($valref->{'master'} eq $master && $valref->{'path'} ne $path); # Check if another image is also using this master
5105
                    }
5106
                }
5107 48fcda6b Origo
                $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$uistatus});
5108 95b003ff Origo
                $register{$path} = {
5109
                    master=>"",
5110
                    name=>"$iname",
5111
                    notes=>$obj->{notes},
5112
                    status=>$uistatus,
5113
                    snap1=>$obj->{snap1},
5114
                    managementlink=>$obj->{managementlink},
5115
                    upgradelink=>$obj->{upgradelink},
5116
                    terminallink=>$obj->{terminallink},
5117
                    image2=>$obj->{image2},
5118
                    storagepool=>$obj->{istoragepool},
5119
                    status=>$uistatus
5120
                };
5121
5122
                if ($macip) {
5123
                    my $esc_localpath = shell_esc_chars($path);
5124
                    my $esc_localpath2 = shell_esc_chars($temppath);
5125
                    $res .= `$sshcmd $macip "/usr/bin/qemu-img convert $esc_localpath -O qcow2 $esc_localpath2"`;
5126
                    $res .= `$sshcmd $macip "if [ -f $esc_localpath2 ]; then /bin/mv -v $esc_localpath2 $esc_localpath; fi"`;
5127
                } else {
5128
                    $res .= `/usr/bin/qemu-img convert -O qcow2 "$path" "$temppath"`;
5129
                    $res .= `if [ -f "$temppath" ]; then /bin/mv -v "$temppath" "$path"; fi`;
5130
                }
5131
                if ($master && !$usedmaster) {
5132
                    $register{$master}->{'status'} = 'unused';
5133
                    $main::syslogit->('info', "Freeing master $master");
5134
                }
5135
                $register{$path}->{'master'} = '';
5136
                $register{$path}->{'status'} = $status;
5137
5138
                $postreply .= "Status=OK $uistatus $obj->{type} image: $obj->{name}\n";
5139 48fcda6b Origo
                $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, status=>$status});
5140 95b003ff Origo
                $main::syslogit->($user, "info", "$uistatus $obj->{type} image: $obj->{name}: $uuid");
5141
                1;
5142
            } or do {$postreply .= "Status=ERROR $@\n";}
5143
        } else {
5144
            $postreply .= "Status=ERROR Not a master, not a child \"$obj->{name}\"\n";
5145
        }
5146
        sleep 1;
5147
        $main::updateUI->({tab=>"images", user=>$user, type=>"update", uuid=>$obj->{'uuid'}, newpath=>$uinewpath, name=>$iname, status=>$status});
5148
    } else {
5149
        $postreply .= "Status=ERROR Only qcow2 images may be unmastered\n";
5150
    }
5151
    return $postreply;
5152
}
5153
5154
# Save or create new image
5155
sub Save {
5156
    my ($img, $action, $obj) = @_;
5157
    if ($help) {
5158
        return <<END
5159
POST:path, uuid, name, type, virtualsize, storagepool, user:
5160
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.
5161
Depending on your privileges not all changes are permitted. If you save without specifying a uuid or path, a new image is created.
5162
END
5163
    }
5164
    my $path = $obj->{path};
5165
    my $uuid = $obj->{uuid};
5166
    my $status = $obj->{status};
5167
    if ($status eq "new") {
5168
        # Create new image
5169
        my $ug = new Data::UUID;
5170
        if (!$uuid || $uuid eq '--') {
5171
            $uuid = $ug->create_str();
5172
        } else { # Validate
5173
            my $valuuid  = $ug->from_string($uuid);
5174
            if ($ug->to_string($valuuid) eq $uuid) {
5175
                ;
5176
            } else {
5177
                $uuid = $ug->create_str();
5178
            }
5179
        }
5180
        my $newuuid = $uuid;
5181
        my $pooldir = $spools[$obj->{storagepool}]->{'path'};
5182
        my $cmd;
5183
        my $name = $obj->{name};
5184
        $name =~ s/\./_/g; # Remove unwanted chars
5185
        $name =~ s/\//_/g;
5186
        eval {
5187
            my $ipath = "$pooldir/$user/$name.$obj->{type}";
5188
            $obj->{type} = "qcow2" unless ($obj->{type});
5189
            # Find an unused path
5190
            if ($register{$ipath} || -e "$ipath") {
5191
                my $i = 1;
5192
                while ($register{"$pooldir/$user/$name.$i.$obj->{type}"} || -e "$pooldir/$user/$name.$i.$obj->{type}") {$i++;};
5193
                $ipath = "$pooldir/$user/$name.$i.$obj->{type}";
5194
                $name = "$name.$i";
5195
            }
5196
5197
            if ($obj->{type} eq 'qcow2' || $obj->{type} eq 'vmdk') {
5198
                my $size = ($obj->{msize})."M";
5199
                my $format = "qcow2";
5200
                $format = "vmdk" if ($path1 =~ /\.vmdk$/);
5201
                $cmd = qq|/usr/bin/qemu-img create -f $format "$ipath" "$size"|;
5202
            } elsif ($obj->{type} eq 'img') {
5203
                my $size = ($obj->{msize})."M";
5204
                $cmd = qq|/usr/bin/qemu-img create -f raw "$ipath" "$size"|;
5205
            } elsif ($obj->{type} eq 'vdi') {
5206
                my $size = $obj->{msize};
5207
                $cmd = qq|/usr/bin/VBoxManage createhd --filename "$ipath" --size "$size" --format VDI|;
5208
            }
5209
            $obj->{name} = 'New Image' if (!$obj->{name} || $obj->{name} eq '--' || $obj->{name} =~ /^\./ || $obj->{name} =~ /\//);
5210
            if (-e $ipath) {
5211
                $postreply .= "Status=ERROR Image already exists: \"$obj->{name}\" in \"$ipath\”\n";
5212
            } elsif (overQuotas($obj->{ksize}*1024)) {
5213
                $postreply .= "Status=ERROR Over quota (". overQuotas($obj->{ksize}*1024) . ") creating: $obj->{name}\n";
5214
                $main::updateUI->({tab=>"images", user=>$user, type=>"message", message=>"Over quota in storage pool $obj->{storagepool}"});
5215
                $main::syslogit->($user, "info", "Over quota in storage pool $obj->{storagepool}, not creating $obj->{type} image $obj->{name}");
5216
            } elsif (overStorage($obj->{ksize}*1024, $obj->{storagepool}+0)) {
5217
                $postreply .= "Status=ERROR Out of storage in destination pool creating: $obj->{name}\n";
5218
                $main::updateUI->({tab=>"images", user=>$user, type=>"update", message=>"Out of storage in storage pool $obj->{storagepool}"});
5219
                $main::syslogit->($user, "info", "Out of storage in storage pool $obj->{storagepool}, not creating $obj->{type} image $obj->{name}");
5220
            } elsif ($obj->{virtualsize} > 10*1024*1024 && $obj->{name} && $obj->{name} ne '--') {
5221
                $register{$ipath} = {
5222
                    uuid=>$newuuid,
5223
                    name=>$obj->{name},
5224
                    user=>$user,
5225
                    notes=>$obj->{notes},
5226
                    type=>$obj->{type},
5227
                    size=>0,
5228
                    realsize=>0,
5229
                    virtualsize=>$obj->{virtualsize},
5230
                    storagepool=>$spools[0]->{'id'},
5231
                    created=>$current_time,
5232
                    managementlink=>$obj->{managementlink},
5233
                    upgradelink=>$obj->{upgradelink},
5234
                    terminallink=>$obj->{terminallink},
5235
                    status=>"creating"
5236
                };
5237
                $uipath = $ipath;
5238
                my $res = `$cmd`;
5239
                $register{$ipath}->{'status'} = 'unused';
5240
5241
                $postreply .= "Status=OK Created $obj->{type} image: $obj->{name}\n";
5242
                $postreply .= "Status=OK uuid: $newuuid\n"; # if ($console || $api);
5243
                $postreply .= "Status=OK path: $ipath\n"; # if ($console || $api);
5244
                sleep 1; # Needed to give updateUI a chance to reload
5245 8d7785ff Origo
                $main::updateUI->({tab=>"images", user=>$user, type=>"update"});
5246
#                $main::updateUI->({tab=>"images", uuid=>$newuuid, user=>$user, type=>"update", name=>$obj->{name}, path=>$obj->{path}});
5247 95b003ff Origo
                $main::syslogit->($user, "info", "Created $obj->{type} image: $obj->{name}: $newuuid");
5248 8d7785ff Origo
                updateBilling("New image: $obj->{name}");
5249 95b003ff Origo
            } else {
5250
                $postreply .= "Status=ERROR Problem creating image: $obj->{name} of size $obj->{virtualsize}\n";
5251
            }
5252
            1;
5253
        } or do {$postreply .= "Status=ERROR $@\n";}
5254
    } else {
5255 d24d9a01 hq
        # Moving images because of owner change or storagepool change
5256 95b003ff Origo
        if ($obj->{user} ne $obj->{reguser} || $obj->{storagepool} ne $obj->{regstoragepool}) {
5257
            $uipath = Move($path, $obj->{user}, $obj->{storagepool}, $obj->{mac});
5258
    # Resize a qcow2 image
5259
        } elsif ($obj->{virtualsize} != $register{$path}->{'virtualsize'} &&
5260
            ($obj->{user} eq $obj->{reguser} || index($privileges,"a")!=-1)) {
5261
            if ($status eq "active" || $status eq "paused") {
5262
                $postreply .= "Status=ERROR Cannot resize active images $path, $status.\n";
5263
                $main::updateUI->({tab=>"images", user=>$user, type=>"update", status=>'ERROR', message=>"ERROR Cannot resize active images"});
5264
            } elsif ($obj->{type} eq "qcow2" || $obj->{type} eq "img") {
5265
                if ($obj->{virtualsize} < $register{$path}->{'virtualsize'}) {
5266
                    $postreply .= "Status=ERROR Only growing of images supported.\n";
5267
                } elsif (overQuotas($obj->{virtualsize}, ($register{$path}->{'storagepool'}==-1))) {
5268
                    $postreply .= "Status=ERROR Over quota (". overQuotas($obj->{virtualsize}, ($register{$path}->{'storagepool'}==-1)) . ") resizing: $obj->{name}\n";
5269
                } elsif (overStorage(
5270
                    $obj->{virtualsize},
5271
                    $register{$path}->{'storagepool'},
5272
                    $register{$path}->{'mac'}
5273
                )) {
5274
                    $postreply .= "Status=ERROR Not enough storage ($obj->{virtualsize}) in destination pool $obj->{storagepool} resizing: $obj->{name}\n";
5275
                } else {
5276
                    $uistatus = "resizing";
5277
                    $uipath = $path;
5278
                    my $mpath = $path;
5279
                    if ($obj->{mac} && $obj->{mac} ne '--') {
5280
                        unless ( tie(%nodereg,'Tie::DBI', Hash::Merge::merge({table=>'nodes', key=>'mac', CLOBBER=>1}, $Stabile::dbopts)) ) {return 0};
5281
                        $macip = $nodereg{$obj->{mac}}->{'ip'};
5282
                        untie %nodereg;
5283
                    }
5284
                    $mpath = "$macip:$mpath" if ($macip && $macip ne '--');
5285
                    $register{$path}->{'status'} = $uistatus;
5286
                    $register{$path}->{'virtualsize'} = $obj->{virtualsize};
5287
                    my $cmd = qq|steamExec $user $uistatus $status "$mpath" "$obj->{ksize}"|;
5288
                    if ($action eq 'sync_save') { # We wait for result
5289
                        my $res = `$cmd`;
5290
                        $res =~ s/\n/ /g; $res = lc $res;
5291
                        $postreply .= "Status=OK $res\n";
5292
                    } else {
5293
                        my $daemon = Proc::Daemon->new(
5294
                            work_dir => '/usr/local/bin',
5295
                            exec_command => $cmd,
5296
#                            exec_command => "suidperl -U steamExec $user $uistatus $status \"$mpath\" \"$obj->{ksize}\""
5297
                        ) or do {$postreply .= "Status=ERROR $@\n";};
5298
                        my $pid = $daemon->Init();
5299
                    }
5300
                    $postreply .=  "Status=OK $uistatus $obj->{type} image: $obj->{name} ($obj->{ksize}k)\n";
5301
                    $main::syslogit->($user, "info", "$uistatus $obj->{type} image $obj->{name} $uuid $mpath ($obj->{virtualsize})");
5302
                }
5303
            } else {
5304
                $postreply .= "Status=ERROR Can only resize .qcow2 and .img images.\n";
5305
            }
5306
        } else {
5307
            # Regular save
5308
            if ($obj->{user} eq $obj->{reguser} || $isadmin) {
5309
                my $qinfo;
5310
                my $e;
5311
                $obj->{bschedule} = "" if ($obj->{bschedule} eq "--");
5312
                if ($obj->{bschedule}) {
5313
                    # Remove backups
5314 8d7785ff Origo
                    if ($obj->{bschedule} eq "none") {
5315
                        if ($spools[$obj->{regstoragepool}]->{'rdiffenabled'}) {
5316
                            my($bname, $dirpath) = fileparse($path);
5317
                            if ($path =~ /\/($user|common)\/(.+)/) {
5318
                                my $buser = $1;
5319
                                if (-d "$backupdir/$buser/$bname" && $backupdir && $bname && $buser) {
5320
                                    eval {
5321
                                        $qinfo = `/bin/rm -rf "$backupdir/$buser/$bname"`;
5322
                                        1;
5323
                                    } or do {$postreply .= "Status=ERROR $@\n"; $e=1;};
5324
                                    if (!$e) {
5325
                                        $postreply .=  "Status=OK Removed all rdiff backups of $obj->{name}\n";
5326
                                        chomp $qinfo;
5327
                                        $register{$path} = {backupsize=>0};
5328
                                        $main::syslogit->($user, "info", "Removed all backups of $obj->{name}: $path: $qinfo");
5329
                                        $main::updateUI->({
5330
                                            user=>$user,
5331
                                            message=>"Removed all backups of $obj->{name}",
5332
                                            backup=>$path
5333
                                        });
5334
                                        updateBilling("no backup $path");
5335
                                        delete $register{$path}->{'btime'};
5336
                                    }
5337 95b003ff Origo
                                }
5338
                            }
5339
                        }
5340
                        $obj->{bschedule} = "manually";
5341
                        $register{$path}->{'bschedule'} = $obj->{bschedule};
5342
                    }
5343
                }
5344
5345
                $register{$path} = {
5346
                    name=>$obj->{name},
5347
                    user=>$obj->{user},
5348
                    notes=>$obj->{notes},
5349
                    bschedule=>$obj->{bschedule},
5350
                    installable=>$obj->{installable},
5351
                    managementlink=>$obj->{managementlink},
5352
                    upgradelink=>$obj->{upgradelink},
5353
                    terminallink=>$obj->{terminallink},
5354
                    action=>""
5355
                };
5356
                my $domains = $register{$path}->{'domains'};
5357
                if ($status eq 'downloading') {
5358
                    unless (`pgrep $obj->{name}`) { # Check if image is in fact being downloaded
5359
                        $status = 'unused';
5360
                        $register{$path}->{'status'} = $status;
5361
                        unlink ("$path.meta") if (-e "$path.meta");
5362
                    }
5363
                }
5364
                elsif ($status ne 'unused') {
5365
                    my $match;
5366
                    if ($path =~ /\.master\.qcow2$/) {
5367
                        my @regkeys = (tied %register)->select_where("master = '$path'");
5368
                        $match = 2 if (@regkeys);
5369
                    } else {
5370
                        if (!$domreg{$domains}) { # Referenced domain no longer exists
5371
                            ;
5372
                        } else { # Verify if referenced domain still uses image
5373
                            my @imgkeys = ('image', 'image2', 'image3', 'image4');
5374
                            for (my $i=0; $i<4; $i++) {
5375
                                $match = 1 if ($domreg{$domains}->{$imgkeys[$i]} eq $path);
5376
                            }
5377
                        }
5378
                    }
5379
                    unless ($match) {
5380
                        $status = 'unused';
5381
                        $register{$path}->{'status'} = $status;
5382
                    }
5383
                }
5384
                if ($status eq 'unused') {
5385
                    delete $register{$path}->{'domains'};
5386
                    delete $register{$path}->{'domainnames'};
5387
                }
5388
                $uipath = $path;
5389
                $postreply .= "Status=OK Saved $obj->{name} ($uuid)\n";
5390
            } else {
5391
                $postreply .= "Status=ERROR Unable to save $obj->{name}\n";
5392
            }
5393
        }
5394
    }
5395
    if ($postreply) {
5396
        $postmsg = $postreply;
5397
    } else {
5398 3657de20 Origo
        $postreply = to_json(\%{$register{$uipath}}, {pretty=>1}) if ($uipath && $register{$uipath});
5399 95b003ff Origo
        $postreply =~ s/""/"--"/g;
5400
        $postreply =~ s/null/"--"/g;
5401
        $postreply =~ s/"notes" {0,1}: {0,1}"--"/"notes":""/g;
5402
        $postreply =~ s/"installable" {0,1}: {0,1}"(true|false)"/"installable":$1/g;
5403
    }
5404 3657de20 Origo
    return $postreply || "Status=OK Saved $uipath\n";
5405 95b003ff Origo
}
5406
5407
sub Setstoragedevice {
5408
    my ($image, $action, $obj) = @_;
5409
    if ($help) {
5410
        return <<END
5411
GET:device,type:
5412
Changes the device - disk or partition, used for images or backup storage.
5413
[type] is either images or backup.
5414
END
5415
    }
5416
    my $dev = $obj->{device};
5417
    my $force = $obj->{force};
5418
    my $type = 'backup';
5419
    $type = 'images' if ($obj->{type} eq 'images');
5420
    return "Status=Error Not allowed\n" unless ($isadmin);
5421
    my $backupdevice = Getbackupdevice('', 'getbackupdevice');
5422
    my $imagesdevice = Getimagesdevice('', 'getimagesdevice');
5423
    my $devices_obj = from_json(Liststoragedevices('', 'liststoragedevices'));
5424
    my %devices = %$devices_obj;
5425
    my $backupdev = $devices{$backupdevice}->{dev};
5426
    my $imagesdev = $devices{$imagesdevice}->{dev};
5427
    if (!$devices{$dev}) {
5428
        $postreply = "Status=Error You must specify a valid device ($dev)\n";
5429
        return $postreply;
5430
    }
5431
    if (!$force && (($backupdev =~ /$dev/) || ($imagesdev =~ /$dev/))  && $dev !~ /vda/ && $dev !~ /sda/) { # make exception to allow returning to default setup
5432
        $postreply = "Status=Error $dev is already in use as images or backup device\n";
5433
        return $postreply;
5434
    }
5435
    my $stordir = $tenderpathslist[0];
5436
    my $stordevice = $imagesdevice;
5437
    if ($type eq 'backup') {
5438
        $stordir = $backupdir;
5439
        $stordevice = $backupdevice;
5440
    }
5441
    return "Status=Error Storage device not found\n" unless ($stordevice);
5442
    my $mp = $devices{$dev}->{mounted};
5443
    my $newstordir;
5444 e9af6c24 Origo
    # my $oldstordir;
5445 95b003ff Origo
    if ($devices{$dev}->{type} eq 'zfs') {
5446
        my $cmd = qq|zfs list stabile-$type/$type -Ho mountpoint|;
5447
        my $zmp = `$cmd`;
5448
        chomp $zmp;
5449
        if ($zmp =~ /^\//) {
5450
            `zfs mount stabile-$type/$type`;
5451
            $mp = $zmp;
5452
            $newstordir = $mp;
5453
        } else {
5454
            `zfs create stabile-$type/$type`;
5455
            $mp = "/stabile-$type/$type";
5456
            $newstordir = $mp;
5457
        }
5458
    } else {
5459
        $newstordir = (($type eq 'images')?"$mp/images":"$mp/backups");
5460
        $newstordir = $1 if ($newstordir =~ /(.+\/images)\/images$/);
5461
        $newstordir = $1 if ($newstordir =~ /(.+\/backups)\/backups$/);
5462
    }
5463
    if ($mp eq '/') {
5464
        $newstordir = (($type eq 'images')?"/mnt/stabile/images":"/mnt/stabile/backups");
5465
        `umount "$newstordir"`; # in case it's mounted
5466
    }
5467
    `mkdir "$newstordir"` unless (-e $newstordir);
5468
    `chmod 777 "$newstordir"`;
5469
5470
    my $cfg = new Config::Simple("/etc/stabile/config.cfg");
5471
    if ($type eq 'backup') {
5472
        $cfg->param('STORAGE_BACKUPDIR', $newstordir);
5473
        $cfg->save();
5474
    } elsif ($type eq 'images') {
5475 e9af6c24 Origo
5476
    # Handle shared storage config
5477
    #    $oldstordir = $stordir;
5478
        my $i = 0;
5479
        for($i = 0; $i <= $#tenderpathslist; $i++) {
5480
            my $dir = $tenderpathslist[$i];
5481
            last if ($dir eq $newstordir);
5482
        }
5483
        # $tenderpathslist[0] = $newstordir;
5484
        splice(@tenderpathslist, $i,1); # Remove existing entry
5485
        unshift(@tenderpathslist, $newstordir); # Then add the new path
5486
        $cfg->param('STORAGE_POOLS_LOCAL_PATHS', join(',', @tenderpathslist));
5487
5488
        # $tenderlist[0] = 'local';
5489
        splice(@tenderlist, $i,1);
5490
        unshift(@tenderlist, 'local');
5491
        $cfg->param('STORAGE_POOLS_ADDRESS_PATHS', join(',', @tenderlist));
5492
5493
        # $tendernameslist[0] = 'Default';
5494
        splice(@tendernameslist, $i,1);
5495
        unshift(@tendernameslist, 'Default');
5496
5497
        if ($i) { # We've actually changed storage device
5498
            my $oldstorname = $tenderpathslist[1];
5499
            $oldstorname = $1 if ($oldstorname =~ /.*\/(.+)/);
5500
            $tendernameslist[1] = "$oldstorname on $imagesdevice"; # Give the previous default pool a fitting name
5501
5502
            $storagepools = "$storagepools,$i" unless ($storagepools =~ /,\s*$i,?/ || $storagepools =~ /,\s*$i$/ || $storagepools =~ /^$i$/);
5503
            $cfg->param('STORAGE_POOLS_DEFAULTS', $storagepools);
5504
        }
5505
        $cfg->param('STORAGE_POOLS_NAMES', join(',', @tendernameslist));
5506
5507 95b003ff Origo
        $cfg->save();
5508
5509 e9af6c24 Origo
5510
    # Handle node storage configs
5511 95b003ff Origo
        unless ( tie(%idreg,'Tie::DBI', Hash::Merge::merge({table=>'nodeidentities',key=>'identity',CLOBBER=>3}, $Stabile::dbopts)) ) {return "Unable to access id register"};
5512
        # Build hash of known node config files
5513 e9af6c24 Origo
        my @nodeconfigs;
5514
        push @nodeconfigs, "/etc/stabile/nodeconfig.cfg";
5515 95b003ff Origo
        foreach my $valref (values %idreg) {
5516
            my $nodeconfigfile = $valref->{'path'} . "/casper/filesystem.dir/etc/stabile/nodeconfig.cfg";
5517
            next if ($nodeconfigs{$nodeconfigfile}); # Node identities may share basedir and node config file
5518
            if (-e $nodeconfigfile) {
5519
                push @nodeconfigs, $nodeconfigfile;
5520
            }
5521
        }
5522
        untie %idreg;
5523
        foreach my $nodeconfig (@nodeconfigs) {
5524
            my $nodecfg = new Config::Simple($nodeconfig);
5525 e9af6c24 Origo
            my @ltenderlist = $nodecfg->param('STORAGE_SERVERS_ADDRESS_PATHS');
5526
            my $ltenders = join(", ", @ltenderlist);
5527
            next if ($ltenders =~ /10\.0\.0\.1:$newstordir$/ || $ltenders =~ /10\.0\.0\.1:$newstordir,/); # This entry already exists
5528
            #my @ltenderlist = split(/,\s*/, $ltenders);
5529
            #$ltenderlist[0] = "10.0.0.1:$newstordir";
5530
            unshift(@ltenderlist, "10.0.0.1:$newstordir");
5531
            $nodecfg->param('STORAGE_SERVERS_ADDRESS_PATHS', join(',', @ltenderlist));
5532
            my @ltenderpathslist = $nodecfg->param('STORAGE_SERVERS_LOCAL_PATHS');
5533
            my $ltenderpaths = join(", ", @ltenderpathslist);
5534
            #my @ltenderpathslist = split(/,\s*/, $ltenderpaths);
5535
            #$ltenderpathslist[0] = $newstordir;
5536
            unshift(@ltenderpathslist, $newstordir);
5537
            $nodecfg->param('STORAGE_SERVERS_LOCAL_PATHS', join(',', @ltenderpathslist));
5538 95b003ff Origo
            $nodecfg->save();
5539
        }
5540
        unless (`grep "$newstordir 10" /etc/exports`) {
5541
            `echo "$newstordir 10.0.0.0/255.255.255.0(sync,no_subtree_check,no_root_squash,rw)" >> /etc/exports`;
5542
            `/usr/sbin/exportfs -r`; #Reexport nfs shares
5543
        }
5544 e9af6c24 Origo
# We no longer undefine storage pools - we add them
5545
#        $oldstordir =~ s/\//\\\//g;
5546
#        `perl -pi -e 's/$oldstordir 10.*\\\n//s;' /etc/exports` if ($oldstordir);
5547
5548 95b003ff Origo
        `mkdir "$newstordir/common"` unless (-e "$newstordir/common");
5549
        `cp "$stordir/ejectcdrom.xml" "$newstordir/ejectcdrom.xml"` unless (-e "$newstordir/ejectcdrom.xml");
5550
        `cp "$stordir/mountvirtio.xml" "$newstordir/mountvirtio.xml"` unless (-e "$newstordir/mountvirtio.xml");
5551
        `cp "$stordir/dummy.qcow2" "$newstordir/dummy.qcow2"` unless (-e "$newstordir/dummy.qcow2");
5552
    }
5553
    Updatedownloads();
5554
5555 27512919 Origo
    # Update /etc/stabile/cgconfig.conf
5556 e9af6c24 Origo
    my $devs = $devices{$dev}->{dev};
5557
    my @pdevs = split(" ", $devs);
5558
    my $majmins;
5559
    foreach my $dev (@pdevs) {
5560
        # It seems that cgroups cannot handle individual partitions for blkio
5561
        my $physdev = $1 if ($dev =~ /(\w+)\d+/);
5562
        if ($physdev && -d "/sys/fs/cgroup" ) {
5563
            my $blkline = `lsblk -l /dev/$physdev`;
5564
            my $majmin = '';
5565
            $majmin = $1 if ($blkline =~ /$physdev +(\d+:\d+)/);
5566
            $postreply .= "Status=OK Setting cgroups block device to $majmin\n";
5567
            if ($majmin) {
5568
                $majmins .= ($majmins)?" $majmin":$majmin;
5569
            }
5570 95b003ff Origo
        }
5571
    }
5572 e9af6c24 Origo
    setCgroupsBlkDevice($majmins) if ($majmins);
5573 95b003ff Origo
5574
    $Stabile::Nodes::console = 1;
5575
    require "$Stabile::basedir/cgi/nodes.cgi";
5576
    $postreply .= Stabile::Nodes::do_reloadall('','reloadall');
5577
5578
    # Update config on stabile.io
5579
    require "$Stabile::basedir/cgi/users.cgi";
5580
    $Stabile::Users::console = 1;
5581
    Stabile::Users::Updateengine('', 'updateengine');
5582
5583
    my $msg = "OK Now using $newstordir for $type on $obj->{device}";
5584
    $main::updateUI->({tab=>'home', user=>$user, type=>'update', message=>$msg});
5585
    $postreply .= "Status=OK Now using $newstordir for $type on $dev\n";
5586
    return $postreply;
5587
}
5588
5589
sub Initializestorage {
5590
    my ($image, $action, $obj) = @_;
5591
    if ($help) {
5592
        return <<END
5593
GET:device,type,fs,activate,force:
5594
Initializes a local disk or partition, and optionally formats it with ZFS and creates a ZFS pool to use as image storage or backup storage.
5595
[device] is a local disk device in /dev like e.g. 'sdd'. [type] may be either 'images' (default) or 'backup'. [fs] may be 'lvm' (default) or 'zfs'.
5596 e9af6c24 Origo
Set [activate] if you want to put the device into use immediately. Set [force] if you want to destroy existing ZFS pool and recreate (obviously use with care).
5597 95b003ff Origo
END
5598
    }
5599
    my $fs = $obj->{fs} || 'zfs';
5600
    my $dev = $obj->{device};
5601
    my $force = $obj->{force};
5602
    my $activate = $obj->{activate};
5603
    my $type = 'backup';
5604
    $type = 'images' if ($obj->{type} eq 'images');
5605
    return "Status=Error Not allowed\n" unless ($isadmin);
5606
    my $backupdevice = Getbackupdevice('', 'getbackupdevice');
5607
    my $imagesdevice = Getimagesdevice('', 'getimagesdevice');
5608
    my $devices_obj = from_json(Liststoragedevices('', 'liststoragedevices'));
5609
    my %devices = %$devices_obj;
5610
    my $backupdev = $devices{$backupdevice}->{dev};
5611
    my $imagesdev = $devices{$imagesdevice}->{dev};
5612
    if (!$dev || !(-e "/dev/$dev")) {
5613
        $postreply = "Status=Error You must specify a valid device\n";
5614
        return $postreply;
5615
    }
5616
    if (($backupdev =~ /$dev/) || ($imagesdev =~ /$dev/)) {
5617
        $postreply = "Status=Error $dev is already in use as images or backup device\n";
5618
        return $postreply;
5619
    }
5620
    my $stordir = "/stabile-$type/$type";
5621
    if ($fs eq 'lvm') {
5622
        if ($type eq 'backup') {
5623
            $stordir = "/mnt/stabile/backups";
5624
        } else {
5625
            $stordir = "/mnt/stabile/images";
5626
        }
5627
    }
5628
    `chmod 666 /dev/zfs` if (-e '/dev/zfs'); # TODO: This should be removed once we upgrade to Bionic and zfs allow is supported
5629
5630
    my $vol = $type . "vol";
5631
    my $mounts = `cat /proc/mounts`;
5632
    my $zpools = `zpool list -v`;
5633
    my $pvs = `pvdisplay -c`;
5634 e9af6c24 Origo
    my $z;
5635 95b003ff Origo
    $postreply = '';
5636
    # Unconfigure existing zfs or lvm if $force and zfs/lvm configured or device is in use by either
5637
    if ($zpools =~ /stabile-$type/ || $mounts =~ /dev\/mapper\/stabile$type/ || $zpools =~ /$dev/ || $pvs =~ /$dev/) {
5638 e9af6c24 Origo
        if ($fs eq 'zfs' || $zpools =~ /$dev/) {
5639
            if ($force) { # ZFS needs to be unconfigured
5640
                my $umount = `LANG=en_US.UTF-8 umount -v "/stabile-$type/$type" 2>&1`;
5641 95b003ff Origo
                unless ($umount =~ /(unmounted|not mounted|no mount point)/) {
5642 e9af6c24 Origo
                    $postreply .= "Status=Error Unable to unmount zfs $type storage on $dev - $umount\n";
5643 95b003ff Origo
                    return $postreply;
5644
                }
5645
                `umount "/stabile-$type"`;
5646
                my $res = `zpool destroy "stabile-$type" 2>&1`;
5647
                chomp $res;
5648
                $postreply .= "Status=OK Unconfigured zfs - $res\n";
5649
            } else {
5650
                $postreply .= "Status=Error ZFS is already configured for $type\n";
5651 e9af6c24 Origo
                $z = 1;
5652
            #    return $postreply;
5653 95b003ff Origo
            }
5654
        }
5655
        if ($fs eq 'lvm' || $pvs =~ /$dev/) {
5656
            if ($force) {
5657
                my $udir = (($type eq 'backup')?"/mnt/stabile/backups":"/mnt/stabile/images");
5658
                my $umount = `umount -v "$udir" 2>&1`;
5659
                unless ($umount =~ /unmounted|not mounted|no mount point/) {
5660
                    $postreply .= "Status=Error Unable to unmount lvm $type storage - $umount\n";
5661
                    return $postreply;
5662
                }
5663
                my $res = `lvremove --yes /dev/stabile$type/$vol  2>&1`;
5664
                chomp $res;
5665
                $res .= `vgremove -f stabile$type 2>&1`;
5666
                chomp $res;
5667
                my $pdev = "/dev/$dev";
5668
                $pdev .= '1' unless ($pdev =~ /1$/);
5669
                $res .= `pvremove $pdev 2>&1`;
5670
                chomp $res;
5671
                $postreply .= "Status=OK Unconfigured lvm - $res\n";
5672
            } else {
5673
                $postreply .= "Status=Error LVM is already configured for $type\n";
5674
                return $postreply;
5675
            }
5676
        }
5677
    }
5678
    # Check if $dev is still in use
5679
    $mounts = `cat /proc/mounts`;
5680
    $zpools = `zpool list -v`;
5681
    $pvs = `pvdisplay -c`;
5682
    if ($mounts =~ /\/dev\/$dev/ || $pvs =~ /$dev/ || $zpools =~ /$dev/) {
5683 e9af6c24 Origo
        $postreply .= "Status=Error $dev is already in use - use force.\n";
5684 95b003ff Origo
        return $postreply;
5685
    }
5686
    # Now format
5687
    my $ispart = 1 if ($dev =~ /[a-zA-Z]+\d+/);
5688
    if ($fs eq 'zfs') { # ZFS was specified
5689
        $postreply = "Status=OK Initializing $dev disk with ZFS for $type...\n";
5690
        if (!$ispart) {
5691
            my $fres = `parted -s /dev/$dev mklabel GPT 2>&1`;
5692
            $postreply .= "Status=OK partitioned $dev: $fres\n";
5693
        }
5694 e9af6c24 Origo
        if ($z) { # zpool already created
5695
            `zpool add stabile-$type /dev/$dev`;
5696
        } else {
5697
            `zpool create stabile-$type /dev/$dev`;
5698
            `zfs create stabile-$type/$type`;
5699
            `zfs set atime=off stabile-$type/$type`;
5700
        }
5701 95b003ff Origo
#        if ($force) {
5702
#            $postreply .= "Status=OK Forcibly removing all files in $stordir to allow ZFS mount\n";
5703
#            `rm -r $stordir/*`;
5704
#        }
5705
#        `zfs set mountpoint=$stordir stabile-$type/$type`;
5706
        $stordir = "/stabile-$type/$type" if (`zfs mount stabile-$type/$type`);
5707
        `/bin/chmod 777 $stordir`;
5708
        $postreply .= "Status=OK Mounted stabile-$type/$type as $type storage on $stordir.\n";
5709
        if ($activate) {
5710
            $postreply .= "Status=OK Setting $type storage device to $dev.\n";
5711
            Setstoragedevice('', 'setstoragedevice', {device=>"stabile-$type", type=>$type});
5712
        }
5713
    } else { # Assume LVM
5714
        $postreply = "Status=OK Initializing $dev with LVM for $type...\n";
5715
        my $part = $dev;
5716
        if (!$ispart) {
5717
            $part = $dev.'1';
5718
            `/sbin/sfdisk -d /dev/$dev > /root/$dev-partition-sectors.save`;
5719
            my $fres = `sfdisk /dev/$dev << EOF\n;\nEOF`;
5720
            $postreply .= "Status=OK partitioned $dev: $fres\n";
5721
        }
5722
        `/sbin/vgcreate -f stabile$type /dev/$part`;
5723
        `/sbin/vgchange -a y stabile$type`;
5724
        my $totalpe =`/sbin/vgdisplay stabile$type | grep "Total PE"`;
5725
        $totalpe =~ /Total PE\s+(\d+)/;
5726
        my $size = $1 -2000;
5727
#        my $size = "10000";
5728
        if ($size <100) {
5729
            $postreply .= "Status=Error Volume is too small to make sense...\n";
5730
            return $postreply;
5731
        }
5732
        my $vol = $type . "vol";
5733
        `/sbin/lvcreate --yes -l $size stabile$type -n $vol`;
5734
#        `/sbin/mkfs.ext4 /dev/stabile$type/$vol`;
5735
        `mkfs.btrfs /dev/stabile$type/$vol`;
5736
        my $mounted = `mount -v /dev/stabile$type/$vol $stordir`;
5737
        `chmod 777 $stordir`;
5738
        if ($mounted) {
5739
            $postreply .= "Status=OK Mounted /dev/stabile$type/$vol as $type storage on $stordir.\n";
5740
        } else {
5741
            $postreply .= "Status=Error Could not mount /dev/stabile$type/$vol as $type storage on $stordir.\n";
5742
        }
5743
        if ($activate){
5744
            Setstoragedevice('', 'setstoragedevice', {device=>"stabile$type-$type".'vol', type=>$type});
5745
        }
5746
    }
5747
    return $postreply;
5748
}
5749
5750
sub setCgroupsBlkDevice {
5751 e9af6c24 Origo
    my @majmins = split(" ", shift);
5752 27512919 Origo
    my $file = "/etc/stabile/cgconfig.conf";
5753
    my %options = (
5754
        blkio.throttle.read_bps_device => $valve_readlimit,
5755
        blkio.throttle.write_bps_device => $valve_writelimit,
5756
        blkio.throttle.read_iops_device => $valve_iopsreadlimit,
5757
        blkio.throttle.write_iops_device => $valve_iopswritelimit
5758
        );
5759
    my @groups = ('stabile', 'stabilevm');
5760 95b003ff Origo
    my @newlines;
5761 27512919 Origo
    foreach my $majmin (@majmins) {
5762
        foreach my $group (@groups) {
5763
            my $mline = qq|group $group {|; push @newlines, $mline;
5764
            my $mline = qq|    blkio {|; push @newlines, $mline;
5765
            foreach my $option (keys %options) {
5766
                my $mline = qq|        $option = "$majmin $options{$option}";|;
5767
                push @newlines, $mline;
5768 e9af6c24 Origo
            }
5769 27512919 Origo
            my $mline = qq|    }|; push @newlines, $mline;
5770
            my $mline = qq|}|; push @newlines, $mline;
5771 95b003ff Origo
        }
5772
    }
5773
    unless (open(FILE, "> $file")) {
5774
        $postreply .= "Status=Error Problem opening $file\n";
5775
        return $postreply;
5776
    }
5777
    print FILE join("\n", @newlines);
5778
    close(FILE);
5779
    return;
5780
}