Project

General

Profile

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