Permalink
Browse files

Merge branch 'release/0.28'

  • Loading branch information...
2 parents c398be8 + 14d9ca3 commit d35e755d1264770ffe115639a605f7321971465d @szabgab committed Sep 26, 2012
View
2 .gitignore
@@ -21,3 +21,5 @@ logs
SETUP.bat
Dwimmer-*
+
+*.db
View
6 Changes
@@ -1,5 +1,11 @@
Changes to the Dwimmer system. See http://dwimmer.org/
+0.28 2012.09.26
+ - in the feed collector allow multiple sites to be in one database
+
+ - rename dwimmer_setup to dwimmer_admin
+ - lots of additional features to dwimmer_admin
+
0.27 2012.03.11
- rename /change_password to /change_my_password
View
6 FEED
@@ -0,0 +1,6 @@
+
+*) perl -Ilib script/dwimmer_feed_admin.pl --store all.db --setup
+*) perl -Ilib eg/import_from_old_feeds.pl all.db perl.db Perl
+*) perl -Ilib script/dwimmer_feed_admin.pl --store all.db --config html_dir /home/gabor/tmp/feedtest --site Perl
+
+*) perl -Ilib script/dwimmer_feed_collector.pl --store all.db --sendmail --collect;
View
10 Makefile.PL
@@ -17,14 +17,16 @@ license 'perl';
author 'Gabor Szabo <szabgab@dwimmer.org>';
all_from 'lib/Dwimmer.pm';
-requires 'perl' => '5.008005';
+requires 'perl' => '5.012000';
my %prereq = (
'autodie' => 0,
'Dancer' => 1.3060,
'Data::Dumper' => 0,
+ 'DateTime' => 0,
'DBIx::Class' => 0,
'DBIx::Class::Schema' => 0,
+ 'DBIx::Class::Schema::Loader' => 0, # only needed for developers using script/dbic.pl
'DBIx::RunSQL' => 0,
'Email::Valid' => 0,
'Encode' => 0,
@@ -56,16 +58,20 @@ foreach my $module ( keys %prereq ) {
test_requires 'Test::More' => 0;
test_requires 'Test::Deep' => 0;
test_requires 'Test::WWW::Mechanize' => 0;
+test_requires 'Test::Differences' => 0;
homepage 'http://dwimmer.org/';
bugtracker 'http://github.com/szabgab/dwimmer';
repository 'http://github.com/szabgab/dwimmer';
-install_script 'script/dwimmer_setup.pl';
+install_script 'script/dwimmer_admin.pl';
install_script 'script/dwimmer_backup.pl';
install_script 'script/dwimmer';
+install_script 'script/dwimmer_feed_admin.pl';
+install_script 'script/dwimmer_feed_collector.pl';
+
# Copy files to share before installing (but it is not included in the distribution)
foreach my $module (qw(File::Copy::Recursive File::Spec)) {
eval "use $module";
View
4 README
@@ -14,14 +14,14 @@ Setup:
If you already have a CPAN enabled perl installed then type "cpan Dwimmer" in your command prompt.
If you don't have perl yet then we have a binary packaged version for windows. Install Dwimperl.
-dwimmer_setup.pl --password ADMIN_PASSWORD --email email-of-admin@company.com --root path/to/your/installation
+dwimmer_admin.pl --setup --password ADMIN_PASSWORD --email email-of-admin@company.com --root path/to/your/installation
------------
Upgrade:
cpan Dwimmer
-dwimmer_setup.pl --password ADMIN_PASSWORD --root path/to/your/installation --upgrade
+dwimmer_admin.pl --upgrade --password ADMIN_PASSWORD --root path/to/your/installation
View
59 eg/convert_planet.pl
@@ -0,0 +1,59 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use v5.12;
+
+use Config::Tiny;
+use Data::Dumper qw(Dumper);
+use XML::Feed;
+
+use Dwimmer::Feed::DB;
+
+
+my ($config_file, $store) = @ARGV;
+
+if (not $store) {
+ die "Usage: $0 path/to/planet/config.ini path/to/feed.db\n";
+}
+
+my $cfg = Config::Tiny->read($config_file);
+
+my $db = Dwimmer::Feed::DB->new( store => $store );
+$db->connect;
+
+foreach my $section (keys %$cfg) {
+ say $section;
+ if ($section eq 'Planet') {
+ } elsif ($section =~ m{^http://}) {
+ my %data;
+ $data{title} = $cfg->{$section}{name};
+ $data{feed} = $section;
+
+ my $feed = XML::Feed->parse(URI->new($section));
+ if ($feed) {
+ #say $feed->title;
+ #say $feed->base;
+ $data{url} = $feed->link;
+ #say $feed->tagline;
+ #say $feed->author;
+ $data{twitter} = '';
+ $data{status} = 'enabled';
+ $data{comment} = '';
+ #say Dumper \%data;
+ my $id = $db->add_source(\%data);
+ if ($id) {
+ say 'added';
+ } else {
+ say 'failed to add';
+ }
+ } else {
+ say 'feed not found';
+ }
+ } else {
+ say "Unhandled section '$section'";
+ }
+}
+
+
+
+
View
105 eg/import_from_old_feeds.pl
@@ -0,0 +1,105 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use v5.10;
+
+use DBI;
+use Dwimmer::Feed::DB;
+use Data::Dumper qw(Dumper);
+
+my %TABLES = (
+ config => [qw(key value)],
+ sources => [qw(id title url feed comment twitter status)],
+ entries => [qw(id source_id link remote_id author issued title summary content tags)],
+ delivery_queue => [qw(channel entry)],
+);
+
+
+main(@ARGV);
+exit;
+
+sub usage {
+ die "Usage: $0 NEW_DB OLD_DB NAME_OF_FEED\n";
+}
+sub main {
+ my ($new, $old, $name, $all) = @_;
+
+ # [1] The last 1 is need to import the entries as well
+ $all = 1;
+
+ usage() if not $new or not -e $new;
+ usage() if not $old or not -e $old;
+ usage() if not $name;
+
+ my $old_dbh = DBI->connect("dbi:SQLite:dbname=$old", "", "", {
+ FetchHashKeyName => 'NAME_lc',
+ RaiseError => 1,
+ PrintError => 0,
+ AutoCommit => 1,
+ });
+
+ if (not $all) {
+ shift @{ $TABLES{sources} }; # remove id
+ }
+
+ my $db = Dwimmer::Feed::DB->new( store => $new );
+ $db->connect;
+ $db->addsite( name => $name );
+ my $site_id = $db->get_site_id($name);
+ die if not $site_id;
+ $db->dbh->begin_work;
+
+ foreach my $table ('config', 'sources', 'entries', 'delivery_queue') {
+ if (not $all) {
+ next if $table eq 'entries';
+ next if $table eq 'delivery_queue';
+ }
+
+ #print "\n";
+ #say $table;
+ my $select_sql = _get_select_sql($table);
+ my $insert_sql = _get_insert_sql($table);
+
+ my $sth = $old_dbh->prepare($select_sql);
+ $sth->execute;
+ while (my @row = $sth->fetchrow_array) {
+ #if ($table ne 'entries') {
+ push @row, $site_id;
+ #}
+ #say "@row";
+ eval {
+ $db->dbh->do($insert_sql, undef, @row);
+ };
+ if ($@) {
+ say "died on: @row";
+ die $@;
+ }
+ }
+ }
+ $db->dbh->commit;
+}
+
+sub _get_select_sql {
+ my $table = shift;
+
+ my $sql = 'SELECT ' . join(', ', @{ $TABLES{$table} }) . " FROM $table";
+ #say $sql;
+
+ return $sql;
+}
+
+sub _get_insert_sql {
+ my $table = shift;
+
+ my @cols = @{ $TABLES{$table} };
+ #if ($table ne 'entries') {
+ push @cols, 'site_id';
+ #}
+ my $sql = "INSERT INTO $table (" . join(', ', @cols) . ') VALUES (';
+ $sql .= join(',', split //, '?' x @cols) . ')';
+ #say $sql;
+
+ return $sql;
+}
+
+
View
46 eg/update_wiki
@@ -0,0 +1,46 @@
+use 5.010;
+use strict;
+use warnings;
+
+# Sample script to create or update a page from a file
+
+use Dwimmer::Client;
+use Data::Dumper qw(Dumper);
+use File::Slurp qw(read_file);
+
+my ($version, $srcfile) = @ARGV;
+die "Usage: $0 VERSION FILENAME\n" if not $srcfile;
+
+my $user_name = $ENV{dwimmer_user_name} or die "Need dwimmer_user_name\n";
+my $password = $ENV{dwimmer_user_pw} or die "Need dwimmer_user_pw\n";
+my $url = $ENV{dwimmer_url} or die "Need dwimmer_url\n";
+
+my $dw = Dwimmer::Client->new( host => $url );
+$dw->login( username => $user_name, password => $password );
+
+my $filename = "/DSP_v$version";
+my $r = $dw->page( filename => $filename);
+
+#print Dumper $r;
+#exit;
+
+my $body = '';
+my $create = 0;
+
+if ($r->{error}) {
+ $body = "<pre>\n" . scalar(read_file $srcfile) . "</pre>\n";
+ $create = 1;
+} else {
+ $body = "<pre>\n" . scalar(read_file $srcfile) . "</pre>\n" . $r->{page}{body};
+ $create = 0;
+}
+my $c = $dw->save_page(
+ body => $body,
+ title => "Version $version",
+ filename => $filename,
+ create => $create,
+ );
+if (not $c->{success}) {
+ die "Failed " . Dumper $c;
+}
+
View
2 lib/Dwimmer.pm
@@ -3,7 +3,7 @@ use Dancer ':syntax';
use 5.008005;
-our $VERSION = '0.27';
+our $VERSION = '0.28';
use Data::Dumper qw(Dumper);
use Dwimmer::DB;
View
4 lib/Dwimmer/Admin.pm
@@ -3,7 +3,7 @@ use Dancer ':syntax';
use 5.008005;
-our $VERSION = '0.27';
+our $VERSION = '0.28';
use Data::Dumper qw(Dumper);
use Email::Valid ();
@@ -427,6 +427,8 @@ post '/create_list.json' => sub {
my $validate_template = params->{'validate_template'} || '';
my $confirm_template = params->{'confirm_template'} || '';
+ $validate_template =~ s/\r//g; # is this a work-around for the 010 tests or is this really needed?
+ $confirm_template =~ s/\r//g;
my $db = _get_db();
my $list = $db->resultset('MailingList')->create(
View
2 lib/Dwimmer/Client.pm
@@ -8,7 +8,7 @@ has host => ( is => 'ro', isa => 'Str', required => 1 );
has mech => ( is => 'rw', isa => 'WWW::Mechanize', default => sub { WWW::Mechanize->new } );
-our $VERSION = '0.27';
+our $VERSION = '0.28';
# get_user parameters can be id => 1
View
99 lib/Dwimmer/Feed/Admin.pm
@@ -3,8 +3,9 @@ use Moose;
use 5.008005;
-our $VERSION = '0.27';
+our $VERSION = '0.28';
+use Carp ();
use Dwimmer::Feed::DB;
use Data::Dumper qw(Dumper);
@@ -21,14 +22,35 @@ sub BUILD {
return;
}
-sub list {
- my ($self, $filter) = @_;
+sub list_source {
+ my ($self, %args) = @_;
my $sources = $self->db->get_sources;
+
+ #my $site_id = $args{site} ? $self->db->get_site_id($args{site}) : undef;
+ my $site_id;
+ if (defined $args{site} and $args{site} ne '') {
+ if ($args{site} =~ /^\d+$/) {
+ my $site = $self->db->get_site_by_id($args{site});
+ die "Invalid site id '$args{site}'\n" if not $site;
+ #die Dumper $site;
+ # check if id is correct
+ $site_id = $args{site};
+ } else {
+ $site_id = $self->db->get_site_id($args{site});
+ if (not defined $site_id) {
+ die "Could not find site '$args{site}'\n";
+ }
+ }
+ }
+
foreach my $s (@$sources) {
my $show;
- if ($filter) {
+ if (defined $site_id) {
+ next if $s->{site_id} != $site_id;
+ }
+ if ($args{filter}) {
foreach my $field (qw(feed url status title)) {
- $show++ if $s->{$field} =~ /$filter/i;
+ $show++ if $s->{$field} =~ /$args{filter}/i;
}
} else {
$show++;
@@ -40,41 +62,38 @@ sub list {
return;
}
-sub enable {
- my ($self, $id) = @_;
- return $self->able($id, 1);
-}
-sub disable {
- my ($self, $id) = @_;
- return $self->able($id, 0);
-}
-
-
-sub able {
- my ($self, $id, $able) = @_;
+sub update {
+ my ($self, %args) = @_;
- my $s = $self->db->get_source_by_id($id);
+ my $s = $self->db->get_source_by_id($args{id});
if (not $s) {
- die "ID '$id' not found\n";
+ die "ID '$args{id}' not found\n";
}
- _dump($s);
- $self->db->able($id, $able);
- _dump($self->db->get_source_by_id($id));
+
+ _dump($self->db->get_source_by_id($args{id}));
+ $self->db->update($args{id}, $args{field}, $args{value});
+ _dump($self->db->get_source_by_id($args{id}));
return;
}
-sub update {
- my ($self, $id, $field, $value) = @_;
- _dump($self->db->get_source_by_id($id));
- $self->db->update($id, $field, $value);
- _dump($self->db->get_source_by_id($id));
+sub get_site_id {
+ my ($self, %args) = @_;
- return;
+ Carp::croak('No site provides')
+ if not defined $args{site};
+ if ($args{site} =~ /^\d+$/) {
+ # TODO check if exists in the database
+ return $args{site};
+ }
+
+ return $self->db->get_site_id($args{site});
}
sub add {
- my ($self) = @_;
+ my ($self, %args) = @_;
+
+
my %data;
$data{url} = prompt('URL');
$data{feed} = prompt('Feed (Atom or RSS)');
@@ -83,6 +102,10 @@ sub add {
$data{status} = 'enabled';
$data{comment} = prompt('Comment');
$data{twitter} =~ s/\@//;
+ $data{site_id} = $self->get_site_id( site => $args{site} );
+
+ Carp::Croak("Could not find site $args{site}")
+ if not $data{site_id};
my $id = $self->db->add_source(\%data);
_dump($self->db->get_source_by_id($id));
@@ -107,12 +130,26 @@ sub prompt {
return $input;
}
+sub list_sites {
+ my ($self) = @_;
+
+ my $sites =$self->db->get_sites;
+ _dump($sites);
+
+ return;
+}
+
sub list_config {
- my ($self) = @_;
- my $config = $self->db->get_config;
+ my ($self, $site) = @_;
+
+ use Dwimmer::Feed::Config;
+ die "site is required now" if not $site;
+ my $site_id = $self->db->get_site_id($site);
+ my $config = Dwimmer::Feed::Config->get_config($self->db, $site_id);
_dump($config);
}
+
1;
View
127 lib/Dwimmer/Feed/Collector.pm
@@ -3,21 +3,31 @@ use Moose;
use 5.008005;
-our $VERSION = '0.27';
+our $VERSION = '0.28';
my $MAX_SIZE = 500;
my $TRIM_SIZE = 400;
-use Dwimmer::Feed::DB;
-
use Cwd qw(abs_path);
+use Data::Dumper qw(Dumper);
use File::Basename qw(dirname);
use File::Path qw(mkpath);
use List::Util qw(min);
use MIME::Lite ();
use Template;
use XML::Feed ();
+use Dwimmer::Feed::DB;
+use Dwimmer::Feed::Config;
+
+my $URL = '';
+my $TITLE = '';
+my $DESCRIPTION = '';
+my $ADMIN_NAME = '';
+my $ADMIN_EMAIL = '';
+my $FRONT_PAGE_SIZE = 20;
+
+
#has 'sources' => (is => 'ro', isa => 'Str', required => 1);
has 'store' => (is => 'ro', isa => 'Str', required => 1);
has 'db' => (is => 'rw', isa => 'Dwimmer::Feed::DB');
@@ -31,20 +41,23 @@ sub BUILD {
return;
}
-my $TRACK = <<'TRACK';
+sub collect_all {
+ my ($self) = @_;
-<script src="//static.getclicky.com/js" type="text/javascript"></script>
-<script type="text/javascript">try{ clicky.init(66514197); }catch(e){}</script>
-<noscript><p><img alt="Clicky" width="1" height="1" src="//in.getclicky.com/66514197ns.gif" /></p></noscript>
+ my $sites = $self->db->get_sites;
+ foreach my $site (@$sites) {
+ $self->collect($site->{id});
+ }
-TRACK
+ return;
+}
sub collect {
- my ($self) = @_;
+ my ($self, $site_id) = @_;
my $INDENT = ' ' x 11;
- my $sources = $self->db->get_sources( enabled => 1 );
+ my $sources = $self->db->get_sources( status => 'enabled', site_id => $site_id );
main::LOG("sources loaded: " . @$sources);
for my $e ( @$sources ) {
@@ -60,6 +73,7 @@ sub collect {
alarm 10;
main::LOG("Processing feed");
+ #main::LOG(Dumper $e);
main::LOG("$INDENT $e->{feed}");
main::LOG("$INDENT Title by us : $e->{title}");
$feed = XML::Feed->parse(URI->new($e->{feed}));
@@ -68,9 +82,16 @@ sub collect {
alarm 0;
if ($err) {
main::LOG(" EXCEPTION: $err");
+ if ($err =~ /TIMEOUT/) {
+ $self->db->update_last_fetch($e->{id}, 'fail_timeout', $err);
+ } else {
+ $self->db->update_last_fetch($e->{id}, 'fail_fetch', $err);
+ }
+ next;
}
if (not $feed) {
main::LOG(" ERROR: " . XML::Feed->errstr);
+ $self->db->update_last_fetch($e->{id}, 'fail_nofeed', XML::Feed->errstr);
next;
}
if ($feed->title) {
@@ -87,16 +108,16 @@ sub collect {
my $hostname = $entry->link;
$hostname =~ s{^(https?://[^/]+).*}{$1};
#main::LOG("HOST: $hostname");
- if ( not $self->db->find( link => "$hostname%" ) ) {
- main::LOG(" ALERT: new hostname ($hostname) in URL: " . $entry->link);
- my $msg = MIME::Lite->new(
- From => 'dwimmer@dwimmer.com',
- To => 'szabgab@gmail.com',
- Subject => "Dwimmer: new URL noticed $hostname",
- Data => $entry->link,
- );
- $msg->send;
- }
+ #if ( not $self->db->find( link => "$hostname%" ) ) {
+ # main::LOG(" ALERT: new hostname ($hostname) in URL: " . $entry->link);
+ # my $msg = MIME::Lite->new(
+ # From => 'dwimmer@dwimmer.com',
+ # To => 'szabgab@gmail.com',
+ # Subject => "Dwimmer: new URL noticed $hostname",
+ # Data => $entry->link,
+ # );
+ # $msg->send;
+ #}
if ( not $self->db->find( link => $entry->link ) ) {
my %current = (
source_id => $e->{id},
@@ -108,44 +129,52 @@ sub collect {
summary => ($entry->summary->body || ''),
content => ($entry->content->body || ''),
tags => '', #$entry->tags,
+ site_id => $site_id,
);
main::LOG(" INFO: Adding $current{link}");
- $self->db->add(%current);
+ $self->db->add_entry(%current);
}
};
if ($@) {
main::LOG(" EXCEPTION: $@");
}
}
+ $self->db->update_last_fetch($e->{id}, 'success', '');
}
-}
-
-
-my $FRONT_PAGE_SIZE = 15;
-# my $FEED_SIZE = 20;
-my $TITLE = "Perlsphere";
-my $URL = "http://feed.szabgab.com/";
-my $DESCRIPTION = 'The largest source of Perl related news';
-my $ADMIN_NAME = 'Gabor Szabo';
-my $ADMIN_EMAIL = 'szabgab@gmail.com';
+ return;
+}
# should be in its own class?
# plan: N item on front page or last N days?
# every day gets its own page in archice/YYYY/MM/DD
+sub generate_html_all {
+ my ($self) = @_;
+
+ my $sites = $self->db->get_sites;
+ foreach my $site (@$sites) {
+ $self->generate_html($site->{id});
+ }
+
+ return;
+}
+
sub generate_html {
- my ($self, $dir) = @_;
- die if not $dir or not -d $dir;
+ my ($self, $site_id) = @_;
+ die if not defined $site_id;
- my $sources = $self->db->get_sources( enabled => 1 );
+ my $dir = Dwimmer::Feed::Config->get($self->db, $site_id, 'html_dir');
+ die 'Missing directory name' if not $dir;
+ die "Not a directory '$dir'" if not -d $dir;
+
+ my $sources = $self->db->get_sources( status => 'enabled', site_id => $site_id );
my %src = map { $_->{id } => $_ } @$sources;
my $all_entries = $self->db->get_all_entries;
my $size = min($FRONT_PAGE_SIZE, scalar @$all_entries);
- my @entries = @$all_entries[0 .. $size-1];
- foreach my $e (@entries) {
+ foreach my $e (@$all_entries) {
$e->{source_name} = $src{ $e->{source_id} }{title};
$e->{source_url} = $src{ $e->{source_id} }{url};
$e->{twitter} = $src{ $e->{source_id} }{twitter};
@@ -161,6 +190,12 @@ sub generate_html {
# }
}
+
+ my @entries = @$all_entries[0 .. $size-1];
+
+ my $clicky_enabled = Dwimmer::Feed::Config->get($self->db, $site_id, 'clicky_enabled');
+ my $clicky_code = Dwimmer::Feed::Config->get($self->db, $site_id, 'clicky_code');
+
my %site = (
url => $URL,
title => $TITLE,
@@ -171,8 +206,7 @@ sub generate_html {
id => $URL,
dwimmer_version => $VERSION,
last_update => scalar localtime,
- track => $TRACK,
-
+ clicky => ($clicky_enabled and $clicky_code ? $clicky_code : ''),
);
$site{last_build_date} = localtime;
@@ -200,18 +234,25 @@ sub generate_html {
my $root = dirname dirname abs_path $0;
my $t = Template->new({ ABSOLUTE => 1, });
- $t->process("$root/views/feed_index.tt", {entries => \@entries, %site}, "$dir/index.html") or die $t->error;
- $t->process("$root/views/feed_rss.tt", {entries => \@entries, %site}, "$dir/rss.xml") or die $t->error;
- $t->process("$root/views/feed_atom.tt", {entries => \@entries, %site}, "$dir/atom.xml") or die $t->error;
- $t->process("$root/views/feed_feeds.tt", {entries => \@feeds}, "$dir/feeds.html") or die $t->error;
+
+ my $header_tt = Dwimmer::Feed::Config->get($self->db, $site_id, 'header_tt');
+ my $footer_tt = Dwimmer::Feed::Config->get($self->db, $site_id, 'footer_tt');
+ my $index_tt = $header_tt . Dwimmer::Feed::Config->get($self->db, $site_id, 'index_tt') . $footer_tt;
+ my $feeds_tt = $header_tt . Dwimmer::Feed::Config->get($self->db, $site_id, 'feeds_tt') . $footer_tt;
+
+ $t->process(\$feeds_tt, {entries => \@feeds, %site}, "$dir/feeds.html") or die $t->error;
+ $t->process(\$index_tt, {entries => \@entries, %site}, "$dir/index.html") or die $t->error;
foreach my $date (keys %entries_on) {
my ($year, $month, $day) = split /-/, $date;
my $path = "$dir/archive/$year/$month";
mkpath $path;
- $t->process("$root/views/feed_index.tt", {entries => $entries_on{$date}, %site}, "$path/$day.html") or die $t->error;
+ $t->process(\$index_tt, {entries => $entries_on{$date}, %site}, "$path/$day.html") or die $t->error;
}
+ $t->process(\Dwimmer::Feed::Config->get($self->db, $site_id, 'rss_tt'), {entries => \@entries, %site}, "$dir/rss.xml") or die $t->error;
+ $t->process(\Dwimmer::Feed::Config->get($self->db, $site_id, 'atom_tt'), {entries => \@entries, %site}, "$dir/atom.xml") or die $t->error;
+
return;
}
View
315 lib/Dwimmer/Feed/Config.pm
@@ -0,0 +1,315 @@
+package Dwimmer::Feed::Config;
+use strict;
+use warnings;
+
+our $VERSION = '0.28';
+
+my %DEFAULT;
+
+sub get_config_hash {
+ my ($self, $db, $site_id) = @_;
+ die 'Need 3 args for get_config_hash' if @_ != 3;
+
+ return $db->get_config_hash(site_id => $site_id);
+}
+
+sub get_config {
+ my ($self, $db, $site_id) = @_;
+ die 'Need 3 args for get_config' if @_ != 3;
+
+ my $config = $db->get_config(site_id => $site_id);
+}
+
+sub get {
+ my ($self, $db, $site_id, $field) = @_;
+ die 'Need 4 args for get' if @_ != 4;
+
+ my $config = $db->get_config_hash(site_id => $site_id);
+ return $config->{$field} // $DEFAULT{$field};
+}
+
+$DEFAULT{subject_tt} = q{[% title %]};
+
+$DEFAULT{text_tt} = q{
+Title: [% title %]
+Link: [% link %]
+Source: [% source %]
+Tags: [% tags %]
+Author: [% author %]
+
+Date: [% issued %]
+Summary:
+[% summary %]
+----------------------------
+};
+
+$DEFAULT{html_tt} = q{
+<html><head><title></title></head><body>
+<h1><a href="[% other.url %]">[% e.title %]</a></h1>
+<p>[% e.summary %]</p>
+<hr />
+
+<p>Entry</p>
+<p><a href="http://twitter.com/home?status=[% other.twitter_status %]">tweet</a></p>
+<p>Original URL: [% e.link %]</p>
+<p>Link: [% e.link %]</p>
+<p>Entry ID: [% e.id %]</p>
+<p>Tags: [% e.tags %]</p>
+<p>Author: [% e.author %]</p>
+<p>Date: [% e.issued %]</p>
+<p>HTTP Status: [% other.status %]</p>
+[% IF other.redirected %]
+ <p>Redirected</p>
+[% END %]
+
+<hr />
+<p>Source:</p>
+<p>ID: [% e.source_id %]</p>
+<p>Title: <a href="[% source.url %]">[% source.title %]</a></p>
+<p>Twitter:
+[% IF source.twitter %]
+ <a href="https://twitter.com/#!/[% source.twitter %]">[% source.twitter %]</a></p>
+[% ELSE %]
+ NO twitter</p>
+[% END %]
+
+</body></html>
+};
+
+
+$DEFAULT{atom_tt} = q{
+<?xml version="1.0" encoding="utf-8"?>
+<feed xmlns="http://www.w3.org/2005/Atom">
+
+<title>[% title %]</title>
+<subtitle>[% subtitle %]></subtitle>
+<link href="[% url %]"/>
+<id>[% id %]</id>
+<updated>[% last_build_date %]</updated>
+
+<author>
+ <name>[% admin_name %]</name>
+ <email>[% admin_email %]</email>
+</author>
+<generator uri="http://search.cpan.org/dist/Dwimmer/" version="[% dwimmer_version %]">Dwimmer</generator>
+
+[% FOR e IN entries %]
+<entry>
+ <author>
+ <name>[% e.author_name %]</name>
+ <uri>[% e.author_uri %]</uri>
+ </author>
+ <title>[% e.title %]</title>
+ <link href="[% e.link %]"/>
+ <id>[% e.id %]</id>
+ <updated>[% e.issued %]</updated>
+ <published>[% e.issued %]</published>
+ <summary><![CDATA[[% e.display %]]]></summary>
+</entry>
+[% END %]
+
+</feed>
+};
+
+$DEFAULT{rss_tt} = q{
+<?xml version="1.0"?>
+<?xml-stylesheet title="CSS_formatting" type="text/css" href="http://www.interglacial.com/rss/rss.css"?>
+<rss version="2.0"><channel>
+
+<link>[% url %]</link>
+<title>[% title %]</title>
+<description>[% description %]</description>
+<language>[% language %]</language>
+<lastBuildDate>[% last_build_date %]</lastBuildDate>
+<webMaster>[% admin_email %]</webMaster>
+
+<docs>http://www.interglacial.com/rss/about.html</docs>
+
+[% FOR e IN entries %]
+<item>
+ <title>[% e.title %]</title>
+ <link>[% e.link %]</link>
+ <description><![CDATA[[% e.display %]]]></description>
+ <dc:date>[% e.issued %]</dc:date>
+</item>
+[% END %]
+
+</channel></rss>
+};
+
+$DEFAULT{header_tt} = q {
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en-us">
+<head>
+<title>[% title %]</title>
+ <link href="/rss.xml" rel="alternate" type="application/rss+xml" title ="[% name %] RSS Feed" />
+ <link href="/atom.xml" rel="alternate" type="application/atom+xml" title ="[% name %] ATOM Feed" />
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+
+ <script type="text/javascript" src="https://apis.google.com/js/plusone.js"></script>
+</head>
+<body>
+<style>
+html {
+ margin: 0;
+ padding: 0;
+}
+body {
+ margin: 0;
+ padding: 0;
+ /* text-align: center;*/
+ width: 800px;
+ margin-left: auto;
+ margin-right: auto;
+ font-size: 16px;
+
+}
+#header_text {
+}
+
+.entry {
+ background-color: #DDD;
+ padding: 10px;
+ margin-top: 10px;
+ margin-bottom: 10px;
+
+ -moz-border-radius: 5px;
+ -webkit-border-radius: 5px;
+ border: 1px solid #000;
+}
+
+.postentry {
+ min-height: 220px;
+ height:auto !important;
+ min-height: 220px;
+}
+
+.left {
+ width: 675px;
+ position: relative;
+ background-color: #EEEEEE;
+
+ padding: 5px;
+
+ -moz-border-radius: 5px;
+ -webkit-border-radius: 5px;
+ border: 1px solid #000;
+
+}
+
+.entry_info {
+ margin-top: 10px;
+ width: 675px;
+ background-color: #E4E4E4;
+ padding: 5px;
+ -moz-border-radius: 5px;
+ -webkit-border-radius: 5px;
+ border: 1px solid #000;
+}
+
+.social_link {
+ float: right;
+ position: relative;
+ width: 70px;
+ background-color: #DFDFDF;
+ text-align: center;
+
+ padding: 5px;
+ -moz-border-radius: 5px;
+ -webkit-border-radius: 5px;
+ border: 1px solid #000;
+
+}
+
+
+.title {
+ font-size: 24px;
+ font-weight: bold;
+}
+.title a {
+ text-decoration: none;
+}
+</style>
+};
+
+$DEFAULT{footer_tt} = qq{
+<div>
+<div>
+Last updated: [% last_update %]
+</div>
+</div>
+
+[% IF clicky %]
+ <script src="//static.getclicky.com/js" type="text/javascript"></script>
+ <script type="text/javascript">try{ clicky.init([% clicky %]); }catch(e){}</script>
+ <noscript><p><img alt="Clicky" width="1" height="1" src="//in.getclicky.com/[% clicky %]ns.gif" /></p></noscript>
+[% END %]
+
+</body>
+</html>
+};
+
+$DEFAULT{index_tt} = q{
+ <h1>[% title %]</h1>
+ <div id="header_text">
+ Admin: [% admin_name %] [% admin_email %] <a href="/feeds.html">feeds</a>.
+ </div>
+
+[% FOR e IN entries %]
+ <div class="entry postentry">
+
+ <div class="social_link">
+ <a href="http://twitter.com/share" class="twitter-share-button"
+ data-text="[% e.title %]" data-url="[% e.link %]" data-count="vertical" data-via="szabgab">Tweet</a>
+ <script type="text/javascript" src="http://platform.twitter.com/widgets.js">
+ </script>
+
+ <script>reddit_url='[% e.link %]'</script>
+ <script>reddit_title='[% e.title %]'</script>
+ <script type="text/javascript" src="http://reddit.com/button.js?t=2"></script>
+
+
+ <g:plusone size="tall" href="[% e.link %]"></g:plusone>
+
+<!--
+ <a name="fb_share" type="box_count" class="fb_share"
+ share_url="[% e.link %]">Share</a>
+ <script src="http://static.ak.fbcdn.net/connect.php/js/FB.Share" type="text/javascript"></script>
+-->
+
+ </div>
+
+ <div class="left">
+ <div class="source"><a href="[% e.source_url %]">[% e.source_name %]</a></div>
+ <div class="title"><a href="[% e.link %]">[% e.title %]</a></div>
+ <div class="summary">
+ [% e.display %]
+ </div>
+ </div>
+ <div class="entry_info">
+ <div class="date">Posted on [% e.issued %]</div>
+ <div class="permalink">For the full article visit <a href="[% e.link %]">[% e.title %]</a></div>
+ </div>
+ </div>
+[% END %]
+};
+
+$DEFAULT{feeds_tt} = q{
+ <h1>[% name %]feeds</h1>
+ <a href="/">home</a>
+
+[% FOR e IN entries %]
+ <div class="entry">
+ <div class="title"><a href="[% e.url %]">[% e.title %]</a></div>
+ [% IF e.twitter %]
+ <div class="twitter"><a href="https://twitter.com/#!/[% e.twitter %]">@[% e.twitter %]</a></div>
+ [% END %]
+ <div class="latest">Latest: <a href="[% e.latest_entry.link %]">[% e.latest_entry.title %]</a> on [% e.latest_entry.issued %]</div>
+ </div>
+[% END %]
+
+</div>
+};
+
+
+1;
View
111 lib/Dwimmer/Feed/DB.pm
@@ -6,7 +6,7 @@ use Data::Dumper qw(Dumper);
use DateTime;
use DBI;
-our $VERSION = '0.27';
+our $VERSION = '0.28';
has 'store' => (is => 'ro', isa => 'Str', required => 1);
has 'dbh' => (is => 'rw', isa => 'DBI::db');
@@ -30,7 +30,7 @@ sub connect {
sub add_source {
my ($self, $e) = @_;
- my @fields = qw(title url feed comment status twitter);
+ my @fields = qw(title url feed comment status twitter site_id);
my $fields = join ', ', @fields;
my $placeholders = join ', ', (('?') x scalar @fields);
$self->dbh->do("INSERT INTO sources ($fields) VALUES($placeholders)",
@@ -60,10 +60,10 @@ sub find {
return $ref;
}
-sub add {
+sub add_entry {
my ($self, %args) = @_;
- my @fields = grep {defined $args{$_}} qw(id source_id link author issued title summary content tags);
+ my @fields = grep {defined $args{$_}} qw(id source_id link author issued title summary content tags site_id);
my $f = join ',', @fields;
my $p = join ',', (('?') x scalar @fields);
@@ -79,7 +79,8 @@ sub add {
# only deliver new things
my $NOT_TOO_OLD = 60*60*24;
if ($issued->epoch > time - $NOT_TOO_OLD) {
- $self->dbh->do(q{INSERT INTO delivery_queue (channel, entry) VALUES ('mail', ?)}, {}, $id);
+ $self->dbh->do(q{INSERT INTO delivery_queue (channel, entry, site_id) VALUES ('mail', ?, ?)},
+ {}, $id, $args{site_id});
}
return;
@@ -109,11 +110,13 @@ sub get_sources {
my ( $self, %opt ) = @_;
my $sql = 'SELECT * FROM sources';
- if ($opt{enabled}) {
- $sql .= ' WHERE status="enabled"';
+ my @fields = sort keys %opt;
+ if (%opt) {
+ $sql .= ' WHERE ';
+ $sql .= join ' AND ', map { "$_=?" } @fields;
}
my $sth = $self->dbh->prepare($sql);
- $sth->execute;
+ $sth->execute(@opt{@fields});
my @r;
while (my $h = $sth->fetchrow_hashref) {
push @r, $h;
@@ -130,40 +133,58 @@ sub get_source_by_id {
return $s;
}
+sub update_last_fetch {
+ my ($self, $source_id, $status, $error) = @_;
+ my $sql = qq{UPDATE sources SET last_fetch_time=?, last_fetch_status=?, last_fetch_error=? WHERE id=?};
+ $self->dbh->do($sql, undef, time(), $status, $error, $source_id);
-sub able {
- my ($self, $id, $able) = @_;
- $able = $able ? 'enabled' : 'disabled';
- my $sql = qq{UPDATE sources SET status = "$able" WHERE id=?};
- $self->dbh->do($sql, undef, $id);
+ return;
}
+
+
sub update {
my ($self, $id, $field, $value) = @_;
Carp::croak("Invalid field '$field'")
- if $field !~ m{^(feed|comment|twitter)$};
+ if $field !~ m{^(feed|comment|twitter|status)$};
+ Carp::croak("Invalid value for status '$value'")
+ if $field eq 'status' and $value !~ m{^(enabled|disabled)$};
my $sql = qq{UPDATE sources SET $field = ? WHERE id=?};
$self->dbh->do($sql, undef, $value, $id);
}
sub set_config {
- my ($self, $key, $value) = @_;
- $self->delete_config($key);
- $self->dbh->do('INSERT INTO config (key, value) VALUES (?, ?)', undef, $key, $value);
+ my ($self, %args) = @_;
+ foreach my $field (qw(key value site_id)) {
+ die "Missing $field" if not defined $args{$field};
+ }
+ $self->delete_config( %args );
+ $self->dbh->do('INSERT INTO config (key, value, site_id) VALUES (?, ?, ?)',
+ undef,
+ $args{key}, $args{value}, $args{site_id});
return;
}
+
sub delete_config {
- my ($self, $key) = @_;
- $self->dbh->do('DELETE FROM config WHERE key=?', undef, $key);
+ my ($self, %args) = @_;
+ foreach my $field (qw(key site_id)) {
+ die "Missing $field" if not defined $args{$field};
+ }
+ $self->dbh->do('DELETE FROM config WHERE key=? AND site_id=?', undef, $args{key}, $args{site_id});
return;
}
sub get_config {
- my ($self) = @_;
+ my ($self, %args) = @_;
- my $sth = $self->dbh->prepare('SELECT * FROM config ORDER BY key DESC');
- $sth->execute;
+ my $sql = 'SELECT * FROM config ';
+ if (defined $args{site_id}) {
+ $sql .= 'WHERE site_id=?';
+ }
+ $sql .= ' ORDER BY key DESC';
+ my $sth = $self->dbh->prepare($sql);
+ defined $args{site_id} ? $sth->execute($args{site_id}) : $sth->execute();;
my @results;
while (my $h = $sth->fetchrow_hashref) {
push @results, $h;
@@ -172,10 +193,16 @@ sub get_config {
return \@results;
}
sub get_config_hash {
- my ($self) = @_;
+ my ($self, %args) = @_;
- my $sth = $self->dbh->prepare('SELECT * FROM config ORDER BY key DESC');
- $sth->execute;
+ my $sql = 'SELECT * FROM config ';
+ if (defined $args{site_id}) {
+ $sql .= 'WHERE site_id=?';
+ }
+ $sql .= ' ORDER BY key DESC';
+
+ my $sth = $self->dbh->prepare($sql);
+ defined $args{site_id} ? $sth->execute($args{site_id}) : $sth->execute();
my %config;
while (my $h = $sth->fetchrow_hashref) {
$config{ $h->{key} } = $h->{value};
@@ -184,5 +211,39 @@ sub get_config_hash {
return \%config;
}
+sub addsite {
+ my ($self, %args) = @_;
+
+ return $self->dbh->do(q{INSERT INTO sites (name) VALUES (?)}, {}, $args{name});
+}
+
+sub get_site_id {
+ my ($self, $name) = @_;
+
+ my $ref = $self->dbh->selectrow_hashref('SELECT id FROM sites WHERE name = ?', {}, $name);
+ return $ref->{id};
+}
+
+sub get_site_by_id {
+ my ($self, $id) = @_;
+
+ my $ref = $self->dbh->selectrow_hashref('SELECT * FROM sites WHERE id = ?', {}, $id);
+ return $ref;
+}
+
+sub get_sites {
+ my ($self) = @_;
+
+ my $sql = 'SELECT * FROM sites';
+ my $sth = $self->dbh->prepare($sql);
+ $sth->execute;
+ my @r;
+ while (my $h = $sth->fetchrow_hashref) {
+ push @r, $h;
+ }
+
+ return \@r;
+}
+
1;
View
83 lib/Dwimmer/Feed/Sendmail.pm
@@ -1,10 +1,14 @@
package Dwimmer::Feed::Sendmail;
use Moose;
-our $VERSION = '0.27';
+our $VERSION = '0.28';
use Encode ();
+use LWP::UserAgent;
use MIME::Lite ();
+use Template;
+
+use Dwimmer::Feed::Config;
has 'db' => (is => 'rw', isa => 'Dwimmer::Feed::DB');
has 'store' => (is => 'ro', isa => 'Str', required => 1);
@@ -23,32 +27,50 @@ sub send {
my ($self) = @_;
my $entries = $self->db->get_queue( 'mail' );
+ my $sources = $self->db->get_sources;
foreach my $e (@$entries) {
- my $text = '';
- $text .= "Title: $e->{title}\n";
- $text .= "Link: $e->{link}\n\n";
- #$text .= "Source: $e->{source}\n\n";
- $text .= "Tags: $e->{tags}\n\n";
- $text .= "Author: $e->{author}\n\n";
- $text .= "Date: $e->{issued}\n\n";
- $text .= "Summary:\n$e->{summary}\n\n";
- #$text .= Encode::encode('UTF-8', "Content:\n$e->{content}\n\n");
- #$text .= "-------------------------------\n\n";
-
- my $html = qq{<html><head><title></title></head><body>\n};
- $html .= qq{<h1><a href="$e->{link}">$e->{title}</a></h1>\n};
- $html .= qq{<p>Link: $e->{link}</p>\n};
- #$html .= qq{<p>Source: $e->{source}</p>\n};
- $html .= qq{<p>Tags: $e->{tags}</p>\n};
- $html .= qq{<p>Author: $e->{author}</p>\n};
- $html .= qq{<p>Date: $e->{issued}</p>\n};
- $html .= qq{<hr><p>Summary:<br>$e->{summary}</p>\n};
-
- $html .= qq{<p><a href="http://twitter.com/home?status=$e->{title} $e->{link}">tweet</a></p>};
- $html .= qq{</body></html>\n};
-
- $self->_sendmail("Perl Feed: $e->{title}", { text => $text, html => $html } );
+ my ($source) = grep { $_->{id} eq $e->{source_id} } @$sources;
+
+ # fix redirection and remove parts after path
+ # This is temporarily here though it should be probably moved to the collector
+ my $ua = LWP::UserAgent->new;
+ my $t = Template->new();
+
+ @{ $ua->requests_redirectable } = ();
+
+ my $url = $e->{link};
+ my $response = $ua->get($url);
+
+ my $status = $response->status_line;
+ my %other;
+ $other{status} = $status;
+ if ( $response->code == 301 ) {
+ $url = $response->header('Location');
+ $other{redirected} = 1;
+ }
+
+ my $uri = URI->new($url);
+ $uri->fragment(undef);
+ $uri->query(undef);
+
+ $url = $uri->canonical;
+ $other{url} = $url;
+ $other{twitter_status} = $e->{title} . ($source->{twitter} ? " via \@$source->{twitter}" : '') . " $url";
+
+ my $site_id;
+ die "need site_id";
+ my $html_tt = Dwimmer::Feed::Config->get($self->db, $site_id, 'html_tt');
+ $t->process(\$html_tt, {e => $e, source => $source, other => \%other}, \my $html) or die $t->error;
+
+ my $text_tt = Dwimmer::Feed::Config->get($self->db, 'text_tt');
+ $t->process(\$text_tt, $e, \my $text) or die $t->error;
+
+ my $subject_tt = Dwimmer::Feed::Config->get($self->db, 'subject_tt');
+ $t->process(\$subject_tt, $e, \my $subject) or die $t->error;
+
+ next if not $self->_sendmail($subject, { text => $text, html => $html } );
+
$self->db->delete_from_queue('mail', $e->{id});
}
@@ -61,9 +83,13 @@ sub _sendmail {
main::LOG("Send Mail: $subject");
- my $config = $self->db->get_config_hash;
+ my $from = Dwimmer::Feed::Config->get($self->db, 'from');
+ if (not $from) {
+ warn "from field is required. Cannot send mail.\n";
+ return;
+ }
my $msg = MIME::Lite->new(
- From => ($config->{from} || 'dwimmer@dwimmer.org'),
+ From => $from,
To => 'szabgab@gmail.com',
Subject => $subject,
Type => 'multipart/alternative',
@@ -87,7 +113,8 @@ sub _sendmail {
$msg->attach($att);
}
- $msg->send;
+ return if not $msg->send;
+ return 1;
}
1;
View
2 lib/Dwimmer/Tools.pm
@@ -9,7 +9,7 @@ use YAML;
use Dwimmer::DB;
-our $VERSION = '0.27';
+our $VERSION = '0.28';
our $SCHEMA_VERSION = 2;
View
2 script/dbic.pl
@@ -19,7 +19,7 @@ BEGIN
my $temp = tempdir( CLEANUP => 0 );
my $root = File::Spec->catdir($temp, 'root');
-system "$^X -I$lib script/dwimmer_setup.pl --email dev\@dwimmer.org --password dwimmer --root $root";
+system "$^X -I$lib script/dwimmer_admin.pl --setup --email dev\@dwimmer.org --password dwimmer --root $root";
my $dbfile = File::Spec->catfile($root, 'db', 'dwimmer.db');
View
14 script/dwimmer
@@ -6,13 +6,22 @@ use Data::Dumper;
use Getopt::Long qw(GetOptions);
use Pod::Usage qw(pod2usage);
+use Dwimmer::Client;
+
+
my %opt;
GetOptions(\%opt,
+ 'version',
'url=s',
'username=s',
'password=s',
) or pod2usage();
+if ($opt{version}) {
+ say "Dwimmer Client: v$Dwimmer::Client::VERSION";
+ exit;
+}
+
$opt{username} ||= 'admin';
pod2usage() if not $opt{url} or not $opt{username} or not $opt{password};
@@ -24,9 +33,6 @@ my %commands = (
change_password => [qw(name password)],
);
-use Dwimmer::Client;
-
-
my $cmd = shift;
pod2usage() if not $cmd or $cmd eq 'help';
@@ -121,6 +127,8 @@ OPTIONAL PARAMETER:
--username OF_ADMINISTRATOR (admin by default)
+ --version to show the version number of the Dwimmer
+
REQUIRED PARAMETERS:
--password OF_ADMINISTRATOR
View
133 script/dwimmer_setup.pl → script/dwimmer_admin.pl
@@ -6,15 +6,15 @@
use Cwd qw(abs_path);
use DBIx::RunSQL;
use Email::Valid;
-use File::Basename qw(dirname);
+use File::Basename qw(dirname basename);
use File::Copy::Recursive;
use File::Find::Rule;
use File::Path qw(mkpath);
use File::Spec;
use File::ShareDir;
use Getopt::Long qw(GetOptions);
-use String::Random;
use Pod::Usage qw(pod2usage);
+use String::Random;
use Dwimmer::Tools qw(sha1_base64 save_page _get_db);
@@ -26,17 +26,36 @@
'dbonly',
'silent',
'share=s',
+
+ 'setup',
'upgrade',
- 'resetpw',
+
'username=s',
+
+ 'resetpw',
+ 'listusers',
+ 'showuser',
+ 'verify=s',
);
usage() if not $opt{root};
+if ($opt{setup}) {
+ if (-e $opt{root} and not $opt{dbonly}) {
+ die "Root directory ($opt{root}) already exists"
+ }
-if ($opt{resetpw}) {
+ usage() if not $opt{email};
+ die 'Invalid e-mail' if not Email::Valid->address($opt{email});
+ usage() if not $opt{password};
+ die 'Password needs to be at least 6 characters' if length $opt{password} < 6;
+} else {
if (not -e $opt{root}) {
die "Root directory ($opt{root}) does NOT exist.";
}
+}
+
+
+if ($opt{resetpw}) {
if (not $opt{password}) {
die "Need password to set it";
}
@@ -55,25 +74,64 @@
exit;
}
-if (-e $opt{root} and not $opt{dbonly} and not $opt{upgrade}) {
- die "Root directory ($opt{root}) already exists"
+if (defined $opt{verify}) {
+ die if $opt{verify} ne '0' and $opt{verify} ne '1';
+ if (not -e $opt{root}) {
+ die "Root directory ($opt{root}) does NOT exist.";
+ }
+ if (not $opt{username}) {
+ die "Need username to verify";
+ }
+
+ $ENV{DWIMMER_ROOT} = $opt{root};
+ my $db = _get_db();
+ my $user = $db->resultset('User')->find( { name => $opt{username} } );
+ die "User was not found" if not $user;
+ $user->verified( $opt{verify} );
+ $user->update;
+
+ exit;
}
-if ($opt{upgrade} and not -e $opt{root}) {
- die "Root directory ($opt{root}) does NOT exist."
+if ($opt{listusers}) {
+ $ENV{DWIMMER_ROOT} = $opt{root};
+ my $db = _get_db();
+ my @users = $db->resultset('User')->all();
+ die "No user was found" if not @users;
+ foreach my $u (@users) {
+ printf("%4s '%s'\n", $u->id, $u->name);
+ }
+
+ exit;
}
-if (not $opt{upgrade}) {
- usage() if not $opt{email};
- die 'Invalid e-mail' if not Email::Valid->address($opt{email});
- usage() if not $opt{password};
- die 'Password needs to be 6 characters' if length $opt{password} < 6;
+if ($opt{showuser}) {
+ if (not $opt{username}) {
+ die "Need username to ";
+ }
+
+ $ENV{DWIMMER_ROOT} = $opt{root};
+ my $db = _get_db();
+ my $user = $db->resultset('User')->find( { name => $opt{username} } );
+ die "User was not found" if not $user;
+ foreach my $key (qw(id name email fname lname country state validation_key verified register_ts)) {
+ say "$key " . ($user->$key // '');
+ }
+
+ exit;
}
-my $dist_dir;
+
+if (not $opt{upgrade} and not $opt{setup}) {
+ usage();
+}
+
+
+
# When we are in the development environment (have .git) set this to the root directory
# When we are in the installation environment (have Makefile.PL) set this to the share/ subdirectory
+my $dist_dir;
if (-e File::Spec->catdir(dirname(dirname abs_path($0)) , '.git') ) {
$dist_dir = dirname(dirname abs_path($0))
} elsif (-e File::Spec->catdir(dirname(dirname abs_path($0)) , 'Makefile.PL') ) {
@@ -119,7 +177,7 @@
my @upgrade_from;
foreach my $sql ( glob File::Spec->catfile($dist_dir, 'schema', '*.sql' ) ) {
- next if $sql !~ m{/\d+\.sql$};
+ next if basename($sql) !~ m{^\d+\.sql$};
push @upgrade_from, sub {
my $dbfile = shift;
@@ -133,7 +191,10 @@
upgrades($dbfile);
+say 'You can now launch the application and visit the web site';
+
exit;
+##################################################################
sub setup_db {
my $dbfile = shift;
@@ -151,7 +212,7 @@ sub setup_db {
my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile");
my $time = time;
my $validation_key = String::Random->new->randregex('[a-zA-Z0-9]{10}') . $time . String::Random->new->randregex('[a-zA-Z0-9]{10}');
- $dbh->do('INSERT INTO user (name, sha1, email, validation_key, verified, register_ts) VALUES(?, ?, ?, ?, ?, ?)',
+ $dbh->do('INSERT INTO user (name, sha1, email, validation_key, verified, register_ts) VALUES(?, ?, ?, ?, ?, ?)',
{},
'admin', sha1_base64($opt{password}), $opt{email}, $validation_key, 1, $time);
@@ -170,11 +231,7 @@ sub setup_db {
return if $opt{silent};
- print <<"END_MSG";
-Database created.
-
-You can now launch the application and visit the web site
-END_MSG
+ say 'Database created.';
return;
}
@@ -197,31 +254,51 @@ sub usage {
=head1 SYNOPSIS
+=head2 Required parameter:
+
+ --root PATH/TO/ROOT path to the root of the installation
-To setup a new instance:
+=head2 To setup a new instance:
+ --setup
--email email of administrator
--password PASSWORD of administrator
- --root ROOT path to the root of the installation
Optional parameters:
--dbonly Create only the database (for development)
--silent no success report (for testing)
-
-To upgrade run:
+=head2 To upgrade run:
--upgrade
- --root PATH/TO/ROOT
-To reset password give the following flags:
+=head2 Admin tools:
+
+=over 4
+
+=item * List users:
+
+ --listusers
+
+=item * Show details of a user:
+
+ --showuser
+ --username USERNAME
+
+=item * Set or remove verified bit of a user:
+
+ --verify [0|1]
+ --username USERNAME
+
+=item * Set the password of a specific user:
--resetpw
- --root PATH/TO/ROOT
--username USERNAME
--password PASSWORD
+=back
+
=cut
View
209 script/dwimmer_feed_admin.pl
@@ -0,0 +1,209 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use v5.8;
+
+use Dwimmer::Feed::Admin;
+
+use Data::Dumper qw(Dumper);
+use Getopt::Long qw(GetOptions);
+
+my %opt;
+GetOptions(\%opt,
+ 'store=s',
+
+ 'setup',
+
+ 'site=s',
+
+ 'addsite=s',
+ 'listsite',
+
+ 'listsource:s',
+ 'enable=i',
+ 'disable=i',
+ 'update=i',
+ 'add',
+
+ 'listconfig',
+ 'config=s',
+ 'unconfig=s',
+
+ 'listqueue=s',
+ 'listentries',
+) or usage();
+usage() if not $opt{store};
+
+if ($opt{setup}) {
+ setup($opt{store});
+ exit;
+}
+
+usage("Database ($opt{store}) does NOT exist") if not -e $opt{store};
+
+my $admin = Dwimmer::Feed::Admin->new(%opt);
+
+if ($opt{addsite}) {
+ $admin->db->addsite( name => $opt{addsite} );
+ exit;
+}
+if ($opt{listsite}) {
+ $admin->list_sites();
+ exit;
+}
+
+$opt{site} ||= '';
+
+if (exists $opt{listsource}) {
+ $admin->list_source( filter => ($opt{listsource} || ''), site => $opt{site} );
+} elsif ( defined $opt{enable} ) {
+# usage('--site SITE required for this operation') if not $opt{site};
+ $admin->update( id => $opt{enable}, field => 'status', value =>'enabled' );
+} elsif ( defined $opt{disable} ) {
+# usage('--site SITE required for this operation') if not $opt{site};
+ $admin->update( id => $opt{disable}, field => 'status', value => 'disabled' );
+} elsif ( defined $opt{update} ) {
+ my $str = shift;
+ usage('Need update value') if not $str;
+ my ($field, $value) = split /=/, $str;
+ $admin->update( id => $opt{update}, field => $field, value => $value );
+} elsif (exists $opt{add}) {
+ usage('--site SITE required for this operation') if not $opt{site};
+ $admin->add( site => $opt{site} );
+} elsif ($opt{listconfig}) {
+ $admin->list_config($opt{site});
+} elsif ($opt{unconfig}) {
+ usage('--site SITE required for this operation') if not $opt{site};
+ my $site_id = $admin->db->get_site_id($opt{site});
+ $admin->db->delete_config( key => $opt{unconfig}, site_id => $site_id );
+} elsif ($opt{config}) {
+ usage('--site SITE required for this operation') if not $opt{site};
+ my $value = shift;
+ usage('') if not defined $value;
+
+ my $site_id = $admin->db->get_site_id( $opt{site} );
+ die("Could not find site '$opt{site}'") if not $site_id;
+ $admin->db->set_config( key => $opt{config}, value => $value, site_id => $site_id );
+} elsif ($opt{listqueue}) {
+ my $entries = $admin->db->get_queue( $opt{listqueue} );
+ print Dumper $entries;
+} elsif ($opt{listentries}) {
+ my $entries = $admin->db->get_all_entries;
+ print Dumper $entries;
+} else {
+ usage();
+}
+exit;
+##############################
+
+sub setup {
+ my ($store) = @_;
+
+ usage("Database ($store) already exists") if -e $store;
+
+my $SCHEMA = <<'SCHEMA';
+CREATE TABLE sites (
+ id INTEGER PRIMARY KEY,
+ name VARCHAR(100) UNIQUE NOT NULL
+);
+
+CREATE TABLE sources (
+ id INTEGER PRIMARY KEY,
+ title VARCHAR(100),
+ url VARCHAR(100) NOT NULL,
+ feed VARCHAR(100) NOT NULL,
+ comment BLOB,
+ twitter VARCHAR(30),
+ status VARCHAR(30),
+ site_id INTEGER NOT NULL,
+ last_fetch_time VARCHAR(10),
+ last_fetch_status VARCHAR(10),
+ last_fetch_error BLOB,
+ CONSTRAINT url_site UNIQUE (url, site_id),
+ CONSTRAINT feed_site UNIQUE (feed, site_id),
+ FOREIGN KEY (site_id) REFERENCES sites(id)
+);
+
+CREATE TABLE entries (
+ id INTEGER PRIMARY KEY,
+ source_id INTEGER NOT NULL,
+ link VARCHAR(100) NOT NULL,
+ site_id INTEGER NOT NULL,
+ remote_id VARCHAR(100),
+ author VARCHAR(100),
+ issued VARCHAR(100),
+ title VARCHAR(100),
+ summary BLOB,
+ content BLOB,
+ tags VARCHAR(100),
+ FOREIGN KEY (source_id) REFERENCES sources(id),
+ FOREIGN KEY (site_id) REFERENCES sites(id)
+);
+CREATE TABLE delivery_queue (
+ channel VARCHAR(30) NOT NULL,
+ entry INTEGER NOT NULL,
+ site_id INTEGER NOT NULL,
+ FOREIGN KEY (site_id) REFERENCES sites(id),
+ FOREIGN KEY (entry) REFERENCES entries(id)
+);
+CREATE TABLE config (
+ key VARCHAR(100) NOT NULL,
+ value VARCHAR(255),
+ site_id INTEGER NOT NULL,
+ CONSTRAINT key_site UNIQUE (key, site_id),
+ FOREIGN KEY (site_id) REFERENCES sites(id)
+)
+SCHEMA
+
+ my $db = Dwimmer::Feed::DB->new( store => $store );
+ $db->connect;
+
+ foreach my $sql (split /;/, $SCHEMA) {
+ $db->dbh->do($sql);
+ }
+}
+
+
+sub usage {
+ my $text = shift || '';
+
+ die <<"END_USAGE";
+$text
+
+Usage: $0
+
+Required:
+ --store storage.db (link to the SQLite database holding everyting)
+
+Optional:
+ --site [SITE|ID]
+ (optional for --listsource and --listconfig, --config, --unconfig)
+ (required for --add)
+ (irrelevant to --setup, --addsite and --update --endable --disable)
+
+Actions:
+
+ --setup (creating the empty database)
+
+ --addsite SITE (one word, not only digits!)
+ --listsite (listing all the sites in the database)
+
+
+ --add (add a new feed, will prompt questions)
+ --listsource [filter] (list sources. the filter is optional)
+ --enable ID
+ --disable ID
+
+ --update ID "feed=http://..."
+ --update ID "comment=some text here"
+ --update ID "twitter=twitter_id"
+
+ --listconfig
+ --config key value
+ --unconfig key
+
+ --listqueue CHANNEL (e.g. mail)
+
+ --listentries Show all the entries
+END_USAGE
+}
View
19 script/feed_collector.pl → script/dwimmer_feed_collector.pl
@@ -14,28 +14,30 @@
'collect',
'sendmail',
- 'html=s',
+ 'html',
) or usage();
-usage() if not $opt{store};
+usage('Missing --store') if not $opt{store};
+usage('At least one of --collect --html --sendmail is needed')
+ if not $opt{collect} and not $opt{html} and not $opt{sendmail}; # and not $opt{twitter};
my $t0 = time;
my $collector = Dwimmer::Feed::Collector->new(%opt);
if ($opt{collect}) {
- $collector->collect();
+ $collector->collect_all();
}
if ($opt{html}) {
- $collector->generate_html( $opt{html} );
+ $collector->generate_html_all();
}
if ($opt{sendmail}) {
my $mail = Dwimmer::Feed::Sendmail->new(%opt);
$mail->send;
}
-if ($opt{tweet}) {
+if ($opt{twitter}) {
# TODO: tweet
}
@@ -49,7 +51,12 @@ sub LOG {
}
sub usage {
- die "Usage: $0 --store storage.db [--collect --sendmail --html DIR]\n";
+ my $txt = shift;
+ if ($txt) {
+ print STDERR "**** $txt\n\n";
+ }
+ print STDERR "Usage: $0 --store storage.db [--collect --sendmail --html DIR]\n";
+ exit 1;
}
View
61 script/dwimmer_feed_setup.pl
@@ -1,61 +0,0 @@
-#!/usr/bin/perl
-use strict;
-use warnings;
-use v5.8;
-
-use Dwimmer::Feed::DB;
-
-use JSON qw(from_json);
-use File::Slurp qw(read_file);
-
-
-my $SCHEMA = <<'SCHEMA';
-CREATE TABLE sources (
- id INTEGER PRIMARY KEY,
- title VARCHAR(100),
- url VARCHAR(100) UNIQUE NOT NULL,
- feed VARCHAR(100) UNIQUE NOT NULL,
- comment BLOB,
- twitter VARCHAR(30),
- status VARCHAR(30)
-);
-
-CREATE TABLE entries (
- id INTEGER PRIMARY KEY,
- source_id INTEGER NOT NULL,
- link VARCHAR(100) UNIQUE NOT NULL,
- remote_id VARCHAR(100),
- author VARCHAR(100),
- issued VARCHAR(100),
- title VARCHAR(100),
- summary BLOB,
- content BLOB,
- tags VARCHAR(100),
- FOREIGN KEY (source_id) REFERENCES sources(id)
-);
-CREATE TABLE delivery_queue (
- channel VARCHAR(30) NOT NULL,
- entry INTEGER NOT NULL,
- FOREIGN KEY (entry) REFERENCES entries(id)
-);
-CREATE TABLE config (
- key VARCHAR(100) UNIQUE NOT NULL,
- value VARCHAR(255)
-)
-SCHEMA
-
-my ($store, $sources_json) = @ARGV;
-
-my $db = Dwimmer::Feed::DB->new( store => $store );
-$db->connect;
-
-foreach my $sql (split /;/, $SCHEMA) {
- $db->dbh->do($sql);
-}
-
-my $sources = from_json scalar read_file $sources_json, binmode => ':utf8';
-
-for my $e ( @{ $sources->{feeds}{entries} } ) {
- $db->add_source($e);
-};
-
View
76 script/feed_admin.pl
@@ -1,76 +0,0 @@
-#!/usr/bin/perl
-use strict;
-use warnings;
-use v5.8;
-
-use Dwimmer::Feed::Admin;
-
-use Data::Dumper qw(Dumper);
-use Getopt::Long qw(GetOptions);
-
-my %opt;
-GetOptions(\%opt,
- 'store=s',
-
- 'list:s',
- 'enable=i',
- 'disable=i',
- 'update=i',
- 'add',
-
- 'listconfig',
- 'config=s',
- 'unconfig=s',
-) or usage();
-usage() if not $opt{store};
-
-my $admin = Dwimmer::Feed::Admin->new(%opt);
-if (exists $opt{list}) {
- $admin->list( $opt{list} );
-} elsif ( defined $opt{enable} ) {
- $admin->enable( $opt{enable} );
-} elsif ( defined $opt{disable} ) {
- $admin->disable( $opt{disable} );
-} elsif ( defined $opt{update} ) {
- my $str = shift;
- usage('Need update value') if not $str;
- my ($field, $value) = split /=/, $str;
- $admin->update($opt{update}, $field, $value);
-} elsif (exists $opt{add}) {
- $admin->add;
-} elsif ($opt{listconfig}) {
- $admin->list_config();
-} elsif ($opt{unconfig}) {
- $admin->db->delete_config( $opt{unconfig} );
-} elsif ($opt{config}) {
- my $value = shift;
- usage('') if not defined $value;
- $admin->db->set_config( $opt{config}, $value);
-} else {
- usage();
-}
-
-
-sub usage {
- my $text = shift || '';
-
- die <<"END_USAGE";
-$text
-
-Usage: $0
- --store storage.db
-
-
- --list [filter]
- --enable ID
- --disable ID
-
- --update ID "feed=http://..."
- --update ID "comment=some text here"
- --update ID "twitter=twitter_id"
-
- --listconfig
- --config key value
- --unconfig key
-END_USAGE
-}
View
15 t/010_subscribe.t
@@ -17,8 +17,9 @@ plan( skip_all => 'Unsupported OS' ) if not $run;
my $url = "http://localhost:$ENV{DWIMMER_PORT}";
-plan( tests => 26 );
+plan( tests => 30 );
+require Test::Differences;
use Dwimmer::Client;
@@ -60,6 +61,7 @@ END_VALIDATE
my $confirm_template = <<'END_CONFIRM';
END_CONFIRM
+