#!/usr/bin/env perl
#
# Copyright (c) 1994-2012 Carnegie Mellon University.  All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in
#    the documentation and/or other materials provided with the
#    distribution.
#
# 3. The name "Carnegie Mellon University" must not be used to
#    endorse or promote products derived from this software without
#    prior written permission. For permission or any legal
#    details, please contact
#      Carnegie Mellon University
#      Center for Technology Transfer and Enterprise Creation
#      4615 Forbes Avenue
#      Suite 302
#      Pittsburgh, PA  15213
#      (412) 268-7393, fax: (412) 268-7395
#      innovation@andrew.cmu.edu
#
# 4. Redistributions of any form whatsoever must retain the following
#    acknowledgment:
#    "This product includes software developed by Computing Services
#     at Carnegie Mellon University (http://www.cmu.edu/computing/)."
#
# CARNEGIE MELLON UNIVERSITY DISCLAIMS ALL WARRANTIES WITH REGARD TO
# THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS, IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY BE LIABLE
# FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING
# OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

use strict;
use warnings;

use Getopt::Std;

my %Opts;
getopts('vnhfFiI', \%Opts);
usage() if $Opts{h};

my $OPT_NoAction = $Opts{n};
my $OPT_Verbose = $Opts{v} || $Opts{n};

# non-buffered output
$| = 1;

# XXX - actually read the cyrus username from the imapd.conf and
# change ownership as appropriate?
die "must not run as root" if ($< == 0);

my $imapdconf = shift || usage();

my @bdirs = ("a".."z");
my @fdirs = ("A".."W");
my %ishash = map { $_ => 1 } (@bdirs, @fdirs);

# evil globals
my @configs = ($imapdconf);
my $confdir = "/var/lib/cyrus";
my @parts;
my $yn = "y";
my $sievedir = "/var/spool/sieve";
my $nosievedir = 0;
my $hashimapspool = 0;
my $fulldirhash = 0;
my $virtdomains = 0;

while (my $conf = shift @configs) {
    read_conf($conf);
}

$fulldirhash = 0 if $Opts{f};
$fulldirhash = 1 if $Opts{F};
$hashimapspool = 0 if $Opts{i};
$hashimapspool = 1 if $Opts{I};

print "converting configuration directory $confdir... ";

foreach my $i ("user", "proc", "lock", "db", "socket", "log", "msg", "quota") {
    ensure_dir("$confdir/$i");
}

# *** rehash the domain subdirectory to the new format,
# don't worry about internal format yet
if ($virtdomains) {
    print "domain ";
    ensure_dir("$confdir/domain");
    move_domains("$confdir/domain", 'conf');
}

# *** user subdirectory; holds subscription files
print "user ";
move_users("$confdir/user");

# *** quota subdirectory; holds quota files for each quotaroot
print "quota ";
move_quotas("$confdir/quota");

print "done\n";

# create the sieve stuff
unless ($nosievedir) {
    print "sieve $sievedir... ";

    ensure_dir($sievedir);
    move_sieve($sievedir);

    print "done\n";
}

# *** now for each data partition
while (my $part = shift @parts) {
    print "partition $part... ";

    ensure_dir($part);
    # stage is good too
    ensure_dir("$part/stage.");

    move_part($part);

    print "done\n";
}

sub usage {
    die <<EOF
usage: $0 [-v] [-n] imapd.conf

       -v verbose
       -n no change - just show what would be done
       -f force fulldirhash: no
       -F force fulldirhash: yes
       -i force hashimapspool: no
       -I force hashimapspool: yes

NOTE: imapd.conf must always be provided.  On a normal system
this will be /etc/imapd.conf.  The correct hashing settings will
be read from the provided imapd.conf, or can be overridden with
options.

In verbose mode, each rename command will be printed, as well as
any creation or deletion of folders.

In "no change" mode, it will just print the changes.  Note,
verbose is always turned on in no-change mode.

NOTE 2: It should be safe to run fixhash on a running system, but
it may mess things up horribly if you have some processes still
running with old config, and some with new - so it is always
recommended to fully shut down Cyrus, change the configuration
file, run fixhash, and then start Cyrus again.
EOF
}

# force 32 bit hashing only
sub dir_hash_c {
    my $name = shift;
    my $isspool = shift;

    my ($h, $n);

    if ($fulldirhash) {
	$name =~ s/\..*//; # remove trailing dots
	$n = 0;
	foreach my $b (split(/ */, $name)) {
	    $n = (($n << 3) ^ ($n >> 5)) ^ ord($b);
	    $n &= 4294967295; # UINT32_MAX
	}
	$h = chr(ord('A') + ($n % 23));
	return $h;
    }
    else {
	$h = lc(substr($name, 0, 1));
	if (!($h =~ /[a-z]/)) { $h = 'q'; }
	return $h;
    }
}

sub hash_path {
    my $path = shift;
    my $item = shift;
    my $isspool = shift;
    my $skiptochar = shift;

    return "$path/$item" unless ($hashimapspool or not $isspool);

    my $tohash = $item;
    if ($skiptochar) {
	# strip up to and including the character
	$tohash =~ s/^.*?\Q$skiptochar//;
	if ($skiptochar eq '/' and $tohash =~ m/\./) {
	    # we've got a top level directory, oops
	    $tohash = $item;
	    $tohash =~ s{/.*$}{};
	}
    }

    return "$path/" . dir_hash_c($tohash) . "/$item";
}

sub read_conf {
    my $file = shift;

    open CONF, $file or die "can't open $file";
    while (<CONF>) {
	if (/^#/) { 
	    next; 
	}
	if (/\@include:\s+(.*)$/) {
	    push @configs, $1;
	}
	if (/^configdirectory:\s+(.*)$/) {
	    $confdir = $1;
	}
	if (/^(?:meta)?partition-.*:\s+(.*)$/) {
	    if (grep /$1/, @parts) {
		next;
	    }
	    push @parts, $1;
	}
	if (/^hashimapspool:\s*(1|t|yes|on)/) {
	    $hashimapspool = 1;
	    print "i will also hash partitions.\n";
	}
	if (/^fulldirhash/) {
	    $fulldirhash = 1;
	}
        if (/^sieveusehomedir:\s+(1|t|yes|on)/) {
	    $nosievedir = 1;
	    print "you are storing sieve scripts in user's home directories.\n";
        }
        if (/^sievedir:\s+(.*)$/) {
	    $sievedir = $1;
	    print "you are using $sievedir as your sieve directory.\n";
        }
        if (/^virtdomains:\s+(1|t|yes|on|userid)/) {
	    $virtdomains = 1;
	    print "i will deal with virtual domains.\n";
        }
    }
    close CONF;
}

sub add_found {
    # here be dragons, eep
    my $type = shift;
    my $found = shift;
    my $name = shift;
    my $location = shift;

    if ($type ne 'part') {
	if ($found->{$name}) {
	    die "FOUND BOTH $found->{$name} and $location - you need to fix this by hand\n";
	}
	$found->{$name} = $location;
	return;
    }

    unless (opendir(SUB, $location)) {
	print "Failed to open directory $location\n";
	die unless $OPT_NoAction;
	return;
    }
    while (my $sub = readdir SUB) {
	next if $sub =~ m/^\./;
	my $key = "$name/$sub";
	if ($found->{$key}) {
	    die "FOUND BOTH $found->{$key} and $location/$sub - you need to fix this by hand\n";
	}
	$found->{$key} = "$location/$sub";
    }
    closedir(SUB);
}

sub find_items {
    my $path = shift;
    my $type = shift;
    my %found;
    my @subs;

    unless (opendir(ITEMS, $path)) {
	print "Failed to open directory $path\n";
	die unless $OPT_NoAction;
	return;
    }
    while (my $item = readdir ITEMS) {
	# guaranteed evil
	next if $item =~ m/^\./;
	next if $item eq 'lost+found';
	next if $item eq 'stage.';
	next if $item eq 'sync.';
	next if $item eq 'domain'; # this is just stupid, it should at LEAST have a dot

	if ($ishash{$item}) {
	    push @subs, $item;
	}
	else {
	    add_found($type, \%found, $item, "$path/$item");
	}
    }
    closedir(ITEMS);

    foreach my $sub (@subs) {
	next unless opendir(ITEMS, "$path/$sub");
	while (my $item = readdir ITEMS) {
	    next if $item =~ m/^\./;
	    # we can't fix duplicate directories ourselves!
	    add_found($type, \%found, $item, "$path/$sub/$item");
	}
	closedir(ITEMS);
    }

    return %found;
}

sub do_moves {
    my $path = shift;
    my $isspool = shift;
    my $skiptochar = shift;
    my %found = @_;

    foreach my $item (sort keys %found) {
	my $src = $found{$item};
	my $dst = hash_path($path, $item, $isspool, $skiptochar);

	if ($src ne $dst) {
	    ensure_parent($dst);
	    print "rename $src to $dst: " if $OPT_Verbose;
	    if ($OPT_NoAction) {
		print "skipped\n" if $OPT_Verbose;
		next;
	    }
	    rename($src, $dst) or die "failed to rename $src to $dst";
	    print "done\n" if $OPT_Verbose;
	}
    }
}

sub move_domains {
    my $path = shift;
    my $type_of_move = shift || die "move_domains called badly";
    my $isspool = ($type_of_move eq 'part');

    my %found = find_items($path, 'domain');

    # let's do the subdirs first, then move the top levels
    foreach my $item (sort keys %found) {
	if ($type_of_move eq 'conf') {
	    if (-d "$found{$item}/quota") {
		move_quotas("$found{$item}/quota");
	    }
	    if (-d "$found{$item}/user") {
		move_users("$found{$item}/user");
	    }
	} elsif ($type_of_move eq 'sieve') {
	    move_sieve($found{$item}, 1);
	} elsif ($type_of_move eq 'part') {
	    move_part($found{$item}, 1);
	} else {
	    die "bad domain move mode: $type_of_move";
	}
    }

    do_moves($path, $isspool, undef, %found);
    tidy_up($path, $isspool, 0);
}

sub move_users {
    my $path = shift;

    my %found = find_items($path, 'user');
    do_moves($path, 0, undef, %found);
    tidy_up($path, 0, 0);
}

sub move_quotas {
    my $path = shift;

    my %found = find_items($path, 'quota');
    do_moves($path, 0, '.', %found);
    tidy_up($path, 0, 0);
}

sub move_sieve {
    my $path = shift;
    my $indomain = shift;

    my %found = find_items($path, 'sieve');

    if ($virtdomains and not $indomain) {
	ensure_dir("$path/domain");
	move_domains("$path/domain", 'sieve');
    }

    do_moves($path, 0, undef, %found);
    tidy_up($path, 0, 0);
}

# could be data or meta
sub move_part {
    my $path = shift;
    my $indomain = shift;

    # let's just assume nobody is being stupid and creating 1 character toplevel names
    my %found = find_items($path, 'part');

    if ($virtdomains and not $indomain) {
	ensure_dir("$path/domain");
	move_domains("$path/domain", 'part');
    }

    do_moves($path, 1, '/', %found);
    tidy_up($path, 1, 1);
}

sub ensure_dir {
    my $dir = shift;
    unless (-d $dir) {
	ensure_parent($dir);
	print "mkdir $dir: " if $OPT_Verbose;
	if ($OPT_NoAction) {
	    print "skipped\n" if $OPT_Verbose;
	    return;
	}
	mkdir($dir, 0755) || die "Failed to create $dir: $!";
	print "done\n" if $OPT_Verbose;
    }
    return 1;
}

sub ensure_parent {
    my $path = shift;
    $path =~ s{/[^/]+$}{};
    return ensure_dir($path);
}

sub remove_dir {
    my $dir = shift;
    return 1 unless -d $dir;
    print "rmdir $dir: " if $OPT_Verbose;
    if ($OPT_NoAction) {
	print "skipped\n" if $OPT_Verbose;
	return;
    }
    if (opendir(DH, $dir)) {
	my @extra;
	while (my $item = readdir(DH)) {
	    next if $item eq '.';
	    next if $item eq '..';
	    push @extra, $item;
	}
	closedir(DH);
	if (@extra) {
	    my $num = @extra;
	    my $s = $num == 1 ? '' : 's';
	    print "skipped, $num extra item$s found, including $dir/$extra[0]\n";
	    return;
	}
    }
    rmdir($dir) || die "Failed to remove $dir: $!";
    print "done\n" if $OPT_Verbose;
    return 1;
}

sub tidydir {
    my $dir = shift;
    my $onemore = shift;

    if ($onemore) {
	if (opendir(DIR, $dir)) {
	    while (my $item = readdir DIR) {
		next if $item =~ m/^\./;
		remove_dir("$dir/$item");
	    }
	    closedir(DIR);
	}
    }

    remove_dir($dir);
}

sub tidy_up {
    my $path = shift;
    my $isspool = shift;
    my $onemore = shift;


    unless (not $fulldirhash and (not $isspool or $hashimapspool)) {
	tidydir("$path/$_", $onemore) for @bdirs;
    }
    unless ($fulldirhash and (not $isspool or $hashimapspool)) {
	tidydir("$path/$_", $onemore) for @fdirs;
    }
}