File Coverage

blib/lib/Games/Lacuna/Task/Storage.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package Games::Lacuna::Task::Storage;

use 5.010;
our $VERSION = $Games::Lacuna::Task::VERSION;

use Moose;
with qw(Games::Lacuna::Task::Role::Logger);

use Games::Lacuna::Task;

use DBI;
use Digest::MD5 qw(md5_hex);
use JSON qw();

our %LOCAL_CACHE;
our $JSON = JSON->new->pretty(0)->utf8(1)->indent(0);

has 'file' => (
    is              => 'ro',
    isa             => 'Path::Class::File',
    required        => 1,
    coerce          => 1,
);

has 'current_version' => (
    is              => 'rw',
    isa             => 'Num',
    lazy_build      => 1,
    required        => 1,
);

has 'latest_version' => (
    is              => 'ro',
    isa             => 'Num',
    default         => $Games::Lacuna::Task::VERSION,
    required        => 1,
);

has 'dbh' => (
    is              => 'ro',
    isa             => 'DBI::db',
    lazy_build      => 1,
);

sub _build_current_version {
    my ($self) = @_;

    my ($current_version) = $self->dbh->selectrow_array('SELECT value FROM meta WHERE key = ?',{},'database_version');
    $current_version ||= 2.00;
    return $current_version;
}

sub _build_dbh {
    my ($self) = @_;

    my $dbh;
    my $database_ok = 1;
    my $file = $self->file;

    # Touch database file if it does not exist
    unless (-e $file->stringify) {
        $database_ok = 0;

        $self->log('info',"Initializing storage file %s",$file->stringify);
        my $file_dir = $file->parent->stringify;
        unless (-e $file_dir) {
            mkdir($file_dir)
                or $self->abort('Could not create storage directory %s: %s',$file_dir,$!);
        }
        $file->touch
            or $self->abort('Could not create storage file %s: %s',$file->stringify,$!);
    }

    # Connect database
    {
        no warnings 'once';
        $dbh = DBI->connect("dbi:SQLite:dbname=$file","","",{ sqlite_unicode => 1 })
            or $self->abort('Could not connect to database: %s',$DBI::errstr);
    }

    # Set dbh
    $self->meta->get_attribute('dbh')->set_raw_value($self,$dbh);

    # Check database for meta table
    if ($database_ok) {
        ($database_ok) = $dbh->selectrow_array('SELECT COUNT(1) FROM sqlite_master WHERE type=? AND name = ?',{},'table','meta');
    }

    # Initialize database
    unless ($database_ok) {
        sleep 1;
        $self->initialize();

    # Upgrade existing database
    } else {
        $self->upgrade();
    }

    # Create distance function
    $dbh->func( 'distance_func', 4, \&Games::Lacuna::Task::Utils::distance, "create_function" );

    return $dbh;
}

sub initialize {
    my ($self) = @_;

    $self->log('info',"Initializing storage tables in %s",$self->file->stringify);

    my $dbh = $self->dbh;
    my $data_fh = *DATA;

    my $sql = '';
    while (my $line = <$data_fh>) {
        $sql .= $line;
        if ($sql =~ m/;/) {
            $dbh->do($sql)
                or $self->abort('Could not excecute sql %s: %s',$sql,$dbh->errstr);
            undef $sql;
        }
    }
    close DATA;

    # Set version
    $self->current_version($self->latest_version);
    $dbh->do('INSERT INTO meta (key,value) VALUES (?,?)',{},'database_version',$self->current_version);
}

sub upgrade {
    my ($self) = @_;

    return
        if $self->current_version == $self->latest_version;

    my $dbh = $self->dbh;

    $self->log('info',"Upgrading storage from version %.2f to %.2f",$self->current_version(),$self->latest_version);

    my @sql;

    if ($self->current_version() < 2.01) {
        $self->log('debug','Upgrade for 2.00->2.01');

        push(@sql,'ALTER TABLE star RENAME TO star_old');

        push(@sql,'CREATE TABLE IF NOT EXISTS star (
                        id INTEGER NOT NULL PRIMARY KEY,
                        x INTEGER NOT NULL,
                        y INTEGER NOT NULL,
                        name TEXT NOT NULL,
                        zone TEXT NOT NULL,
                        last_checked INTEGER,
                        is_probed INTEGER,
                        is_known INTEGER
                )');

        push(@sql,'INSERT INTO star (id,x,y,name,zone,last_checked,is_probed,is_known) SELECT id,x,y,name,zone,last_checked,probed,probed FROM star_old');

        push(@sql,'DROP TABLE star_old');

        push(@sql,'DELETE FROM cache');
    }

    if ($self->current_version() < 2.02) {
        $self->log('debug','Upgrade for 2.01->2.02');
        push(@sql,'ALTER TABLE empire ADD COLUMN alliance INTEGER');
        push(@sql,'ALTER TABLE empire ADD COLUMN colony_count INTEGER');
        push(@sql,'ALTER TABLE empire ADD COLUMN level INTEGER');
        push(@sql,'ALTER TABLE empire ADD COLUMN date_founded INTEGER');
        push(@sql,'ALTER TABLE empire ADD COLUMN affinity TEXT');
        push(@sql,'ALTER TABLE empire ADD COLUMN last_checked INTEGER');
    }

    if ($self->current_version() < 2.03) {
        $self->log('debug','Upgrade for 2.02->2.03');

        push(@sql,'ALTER TABLE body RENAME TO body_old');

        push(@sql,'CREATE TABLE IF NOT EXISTS body (
                    id INTEGER NOT NULL PRIMARY KEY,
                    star INTEGER NOT NULL,
                    x INTEGER NOT NULL,
                    y INTEGER NOT NULL,
                    orbit INTEGER NOT NULL,
                    size INTEGER NOT NULL,
                    name TEXT NOT NULL,
                    normalized_name TEXT NOT NULL,
                    type TEXT NOT NULL,
                    water INTEGER,
                    ore TEXT,
                    empire INTEGER,
                    is_excavated INTEGER
                )');

        push(@sql,'INSERT INTO body (id,star,x,y,orbit,size,name,normalized_name,type,water,ore,empire) SELECT id,star,x,y,orbit,size,name,normalized_name,type,water,ore,empire FROM body_old');

        push(@sql,'DROP TABLE body_old');
    }

    if (scalar @sql) {
        foreach my $sql (@sql) {
            $dbh->do($sql)
                or $self->abort('Could not excecute sql %s: %s',$sql,$dbh->errstr);
        }
    }

    $self->current_version($self->latest_version);

    $dbh->do('INSERT OR REPLACE INTO meta (key,value) VALUES (?,?)',{},'database_version',$self->latest_version);

    return;
}

sub selectrow_array {
    my ($self,$sql,@bind) = @_;

    my $sth = $self->prepare($sql);
    $sth->execute(@bind)
        or return;

    my (@row) = $sth->fetchrow_array()
        and $sth->finish;

    return @row;
}

sub selectrow_hashref {
    my ($self,$sql,@bind) = @_;

    my $sth = $self->prepare($sql);
    $sth->execute(@bind)
        or return;

    my $row = $sth->fetchrow_hashref()
        and $sth->finish;

    return $row;
}

sub do {
    my ($self,$sql,@params) = @_;

    my $sql_log = $sql;
    $sql_log =~ s/\n/ /g;

    foreach my $element (@params) {
        if (ref $element) {
            $element = $JSON->encode($element);
        }
    }

    return $self->dbh->do($sql,{},@params)
        or $self->abort('Could not run SQL command "%s": %s',$sql_log,$self->dbh->errstr);
}

sub prepare {
    my ($self,$sql) = @_;

    my $sql_log = $sql;
    $sql_log =~ s/\n/ /g;

    return $self->dbh->prepare($sql)
        or $self->abort('Could not prepare SQL command "%s": %s',$sql_log,$self->dbh->errstr);
}

sub get_cache {
    my ($self,$key) = @_;

    return $LOCAL_CACHE{$key}->[0]
        if defined $LOCAL_CACHE{$key};

    my ($value,$valid_until) = $self
        ->selectrow_array(
            'SELECT value, valid_until FROM cache WHERE key = ?',
            $key
        );

    return
        if ! defined $value
        || $valid_until < time();

    return $JSON->decode($value);
}

sub set_cache {
    my ($self,%params) = @_;

    $params{max_age} ||= 3600;

    my $valid_until = $params{valid_until} || ($params{max_age} + time());
    my $key = $params{key};
    my $value = $JSON->encode($params{value});
    my $checksum = md5_hex($value);

    return
        if defined $LOCAL_CACHE{$key}
        && $LOCAL_CACHE{$key}->[1] eq $checksum;

    $LOCAL_CACHE{$key} = [ $params{value},$checksum ];

#    # Check local write cache
#    my $checksum = $cache->checksum();
#    if (defined $LOCAL_CACHE{$key}) {
#        my $local_cache = $LOCAL_CACHE{$key};
#        return $cache
#            if $local_cache eq $checksum;
#    }
#
#    $LOCAL_CACHE{$key} = $checksum;

    $self->do(
        'INSERT OR REPLACE INTO cache (key,value,valid_until,checksum) VALUES (?,?,?,?)',
        $key,
        $value,
        $valid_until,
        $checksum,
    );

    return;
}

sub clear_cache {
    my ($self,$key) = @_;

    delete $LOCAL_CACHE{$key};

    $self->do(
        'DELETE FROM cache WHERE key = ?',
        $key,
    );
}


__PACKAGE__->meta->make_immutable;
no Moose;
1;

__DATA__
DROP TABLE IF EXISTS star;

CREATE TABLE IF NOT EXISTS star (
  id INTEGER NOT NULL PRIMARY KEY,
  x INTEGER NOT NULL,
  y INTEGER NOT NULL,
  name TEXT NOT NULL,
  zone TEXT NOT NULL,
  last_checked INTEGER,
  is_probed INTEGER,
  is_known INTEGER
);

DROP TABLE IF EXISTS body;

CREATE TABLE IF NOT EXISTS body (
  id INTEGER NOT NULL PRIMARY KEY,
  star INTEGER NOT NULL,
  x INTEGER NOT NULL,
  y INTEGER NOT NULL,
  orbit INTEGER NOT NULL,
  size INTEGER NOT NULL,
  name TEXT NOT NULL,
  normalized_name TEXT NOT NULL,
  type TEXT NOT NULL,
  water INTEGER,
  ore TEXT,
  empire INTEGER,
  is_excavated INTEGER
);

CREATE INDEX IF NOT EXISTS body_star_index ON body(star);

DROP TABLE IF EXISTS empire;

CREATE TABLE IF NOT EXISTS empire (
  id INTEGER NOT NULL PRIMARY KEY,
  name TEXT NOT NULL,
  normalized_name TEXT NOT NULL,
  alignment TEXT NOT NULL,
  is_isolationist TEXT NOT NULL,
  alliance INTEGER,
  colony_count INTEGER,
  level INTEGER,
  date_founded INTEGER,
  affinity TEXT,
  last_checked INTEGER
);

DROP TABLE IF EXISTS cache;

CREATE TABLE IF NOT EXISTS cache (
  key TEXT NOT NULL PRIMARY KEY,
  value TEXT NOT NULL,
  valid_until INTEGER,
  checksum TEXT NOT NULL
);

CREATE TABLE IF NOT EXISTS meta (
  key TEXT NOT NULL PRIMARY KEY,
  value TEXT NOT NULL
);