Commit 9576cfee authored by Luc Didry's avatar Luc Didry

Add PostgreSQL support. Fix #21

parent 95adc29c
image: debian:jessie
test:
script:
- apt-get update
- apt-get install -y build-essential libssl-dev openssl perl-doc
- echo yes | cpan Carton
- carton install
- cp lstu.conf.template lstu.conf
- sed -i -e "s@#contact@contact@" -e "s@#adminpwd.*@adminpwd => 'toto',@" -e "s@#db_path.*@db_path => 'test.db',@" lstu.conf
stages:
- sqlite
- postgresql
before_script:
- apt-get update
- apt-get install -y build-essential libssl-dev openssl perl-doc libpq-dev
- echo yes | cpan Carton
- carton install
- cp lstu.conf.template lstu.conf
- sed -i -e "s@#contact@contact@" -e "s@#adminpwd.*@adminpwd => 'toto',@" -e "s@#db_path.*@db_path => 'test.db',@" -e "s@#pgdb.*@pgdb => {database => 'lstu', host => 'localhost', user => 'lstu', pwd => 'lstu'},@" lstu.conf
sqlite:
stage: sqlite
script:
- rm -f test.db
- make test
- sed -i -e "s@ \(adminpwd.*\)@ \#\1@" -e "s@#hashed_adminpwd.*@hashed_adminpwd => '31f7a65e315586ac198bd798b6629ce4903d0899476d5741a9f32e2e521b6a66',@" lstu.conf
......@@ -19,3 +24,22 @@ test:
tags:
- Debian
- Jessie
postgresql:
stage: postgresql
script:
- apt-get install -y postgresql
- service postgresql start
- sleep 2
- service postgresql status
- su -c "psql -f t/test.sql" postgres
- sed -i -e "s@#dbtype =>.*@dbtype => 'postgresql'@" lstu.conf
- make test
- sed -i -e "s@ \(adminpwd.*\)@ \#\1@" -e "s@#hashed_adminpwd.*@hashed_adminpwd => '31f7a65e315586ac198bd798b6629ce4903d0899476d5741a9f32e2e521b6a66',@" lstu.conf
- make test
- sed -i -e "s@#minion.*@minion => { enabled => 1, db_path => 'minion.db' },@" lstu.conf
- rm -f minion.db
- make minion &
- make test
tags:
- Debian
- Jessie
......@@ -10,12 +10,24 @@ Lstu is licensed under the terms of the WTFPL. See the LICENSE file.
## Dependencies
* In order to compile some dependencies, you'll need some packages from your distro:
```shell
sudo apt-get install build-essential libssl-dev
```
* Carton : Perl dependencies manager, it will get what you need, so don't bother about dependencies (but you can read the file `cpanfile` if you want).
```shell
sudo cpan Carton
```
* If you want to use PostgreSQL as a backend, install `libpq-dev` too:
```shell
sudo apt-get install libpq-dev
```
## Installation
After installing Carton :
......@@ -23,8 +35,20 @@ After installing Carton :
```shell
git clone https://framagit.org/luc/lstu.git
cd lstu
```
If you **don't** want to use PostgreSQL as a backend, comment the line `requires 'Mojo::Pg';` in the `cpanfile` file:
```shell
sed -e "s@requires 'Mojo::Pg';@#requires 'Mojo::Pg';@" -i cpanfile
```
Let's continue the installation:
```shell
make installdeps
cp lstu.conf.template lstu.conf
# Edit the configuration file
vi lstu.conf
```
......@@ -35,6 +59,17 @@ The configuration file is self-documented.
```shell
cd /your/lstu/installation/directory
git pull
```
If you **don't** want to use PostgreSQL as a backend, comment the line `requires 'Mojo::Pg';` in the `cpanfile` file:
```shell
sed -e "s@requires 'Mojo::Pg';@#requires 'Mojo::Pg';@" -i cpanfile
```
Then:
```shell
make installdeps
vimdiff lstu.conf.template lstu.conf
```
......
requires 'Mojolicious', '>= 4.63';
requires 'ORLite';
requires 'Mojo::Pg';
requires 'Data::Validate::URI';
requires 'Net::Domain::TLD', '>= 1.74';
requires 'Mojolicious::Plugin::I18N';
......
......@@ -74,6 +74,17 @@ DISTRIBUTIONS
Test::More 0.94
strict 0
warnings 0
DBD-Pg-3.5.3
pathname: T/TU/TURNSTEP/DBD-Pg-3.5.3.tar.gz
provides:
Bundle::DBD::Pg v3.5.3
DBD::Pg v3.5.3
requirements:
DBI 1.614
ExtUtils::MakeMaker 6.11
Test::More 0.88
Time::HiRes 0
version 0
DBD-SQLite-1.54
pathname: I/IS/ISHIGAKI/DBD-SQLite-1.54.tar.gz
provides:
......@@ -415,17 +426,17 @@ DISTRIBUTIONS
IO::Socket 0
Socket 1.97
Test::More 0.88
IO-Socket-SSL-2.043
pathname: S/SU/SULLR/IO-Socket-SSL-2.043.tar.gz
IO-Socket-SSL-2.044
pathname: S/SU/SULLR/IO-Socket-SSL-2.044.tar.gz
provides:
IO::Socket::SSL 2.043
IO::Socket::SSL 2.044
IO::Socket::SSL::Intercept 2.014
IO::Socket::SSL::OCSP_Cache 2.043
IO::Socket::SSL::OCSP_Resolver 2.043
IO::Socket::SSL::OCSP_Cache 2.044
IO::Socket::SSL::OCSP_Resolver 2.044
IO::Socket::SSL::PublicSuffix undef
IO::Socket::SSL::SSL_Context 2.043
IO::Socket::SSL::SSL_HANDLE 2.043
IO::Socket::SSL::Session_Cache 2.043
IO::Socket::SSL::SSL_Context 2.044
IO::Socket::SSL::SSL_HANDLE 2.044
IO::Socket::SSL::Session_Cache 2.044
IO::Socket::SSL::Utils 2.014
requirements:
ExtUtils::MakeMaker 0
......@@ -594,6 +605,19 @@ DISTRIBUTIONS
perl 5.006
strict 0
warnings 0
Mojo-Pg-2.35
pathname: S/SR/SRI/Mojo-Pg-2.35.tar.gz
provides:
Mojo::Pg 2.35
Mojo::Pg::Database undef
Mojo::Pg::Migrations undef
Mojo::Pg::PubSub undef
Mojo::Pg::Results undef
Mojo::Pg::Transaction undef
requirements:
DBD::Pg 3.005001
ExtUtils::MakeMaker 0
Mojolicious 7.15
Mojo-SQLite-1.003
pathname: D/DB/DBOOK/Mojo-SQLite-1.003.tar.gz
provides:
......@@ -616,8 +640,8 @@ DISTRIBUTIONS
URI::db 0.15
URI::file 4.21
perl 5.010001
Mojolicious-7.18
pathname: S/SR/SRI/Mojolicious-7.18.tar.gz
Mojolicious-7.23
pathname: S/SR/SRI/Mojolicious-7.23.tar.gz
provides:
Mojo undef
Mojo::Asset undef
......@@ -649,6 +673,7 @@ DISTRIBUTIONS
Mojo::IOLoop::Server undef
Mojo::IOLoop::Stream undef
Mojo::IOLoop::Subprocess undef
Mojo::IOLoop::TLS undef
Mojo::JSON undef
Mojo::JSON::Pointer undef
Mojo::Loader undef
......@@ -682,7 +707,7 @@ DISTRIBUTIONS
Mojo::UserAgent::Transactor undef
Mojo::Util undef
Mojo::WebSocket undef
Mojolicious 7.18
Mojolicious 7.23
Mojolicious::Command undef
Mojolicious::Command::cgi undef
Mojolicious::Command::cpanify undef
......
# vim:set sw=4 ts=4 sts=4 ft=perl expandtab:
package Lstu;
use Mojo::Base 'Mojolicious';
use Data::Validate::URI qw(is_http_uri is_https_uri);
use Mojo::JSON qw(to_json decode_json);
use Mojo::URL;
use Net::Abuse::Utils::Spamhaus qw(check_fqdn);
use Net::LDAP;
use Apache::Htpasswd;
use Lstu::DB::URL;
use Lstu::DB::Ban;
use Lstu::DB::Session;
$ENV{MOJO_REVERSE_PROXY} = 1;
......@@ -61,6 +55,9 @@ sub startup {
# Piwik
$self->plugin('Piwik');
# Lstu Helpers
$self->plugin('Lstu::Plugin::Helpers');
# Authentication (if configured)
if (defined($self->config('ldap')) || defined($self->config('htpasswd'))) {
die 'Unable to read '.$self->config('htpasswd') if (defined($self->config('htpasswd')) && !-r $self->config('htpasswd'));
......@@ -134,122 +131,6 @@ sub startup {
# Secrets
$self->secrets($config->{secret});
# Helpers
$self->helper(
cache => sub {
my $c = shift;
state $cache = {};
}
);
$self->helper(
clear_cache => sub {
my $c = shift;
my $cache = $c->cache;
my @keys = keys %{$cache};
my $limit = ($c->app->mode eq 'production') ? 500 : 1;
map {delete $cache->{$_};} @keys if (scalar(@keys) > $limit);
}
);
$self->helper(
ip => sub {
my $c = shift;
my $proxy = $c->req->headers->header('X-Forwarded-For');
my $ip = ($proxy) ? $proxy : $c->tx->remote_address;
return $ip;
}
);
$self->helper(
provisioning => sub {
my $c = shift;
# Create some short patterns for provisioning
my $db_url = Lstu::DB::URL->new(dbtype => $c->config('dbtype'));
if ($db_url->count_empty < $c->config('provisioning')) {
for (my $i = 0; $i < $c->config('provis_step'); $i++) {
my $short;
do {
$short= $c->shortener($c->config('length'));
} while ($db_url->exist($short));
$db_url->short($short)->write;
}
}
}
);
$self->helper(
prefix => sub {
my $c = shift;
my $prefix = $c->url_for('index')->to_abs;
# Forced domain
$prefix->host($c->config('fixed_domain')) if (defined($c->config('fixed_domain')) && $c->config('fixed_domain') ne '');
# Hack for prefix (subdir) handling
$prefix .= '/' unless ($prefix =~ m#/$#);
return $prefix;
}
);
$self->helper(
shortener => sub {
my $c = shift;
my $length = shift;
my @chars = ('a'..'h', 'j', 'k', 'm'..'z','A'..'H', 'J'..'N', 'P'..'Z','0'..'9', '-', '_');
my $result = '';
foreach (1..$length) {
$result .= $chars[rand scalar(@chars)];
}
return $result;
}
);
$self->helper(
is_spam => sub {
my $c = shift;
my $url = shift;
my $nb_redir = shift;
if ($nb_redir++ <= 2) {
my $res = check_fqdn($url->host);
if (defined $res) {
return {
is_spam => 1,
msg => $c->l('The URL host or one of its redirection(s) (%1) is blacklisted at Spamhaus. I refuse to shorten it.', $url->host)
}
} else {
my $res = $c->ua->get($url)->res;
if ($res->code >= 300 && $res->code < 400) {
return $c->is_spam(Mojo::URL->new($res->headers->location), $nb_redir);
} else {
return { is_spam => 0 };
}
}
} else {
return {
is_spam => 1,
msg => $c->l('The URL redirects 3 times or most. It\'s most likely a dangerous URL (spam, phishing, etc.). I refuse to shorten it.', $url->host)
}
}
}
);
$self->helper(
cleaning => sub {
my $c = shift;
# Delete old sessions
Lstu::DB::Session->new(dbtype => $c->config('dbtype'))->clear();
# Delete old bans
Lstu::DB::Ban->new(dbtype => $c->config('dbtype'))->clear();
}
);
# Hooks
$self->hook(
after_dispatch => sub {
......@@ -291,7 +172,7 @@ sub startup {
my $url = shift;
my $db_url = Lstu::DB::URL->new(
dbtype => $job->app->config('dbtype'),
app => $job->app,
short => $short
)->increment_counter;
......
......@@ -16,7 +16,7 @@ sub login {
my $ip = $c->ip;
my $banned = Lstu::DB::Ban->new(
dbtype => $c->config('dbtype'),
app => $c,
ip => $ip
)->is_banned($c->config('ban_min_strike'));
if (defined $banned) {
......@@ -37,7 +37,7 @@ sub login {
my $token = $c->shortener(32);
Lstu::DB::Session->new(
dbtype => $c->config('dbtype'),
app => $c,
token => $token,
until => time + 3600
)->write;
......@@ -46,14 +46,14 @@ sub login {
$c->redirect_to('stats');
} elsif (defined($act) && $act eq 'logout') {
Lstu::DB::Session->new(
dbtype => $c->config('dbtype'),
app => $c,
token => $c->session('token')
)->delete;
delete $c->session->{token};
$c->redirect_to('stats');
} else {
Lstu::DB::Ban->new(
dbtype => $c->config('dbtype'),
app => $c,
ip => $ip
)->increment_ban_delay(3600);
......@@ -68,12 +68,12 @@ sub delete {
my $short = $c->param('short');
my $db_session = Lstu::DB::Session->new(
dbtype => $c->config('dbtype'),
app => $c,
token => $c->session('token')
);
if (defined($c->session('token')) && $db_session->is_valid) {
my $db_url = Lstu::DB::URL->new(
dbtype => $c->config('dbtype'),
app => $c,
short => $short
);
if ($db_url->url) {
......
......@@ -17,7 +17,7 @@ sub add {
my $ip = $c->ip;
my $banned = Lstu::DB::Ban->new(
dbtype => $c->config('dbtype'),
app => $c,
ip => $c->ip
)->is_banned($c->config('ban_min_strike'));
if (defined $banned) {
......@@ -60,12 +60,12 @@ sub add {
$msg = $res->{msg};
} else {
my $db_url = Lstu::DB::URL->new(
dbtype => $c->config('dbtype'),
app => $c,
url => $url
);
Lstu::DB::Ban->new(
dbtype => $c->config('dbtype'),
app => $c,
ip => $ip
)->increment_ban_delay(1);
......@@ -82,7 +82,7 @@ sub add {
$short = $custom_url;
} else {
$db_url = Lstu::DB::URL->new(dbtype => $c->config('dbtype'))->choose_empty;
$db_url = Lstu::DB::URL->new(app => $c)->choose_empty;
if (defined $db_url) {
$db_url->url($url)->timestamp(time)->write;
......@@ -142,11 +142,11 @@ sub stats {
my $c = shift;
if ((!defined($c->config('ldap')) && !defined($c->config('htpasswd'))) || $c->is_user_authenticated) {
my $db_session = Lstu::DB::Session->new(
dbtype => $c->config('dbtype'),
app => $c,
token => $c->session('token')
);
if (defined($c->session('token')) && $db_session->is_valid) {
my $total = Lstu::DB::URL->new(dbtype => $c->config('dbtype'))->total;
my $total = Lstu::DB::URL->new(app => $c)->total;
my $page = $c->param('page') || 0;
$page = 0 if ($page < 0);
$page = $page - 1 if ($page * $c->config('page_offset') > $total);
......@@ -154,7 +154,7 @@ sub stats {
my ($first, $last) = (!$page, ($page * $c->config('page_offset') <= $total && $total < ($page + 1) * $c->config('page_offset')));
my @urls = Lstu::DB::URL->new(
dbtype => $c->config('dbtype'),
app => $c,
)->paginate($page, $c->config('page_offset'));
$c->respond_to(
json => sub {
......@@ -189,7 +189,7 @@ sub stats {
my $u = (defined($c->cookie('url'))) ? decode_json $c->cookie('url') : [];
my @urls = Lstu::DB::URL->new(
dbtype => $c->config('dbtype'),
app => $c
)->get_a_lot($u);
my $prefix = $c->prefix;
......@@ -230,7 +230,7 @@ sub get {
$url = $c->cache->{$short}->{url};
} else {
$db_url = Lstu::DB::URL->new(
dbtype => $c->config('dbtype'),
app => $c,
short => $short
);
$url = $db_url->url;
......@@ -255,7 +255,7 @@ sub get {
$c->app->minion->enqueue(increase_counter => [$short, $c->{url}]);
} else {
$db_url = Lstu::DB::URL->new(
dbtype => $c->config('dbtype'),
app => $c,
short => $short
) if (defined $c->cache->{$short});
......
......@@ -5,7 +5,7 @@ use Mojo::Base -base;
has 'ip';
has 'until';
has 'strike' => 0;
has 'dbtype';
has 'app';
=head1 NAME
......@@ -28,7 +28,7 @@ Have a look at Lstu::DB::Ban::SQLite's code: it's simple and may be more underst
=item B<strike> : integer
=item B<dbtype> : string
=item B<app> : a mojolicious object
=back
......@@ -38,7 +38,7 @@ Have a look at Lstu::DB::Ban::SQLite's code: it's simple and may be more underst
=over 1
=item B<Usage> : C<$c = Lstu::DB::Ban-E<gt>new(dbtype =E<gt> 'sqlite');>
=item B<Usage> : C<$c = Lstu::DB::Ban-E<gt>new(app =E<gt> $self);>
=item B<Arguments> : any of the attribute above
......@@ -46,7 +46,7 @@ Have a look at Lstu::DB::Ban::SQLite's code: it's simple and may be more underst
=item B<Returns> : the db accessor object
=item B<Info> : the dbtype argument is used by Lstu::DB::Ban to choose which db accessor will be used, you don't need to use it
=item B<Info> : the app argument is used by Lstu::DB::Ban to choose which db accessor will be used, you don't need to use it in new(), but you can use it to access helpers or configuration settings in the other subroutines
=back
......@@ -58,9 +58,13 @@ sub new {
$c = $c->SUPER::new(@_);
if (ref($c) eq 'Lstu::DB::Ban') {
if ($c->dbtype eq 'sqlite') {
my $dbtype = $c->app->config('dbtype');
if ($dbtype eq 'sqlite') {
use Lstu::DB::Ban::SQLite;
$c = Lstu::DB::Ban::SQLite->new(@_);
} elsif ($dbtype eq 'postgresql') {
use Lstu::DB::Ban::Pg;
$c = Lstu::DB::Ban::Pg->new(@_);
}
}
......
# vim:set sw=4 ts=4 sts=4 ft=perl expandtab:
package Lstu::DB::Ban::Pg;
use Mojo::Base 'Lstu::DB::Ban';
has 'record' => 0;
sub new {
my $c = shift;
$c = $c->SUPER::new(@_);
$c = $c->_slurp if ($c->ip);
return $c;
}
sub is_banned {
my $c = shift;
my $ban_min_strike = shift;
my $h = $c->app->pg->db->query('SELECT * FROM ban WHERE ip = ? AND until > ? AND strike >= ?', $c->ip, time, $ban_min_strike)->hashes;
if ($h->size) {
$c->until($h->first->{until});
$c->strike($h->first->{strike});
$c->record(1);
return $c;
} else {
return undef;
}
}
sub increment_ban_delay {
my $c = shift;
my $penalty = shift;
my $until = time + $penalty;
my $h = {
strike => 1
};
if ($c->record) {
$h = $c->app->pg->db->query('UPDATE ban SET until = ?, strike = strike + 1 WHERE ip = ? RETURNING strike', $until, $c->ip)->hashes->first;
} else {
$c->app->pg->db->query('INSERT INTO ban (ip, until, strike) VALUES (?, ?, 1)', $c->ip, $until);
$c->record(1);
}
$c->strike($h->{strike});
$c->until($until);
return $c;
}
sub clear {
my $c = shift;
$c->app->pg->db->query('DELETE FROM ban WHERE until < ?', time);
}
sub delete_all {
my $c = shift;
$c->app->pg->db->query('DELETE FROM ban');
}
sub _slurp {
my $c = shift;
my $h = $c->app->pg->db->query('SELECT * FROM ban WHERE ip = ?', $c->ip)->hashes;
if ($h->size) {
$c->until($h->first->{until});
$c->strike($h->first->{strike});
$c->record(1);
}
return $c;
}
1;
......@@ -77,7 +77,7 @@ sub _slurp {
my $c = shift;
my @banned = Lstu::DB::SQLite::Ban->select('WHERE ip = ?', $c->ip);
if (scalar(@banned)) {
if (scalar @banned) {
$c->until($banned[0]->until);
$c->strike($banned[0]->strike);
$c->record($banned[0]);
......
......@@ -4,7 +4,7 @@ use Mojo::Base -base;
has 'token';
has 'until';
has 'dbtype';
has 'app';
=head1 NAME
......@@ -25,7 +25,7 @@ Have a look at Lstu::DB::Session::SQLite's code: it's simple and may be more und
=item B<until> : unix timestamp
=item B<dbtype> : string
=item B<app> : a mojolicious object
=back
......@@ -35,7 +35,7 @@ Have a look at Lstu::DB::Session::SQLite's code: it's simple and may be more und
=over 1
=item B<Usage> : C<$c = Lstu::DB::Session-E<gt>new(dbtype =E<gt> 'sqlite');>
=item B<Usage> : C<$c = Lstu::DB::Session-E<gt>new(app =E<gt> $self);>
=item B<Arguments> : any of the attribute above
......@@ -43,7 +43,7 @@ Have a look at Lstu::DB::Session::SQLite's code: it's simple and may be more und
=item B<Returns> : the db accessor object
=item B<Info> : the dbtype argument is used by Lstu::DB::Session to choose which db accessor will be used, you don't need to use it
=item B<Info> : the app argument is used by Lstu::DB::Session to choose which db accessor will be used, you don't need to use it in new(), but you can use it to access helpers or configuration settings in the other subroutines
=back
......@@ -55,9 +55,13 @@ sub new {
$c = $c->SUPER::new(@_);
if (ref($c) eq 'Lstu::DB::Session') {
if ($c->dbtype eq 'sqlite') {
my $dbtype = $c->app->config('dbtype');
if ($dbtype eq 'sqlite') {
use Lstu::DB::Session::SQLite;
$c = Lstu::DB::Session::SQLite->new(@_);
} elsif ($dbtype eq 'postgresql') {
use Lstu::DB::Session::Pg;
$c = Lstu::DB::Session::Pg->new(@_);
}
}
......@@ -67,6 +71,7 @@ sub new {
sub is_valid {
my $c = shift;
return 0 unless defined $c->until;
return ($c->until > time);
}
......
# vim:set sw=4 ts=4 sts=4 ft=perl expandtab:
package Lstu::DB::Session::Pg;
use Mojo::Base 'Lstu::DB::Session';
has 'record' => 0;
sub new {
my $c = shift;
$c = $c->SUPER::new(@_);
$c = $c->_slurp if ($c->token);
return $c;
}
sub delete {
my $c = shift;
my $h = $c->app->pg->db->query('DELETE FROM sessions WHERE token = ? RETURNING *', $c->token)->hashes;
if ($h->size) {
$c = Lstu::DB::Session->new(app => $c->app);
}
return $h->size;
}
sub write {
my $c = shift;
if ($c->record) {
$c->app->pg->db->query('UPDATE sessions SET until = ? WHERE token = ?', $c->until, $c->token);
} else {
$c->app->pg->db->query('INSERT INTO sessions (token, until) VALUES (?, ?)', $c->token, $c->until);
$c->record(1);
}
return $c;
}
sub clear {
my $c = shift;
$c->app->pg->db->query('DELETE FROM sessions WHERE until < ?', time);
}