view release on metacpan or  search on metacpan

lib/URI/Shortener.pm  view on Meta::CPAN

sub _dbh {
    my ($self) = @_;
    return $db_dispatch{$self->{dbtype}}->(@_);
}

sub _sqlite_dbh {
    my ($self) = @_;
    my $dbname = $self->{dbname};
    return $self->{dbh}->{$dbname} if exists $self->{dbh}->{$dbname};

    # Some systems splash down without this.  YMMV.
    File::Touch::touch($dbname) if $dbname ne ':memory:' && !-f $dbname;

    my $db = DBI->connect( "dbi:SQLite:dbname=$dbname", "", "" );
    $db->{sqlite_allow_multiple_statements} = 1;
    $db->do($self->{sqlite_schema}) or die "Could not ensure database consistency: " . $db->errstr;
    $db->{sqlite_allow_multiple_statements} = 0;
    $self->{dbh}->{$dbname} = $db;

    # Turn on fkeys
    $db->do("PRAGMA foreign_keys = ON") or die "Could not enable foreign keys";

    # Turn on WALmode, performance
    $db->do("PRAGMA journal_mode = WAL") or die "Could not enable WAL mode";

    return $db;
}

sub _pg_dbh {
    my ($self) = @_;
    my $dbname = $self->{dbname};
    return $self->{dbh}->{$dbname} if exists $self->{dbh}->{$dbname};

    my $host = $self->{dbhost} // $ENV{PGHOST} || 'localhost';
    my $port = $self->{dbport} // $ENV{PGPORT} || 5432;
    my $user = $self->{dbuser} // $ENV{PGUSER};
    my $pass = $self->{dbpass} // $ENV{PGPASSWORD};

    my $db = DBI->connect("dbi:Pg:dbname=$dbname;host=$host;port=$port", $user, $pass);

    #XXX pg is noisy even when you say 'IF NOT EXISTS'
    my $result;
    capture_merged { $result = $db->do($self->{pg_schema}) };
    die "Could not ensure database consistency: " . $db->errstr unless $result;

    $self->{dbh}->{$dbname} = $db;
    return $db;
}

sub _my_dbh {
    my ($self) = @_;
    my $dbname = $self->{dbname};
    return $self->{dbh}->{$dbname} if exists $self->{dbh}->{$dbname};

    my $host = $self->{dbhost} // $ENV{MYSQL_HOST} || 'localhost';
    my $port = $self->{dbport} // $ENV{MYSQL_TCP_PORT} || 3306;
    my $user = $self->{dbuser} // $ENV{DBI_USER};
    my $pass = $self->{dbpass} // $ENV{MYSQL_PWD};

    # Handle the mysql defaults file
    my $defaults_file = $self->{mysql_read_default_file} // "$ENV{HOME}/.my.cnf";
    my $defaults_group = $self->{mysql_read_default_group} // 'client';
    my $df = "";
    $df .= "mysql_read_default_file=$defaults_file;"   if -f $defaults_file;
    $df .= "mysql_read_default_group=$defaults_group;" if $defaults_group;

    my $dsn = "dbi:mysql:mysql_multi_statements=1;database=$dbname;".$df."host=$host;port=$port";

    my $db = DBI->connect($dsn, $user, $pass);
    $db->do($self->{mysql_schema}) or die "Could not ensure database consistency: " . $db->errstr;

    $self->{dbh}->{$dbname} = $db;
    return $db;
}


sub migrate {
    my ($self, $new) = @_;
    my $from_dbh = $self->_dbh();
    my $to_dbh   = $new->_dbh();

    my $prefixes = $from_dbh->selectall_arrayref(qq|SELECT * FROM $self->{prefix_tablename}|);
    _batch_insert($to_dbh, $new->{prefix_tablename}, @$prefixes) if @$prefixes;

    my $uris = $from_dbh->selectall_arrayref(qq|SELECT * FROM $self->{uri_tablename}|);
    _batch_insert($to_dbh, $new->{uri_tablename}, @$uris) if @$uris;
}

# Gotta batch stuff cuz sqlite has a 10k param limit
sub _batch_insert {
    my ($dbh, $tbl, @data) = @_;
    my $ncols = @{$data[0]};
    die "No columns in table $tbl" unless $ncols;

    while (my @batch = splice(@data, 0,int(10_000 / $ncols)) ) {
        my $param = join(',', map { '?' } @{$batch[0]});
        my $bind = join(',', map { "($param)" } @batch);

        my $query = "INSERT INTO $tbl VALUES $bind";

        print "Migrating ".scalar(@batch)." rows (".scalar(@data)." left) to $tbl...";
        $dbh->do($query, undef, map { @$_ } @batch);
        print "Done.\n"
    }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

URI::Shortener - Shorten URIs so that you don't have to rely on external services

=head1 VERSION

version 1.006

=head1 SYNOPSIS

lib/URI/Shortener.pm  view on Meta::CPAN

=head2 OTHER DATABASES

We support use of other databases than sqlite, should you so desire.
Set the dbhost, dbport, dbuser, dbpass and specify an appropriate dbtype (supported: sqlite, pg, mysql).

While we choose to use the largest possible autoincrementing primary key type,
be aware you will be fundamentally limited to the largest integer that can represent.
Mysql's BIGINT in particular is different than Postgres' BIGSERIAL and SQLite's INTEGER.

If the names of the tables/indexes collides with stuff already in your DB, you can pass parameters to the constructor to fix that.
Here are the defaults:

    uri_tablename    => 'uris',
    prefix_tablename => 'prefix',
    uri_idxname      => 'uri_idx',
    prefix_idxname   => 'prefix_idx',
    cipher_idxname   => 'cipher_idx',
    created_idxname  => 'created_idx',

Be aware that this is done via regexp replacement, so if you have too similar of names, bad things will occur.

=head2 GRANTS

On DBs that support grants, it is your responsibility to setup grants for the various users accessing these tables.
In general we make the assumption that the creator of the tables is the exclusive user of it, and this is generally a wise policy.
Specific functions on public DBs should have their own users to minimize the impact of any given login being compromised.
This module is designed to be self-contained and never really needs to be queried in any way other than normal operation.

=head2 MYSQL LIMITATIONS

Due to the nature of mysql's text handling, we don't make the 'uri' or 'prefix' fields in their respective tables unique.
Similarly, the cipher (domain) length is limited to 180 chars, as this is about as big as you can prudently use on utf8mb4.

We also are not creating any indices whatsoever.
Pull requests welcome.

=head1 CONSTRUCTOR

=head2 $class->new(%options)

=over 4

=item C<dbname>

Name of the database to use.  Filename when using sqlite.

=item C<dbtype>

Type of database to use.  Supported: (sqlite, mysql, pg)

=item C<dbhost,dbport,dbuser,dbpass>

Means to connect to remote databases, such as is the case with mysql/pg

dbhost defaults to localhost, and dbport defaults to the relevant default port.
Otherwise the relevant ENV vars are obeyed when no options are passed.

See _my_dbh() and _pg_dbh() for the particulars.

Also, mysql will obey the mysql_read_default_file/group parameters, and defaults to using ~/.my.cnf and the 'client' group.

=item C<prefix>

URI prefix of shortened output.  Trailing slashes will be stripped.  Example: https://big.hugs/go/

=item C<length>

Length of the minified path component. Defaulted to 12 when not a member of the natural numbers.

=item C<domain>

Input domain string. Shortened path components are a char within this string. By default a..zA..Z.

=item C<seed>

Starting seed of the PRNG.

=back

This is obviously an "N Choose K" situation (n possible chars from 'domain' in 'length' slots).
The default number of URIs possible is:

    558,383,307,300

Which I should hope is more than enough for most use cases.

=head1 METHODS

=head2 cipher( INTEGER $id )

Wrapper around Crypt::PRNG::string_from().

Uses the passed seed + id as the seed, and builds string_from via the domain passed to the constructor.

=head2 shorten( STRING $uri)

Transform original URI into a shortened one.

=head2 lengthen( STRING $uri)

Transform shortened URI into it's original.

=head2 prune_before(TIME_T $when)

Remove entries older than UNIX timestamp $when.

=head2 migrate(URI::Shortener $to)

Migrate data in one shortener to another.

Useful when going from sqlite to pg, etc.

Only supports importing into an empty DB.
To support this would require re-ID/indexing everything which is nontrivial work, but doable.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website
L<https://github.com/Troglodyne-Internet-Widgets/URI-Shorten/issues>