view release on metacpan or  search on metacpan

lib/CallBackery/Config.pm  view on Meta::CPAN

sub instantiatePlugin {
    my $self = shift;
    my @args = @_;
    my $obj = $self->_getPluginObject(@args);
    my $name = $obj->name;
    die mkerror(39944,"No permission to access $name")
        if not $self->promiseDeath($obj->checkAccess);
    return $obj;
}

=head2 $configBlob = $cfg->getConfigBlob()

return the configuration state of the system as a blob

The blob is encrypted with AES-256 and authenticated with HMAC-SHA256,
both keyed from the password with PBKDF2 and a random salt. Releases
before this format cannot restore it.

=cut

has configPlugins => sub {
    my $self = shift;
    my $user = $self->app->userObject->new(app=>$self->app,userId=>'__CONFIG', log=>$self->log);
    my $cfg = $self->cfgHash;
    my @plugins;
    for my $name (@{$cfg->{PLUGIN}{list}}){
        my $obj = eval {
            $self->instantiatePlugin($name,$user);
        } or next;
        push @plugins, $obj;
    }
    return \@plugins;
};

sub getCrypt {
    require Crypt::Rijndael;
    my $self = shift;
    my $password = substr((shift || '').('x' x 32),0,32);
    return Crypt::Rijndael->new( $password,Crypt::Rijndael::MODE_CBC() );
}

sub pack16 {
    my $self = shift;
    my $string = shift;
    my $len = length($string);
    my $mod = 16 - ($len % 16);
    return sprintf("%016x%s",$len,$string.('x' x $mod));
}

sub unpack16 {
    my $self = shift;
    my $string = shift;
    my $len = substr($string,0,16);
    if ( $len !~ /^[0-9a-f]{16}$/ or hex($len) > length($string)-16 ){
        die mkerror(3844,trm("Wrong password!"));
    }
    return substr($string,16,hex($len));
}

# PBKDF2-HMAC-SHA256 rounds for the backup key; part of the CBK2 format
my $BLOB_KDF_ROUNDS = 100_000;

sub _randomBytes ($self,$n) {
    open my $fh, '<:raw', '/dev/urandom';
    read($fh, my $bytes, $n) == $n or croak "short read from /dev/urandom";
    return $bytes;
}

sub _blobKeys ($self,$password,$salt) {
    $password = encode('UTF-8',$password // '');
    my $u = my $key = hmac_sha256($salt.pack('N',1),$password);
    for (2..$BLOB_KDF_ROUNDS) {
        $u = hmac_sha256($u,$password);
        $key ^= $u;
    }
    return (hmac_sha256('encrypt',$key), hmac_sha256('authenticate',$key));
}

sub getConfigBlob {
    my $self = shift;
    my $password = shift;
    require Archive::Zip;

    my $zip = Archive::Zip->new();
    my $cfg = $self->cfgHash;
    # read the dump from a pipe; a file in /tmp would leave the secrets behind
    open my $dump, '-|','/usr/bin/sqlite3',$cfg->{BACKEND}{cfg_db},'.dump';
    my $sql = do { local $/; <$dump> };
    close $dump;
    $zip->addString($sql,'{DATABASEDUMP}')
        ->desiredCompressionMethod(Archive::Zip::COMPRESSION_DEFLATED());
    for my $obj (@{$self->configPlugins}){
        my $name = $obj->name;
        for my $file (@{$obj->stateFiles}) {
            if (-r $file){
                $zip->addFile({
                    filename => $file,
                    zipName => '{PLUGINSTATE.'.$name.'}'.$file
                })
            }
        }
    }
    my $zipData;
    open(my $fh, ">", \$zipData);
    $zip->writeToFileHandle($fh,0);

    require Crypt::Rijndael;
    my $salt = $self->_randomBytes(16);
    my $iv = $self->_randomBytes(16);
    my ($encKey,$macKey) = $self->_blobKeys($password,$salt);
    my $crypt = Crypt::Rijndael->new($encKey,Crypt::Rijndael::MODE_CBC());
    $crypt->set_iv($iv);
    my $blob = 'CBK2'.$salt.$iv.$crypt->encrypt($self->pack16($zipData));
    return $blob.hmac_sha256($blob,$macKey);
}

# how long to keep trying when someone else holds a lock on the config
# database; package scoped so that tests can shorten it
our $RESTORE_BUSY_TIMEOUT_MS = 30_000;

# Build a replacement config database with $builder and then copy it over the
# live one with SQLite's online backup API, so that the database keeps its
# inode.
#
# Replacing the file instead (the way this used to work) leaves every long
# lived handle in the system attached to the old, now unlinked inode: the
# config daemon and its workers, the application server, and any helper that
# happens to be running at the time. Those handles go on reading stale
# configuration and fail on their first write with SQLITE_READONLY_DBMOVED,
# which SQLite reports as "attempt to write a readonly database".
#
# The staging database lives next to the config database rather than in a
# world readable temp directory, since it holds the same secrets, and on the
# same filesystem, so it does not compete for space with anything else.
sub _stageAndRestoreDb ($self,$builder) {
    my $cfgDb = $self->cfgHash->{BACKEND}{cfg_db};
    my $staging = $cfgDb.'.restore.'.$$;
    my $err;
    eval {
        # unlink glob, not plain unlink: a leftover journal of our own would
        # otherwise be rolled back into the staging database
        no autodie;
        unlink glob $staging.'*';
        use autodie;
        $builder->($staging);
        chmod 0600, $staging;
        my $dbh = DBI->connect("dbi:SQLite:dbname=$cfgDb",'','',{
            RaiseError => 1,
            PrintError => 0,
            AutoCommit => 1,
        });
        # the backup runs the destination's busy handler while it waits for
        # the write lock; on top of that we retry, because a backup that
        # starts while another connection sits in a read transaction gives up
        # rather than waiting
        $dbh->sqlite_busy_timeout($RESTORE_BUSY_TIMEOUT_MS);
        my $deadline = Time::HiRes::time() + $RESTORE_BUSY_TIMEOUT_MS / 1000;
        my ($busy,$tries) = (undef,0);
        while (1) {
            $busy = undef;
            last if eval { $dbh->sqlite_backup_from_file($staging) };
            $busy = $@ || $dbh->errstr || 'unknown error';
            last if Time::HiRes::time() >= $deadline;
            # first attempt and then roughly every five seconds, so that a
            # long wait is visible without a log line per retry
            $self->log->warn("Config database busy, retrying restore: $busy")
                if $tries++ % 50 == 0;
            Time::HiRes::sleep(0.1);
        }
        $dbh->disconnect;
        # giving up here is safe: the live database has not been touched, so
        # this degrades to a clean error rather than a half restored config
        die mkerror(3845,trm("Could not restore the configuration database: %1",$busy))
            if $busy;
        1;
    } or $err = $@;
    no autodie;
    unlink glob $staging.'*';
    die $err if $err;
    return;
}

# DBD::SQLite registers an FTS3/FTS4 tokenizer called "perl" on every
# connection; a table using it calls the Perl sub named in its definition
# whenever the table is used. A restored schema must not name it.
sub _refusePerlTokenizer ($self,$dbh) {
    my $schema = $dbh->selectcol_arrayref(q{SELECT sql FROM sqlite_master WHERE sql IS NOT NULL});
    die mkerror(3846,trm("The backup contains a table with a Perl tokenizer"))
        if grep { /tokeni[sz]e\W*perl/i } @$schema;
    return;
}

=head2 $cfg->restoreConfigBlob(configBlob)

retore the confguration state

A blob in the format used before CBK2 has no authentication; it is still
restored, with a warning, and should be replaced by a new backup.

=cut

sub restoreConfigBlob {
    my $self = shift;
    my $config = shift;
    my $password = shift;
    require Archive::Zip;
    if ($config =~ /^CBK2/ and length($config) % 16 == 4) {
        require Crypt::Rijndael;
        my ($salt,$iv) = (substr($config,4,16),substr($config,20,16));
        my ($encKey,$macKey) = $self->_blobKeys($password,$salt);
        my $mac = substr($config,-32,32,'');
        die mkerror(3844,trm("Wrong password!"))
            unless secure_compare($mac,hmac_sha256($config,$macKey));
        my $crypt = Crypt::Rijndael->new($encKey,Crypt::Rijndael::MODE_CBC());
        $crypt->set_iv($iv);
        $config = $self->unpack16($crypt->decrypt(substr($config,36)));
    }
    else {
        $self->log->warn("Restoring a backup in the old, unauthenticated format; take a new backup to replace it");
        my $crypt = $self->getCrypt($password);
        $config = $self->unpack16($crypt->decrypt($config));
    }

    my $user = $self->app->userObject->new(app=>$self->app,userId=>'__CONFIG', log=>$self->log);
    open my $fh ,'<', \$config;
    my $zip = Archive::Zip->new();
    $zip->readFromFileHandle($fh);
    my %stateFileCache;
    for my $member ($zip->members){
        for ($member->fileName){
            /^\{DATABASE\}$/ && do {
                $self->log->warn("Restoring Database!");
                $self->_stageAndRestoreDb(sub ($staging) {
                    $member->extractToFileNamed($staging);
                    my $dbh = DBI->connect("dbi:SQLite:dbname=$staging",'','',{RaiseError => 1, PrintError => 0});
                    $self->_refusePerlTokenizer($dbh);
                    $dbh->disconnect;
                });
                last;
            };
            /^\{DATABASEDUMP\}$/ && do {
                $self->log->warn("Restoring Database Dump!");
                $self->_stageAndRestoreDb(sub ($staging) {
                    my $sql = $member->contents();
                    $sql =~ s/0$//; # for some reason the dump ends in 0
                    # SQL only: the sqlite3 shell would also run .shell, fsdir() etc.
                    my $dbh = DBI->connect("dbi:SQLite:dbname=$staging",'','',{
                        RaiseError => 1,
                        PrintError => 0,
                        AutoCommit => 1,
                        sqlite_allow_multiple_statements => 1,
                    });
                    # while the dump replays, "perl" is the plain tokenizer, so
                    # no Perl sub named by a table in the dump can run
                    $dbh->do(q{SELECT fts3_tokenizer('perl',fts3_tokenizer('simple'))});
                    # no ATTACH or fts3_tokenizer(); the only pragmas are the
                    # ones sqlite3 .dump writes (writable_schema adds FTS tables)
                    $dbh->sqlite_set_authorizer(sub {
                        my ($action,$arg1,$arg2) = @_;
                        return SQLITE_DENY if $action == SQLITE_ATTACH
                            or ($action == SQLITE_FUNCTION and lc($arg2 // '') eq 'fts3_tokenizer')
                            or ($action == SQLITE_PRAGMA and lc($arg1 // '') !~ /^(?:foreign_keys|writable_schema)$/);
                        return SQLITE_OK;
                    });
                    $dbh->do($sql);
                    $dbh->sqlite_set_authorizer(undef);
                    $self->_refusePerlTokenizer($dbh);
                    $dbh->disconnect;
                });
                last;
            };
            m/^\{PLUGINSTATE\.([^.]+)\}(.+)/ && do {
                my $plugin = $1;
                my $file = $2;
                if (not $stateFileCache{$plugin}){
                    my $obj = eval {
                         $self->instantiatePlugin($plugin,$user);
                    };
                    if (not $obj){