path: root/ldap/admin/src/scripts/DSMigration.pm.in

# BEGIN COPYRIGHT BLOCK
# This Program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; version 2 of the License.
# 
# This Program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License along with
# this Program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# 
# In addition, as a special exception, Red Hat, Inc. gives You the additional
# right to link the code of this Program with code not covered under the GNU
# General Public License ("Non-GPL Code") and to distribute linked combinations
# including the two, subject to the limitations in this paragraph. Non-GPL Code
# permitted under this exception must only link to the code of this Program
# through those well defined interfaces identified in the file named EXCEPTION
# found in the source code files (the "Approved Interfaces"). The files of
# Non-GPL Code may instantiate templates or use macros or inline functions from
# the Approved Interfaces without causing the resulting work to be covered by
# the GNU General Public License. Only Red Hat, Inc. may make changes or
# additions to the list of Approved Interfaces. You must obey the GNU General
# Public License in all respects for all of the Program code and other code used
# in conjunction with the Program except the Non-GPL Code covered by this
# exception. If you modify this file, you may extend this exception to your
# version of the file, but you are not obligated to do so. If you do not wish to
# provide this exception without modification, you must delete this exception
# statement from your version and license this file solely under the GPL without
# exception. 
# 
# 
# Copyright (C) 2007 Red Hat, Inc.
# All rights reserved.
# END COPYRIGHT BLOCK
#

###########################
#
# This perl module provides a way to set up a new installation after
# the binaries have already been extracted.  This is typically after
# using native packaging support to install the package e.g. RPM,
# pkgadd, depot, etc.  This script will show the license, readme,
# dsktune, then run the usual setup pre and post installers.
#
##########################

package DSMigration;
use Migration;
use Util;
use Inf;

# tempfiles
use File::Temp qw(tempfile tempdir);
use File::Basename qw(basename);

# load perldap
use Mozilla::LDAP::Conn;
use Mozilla::LDAP::Utils qw(normalizeDN);
use Mozilla::LDAP::API qw(ldap_explode_dn);
use Mozilla::LDAP::LDIF;

use Exporter;
@ISA       = qw(Exporter);
@EXPORT    = qw(migrateDS);
@EXPORT_OK = qw(migrateDS);

use strict;

use SetupLog;
use Util;

# these are the attributes for which we will always use
# the new value, or which do not apply anymore
my %ignoreOld =
(
 'nsslapd-errorlog'                => 'nsslapd-errorlog',
 'nsslapd-accesslog'               => 'nsslapd-accesslog',
 'nsslapd-auditlog'                => 'nsslapd-auditlog',
 'nskeyfile'                       => 'nsKeyfile',
 'nscertfile'                      => 'nsCertfile',
 'nsslapd-pluginpath'              => 'nsslapd-pluginPath',
 'nsslapd-plugintype'              => 'nsslapd-pluginType',
 'nsslapd-pluginversion'           => 'nsslapd-pluginVersion',
 'nsslapd-plugin-depends-on-named' => 'nsslapd-plugin-depends-on-named',
# these are new attrs that we should just pass through
 'nsslapd-schemadir'               => 'nsslapd-schemadir',
 'nsslapd-lockdir'                 => 'nsslapd-lockdir',
 'nsslapd-tmpdir'                  => 'nsslapd-tmpdir',
 'nsslapd-certdir'                 => 'nsslapd-certdir',
 'nsslapd-ldifdir'                 => 'nsslapd-ldifdir',
 'nsslapd-bakdir'                  => 'nsslapd-bakdir',
 'nsslapd-ldapifilepath'           => 'nsslapd-ldapifilepath',
 'nsslapd-ldapilisten'             => 'nsslapd-ldapilisten',
 'nsslapd-ldapiautobind'           => 'nsslapd-ldapiautobind',
 'nsslapd-ldapimaprootdn'          => 'nsslapd-ldapimaprootdn',
 'nsslapd-ldapimaptoentries'       => 'nsslapd-ldapimaptoentries',
 'nsslapd-ldapiuidnumbertype'      => 'nsslapd-ldapiuidnumbertype',
 'nsslapd-ldapigidnumbertype'      => 'nsslapd-ldapigidnumbertype',
 'nsslapd-ldapientrysearchbase'    => 'nsslapd-ldapientrysearchbase',
 'nsslapd-ldapiautodnsuffix'       => 'nsslapd-ldapiautodnsuffix'
);

# these are the attributes for which we will always use
# the old value
my %alwaysUseOld =
(
 'aci'      => 'aci'
);

sub getNewDbDir {
    my ($ent, $attr, $mig, $inst) = @_;
    my %objclasses = map { lc($_) => $_ } $ent->getValues('objectclass');
    my $cn = $ent->getValues('cn');
    my $oldval = $ent->getValues($attr);
    my $newval;
    # there is one case where we want to just use the existing db directory
    # that's the case where the user has moved the indexes and/or the
    # transaction logs to different partitions for performance
    # in that case, the old directory will not be the same as the default,
    # and the directory will exist
    my $olddefault = "$mig->{actualsroot}/$inst";
    if (-d $oldval and ($oldval !~ /^$olddefault/)) {
        debug(2, "Keeping old value [$oldval] for attr $attr in entry ", $ent->getDN(), "\n");
        return $oldval;
    }
    # otherwise, just use the new default locations
    if ($objclasses{nsbackendinstance}) {
        $newval = "@localstatedir@/lib/$mig->{pkgname}/$inst/db/$cn";
    } elsif (lc $cn eq 'config') {
        $newval = "@localstatedir@/lib/$mig->{pkgname}/$inst/db";
    } elsif (lc $cn eq 'changelog5') {
        $newval = "@localstatedir@/lib/$mig->{pkgname}/$inst/changelogdb";
    }
    debug(2, "New value [$newval] for attr $attr in entry ", $ent->getDN(), "\n");
    return $newval;
}

sub migrateCredentials {
    my ($ent, $attr, $mig, $inst) = @_;
    my $oldval = $ent->getValues($attr);
    debug(3, "Executing migratecred -o $mig->{actualsroot}/$inst -n @instconfigdir@/$inst -c $oldval . . .\n");
    my $newval = `migratecred -o $mig->{actualsroot}/$inst -n @instconfigdir@/$inst -c $oldval`;
    debug(3, "Converted old value [$oldval] to new value [$newval] for attr $attr in entry ", $ent->getDN(), "\n");
    return $newval;
}

sub removensState {
    my ($ent, $attr, $mig, $inst) = @_;
    my $newval;

    # nsstate is binary and cannot be migrated cross platform
    if (!$mig->{crossplatform}) {
        $newval = $ent->getValues($attr);
    }

    return $newval;
}

# these are attributes that we have to transform from
# the old value to the new value (e.g. a pathname)
# The key of this hash is the attribute name.  The value
# is an anonymous sub which takes two arguments - the entry
# and the old value.  The return value of the sub is
# the new value
my %transformAttr =
(
 'nsslapd-directory' => \&getNewDbDir,
 'nsslapd-db-logdirectory' => \&getNewDbDir,
 'nsslapd-changelogdir' => \&getNewDbDir,
 'nsds5replicacredentials' => \&migrateCredentials,
 'nsmultiplexorcredentials' => \&migrateCredentials,
 'nsstate' => \&removensState
);

sub copyDatabaseDirs {
    my $srcdir = shift;
    my $destdir = shift;
    my $filesonly = shift;
    if (-d $srcdir && ! -d $destdir && !$filesonly) {
        debug(1, "Copying database directory $srcdir to $destdir\n");
        if (system ("cp -p -r $srcdir $destdir")) {
            return ('error_copying_dbdir', $srcdir, $destdir, $?);
        }
    } elsif (! -d $srcdir) {
        return ("error_dbsrcdir_not_exist", $srcdir);
    } else {
        debug(1, "The destination directory $destdir already exists, copying files/dirs individually\n");
        foreach my $file (glob("$srcdir/*")) {
            debug(3, "Copying $file to $destdir\n");
            if (-f $file) {
                if (system ("cp -p $file $destdir")) {
                    return ('error_copying_dbfile', $file, $destdir, $?);
                }
            } elsif (-d $file && !$filesonly) {
                if (system ("cp -p -r $file $destdir")) {
                    return ('error_copying_dbdir', $file, $destdir, $?);
                }
            }
        }
    }
}

# migrate all of the databases in an instance
sub migrateDatabases {
    my $mig = shift; # the Migration object
    my $inst = shift; # the instance name (e.g. slapd-instance)
    my $src = shift; # a Conn to the source
    my $dest = shift; # a Conn to the dest
    my $olddefault = "$mig->{actualsroot}/$inst/db"; # old default db home directory
    my @errs;

    # first, look for an LDIF file in that directory with the same name as the
    # database
    my $foundldif;
    for (glob("$mig->{oldsroot}/$inst/db/*.ldif")) {
        my $dbname = basename($_, '.ldif');
        my @cmd = ("@serverdir@/$inst/ldif2db", "-n", $dbname, "-i", $_);
        debug(1, "migrateDatabases: executing command ", @cmd);
        if (system(@cmd)) {
            return ('error_importing_migrated_db', $_, $?);
        }
        $foundldif = 1;
    }

    if ($foundldif) {
        return (); # done - can do nothing else for cross-platform
    }

    # if no LDIF files, just copy over the database directories
    my $ent = $src->search("cn=ldbm database,cn=plugins,cn=config", "one",
                           "(objectclass=*)");
    if (!$ent) {
        return ("error_reading_olddbconfig", $src->getErrorString());
    }
    # there is one case where we want to just use the existing db directory
    # that's the case where the user has moved the indexes and/or the
    # transaction logs to different partitions for performance
    # in that case, the old directory will not be the same as the default,
    # and the directory will exist
    my $olddefault = "$mig->{actualsroot}/$inst";
    do {
        my $cn = $ent->getValues('cn');
        my %objclasses = map { lc($_) => $_ } $ent->getValues('objectclass');
        if ($cn eq 'config') { # global config
            my $newent = $dest->search($ent->getDN(), "base", "(objectclass=*)");
            my $newdbdir = $newent->getValues('nsslapd-directory') ||
                "@localstatedir@/lib/$mig->{pkgname}/$inst/db";
            debug(1, "Found ldbm database plugin config entry ", $ent->getDN(), "\n");
            my $dir = $ent->getValues('nsslapd-directory');
            my $homedir = $ent->getValues('nsslapd-db-home-directory');
            my $logdir = $ent->getValues('nsslapd-db-logdirectory');
            debug(1, "old db dir = $dir homedir = $homedir logdir = $logdir\n");
            my $srcdir = $homedir || $dir || "$olddefault/db";
            if (-d $srcdir and ($srcdir !~ /^$olddefault/)) {
                debug(2, "Not copying database files from [$srcdir]\n");
            } else {
                # replace the old sroot value with the actual physical location on the target/dest
                $srcdir =~ s/^$mig->{actualsroot}/$mig->{oldsroot}/;
                if (@errs = copyDatabaseDirs($srcdir, $newdbdir, 1)) {
                    return @errs;
                }
            }
            if ($logdir && ($logdir ne $srcdir)) {
                if (-d $logdir and ($logdir !~ /^$olddefault/)) {
                    debug(2, "Not copying transaction logs from [$logdir]\n");
                } else {
                    # replace the old sroot value with the actual physical location on the target/dest
                    $newdbdir = $newent->getValues('nsslapd-db-logdirectory') ||
                        $newdbdir;
                    $logdir =~ s/^$mig->{actualsroot}/$mig->{oldsroot}/;
                    if (@errs = copyDatabaseDirs($logdir, $newdbdir, 1)) {
                        return @errs;
                    }
                }
            }
        } elsif ($objclasses{nsbackendinstance}) {
            debug(1, "Found ldbm database instance entry ", $ent->getDN(), "\n");
            my $dir = $ent->getValues('nsslapd-directory');
            # the default db instance directory is
            # $oldroot/$inst/$cn
            debug(1, "old instance $cn dbdir $dir\n");
            my $srcdir = $dir || "$olddefault/db/$cn";
            my $newent = $dest->search($ent->getDN(), "base", "(objectclass=*)");
            my $newdbdir = $newent->getValues('nsslapd-directory') ||
                "@localstatedir@/lib/$mig->{pkgname}/$inst/db";
            if (-d $srcdir and ($srcdir !~ /^$olddefault/)) {
                debug(2, "Not copying database indexes from [$srcdir]\n");
            } else {
                # replace the old sroot value with the actual physical location on the target/dest
                $srcdir =~ s/^$mig->{actualsroot}/$mig->{oldsroot}/;
                if (@errs = copyDatabaseDirs($srcdir, "$newdbdir/$cn")) {
                    return @errs;
                }
            }
        }
    } while ($ent = $src->nextEntry());

    return ();
}

sub migrateChangelogs {
    my $mig = shift; # the Migration object
    my $inst = shift; # the instance name (e.g. slapd-instance)
    my $src = shift; # a Conn to the source
    my $dest = shift; # a Conn to the dest
    my $olddefault = "$mig->{actualsroot}/$inst"; # old default db home directory
    # changelog config entry
    my $oldent = $src->search("cn=changelog5, cn=config", "base", "(objectclass=*)");
    my $newent = $dest->search("cn=changelog5, cn=config", "base", "(objectclass=*)");
    if ($oldent and $newent) { # changelog configured
        my $oldcldir = $oldent->getValues('nsslapd-changelogdir');
        if (-d $oldcldir and ($oldcldir !~ /^$olddefault/)) {
            debug(2, "Not copying changelogdb from [$oldcldir]\n");
        } else {
            # replace the old sroot value with the actual physical location on the target/dest
            $oldcldir =~ s/^$mig->{actualsroot}/$mig->{oldsroot}/;
            my $newcldir = $newent->getValues('nsslapd-changelogdir');
            copyDatabaseDirs($oldcldir, $newcldir);
        }
    }
}

sub fixAttrsInEntry {
    my ($ent, $mig, $inst) = @_;
    for my $attr (keys %{$ent}) {
        my $lcattr = lc $attr;
        if ($transformAttr{$lcattr}) {
            $ent->setValues($attr, &{$transformAttr{$lcattr}}($ent, $attr, $mig, $inst));
        }
    }
}

sub mergeEntries {
    my ($old, $new, $mig, $inst) = @_;
    my %inoldonly; # attrs in old entry but not new one
    my %innewonly; # attrs in new entry but not old one
    my @attrs; # attrs common to old and new
    # if the attribute exists in the old entry but not the new one
    # we should probably add it (checking for special cases first)
    # if the attribute exists in the new entry but not the old one
    # we might have to delete it from the new entry
    # first, get a list of all attributes
    foreach my $attr (keys %{$old}) {
        if (! $new->exists($attr)) {
            $inoldonly{$attr} = $attr;
        } else {
            push @attrs, $attr;
        }
    }
    foreach my $attr (keys %{$new}) {
        if (! $old->exists($attr)) {
            $innewonly{$attr} = $attr;
        }
    }
            
    # iterate through the attr lists
    my $cn = lc $new->getValues("cn");
    foreach my $attr (keys %inoldonly, keys %innewonly, @attrs) {
        my $lcattr = lc $attr;
        if ($ignoreOld{$lcattr}) {
            next; # use new value or just omit if attr is obsolete
        } elsif ($transformAttr{$lcattr}) {
            # only transform if the value is in the old entry
            if (!$innewonly{$attr}) {
                $new->setValues($attr, &{$transformAttr{$lcattr}}($old, $attr, $mig, $inst));
            }
        } elsif ($cn eq "internationalization plugin" and $lcattr eq "nsslapd-pluginarg0") {
            next; # use the new value of this path name
        } elsif ($cn eq "referential integrity postoperation" and $lcattr eq "nsslapd-pluginarg1") {
            next; # use the new value of this path name
        } elsif ($innewonly{$attr}) {
            $new->remove($attr); # in new but not old - just remove it
        } else {
            $new->setValues($attr, $old->getValues($attr)); # use old value
        }
    }
}


my @allattrlist = ('*', 'aci', 'createTimestamp', 'creatorsName',
                   'modifyTimestamp', 'modifiersName');

sub getAllEntries {
    my $conn = shift;
    my $href = shift;
    my $aref = shift;

    # these are the special DSEs for which we only need ACIs
    for my $dn ("", "cn=monitor", "cn=config") {
        my $scope = $dn ? "sub" : "base";
        my @attrlist;
        if ($dn eq "cn=config") {
            @attrlist = @allattrlist;
        } else {
            @attrlist = qw(aci);
        }
        my $ent = $conn->search($dn, $scope, "(objectclass=*)", 0, @attrlist);
        next if (!$ent or ($conn->getErrorCode() eq 32));
        if ($conn->getErrorCode()) {
            return ('error_reading_entry', $dn, $conn->getErrorString());
        }
        do {
            my $ndn = normalizeDN($ent->getDN());
            $href->{$ndn} = $ent;
            push @{$aref}, $ndn;
        } while ($ent = $conn->nextEntry());
    }

    return ();
}

# these entries cannot be migrated if doing cross platform
my %noCrossPlatformDN = (
    'cn=uniqueid generator,cn=config' => 'cn=uniqueid generator,cn=config'
);

sub mergeConfigEntries {
    my $mig = shift; # the Migration object
    my $inst = shift; # the instance name (e.g. slapd-instance)
    my $src = shift; # a Conn to the source
    my $dest = shift; # a Conn to the dest

    # first, read in old file
    my %olddse; # map of normalized DN to Entry
    my @olddns; # the DNs in their original order
    my @errs;
    if (@errs = getAllEntries($src, \%olddse, \@olddns)) {
        return @errs;
    }

    # next, read in new file
    my %newdse; # map of normalized DN to Entry
    my @allnewdns;
    my @newdns; # the DNs in their original order that are not in olddns
    if (@errs = getAllEntries($dest, \%newdse, \@allnewdns)) {
        return @errs;
    }

    for my $ndn (@allnewdns) {
        if (! exists $olddse{$ndn}) {
            push @newdns, $ndn;
        }
    }

    # now, compare entries
    # if the entry exists in the old tree but not the new, add it
    # if the entry exists in the new tree but not the old, delete it
    # otherwise, merge the entries
    # @olddns contains the dns in the old dse.ldif, including ones that
    # may also be in the new dse.ldif
    # @newdns contains dns that are only in the new dse.ldif
    for my $dn (@olddns, @newdns) {
        my $oldent = $olddse{$dn};
        my $newent = $newdse{$dn};
        my $op;
        my $rc = 1;
        if ($mig->{crossplatform} && $noCrossPlatformDN{$dn}) {
            debug(1, "Cannot migrate the entry $dn - skipping\n");
            next;
        } elsif ($oldent && !$newent) {
            # may have to fix up some values in the old entry
            fixAttrsInEntry($oldent, $mig, $inst);
            $rc = $dest->add($oldent);
            $op = "add";
        } elsif (!$oldent && $newent) {
            if ($dn =~ /o=deleteAfterMigration/i) {
                $rc = $dest->delete($dn);
                $op = "delete";
            } else {
                # do nothing - no change to entry
            }
        } else { #merge
            # $newent will contain the merged entry
            mergeEntries($oldent, $newent, $mig, $inst);
            $rc = $dest->update($newent);
            $op = "update";
        }
        
        if (!$rc) {
            return ('error_updating_merge_entry', $op, $dn, $dest->getErrorString());
        }
    }

    return ();
}

my %deletedschema = (
    '50ns-calendar'        => '50ns-calendar.ldif',
    '50ns-compass'         => '50ns-compass.ldif',
    '50ns-delegated-admin' => '50ns-delegated-admin.ldif',
    '50ns-legacy'          => '50ns-legacy.ldif',
    '50ns-mail'            => '50ns-mail.ldif',
    '50ns-mcd-browser'     => '50ns-mcd-browser.ldif',
    '50ns-mcd-config'      => '50ns-mcd-config.ldif',
    '50ns-mcd-li'          => '50ns-mcd-li.ldif',
    '50ns-mcd-mail'        => '50ns-mcd-mail.ldif',
    '50ns-media'           => '50ns-media.ldif',
    '50ns-mlm'             => '50ns-mlm.ldif',
    '50ns-msg'             => '50ns-msg.ldif',
    '50ns-netshare'        => '50ns-netshare.ldif',
    '50ns-news'            => '50ns-news.ldif',
    '50ns-proxy'           => '50ns-proxy.ldif',
    '50ns-wcal'            => '50ns-wcal.ldif',
    '51ns-calendar'        => '51ns-calendar.ldif'
);

sub migrateSchema {
    my $mig = shift; # the Migration object
    my $inst = shift; # the instance name (e.g. slapd-instance)
    my $src = shift; # a Conn to the source
    my $dest = shift; # a Conn to the dest

    my $cfgent = $dest->search("cn=config", "base", "(objectclass=*)");
    my $newschemadir = $cfgent->getValues('nsslapd-schemadir') ||
        "$mig->{configdir}/$inst/schema";
    my %newschema = map {basename($_, '.ldif') => $_} glob("$newschemadir/*.ldif");
    delete $newschema{"99user"}; # always copy this one
    for (glob("$mig->{oldsroot}/$inst/config/schema/*.ldif")) {
        my $fname = basename($_, '.ldif');
        next if ($deletedschema{$fname}); # don't copy deleted schema
        next if ($newschema{$fname}); # use new version
        if (system("cp -p $_ $newschemadir")) {
            return ("error_migrating_schema", $_, $!);
        }
    }

    return ();
}

sub migrateDSInstance {
    my $mig = shift; # the Migration object
    my $inst = shift; # the instance name (e.g. slapd-instance)
    my $src = shift; # a Conn to the source
    my $dest = shift; # a Conn to the dest

    my @errs;
    # first, merge dse ldif
    if (@errs = mergeConfigEntries($mig, $inst, $src, $dest)) {
        return @errs;
    }

    # next, grab the old schema
    if (@errs = migrateSchema($mig, $inst, $src, $dest)) {
        return @errs;
    }

    # next, the databases
    if (@errs = migrateDatabases($mig, $inst, $src, $dest)) {
        return @errs;
    }

    # next, the changelogs
    if (!$mig->{crossplatform}) {
        if (@errs = migrateChangelogs($mig, $inst, $src, $dest)) {
            return @errs;
        }
    }

    # next, the security files
    my $cfgent = $dest->search("cn=config", "base", "(objectclass=*)");
    my $newcertdir = $cfgent->getValues("nsslapd-certdir") ||
        "@instconfigdir@/$inst";
    $mig->migrateSecurityFiles($inst, $newcertdir);

    return @errs;
}

sub migrateDS {
    my $mig = shift;
    my @errs;

    # for each instance
    foreach my $inst (@{$mig->{instances}}) {
        if (-f "$mig->{configdir}/$inst/dse.ldif") {
            $mig->msg($WARN, 'instance_already_exists', "$mig->{configdir}/$inst/dse.ldif");
            next;
        }

        # you could theoretically make this work with either a remote source or
        # remote dest
        # $mig->{inf} would contain an entry for each instance e.g.
        # $mig->{inf}->{$inst}
        # each instance specific entry would contain a {General} and a {slapd}
        # all the information necessary to open an LDAP::Conn to the server
        # if the source, you could also change createInfFromConfig to read
        # the info from the Conn (or FileConn) that's needed to create the
        # instance on the dest

        # extract the information needed for ds_newinst.pl
        my $oldconfigdir = "$mig->{oldsroot}/$inst/config";
        my $inf = createInfFromConfig($oldconfigdir, $inst, \@errs);
        debug(2, "Using inffile $inf->{filename} created from $oldconfigdir\n");
        if (@errs) {
            $mig->msg(@errs);
            return 0;
        }

        # create the new instance
        my ($rc, $output) = createDSInstance($inf, \@errs);
        unlink($inf->{filename});
        if ($rc) {
            $mig->msg(@errs);
            $mig->msg($FATAL, 'error_creating_dsinstance', $rc, $output);
            return 0;
        } else {
            $mig->msg('created_dsinstance', $output);
        }

        my $src = new FileConn("$oldconfigdir/dse.ldif", 1); # read-only
        my $dest = new FileConn("$mig->{configdir}/$inst/dse.ldif");

        @errs = migrateDSInstance($mig, $inst, $src, $dest);
        $src->close();
        $dest->close();
        if (@errs) {
            $mig->msg(@errs);
            return 0;
        }
    }

    return 1;
}

#############################################################################
# Mandatory TRUE return value.
#
1;