Initial checkin.
Signed-off-by: Thomas Hochstein <thh@thh.name>
This commit is contained in:
commit
30132626b8
68 changed files with 5497 additions and 0 deletions
261
MOD/DBIUtils.pm
Normal file
261
MOD/DBIUtils.pm
Normal file
|
|
@ -0,0 +1,261 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: DBIUtils.pm 305 2011-12-26 19:51:53Z root $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::DBIUtils;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use Carp qw( confess );
|
||||
|
||||
use DBI();
|
||||
use MOD::Utils qw(read_private_config);
|
||||
use News::Article();
|
||||
use MOD::DBIUtilsPublic();
|
||||
use Digest::SHA1();
|
||||
|
||||
push @MOD::DBIUtils::ISA,'MOD::DBIUtilsPublic';
|
||||
|
||||
######################################################################
|
||||
sub enter_table($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$article,$status,$spamcount) = @_;
|
||||
my %tmphash;
|
||||
for my $headerdata (qw(Reply-To Subject Message-ID)) {
|
||||
$tmphash{$headerdata} = defined($article->header($headerdata)) ? $article->header($headerdata) : ' ';
|
||||
}
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $body = join("\n", $article->body());
|
||||
|
||||
my @columns = (
|
||||
'Sender',
|
||||
'ReplyTo',
|
||||
'Subject',
|
||||
'MessageID',
|
||||
'Spamcount',
|
||||
'Status',
|
||||
'Header',
|
||||
'Body',
|
||||
'Datum',
|
||||
'checksum'
|
||||
);
|
||||
my @values = (
|
||||
$article->header('From'),
|
||||
$tmphash{'Reply-To'},
|
||||
$tmphash{'Subject'},
|
||||
$tmphash{'Message-ID'},
|
||||
$spamcount,
|
||||
$status,
|
||||
join("\n", $article->headers()),
|
||||
$body,
|
||||
);
|
||||
|
||||
my $value_format = '?,?,?,?,?,?,?,?,NOW(),SHA1(Body)';
|
||||
if ($status eq 'moderated')
|
||||
{
|
||||
push @columns, 'Moddatum';
|
||||
$value_format .= ',NOW()';
|
||||
}
|
||||
|
||||
my $rc = $self->{'dbh'}->do(
|
||||
'INSERT IGNORE INTO ' . $table .
|
||||
' (' . join(',', @columns) . ')' .
|
||||
' VALUES(' . $value_format . ')',
|
||||
undef,
|
||||
@values
|
||||
);
|
||||
if ($rc != 1)
|
||||
{
|
||||
my $msg = 'enter_table failed';
|
||||
my $article_id = undef;
|
||||
|
||||
my $age = $self->{'config'}->{'check_duplicates_age'} || 7;
|
||||
my $sha1 = Digest::SHA1::sha1_hex($body);
|
||||
my $stmt = $self->{'dbh'}->prepare(
|
||||
"SELECT id\n" .
|
||||
"\nFROM " . $table .
|
||||
"\nWHERE checksum=?" .
|
||||
"\nAND Datum < DATE_SUB(CURDATE(), INTERVAL ? DAY);"
|
||||
);
|
||||
$stmt->execute($sha1, $age);
|
||||
my $row = $stmt->fetchrow_arrayref;
|
||||
if ($row)
|
||||
{
|
||||
( $article_id ) = @$row;
|
||||
$msg = 'Duplicate received';
|
||||
}
|
||||
|
||||
$msg .= "\n*** sha1_hex(\$body) ***\n" . $sha1;
|
||||
for(my $i = 0; $i <= $#values; $i++)
|
||||
{
|
||||
if ($values[$i])
|
||||
{
|
||||
$msg .= "\n*** " . $columns[$i] . "***\n" . $values[$i];
|
||||
}
|
||||
}
|
||||
$self->increase_errorlevel($article_id, $msg);
|
||||
}
|
||||
return $rc;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub select_unposted($)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query = $self->{'dbh'}->prepare(
|
||||
"SELECT ID, CONCAT(header,\"\\n\\n\",body)\n" .
|
||||
"FROM $table\n" .
|
||||
"WHERE status='moderated'");
|
||||
$query->execute();
|
||||
return $query;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub set_posted_status($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id,$mid) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
$self->{'dbh'}->do(
|
||||
"UPDATE $table\n" .
|
||||
"SET status='posted', MessageID=(?)\n" .
|
||||
"WHERE ID=(?)\n" .
|
||||
"AND (status = 'moderated' OR status = 'sending')",
|
||||
undef, $mid, $id
|
||||
);
|
||||
$self->{'dbh'}->do(
|
||||
"DELETE FROM ${table}_error\n" .
|
||||
"WHERE article_id=(?)\n",
|
||||
undef, $id
|
||||
);
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub delete_posting($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
$self->{'dbh'}->do(
|
||||
"DELETE FROM $table" .
|
||||
"\nWHERE ID=(?)" .
|
||||
"\nAND status <> 'pending'" .
|
||||
"\nAND status <> 'sending'",
|
||||
undef, $id
|
||||
);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub select_old_postings($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$end,$start,$status) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query =
|
||||
"SELECT ID, CONCAT(header,\"\\n\\n\",body)" .
|
||||
"\nFROM $table" .
|
||||
"\nWHERE status <> 'pending'" .
|
||||
"\nAND Datum < DATE_SUB(CURDATE(), INTERVAL ? DAY)";
|
||||
my @values = ( $end );
|
||||
if (defined($start)) {
|
||||
$query .= "\nAND Datum > DATE_SUB(CURDATE(), INTERVAL ? DAY)";
|
||||
push @values, $start;
|
||||
}
|
||||
if (defined($status)) {
|
||||
$query .= "\nAND status=?";
|
||||
push @values, $status;
|
||||
}
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute(@values);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub delete_old_errors($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $end, $start, $status) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query =
|
||||
"DELETE FROM ${table}_error" .
|
||||
"\nWHERE error_date < DATE_SUB(CURDATE(), INTERVAL ? DAY)";
|
||||
my @values = ( $end );
|
||||
if (defined($start)) {
|
||||
$query .= "\nAND error_date > DATE_SUB(CURDATE(), INTERVAL ? DAY)";
|
||||
push @values, $start;
|
||||
}
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute(@values);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub select_pending($)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || die;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query =
|
||||
"select DISTINCT(if (length(replyto) > 1,replyto,sender)) AS Adresse" .
|
||||
"\nFROM ${table}" .
|
||||
"\nwhere status='pending'" .
|
||||
"\nAND datum < DATE_SUB(NOW(), INTERVAL ? HOUR)" .
|
||||
"\nAND datum > DATE_SUB(NOW(), INTERVAL ? HOUR)";
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute(
|
||||
$self->{'config'}->{'min_time_until_autoreply'},
|
||||
$self->{'config'}->{'max_time_until_autoreply'}
|
||||
);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub increase_errorlevel($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $article_id, $reason) = @_;
|
||||
|
||||
my $query = sprintf(
|
||||
"INSERT INTO %s_error\n" .
|
||||
"(article_id, error_date, error_count, error_message)\n" .
|
||||
"VALUES (?, NOW(), 1, ?)\n" .
|
||||
"ON DUPLICATE KEY UPDATE\n" .
|
||||
" error_count = IF(error_count + 1 > 100, 100, error_count + 1),\n" .
|
||||
" error_date = NOW(),\n" .
|
||||
" error_message=(?)",
|
||||
$self->{'config'}->{'mysql_table'}
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($article_id, $reason, $reason);
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub check_subject($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$subject) = @_;
|
||||
my $query = $self->{'dbh'}->prepare("select count(subject) from $self->{'config'}->{'mysql_table'} where subject=(?) and status='spam';");
|
||||
$query->execute($subject);
|
||||
my ($result) = @{$query->fetchrow_arrayref};
|
||||
return $result;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
478
MOD/DBIUtilsPublic.pm
Normal file
478
MOD/DBIUtilsPublic.pm
Normal file
|
|
@ -0,0 +1,478 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: DBIUtilsPublic.pm 267 2010-05-27 19:46:57Z alba $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::DBIUtilsPublic;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use DBI;
|
||||
use News::Article;
|
||||
use Carp qw(confess);
|
||||
use Time::Local;
|
||||
|
||||
sub display_single;
|
||||
sub set_status;
|
||||
sub set_status_by_moderator;
|
||||
sub displayrange;
|
||||
sub get_working_by_id;
|
||||
sub get_reason;
|
||||
sub set_rejected;
|
||||
sub get_statistics;
|
||||
|
||||
# 'spam' can be put back to 'pending' queue
|
||||
# 'moderated' tells poster.pl to send the message via NNTP (there is
|
||||
# no safe way to undo this)
|
||||
# 'rejected' means that a mail was sent the poster - cannot be undone
|
||||
# 'deleted' can be put back to 'pending' queue
|
||||
# 'posted' means that message was sent to server - cannot be undone
|
||||
|
||||
use constant NOT_FINAL =>
|
||||
"status <> 'rejected' AND status <> 'posted' AND status <> 'sending'";
|
||||
|
||||
######################################################################
|
||||
# Constructor, open a new connection to the database
|
||||
######################################################################
|
||||
sub new($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($class,$configref) = @_;
|
||||
my $self = {};
|
||||
$self->{'config'} = $configref;
|
||||
$self->{'dsn'} = "DBI:mysql:database=$self->{'config'}->{'mysql_db'};host=$self->{'config'}->{'mysql_host'};port=$self->{'config'}->{'mysql_port'}";
|
||||
$self->{'dbh'} = DBI->connect($self->{'dsn'},$self->{'config'}->{'mysql_username'},$self->{'config'}->{'mysql_password'},
|
||||
{ RaiseError => 1})
|
||||
or die($DBI::errstr);
|
||||
|
||||
bless $self,$class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
##Die nachfolgenden Methoden sind fuer den Gebrauch im Webinterface bestimmt, alle Methoden, die den Zustand der DB
|
||||
##aendern, muessen idempotent sein!
|
||||
|
||||
######################################################################
|
||||
# Update the Status of a posting
|
||||
######################################################################
|
||||
sub set_status($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $id, $newstatus, $prevstatus) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query =
|
||||
"UPDATE $table" .
|
||||
"\nSET status=(?)" .
|
||||
"\nWHERE id=(?)";
|
||||
if ($prevstatus)
|
||||
{
|
||||
$query .= "\nAND (\n status = '";
|
||||
$query .= join("'\n OR status = '", @$prevstatus);
|
||||
$query .= "'\n)";
|
||||
}
|
||||
else
|
||||
{
|
||||
$query .= "\nAND " . NOT_FINAL;
|
||||
}
|
||||
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
return $stmt->execute($newstatus, $id);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# Update the Status of a posting
|
||||
######################################################################
|
||||
sub set_status_by_moderator()
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $newstatus, $id, $moderator) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
$self->{'dbh'}->do(
|
||||
"UPDATE $table" .
|
||||
"\nSET status=(?), Moderator=(?), Moddatum=NOW()" .
|
||||
"\nWHERE id=(?)" .
|
||||
"\nAND " . NOT_FINAL,
|
||||
undef, $newstatus, $moderator, $id
|
||||
);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub set_rejected($$$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $newstatus, $article_id, $moderator, $reply) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
$self->set_status_by_moderator($newstatus, $article_id, $moderator);
|
||||
|
||||
my $query = sprintf(
|
||||
"INSERT INTO %s_reply\n" .
|
||||
"(article_id, reply_date, reply_message)\n" .
|
||||
"VALUES (?, NOW(), ?)\n" .
|
||||
"ON DUPLICATE KEY UPDATE\n" .
|
||||
" reply_date = NOW(),\n" .
|
||||
" reply_message=(?)",
|
||||
$table
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($article_id, $reply, $reply);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub set_reply($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $article_id, $reply) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query = sprintf(
|
||||
"INSERT INTO %s_reply\n" .
|
||||
"(article_id, reply_date, reply_message)\n" .
|
||||
"VALUES (?, NOW(), ?)\n" .
|
||||
"ON DUPLICATE KEY UPDATE\n" .
|
||||
" reply_date = NOW(),\n" .
|
||||
" reply_message=(?)",
|
||||
$table
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($article_id, $reply, $reply);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# Display a range out of a table
|
||||
######################################################################
|
||||
sub displayrange($$$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$status,$start,$number_of_results,$overviewref) = @_;
|
||||
$start = 0 if ($start !~ /^\d+$/);
|
||||
$number_of_results = 1 if ($number_of_results !~ /^\d+$/);
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'}
|
||||
|| confess 'No "mysql_table" in config';
|
||||
|
||||
my $query = sprintf(
|
||||
"SELECT %s" .
|
||||
"\nFROM %s" .
|
||||
"\nWHERE status=(?)" .
|
||||
"\nORDER BY ID DESC" .
|
||||
"\nLIMIT %d,%d",
|
||||
join(',', @$overviewref),
|
||||
$table,
|
||||
$start, $number_of_results
|
||||
);
|
||||
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($status);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# display a single entry of a table
|
||||
######################################################################
|
||||
sub display_single($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$status,$id) = @_;
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query =
|
||||
"SELECT CONCAT(header, \"\\n\\n\", body)," .
|
||||
"\n Status," .
|
||||
"\n Spamcount," .
|
||||
"\n Moderator," .
|
||||
"\n Moddatum AS 'Decision Date'," .
|
||||
"\n Flag" .
|
||||
"\nFROM $table" .
|
||||
"\nWHERE id=(?)";
|
||||
my @param = ( $id );
|
||||
|
||||
if ($status)
|
||||
{
|
||||
$query .= "\nAND Status=(?)";
|
||||
push @param, $status;
|
||||
}
|
||||
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute(@param);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub set_status_posted($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id,$user) = @_;
|
||||
return $self->set_status_by_moderator('moderated', $id, $user);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_working_by_id($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query = $self->{'dbh'}->prepare(
|
||||
"SELECT" .
|
||||
"\n CONCAT(header,\"\\n\\n\",body) AS Posting," .
|
||||
"\n if (length(replyto) > 1,replyto,sender) AS Adresse" .
|
||||
"\nFROM $table" .
|
||||
"\nWHERE ID=(?)" .
|
||||
"\nAND " . NOT_FINAL
|
||||
);
|
||||
$query->execute($id);
|
||||
return $query;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_reason($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query = $self->{'dbh'}->prepare(
|
||||
"SELECT reply_message" .
|
||||
"\nFROM ${table}, ${table}_reply" .
|
||||
"\nWHERE ${table}.id = ${table}_reply.article_id" .
|
||||
"\nAND article_id=(?)" .
|
||||
"\nAND (status='rejected' OR status='deleted')
|
||||
");
|
||||
$query->execute($id);
|
||||
return $query;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_errors($$$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$status,$start,$number_of_results,$overviewref) = @_;
|
||||
$start = 0 if ($start !~ /^\d+$/);
|
||||
$number_of_results = 1 if ($number_of_results !~ /^\d+$/);
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query = sprintf(
|
||||
"SELECT %s" .
|
||||
"\nFROM %s_error_view" .
|
||||
"\nORDER BY error_date DESC" .
|
||||
"\nLIMIT %d, %d",
|
||||
join(',', @$overviewref),
|
||||
$table,
|
||||
$start, $number_of_results
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute();
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_errormessage($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query = sprintf(
|
||||
"SELECT error_message" .
|
||||
"\nFROM %s_error" .
|
||||
"\nWHERE error_id=(?)",
|
||||
$table
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($id);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub invert_flag($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
$self->{'dbh'}->do(
|
||||
"UPDATE $table" .
|
||||
"\nSET flag = !flag" .
|
||||
"\nWHERE ID=(?)" .
|
||||
"\nAND " . NOT_FINAL,
|
||||
undef, $id
|
||||
);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub calc_item_stats($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($r_result, $r_items) = @_;
|
||||
|
||||
my @items = sort { $a <=> $b }( @$r_items );
|
||||
return undef unless($#items >= 0);
|
||||
|
||||
my $sum = 0;
|
||||
for my $i( @items ) { $sum += $i; }
|
||||
|
||||
my $nr_items = 1 + $#items;
|
||||
my $pivot = int($nr_items / 2);
|
||||
my $median = $items[$pivot];
|
||||
if (($nr_items % 2) == 0)
|
||||
{
|
||||
$median = ( $median + $items[$pivot - 1] ) / 2;
|
||||
}
|
||||
|
||||
$r_result->{'count'} = $nr_items;
|
||||
$r_result->{'sum'} = $sum;
|
||||
$r_result->{'avg'} = $sum / $nr_items;
|
||||
$r_result->{'median'} = $median;
|
||||
$r_result->{'min'} = $items[0];
|
||||
$r_result->{'max'} = $items[ $#items ];
|
||||
|
||||
return $r_items;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_reaction_time($;$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ( $self, $from, $to, $status ) = @_;
|
||||
|
||||
# Warning: Plain "Moddatum - Datum" returns strange values when
|
||||
# crossing day boundaries. Using unix_timestamp instead.
|
||||
|
||||
my $query =
|
||||
"select unix_timestamp(Datum), timestampdiff(SECOND, Datum, Moddatum)" .
|
||||
"\nfrom " . $self->{'config'}->{'mysql_table'} .
|
||||
"\nwhere datum is not null" .
|
||||
"\nand Moddatum is not null" .
|
||||
"\nand Datum is not null";
|
||||
|
||||
if ($from)
|
||||
{ $query .= "\nand datum >= from_unixtime($from)"; }
|
||||
if ($to)
|
||||
{ $query .= "\nand datum < from_unixtime($to)"; }
|
||||
if ($status)
|
||||
{ $query .= "\nand Status = '$status'"; }
|
||||
|
||||
my $sth = $self->{'dbh'}->prepare($query);
|
||||
$sth->execute();
|
||||
|
||||
my %result;
|
||||
while(my $row = $sth->fetchrow_arrayref )
|
||||
{
|
||||
my $datum = 0 + $row->[0];
|
||||
my $reaction_time = 0 + $row->[1];
|
||||
my ($sec, $minute, $hour, $mday, $month, $year, $wday, $yday, $isdst) =
|
||||
localtime($datum);
|
||||
|
||||
my $y = sprintf("%04d", $year + 1900);
|
||||
my $m = sprintf("%02d", $month + 1);
|
||||
my $d = sprintf("%02d", $mday);
|
||||
|
||||
my $items = $result{$y}->{$m}->{$d}->{'items'};
|
||||
if (defined( $items ))
|
||||
{
|
||||
push @$items, $reaction_time;
|
||||
}
|
||||
else
|
||||
{
|
||||
$result{$y}->{$m}->{$d}->{'items'} = [ $reaction_time ];
|
||||
}
|
||||
}
|
||||
|
||||
# we are going to modify the hash so we need robust iteration
|
||||
my @year = keys(%result);
|
||||
my @all_items;
|
||||
|
||||
for my $year(@year)
|
||||
{
|
||||
my $r_month = $result{$year};
|
||||
my @month = keys(%$r_month);
|
||||
my @year_items;
|
||||
|
||||
for my $month(@month)
|
||||
{
|
||||
my $r_mday = $r_month->{$month};
|
||||
my @mday = keys(%$r_mday);
|
||||
my @month_items;
|
||||
|
||||
for my $mday(@mday)
|
||||
{
|
||||
my $r = $r_mday->{$mday};
|
||||
my $r_items = $r->{'items'};
|
||||
push @month_items, @$r_items;
|
||||
calc_item_stats($r, $r_items);
|
||||
# delete $r->{'items'};
|
||||
}
|
||||
|
||||
push @year_items, @month_items;
|
||||
calc_item_stats($r_mday->{'total'} = {}, \@month_items);
|
||||
}
|
||||
push @all_items, @year_items;
|
||||
calc_item_stats($r_month->{'total'} = {}, \@year_items);
|
||||
}
|
||||
calc_item_stats($result{'total'} = {}, \@all_items);
|
||||
|
||||
return \%result;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_statistics($)
|
||||
######################################################################
|
||||
{
|
||||
my ($self) = @_;
|
||||
my $dbh = $self->{'dbh'}
|
||||
|| confess 'No "dbh" in self';
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
#
|
||||
# Warning: The combination of union and selectall_arrayref does not
|
||||
# like null values. They are just ommitted from the result.
|
||||
#
|
||||
my $arrayref = $dbh->selectall_arrayref(
|
||||
"select unix_timestamp(min(datum)) from $table" .
|
||||
"\nunion" .
|
||||
"\nselect unix_timestamp(max(datum)) from $table"
|
||||
);
|
||||
|
||||
if (!$arrayref) { return undef; }
|
||||
if (!$arrayref->[1]) { return undef; }
|
||||
if (!$arrayref->[0]) { return undef; }
|
||||
|
||||
# add 1 because query is (datum >= min and datum < max)
|
||||
my $to = 1 + $arrayref->[1]->[0];
|
||||
my $from = $arrayref->[0]->[0];
|
||||
undef $arrayref;
|
||||
|
||||
my $result = {
|
||||
'all' => $self->get_reaction_time($from, $to)
|
||||
};
|
||||
for my $status(
|
||||
'pending',
|
||||
'moderated',
|
||||
'spam',
|
||||
'rejected',
|
||||
'deleted',
|
||||
'posted',
|
||||
'sending')
|
||||
{
|
||||
$result->{$status} = $self->get_reaction_time($from, $to, $status);
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
811
MOD/Displaylib.pm
Normal file
811
MOD/Displaylib.pm
Normal file
|
|
@ -0,0 +1,811 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: Displaylib.pm 305 2011-12-26 19:51:53Z root $
|
||||
#
|
||||
# Copyright 2007-2009 Roman Racine
|
||||
# Copyright 2009-2011 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::Displaylib;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw( confess );
|
||||
|
||||
use Mail::Mailer();
|
||||
use News::Article();
|
||||
use News::Article::Response();
|
||||
use MIME::QuotedPrint();
|
||||
use MIME::Base64();
|
||||
use Encode();
|
||||
use CGI();
|
||||
use CGI::Pretty();
|
||||
|
||||
use MOD::DBIUtilsPublic;
|
||||
use MOD::Utils;
|
||||
|
||||
use constant VERSION => 0.09;
|
||||
|
||||
use constant MENU_MESSAGES => [
|
||||
[ 'pending', 'Pending' ],
|
||||
[ 'spam', 'Spam' ],
|
||||
[ 'moderated', 'Approved' ],
|
||||
[ 'posted', 'Posted' ],
|
||||
[ 'rejected', 'Rejected' ],
|
||||
[ 'deleted', 'Deleted' ],
|
||||
[ 'errors', 'Error Messages' ],
|
||||
];
|
||||
use constant MENU_CONFIGURATION => undef;
|
||||
|
||||
use constant MENU_MAIN => [
|
||||
[ 'pending', 'Messages', MENU_MESSAGES ],
|
||||
[ 'config', 'Configuration', MENU_CONFIGURATION ],
|
||||
];
|
||||
|
||||
######################################################################
|
||||
sub new($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($class, $configref, $privileged) = @_;
|
||||
my $self = {};
|
||||
|
||||
$self->{'db'} = MOD::DBIUtilsPublic->new($configref);
|
||||
my $q = $self->{'q'} = CGI->new();
|
||||
|
||||
my $self_url = $q->self_url;
|
||||
$self_url =~ s/\?+.+$//;
|
||||
$self->{'self_url'} = $self_url;
|
||||
|
||||
$self->{'config'} = $configref;
|
||||
$self->{'privileged'} = $privileged;
|
||||
|
||||
my $lang = MOD::Utils::get_translator_language(
|
||||
$configref->{'html_language'},
|
||||
$configref->{'http_negotiate_language'}
|
||||
);
|
||||
$self->{'trans_lang'} = $lang;
|
||||
$self->{'trans'} = MOD::Utils::get_translator($lang);
|
||||
|
||||
if ($privileged)
|
||||
{
|
||||
my $authentication = $configref->{'http_authentication_method'};
|
||||
die "No 'http_authentication_method' in configuration file." unless($authentication);
|
||||
|
||||
if ($q->auth_type() && $q->auth_type() eq $authentication)
|
||||
{
|
||||
$self->{'user_name'} = $q->remote_user();
|
||||
}
|
||||
elsif ($authentication eq 'None')
|
||||
{
|
||||
$self->{'user_name'} = $q->remote_host();
|
||||
}
|
||||
die 'Not authorized' unless($self->{'user_name'});
|
||||
}
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_start($;$$$@)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift;
|
||||
my %args = @_;
|
||||
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
my $title = $args{'-title'} || confess 'No -title';
|
||||
$title = $trans->($title);
|
||||
|
||||
my $group = $self->{'config'}->{'moderated_group'};
|
||||
my @title;
|
||||
push @title, '[*]' if ( $args{'-mark'} );
|
||||
push @title, $group if ($group);
|
||||
push @title, $title if ($title);
|
||||
|
||||
my $q = $self->{'q'};
|
||||
my @head = ($q->meta({
|
||||
-http_equiv => 'expires',
|
||||
-content => '0'
|
||||
}));
|
||||
|
||||
my $refresh = $args{'-refresh'};
|
||||
if ($refresh)
|
||||
{
|
||||
push @head, $q->meta({
|
||||
-http_equiv => 'Refresh',
|
||||
-content => $refresh
|
||||
});
|
||||
}
|
||||
|
||||
my @param = (
|
||||
-title => join(' ', @title),
|
||||
-head => \@head
|
||||
);
|
||||
|
||||
my $css = $self->{'config'}->{'html_stylesheet_href'};
|
||||
if ($css)
|
||||
{ push @param, -style => { -src => $css }; }
|
||||
|
||||
print
|
||||
$q->header,
|
||||
$q->start_html( @param );
|
||||
$self->print_menu_items() if ($self->{'privileged'});
|
||||
|
||||
print '<div class="huhuContents">';
|
||||
print $q->h1($title);
|
||||
my $subtitle = $args{'-subtitle'};
|
||||
if ($subtitle)
|
||||
{
|
||||
printf '<div class="huhuSubtitle">%s</div>', $trans->($subtitle);
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_end($)
|
||||
######################################################################
|
||||
{
|
||||
my ($self) = @_;
|
||||
|
||||
my $group = $self->{'config'}->{'moderated_group'};
|
||||
my $user = $self->{'user_name'};
|
||||
|
||||
my @a;
|
||||
push @a, $group if ($group);
|
||||
push @a, $self->{'trans_lang'};
|
||||
push @a, $user if ($user);
|
||||
push @a, 'huhu version ' . VERSION;
|
||||
|
||||
print
|
||||
'<div class="huhuVersion">',
|
||||
join(' · ', @a),
|
||||
'.</div>',
|
||||
'</div><!-- class="huhuContents" -->',
|
||||
$self->{'q'}->end_html;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_die_msg($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $title, $msg) = @_;
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
$self->display_start(-title => 'Error');
|
||||
print '<div class="huhuError">',
|
||||
$trans->($msg ? $msg : $title),
|
||||
'</div>';
|
||||
$self->display_end();
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_table($@)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess 'No $self';
|
||||
my %args = @_;
|
||||
|
||||
my $status = $args{'-status'} || confess 'No -status';
|
||||
my $start = $args{'-start'}; # can be 0
|
||||
my $no_of_elements = $args{'-no_of_elements'} || confess 'No -no_of_elements';
|
||||
my $overviewref = $args{'-overviewref'} || confess 'No -overviewref';
|
||||
my $decisionref = $args{'-decisionref'} || confess 'No -decisionref';
|
||||
my $cmd = $args{'-cmd'};
|
||||
|
||||
my @hidden_columns = ( 'flag', 'id' );
|
||||
{
|
||||
my $extra_hidden_columns = $args{'-hiddencolumns'};
|
||||
if ($extra_hidden_columns) {
|
||||
push @hidden_columns, @$extra_hidden_columns;
|
||||
}
|
||||
}
|
||||
my @columns = ( @hidden_columns, @$overviewref );
|
||||
|
||||
my $db = $self->{'db'} || confess 'No "db" in $self';
|
||||
|
||||
my $dataref;
|
||||
if ($status eq 'errors' and $self->{'privileged'}) {
|
||||
$dataref = $db->display_errors($status,$start,$no_of_elements,\@columns);
|
||||
} else {
|
||||
$dataref = $db->displayrange($status,$start,$no_of_elements,\@columns);
|
||||
}
|
||||
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
my $sqlnames = $dataref->{'NAME'} || confess 'No "NAME" in $dataref';
|
||||
my @names = map { CGI::escapeHTML($trans->( $_ )) } (
|
||||
@$sqlnames[1 + $#hidden_columns .. $#$sqlnames],
|
||||
'Available Actions'
|
||||
);
|
||||
|
||||
my $ref = $dataref->fetchrow_arrayref();
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
|
||||
$self->display_start(
|
||||
-title => $args{'-title'},
|
||||
-subtitle => $args{'-subtitle'},
|
||||
-mark => $ref && $self->{'privileged'},
|
||||
-refresh => '300; ' . $q->url() . '?' . $cmd
|
||||
);
|
||||
|
||||
print '<table class="huhuPostList">';
|
||||
print $q->Tr($q->th({-align=>'left'},\@names));
|
||||
|
||||
my $css = $self->{'config'}->{'html_stylesheet_href'};
|
||||
my $flagattr = ($css) ? ' class="huhuFlag"' : ' bgcolor="#ffcccc"';
|
||||
|
||||
my $row_nr = 0;
|
||||
if ($ref) {
|
||||
do {
|
||||
$row_nr++;
|
||||
my @dataline = @{$ref};
|
||||
my $flag = $dataline[0];
|
||||
my $rowattr = ($flag and $self->{'privileged'})
|
||||
? $flagattr
|
||||
: ($row_nr % 2)
|
||||
? ' class="huhuOdd"'
|
||||
: ' class="huhuEven"';
|
||||
|
||||
my $id = $dataline[1];
|
||||
print "<tr$rowattr>";
|
||||
for my $i(1 + $#hidden_columns .. $#dataline) {
|
||||
my $data = $dataline[$i];
|
||||
$data = CGI::escapeHTML(substr($self->decode_line($data),0,40));
|
||||
$data =~ s/\@/#/g if (!defined($self->{'user_name'}));
|
||||
print $q->td($data);
|
||||
}
|
||||
print'<td>';
|
||||
$self->display_decisionbuttons($decisionref, $ref, \@hidden_columns);
|
||||
print '</td></tr>',"\n";
|
||||
} while ($ref = $dataref->fetchrow_arrayref);
|
||||
}
|
||||
|
||||
if ($row_nr == 0)
|
||||
{
|
||||
printf '<tr><td class="huhuNoRows" colspan="%d">', 1 + $#names;
|
||||
print $trans->('No matching records available.');
|
||||
print '</td></tr>';
|
||||
}
|
||||
|
||||
print "</table>\n";
|
||||
$self->nextpage($cmd, $start, $args{'-display_per_page'});
|
||||
|
||||
$self->display_end();
|
||||
return;
|
||||
}
|
||||
|
||||
sub display_reason {
|
||||
my ($self,$id,$decisionref,$title) = @_;
|
||||
my $dataref = $self->{'db'}->get_reason($id);
|
||||
my $reason;
|
||||
eval {
|
||||
($reason) = @{$dataref->fetchrow_arrayref};
|
||||
}; if ($@) {
|
||||
$self->display_die_msg('No reason stored in database!');
|
||||
return;
|
||||
}
|
||||
|
||||
$self->display_start(-title => $title);
|
||||
|
||||
print
|
||||
'<div class="huhuReason">',
|
||||
'<pre width="100">', CGI::escapeHTML($reason), '</pre>',
|
||||
'</div>';
|
||||
$self->display_decisionbuttons($decisionref, [ $id ]);
|
||||
print $self->{'q'}->end_html;
|
||||
return;
|
||||
}
|
||||
|
||||
sub display_navigation_back() {
|
||||
my ($self) = @_;
|
||||
my $q = $self->{'q'} || confess 'No q';
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
print
|
||||
'<div class="huhuNavigation">',
|
||||
'<span>',
|
||||
$q->a({ href => $q->referer() }, $trans->('Back')),
|
||||
'</span>',
|
||||
'</div>';
|
||||
}
|
||||
|
||||
sub display_article_info($$$)
|
||||
{
|
||||
my ( $self, $sqlnames, $row ) = @_;
|
||||
|
||||
$sqlnames || confess 'No "NAME" in $dataref';
|
||||
$row || confess 'No $row';
|
||||
$#$row == $#$sqlnames || confess '$#$row != $#$sqlnames';
|
||||
|
||||
my @a;
|
||||
for(my $i = 1; $i <= $#$row; $i++)
|
||||
{
|
||||
my $value = $row->[$i];
|
||||
if ($value)
|
||||
{
|
||||
push @a,
|
||||
CGI::escapeHTML($sqlnames->[$i]) .
|
||||
': ' .
|
||||
CGI::escapeHTML($value);
|
||||
}
|
||||
}
|
||||
if (@a)
|
||||
{
|
||||
print
|
||||
'<div class="huhuArticleInfo">',
|
||||
join(' · ', @a),
|
||||
'</div>';
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_article($@)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess 'No $self';
|
||||
my %args = @_;
|
||||
|
||||
my $status = $args{'-status'};
|
||||
my $id = $args{'-id'};
|
||||
my $headerref = $args{'-headerref'};
|
||||
my $decisionref = $args{'-decisionref'};
|
||||
my $fullheader = $args{'-fullheader'};
|
||||
|
||||
if ($status eq 'errors') {
|
||||
$status = undef;
|
||||
}
|
||||
|
||||
my $dataref = $self->{'db'}->display_single($status,$id);
|
||||
my $row = $dataref->fetchrow_arrayref;
|
||||
if (!$row || $#$row < 1) {
|
||||
$self->display_die_msg('_ALREADY_HANDLED' . " (status=$status, id=$id)");
|
||||
return;
|
||||
}
|
||||
|
||||
my $article = $self->decode_article(News::Article->new(\$row->[0]));
|
||||
|
||||
$self->display_start(-title => 'Selected Article');
|
||||
$self->display_article_info($dataref->{'NAME'}, $row);
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
|
||||
print '<table class="huhuArticle">';
|
||||
if ($fullheader) {
|
||||
my $header = join "\n",$article->headers();
|
||||
print $q->Tr($q->td({-colspan=>2},'<pre width="100">' . CGI::escapeHTML($header) .'</pre>'));
|
||||
} else {
|
||||
for my $headerline (@{$headerref}) {
|
||||
print
|
||||
'<tr class="huhuArticleHeader">',
|
||||
'<th>', CGI::escapeHTML($headerline), '</th>',
|
||||
'<td>', CGI::escapeHTML($article->header($headerline)), '</td>',
|
||||
'</tr>';
|
||||
}
|
||||
}
|
||||
my @ngs = split ',', $article->header('Newsgroups');
|
||||
if ($self->{'user_name'} && @ngs > 2)
|
||||
{
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
print $q->Tr($q->td(
|
||||
{-colspan=>2,-bgcolor=>'#ffcccc'},
|
||||
$trans->( '_CROSSPOSTED' )
|
||||
));
|
||||
}
|
||||
|
||||
print $q->Tr($q->td({-colspan=>2},
|
||||
'<pre width="100">' . CGI::escapeHTML(join ("\n",$article->body())) . '</pre>')),
|
||||
'</table><table class="huhuDecisionButtons"><tr><td>';
|
||||
$self->display_decisionbuttons($decisionref, [ $id ]);
|
||||
print "</td></tr>\n</table>";
|
||||
|
||||
$self->display_navigation_back();
|
||||
print $q->end_html;
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_errormessage($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $id, $title) = @_;
|
||||
my $dataref = $self->{'db'}->get_errormessage($id);
|
||||
my $input;
|
||||
eval {
|
||||
($input) = @{$dataref->fetchrow_arrayref};
|
||||
}; if ($@) {
|
||||
$self->display_die_msg('_ERROR_GONE');
|
||||
return;
|
||||
}
|
||||
|
||||
$self->display_start(-title => $title);
|
||||
my $q = $self->{'q'};
|
||||
|
||||
print '<div class="huhuErrorMessage"><pre>',
|
||||
CGI::escapeHTML($input),
|
||||
'</pre></div>';
|
||||
$self->display_navigation_back();
|
||||
print $q->end_html;
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub generate_answer($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $id, $behaviour, $title) = @_;
|
||||
my $db = $self->{'db'} || confess 'No "db" in $self';
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
my $q = $self->{'q'} || confess 'No q';
|
||||
|
||||
# first of all move the article out of the pending queue
|
||||
$db->set_status_by_moderator('deleted', $id, $self->{'user_name'});
|
||||
|
||||
my $dataref = $db->get_working_by_id($id);
|
||||
my ($input,$addr);
|
||||
eval {
|
||||
($input,$addr) = @{$dataref->fetchrow_arrayref};
|
||||
}; if ($@) {
|
||||
$self->display_die_msg('_ALREADY_HANDLED');
|
||||
return;
|
||||
}
|
||||
my $article = $self->decode_article(News::Article->new(\$input));
|
||||
|
||||
my $attribution = sprintf(
|
||||
$trans->('%s wrote:'),
|
||||
$article->header('From')
|
||||
);
|
||||
|
||||
my $response = News::Article->response(
|
||||
$article,
|
||||
{
|
||||
'From' => $self->{'config'}->{'mailfrom'},
|
||||
},
|
||||
'respstring' => sub { return $attribution; }
|
||||
);
|
||||
|
||||
my $body = join ("\n",$response->body());
|
||||
$self->display_start(-title => $title);
|
||||
|
||||
if ($behaviour eq 'answer')
|
||||
{
|
||||
print
|
||||
$q->start_form,
|
||||
$q->hidden(-name => 'id', -value => $id),
|
||||
$q->table
|
||||
(
|
||||
$q->Tr([
|
||||
$q->td(['From', $self->{'config'}->{'mailfrom'}]),
|
||||
$q->td(['To', CGI::escapeHTML($addr)]),
|
||||
$q->td(['Subject', CGI::escapeHTML($response->header('Subject'))]),
|
||||
$q->td(
|
||||
{ -colspan => 2},
|
||||
$q->textarea({
|
||||
-name =>'antwort',
|
||||
-cols => 80,
|
||||
-rows => 40,
|
||||
-default => $body,
|
||||
-wrap => 'hard'
|
||||
})
|
||||
),
|
||||
$q->td(
|
||||
{ -colspan => 2 },
|
||||
$q->submit(
|
||||
-name => 'action.Send Mail',
|
||||
-value => $trans->('Send Mail')
|
||||
),
|
||||
$q->submit(
|
||||
-name => 'action.Put back in queue',
|
||||
-value => $trans->('Put back in queue')
|
||||
)
|
||||
)
|
||||
])
|
||||
),
|
||||
$q->end_form;
|
||||
}
|
||||
else
|
||||
{
|
||||
print
|
||||
$trans->('_EXPLAIN_REASON'),
|
||||
$q->start_form,
|
||||
$q->hidden({ -name => 'id', -value => $id }),
|
||||
$q->textarea({
|
||||
-name => 'antwort',
|
||||
-cols => 80,
|
||||
-rows => 40,
|
||||
-default => $body,
|
||||
-wrap => 'hard'
|
||||
}),
|
||||
'<br/>',
|
||||
$q->submit(
|
||||
-name => 'action.Delete and save reason',
|
||||
-value => $trans->('Delete and save reason')
|
||||
),
|
||||
$q->submit(
|
||||
-name => 'action.Put back in queue',
|
||||
-value => $trans->('Put back in queue')
|
||||
),
|
||||
$q->end_form;
|
||||
}
|
||||
print $q->end_html;
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub delete_posting
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $antwort = $self->{'q'}->param('antwort');
|
||||
$antwort =~ s/\>/>/sg;
|
||||
$antwort =~ s/\</</sg;
|
||||
$antwort =~ s/\&/&/sg;
|
||||
$self->{'db'}->set_rejected('deleted', $id, $self->{'user_name'}, $antwort);
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub send_mail($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $antwort = $self->{'q'}->param('antwort');
|
||||
$antwort =~ s/\>/>/sg;
|
||||
$antwort =~ s/\</</sg;
|
||||
$antwort =~ s/\&/&/sg;
|
||||
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
my $dataref = $self->{'db'}->get_working_by_id($id);
|
||||
my ($input,$addr);
|
||||
eval {
|
||||
($input,$addr) = @{$dataref->fetchrow_arrayref};
|
||||
}; if ($@) {
|
||||
$self->display_die_msg('_ALREADY_HANDLED');
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $article = News::Article->new(\$input);
|
||||
my $original_subject = $article->header('Subject');
|
||||
if (!$original_subject)
|
||||
{ $original_subject = $trans->('No subject'); }
|
||||
|
||||
$article = $self->decode_article($article);
|
||||
if ($addr =~ /(,|\n)/s or $addr =~ /invalid>$/) {
|
||||
$self->display_die_msg('_ERROR_INVALID_ADDRESS');
|
||||
return 0;
|
||||
}
|
||||
my $mailer = new Mail::Mailer;
|
||||
|
||||
my $subject_prefix = $trans->('Your post regarding');
|
||||
$original_subject =~ s/(AW|Re):\s*$subject_prefix\s*/Re:/i;
|
||||
|
||||
$mailer->open({
|
||||
'From' => $self->{'config'}->{'mailfrom'},
|
||||
'Subject' => $subject_prefix . ' ' . $original_subject,
|
||||
'To' => $addr,
|
||||
'Content-Type' => "text/plain;\n charset=\"". $self->{'config'}->{'html_content_type'}. '"',
|
||||
'Content-Transfer-Encoding' => '8bit'
|
||||
});
|
||||
print $mailer $antwort;
|
||||
$mailer->close();
|
||||
$self->{'db'}->set_rejected('rejected', $id, $self->{'user_name'}, $antwort);
|
||||
return 1;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_decisionbuttons
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $decisionref, $hidden_values, $hidden_names) = @_;
|
||||
|
||||
$hidden_names = [ 'id' ] unless($hidden_names);
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
print $q->start_form;
|
||||
for(my $i = 0; $i <= $#$hidden_names; $i++)
|
||||
{
|
||||
printf
|
||||
'<input type="hidden" name="%s" value="%s"/>',
|
||||
$hidden_names->[$i], $hidden_values->[$i];
|
||||
}
|
||||
for my $decision (@{$decisionref})
|
||||
{
|
||||
print $q->submit(
|
||||
-name => 'action.' . $decision,
|
||||
-label => CGI::escapeHTML($trans->($decision))
|
||||
);
|
||||
}
|
||||
print $q->end_form;
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub nextpage {
|
||||
my ($self, $cmd, $start, $display_per_page) = @_;
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
$cmd || confess 'No $cmd';
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
if (!defined($display_per_page) || $display_per_page !~ /^\d+$/)
|
||||
{
|
||||
$display_per_page = $self->{'config'}->{'display_per_page'};
|
||||
}
|
||||
$start = 0 if ($start !~ /^\d+$/);
|
||||
|
||||
my $before = $start - $display_per_page;
|
||||
my $next = $start + $display_per_page;
|
||||
$before = 0 if ($before < 0);
|
||||
my $self_url = $self->{'self_url'} || confess;
|
||||
|
||||
print '<div class="huhuNavigation"><span>',
|
||||
$q->a(
|
||||
{ href => $self_url . '?'. $cmd . ',' . $before },
|
||||
$trans->('Previous page')
|
||||
),
|
||||
'</span><span>',
|
||||
$q->a(
|
||||
{ href => $self_url . '?'. $cmd . ',' . $next },
|
||||
$trans->('Next page')
|
||||
),
|
||||
'</span></div>';
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub print_menu_items($$$)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess;
|
||||
my $r_items = shift || MENU_MAIN;
|
||||
my $level = shift || 0;
|
||||
|
||||
my $self_url = $self->{'self_url'} || confess;
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
printf '<ul class="huhuMainMenu%d">', $level;
|
||||
for my $r_definition(@$r_items)
|
||||
{
|
||||
my $submenu = $r_definition->[2];
|
||||
printf
|
||||
'<li><span><a href="%s">%s</a></span>',
|
||||
$self_url . '?' . $r_definition->[0],
|
||||
$trans->( $r_definition->[1] );
|
||||
if ($submenu)
|
||||
{
|
||||
$self->print_menu_items($submenu, $level + 1);
|
||||
}
|
||||
print '</li>';
|
||||
}
|
||||
print '</ul>';
|
||||
}
|
||||
|
||||
sub set_status_by_moderator {
|
||||
my ($self, $newstatus, $id) = @_;
|
||||
$self->{'db'}->set_status_by_moderator($newstatus, $id, $self->{'user_name'});
|
||||
return;
|
||||
}
|
||||
|
||||
sub post {
|
||||
my ($self,$id) = @_;
|
||||
$self->{'db'}->set_status_posted($id, $self->{'user_name'});
|
||||
return;
|
||||
}
|
||||
|
||||
sub decode_article {
|
||||
my ($self, $article) = @_;
|
||||
|
||||
$self || confess 'No $self';
|
||||
$article || confess 'No $article';
|
||||
|
||||
for my $headerline (qw(Subject From Reply-To)) {
|
||||
$article->set_headers($headerline,$self->decode_line($article->header($headerline)));
|
||||
}
|
||||
|
||||
my $body = join "\n",$article->body();
|
||||
|
||||
if (defined($article->header('Content-Transfer-Encoding')) and
|
||||
$article->header('Content-Transfer-Encoding') eq 'quoted-printable') {
|
||||
$body = MIME::QuotedPrint::decode($body);
|
||||
}
|
||||
my $encoding;
|
||||
if (defined($article->header('Content-Type')) and
|
||||
$article->header('Content-Type') =~ m|^text/plain;.+charset=[\s"]*([\w-]+)[\s"]?|si) {
|
||||
$encoding = $1;
|
||||
} else {
|
||||
$encoding = 'iso-8859-1';
|
||||
}
|
||||
eval {
|
||||
if (Encode::find_encoding($encoding)->perlio_ok) {
|
||||
Encode::from_to($body,$encoding,$self->{'config'}->{'html_content_type'});
|
||||
}
|
||||
};
|
||||
$article->set_body(($body));
|
||||
return $article;
|
||||
}
|
||||
|
||||
sub decode_line {
|
||||
my ($self,$line) = @_;
|
||||
if (!$self->{'privileged'}) {
|
||||
$line =~ s/\@/#/g;
|
||||
}
|
||||
my $newline;
|
||||
while ($line =~ s/^(.*?)=\?([^?]+)\?(.)\?([^?]*)\?=(?:\r?\n +)?//s) {
|
||||
my ($before,$charset,$encoding,$content) = ($1,$2,lc($3),$4);
|
||||
$newline .= $before;
|
||||
if ($encoding eq 'q') {
|
||||
$content =~ s/_/ /g;
|
||||
$content = MIME::QuotedPrint::decode($content);
|
||||
chomp $content;
|
||||
} elsif ($encoding eq 'b') {
|
||||
$content = MIME::Base64::decode($content);
|
||||
}
|
||||
eval {
|
||||
if (Encode::find_encoding($charset)->perlio_ok) {
|
||||
Encode::from_to($content,$charset,$self->{'config'}->{'html_content_type'});
|
||||
}
|
||||
};
|
||||
$newline .= $content;
|
||||
}
|
||||
$newline .= $line;
|
||||
return $newline;
|
||||
}
|
||||
|
||||
sub set_flag {
|
||||
my ($self,$id) = @_;
|
||||
$self->{'db'}->invert_flag($id);
|
||||
return;
|
||||
}
|
||||
|
||||
use constant SHOW_CONFIG => (
|
||||
'approve_string',
|
||||
'check_duplicates_age',
|
||||
'display_per_page',
|
||||
'followup_to',
|
||||
'html_content_type',
|
||||
'http_authentication_method',
|
||||
'http_negotiate_language',
|
||||
'mailfrom',
|
||||
'moderated_group',
|
||||
'mysql_host',
|
||||
'mysql_port',
|
||||
'mysql_username',
|
||||
);
|
||||
|
||||
######################################################################
|
||||
sub display_config($)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess;
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
my $trans = $self->{'trans'} || confess 'No "trans" in $self';
|
||||
my $config = $self->{'config'} || confess 'No "config" in $self';
|
||||
|
||||
$self->display_start(
|
||||
-title => $trans->('Configuration'),
|
||||
# -subtitle => $args{'-subtitle'},
|
||||
-mark => 0,
|
||||
# -refresh => '300; ' . $q->url() . '?' . $cmd
|
||||
);
|
||||
|
||||
print '<table class="huhuPostList">';
|
||||
print $q->Tr($q->th({-align=>'left'}, [ 'Key', 'Value' ]));
|
||||
|
||||
my @key = SHOW_CONFIG;
|
||||
for my $key(@key)
|
||||
{
|
||||
printf "<tr><td>%s</td><td>%s</td></tr>", $key, $config->{$key};
|
||||
}
|
||||
print "</table>";
|
||||
|
||||
$self->display_end();
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
281
MOD/Handler.pm
Normal file
281
MOD/Handler.pm
Normal file
|
|
@ -0,0 +1,281 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: Handler.pm 261 2010-02-21 16:10:09Z root $
|
||||
#
|
||||
# Copyright 2007-2009 Roman Racine
|
||||
# Copyright 2009-2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::Handler;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw( confess );
|
||||
use CGI();
|
||||
use MOD::Utils;
|
||||
use MOD::Displaylib;
|
||||
|
||||
######################################################################
|
||||
sub new($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($class, $filename) = @_;
|
||||
my $self = {};
|
||||
|
||||
my %config = MOD::Utils::read_public_config($filename);
|
||||
$self->{'config'} = \%config;
|
||||
|
||||
$self->{'d'} = MOD::Displaylib->new(\%config, 1);
|
||||
$self->{'q'} = $self->{'d'}->{'q'} || confess;
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub run($)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess;
|
||||
|
||||
my $query = $ENV{'QUERY_STRING'};
|
||||
$query =~ s/keywords=//;
|
||||
my ($cmd, $start, $id) = split(',',$query);
|
||||
if (!defined($start) || $start !~ /^\d+$/) {
|
||||
$start = 0;
|
||||
}
|
||||
if (!$cmd) { $cmd = 'pending'; }
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
|
||||
$id = $q->param('id');
|
||||
if (!defined($id) || $id !~ /^\d+$/) {
|
||||
$id = 0;
|
||||
}
|
||||
|
||||
if ($q->param('action.Show') ||
|
||||
$q->param('action.Header') ||
|
||||
$q->param('action.Brief Headers') ||
|
||||
$q->param('action.Show Post'))
|
||||
{
|
||||
return $self->display_single($cmd, $start, $id);
|
||||
}
|
||||
if (
|
||||
$q->param('action.Spam') ||
|
||||
$q->param('action.No Spam') ||
|
||||
$q->param('action.Put back in queue'))
|
||||
{
|
||||
$self->{'d'}->set_status_by_moderator(
|
||||
$q->param('action.Spam') ? 'spam' : 'pending',
|
||||
$id
|
||||
);
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Flag')) {
|
||||
$self->{'d'}->set_flag($id);
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Reject')) {
|
||||
return $self->reject('answer', $id);
|
||||
}
|
||||
if ($q->param('action.Approve')) {
|
||||
$self->{'d'}->post($id);
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Send Mail')) {
|
||||
$self->{'d'}->send_mail($id) &&
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Show Reply') ||
|
||||
$q->param('action.Reason'))
|
||||
{
|
||||
return $self->display_answer($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Delete')) {
|
||||
return $self->reject('noanswer', $id);
|
||||
}
|
||||
if ($q->param('action.Delete and save reason')) {
|
||||
$self->{'d'}->delete_posting($id);
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Show Error Message')) {
|
||||
return $self->display_errormessage($q->param('error_id'));
|
||||
}
|
||||
if ($cmd eq 'config') {
|
||||
return $self->{'d'}->display_config();
|
||||
}
|
||||
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
|
||||
use constant SQL_TIME_FORMAT => '"%d.%m.%Y, %H:%i:%s"';
|
||||
use constant DEFAULT_COLUMNS => [
|
||||
'Moderator',
|
||||
'Sender',
|
||||
'Subject',
|
||||
'Date_Format(Datum, ' . SQL_TIME_FORMAT . ") AS 'Incoming Date'",
|
||||
'Date_Format(Moddatum, ' . SQL_TIME_FORMAT . ") AS 'Decision Date'"
|
||||
];
|
||||
use constant PENDING_COLUMNS => [
|
||||
'Sender',
|
||||
'Subject',
|
||||
'DATE_Format(Datum, ' . SQL_TIME_FORMAT . ') Date',
|
||||
'Spamcount'
|
||||
];
|
||||
use constant OVERVIEW => {
|
||||
'spam' => {
|
||||
-decisionref => [ 'Show', 'No Spam', 'Flag' ],
|
||||
-overviewref => [
|
||||
'Moderator',
|
||||
'Sender',
|
||||
'Subject',
|
||||
'DATE_Format(Datum, ' . SQL_TIME_FORMAT . ') Date',
|
||||
'Spamcount'
|
||||
],
|
||||
-title => 'Spam Folder',
|
||||
-subtitle => '_SUBTITLE_SPAM',
|
||||
},
|
||||
'pending' => {
|
||||
-decisionref => [ 'Show', 'Spam', 'Flag' ],
|
||||
-overviewref => PENDING_COLUMNS,
|
||||
-title => 'Pending Posts',
|
||||
-subtitle => '_SUBTITLE_PENDING',
|
||||
},
|
||||
'rejected' => {
|
||||
-title => 'Rejected Posts',
|
||||
-subtitle => '_SUBTITLE_REJECTED',
|
||||
},
|
||||
'errors' => {
|
||||
-decisionref => [ 'Show Post', 'Show Error Message' ],
|
||||
-overviewref => [
|
||||
'error_date',
|
||||
'article_sender',
|
||||
'article_subject',
|
||||
'article_status',
|
||||
'error_count',
|
||||
'LEFT(error_message, INSTR(error_message, "\n")) AS error_message',
|
||||
],
|
||||
-title => 'Error Messages',
|
||||
-subtitle => '_SUBTITLE_ERROR',
|
||||
-hiddencolumns => [ 'error_id' ],
|
||||
},
|
||||
'moderated' => {
|
||||
-title => 'Approved Messages',
|
||||
-subtitle => '_SUBTITLE_APPROVED',
|
||||
},
|
||||
'posted' => {
|
||||
-title => 'Posted Messages',
|
||||
-subtitle => '_SUBTITLE_POSTED',
|
||||
},
|
||||
'deleted' => {
|
||||
-title => 'Deleted Posts',
|
||||
-subtitle => '_SUBTITLE_DELETED',
|
||||
},
|
||||
};
|
||||
|
||||
|
||||
sub display_overview {
|
||||
my ($self, $cmd, $start, $id) = @_;
|
||||
my @decisions;
|
||||
my @overviewdata;
|
||||
my ($status, $title);
|
||||
|
||||
my $ovref = OVERVIEW->{$cmd} || confess 'Illegal $cmd';
|
||||
my %params = %{$ovref}; # create copy of the hash
|
||||
|
||||
if (!exists( $params{'-cmd'} )) {
|
||||
$params{'-cmd'} = $cmd;
|
||||
}
|
||||
if (!exists( $params{'-status'} )) {
|
||||
$params{'-status'} = $cmd;
|
||||
}
|
||||
if (!exists( $params{'-decisionref'} )) {
|
||||
$params{'-decisionref'} = [ 'Show' ];
|
||||
}
|
||||
if (!exists( $params{'-overviewref'} )) {
|
||||
$params{'-overviewref'} = DEFAULT_COLUMNS;
|
||||
}
|
||||
if (!exists( $params{'-no_of_elements'} )) {
|
||||
my $config = $self->{'config'} || confess 'No "config" in $self';
|
||||
my $c = $config->{'display_per_page'} || confess 'No "display_per_page" in $config';
|
||||
$params{'-no_of_elements'} = $c;
|
||||
}
|
||||
|
||||
$params{'-start'} = $start;
|
||||
$params{'-startrange'} = $id;
|
||||
|
||||
$self->{'d'}->display_table(%params);
|
||||
}
|
||||
|
||||
sub reject {
|
||||
my ($self,$behaviour,$id) = @_;
|
||||
my $title = ($behaviour eq 'noanswer')
|
||||
? 'Delete Post'
|
||||
: 'Reject Post';
|
||||
$self->{'d'}->generate_answer($id,$behaviour,$title);
|
||||
return;
|
||||
}
|
||||
|
||||
sub display_answer {
|
||||
my ($self,$cmd,$start,$id) = @_;
|
||||
my $title = ($cmd eq 'rejected') ? 'Reply' : 'Reason';
|
||||
my @decisions = ('Show Post');
|
||||
$self->{'d'}->display_reason($id,\@decisions,$title);
|
||||
return;
|
||||
}
|
||||
|
||||
sub display_errormessage {
|
||||
my ($self,$id) = @_;
|
||||
$self->{'d'}->display_errormessage($id, 'Error Message');
|
||||
return;
|
||||
}
|
||||
|
||||
use constant HEADERS => [
|
||||
'From',
|
||||
'Reply-To',
|
||||
'Subject',
|
||||
'Message-ID',
|
||||
'Date',
|
||||
'Newsgroups',
|
||||
'Followup-To',
|
||||
];
|
||||
|
||||
use constant SINGLE => {
|
||||
'pending' => [ 'Approve', 'Reject', 'Flag', 'Spam', 'Delete' ],
|
||||
'spam' => [ 'No Spam', 'Approve', 'Flag', 'Reject', 'Delete' ],
|
||||
'errors' => [ 'Reject', 'Flag', 'Spam', 'Delete' ],
|
||||
'moderated' => [ 'Put back in queue' ],
|
||||
'posted' => [],
|
||||
'rejected' => [ 'Show Reply' ],
|
||||
'deleted' => [ 'Put back in queue', 'Reason' ],
|
||||
};
|
||||
|
||||
sub display_single {
|
||||
my ($self, $cmd, $start, $id) = @_;
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
my $decisionref = SINGLE->{$cmd} || confess "Illegal \$cmd ($cmd)";
|
||||
my @decisions = @$decisionref;
|
||||
|
||||
my $fullheader = $q->param('action.Header') ? 1 : 0;
|
||||
push(@decisions, $fullheader ? 'Brief Headers' : 'Header');
|
||||
|
||||
my %args = (
|
||||
-status => $cmd,
|
||||
-id => $id,
|
||||
-headerref => HEADERS,
|
||||
-decisionref => \@decisions,
|
||||
-fullheader => $fullheader
|
||||
);
|
||||
$self->{'d'}->display_article(%args);
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
85
MOD/NotificationSocket.pm
Normal file
85
MOD/NotificationSocket.pm
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
#!/usr/bin/perl -sw
|
||||
######################################################################
|
||||
#
|
||||
# $Id: NotificationSocket.pm 266 2010-05-18 15:14:08Z alba $
|
||||
#
|
||||
# Copyright 2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::NotificationSocket;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw( confess );
|
||||
|
||||
use Socket qw(
|
||||
PF_UNIX
|
||||
sockaddr_un
|
||||
SOCK_STREAM
|
||||
SOMAXCONN
|
||||
);
|
||||
|
||||
######################################################################
|
||||
sub socket_read($;$$)
|
||||
######################################################################
|
||||
{
|
||||
my $fh = shift || confess;
|
||||
my $on_close = shift;
|
||||
my $on_debug_print = shift;
|
||||
|
||||
my $buffer;
|
||||
my $rc = sysread($fh, $buffer, 512);
|
||||
|
||||
if (!defined($rc))
|
||||
{
|
||||
if ($on_debug_print) { &$on_debug_print("socket_read $!"); }
|
||||
return undef;
|
||||
}
|
||||
|
||||
if ($rc == 0)
|
||||
{
|
||||
if ($on_debug_print) { &$on_debug_print('socket_read close'); }
|
||||
|
||||
if ($on_close) { &$on_close($fh); }
|
||||
else { close($fh) || confess; }
|
||||
return undef;
|
||||
|
||||
# Do not call close($fh), this will hang the process.
|
||||
# Socket is automatically closed when the last reference is freed.
|
||||
# $irc->removefh($fh) || confess;
|
||||
# return;
|
||||
}
|
||||
|
||||
$buffer =~ s/\s+$//;
|
||||
if ($on_debug_print) { &$on_debug_print("socket_read rc=$rc buffer=[$buffer]"); }
|
||||
return $buffer;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub socket_create_listening($)
|
||||
######################################################################
|
||||
{
|
||||
my $config = shift || confess;
|
||||
|
||||
my $filename = $config->{'ircbot_notify_sock'};
|
||||
return undef if (!$filename);
|
||||
|
||||
unlink($filename);
|
||||
my $uaddr = sockaddr_un($filename) || die "sockaddr_un: $!";
|
||||
my $proto = getprotobyname('tcp') || die "getprotobyname: $!";
|
||||
my $fh;
|
||||
socket($fh, PF_UNIX,SOCK_STREAM, 0) || die "socket: $!";
|
||||
bind ($fh, $uaddr) || die "bind: $!";
|
||||
listen($fh, SOMAXCONN) || die "listen: $!";
|
||||
|
||||
return $fh;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
159
MOD/PublicHandler.pm
Normal file
159
MOD/PublicHandler.pm
Normal file
|
|
@ -0,0 +1,159 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: PublicHandler.pm 159 2009-10-30 11:32:21Z root $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::PublicHandler;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw(confess);
|
||||
use CGI();
|
||||
use MOD::Utils;
|
||||
use MOD::Displaylib;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MOD::PublicHandler
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides public access to the moderation database. Only things which should
|
||||
be viewable to the public. Data which should only be accessable or changeable by the
|
||||
moderators cannot be retrieved, manipulated whith this module. Use MOD::Handler instead.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
MOD:*
|
||||
CGI
|
||||
News::Article
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Roman Racine <roman.racine@gmx.net>
|
||||
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
2007-11-24
|
||||
|
||||
=cut
|
||||
|
||||
$MOD::PublicHandler::VERSION = 0.04;
|
||||
my %config;
|
||||
my $sql_time_format = '"%d.%m.%Y, %H:%i:%s"';
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 new
|
||||
|
||||
constructor
|
||||
|
||||
usage:
|
||||
|
||||
my $handler = MOD::PublicHandler->new('/path/to/the/config/file');
|
||||
$handler->run();
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class,$filename) = @_;
|
||||
my $self = {};
|
||||
%config = MOD::Utils::read_public_config($filename);
|
||||
$self->{'q'} = new CGI;
|
||||
|
||||
# 0 -> get unpriviledged (i.e. non-moderator) access to the displaylib
|
||||
$self->{'d'} = MOD::Displaylib->new(\%config,0);
|
||||
$self->{'config'} = \%config;
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 run
|
||||
|
||||
usage:
|
||||
|
||||
my $handler = MOD::PublicHandler->new('/path/to/the/config/file');
|
||||
$handler->run();
|
||||
|
||||
This is the main handling routine, this method will get the arguments from the browser,
|
||||
parse it and handle it, calling the necessary routines.
|
||||
|
||||
=cut
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
my $start;
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
|
||||
#get the parameters, check for illegal values
|
||||
(undef,$start) = split (',',$ENV{'QUERY_STRING'});
|
||||
if (!defined($start) || $start !~ /^\d+$/) {
|
||||
$start = 0;
|
||||
}
|
||||
|
||||
my $id = $q->param('id');
|
||||
$id = 0 unless($id);
|
||||
|
||||
#call the handling routines
|
||||
if ($q->param('action.Show')) {
|
||||
$self->display_single($start,$id);
|
||||
} else {
|
||||
$self->display_overview($start,$id);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
########## The following methods are for internal use only #####################
|
||||
|
||||
#method to display an overview over a number of postings using a table format.
|
||||
sub display_overview {
|
||||
my ($self,$start,$id) = @_;
|
||||
|
||||
$self->{'d'}->display_table(
|
||||
-status => 'posted',
|
||||
-start => $start,
|
||||
-no_of_elements => $self->{'config'}->{'display_per_page'},
|
||||
-overviewref => [
|
||||
'Sender',
|
||||
'Subject',
|
||||
"Date_Format(Datum,$sql_time_format) AS 'Incoming Date'",
|
||||
"Date_Format(Moddatum,$sql_time_format) AS 'Decision Date'"
|
||||
],
|
||||
-decisionref => [ 'Show' ],
|
||||
-title => 'Overview of Approved Posts',
|
||||
-cmd => 'bla',
|
||||
-startrange => $id
|
||||
);
|
||||
return;
|
||||
}
|
||||
|
||||
#method to display a single article given by an ID.
|
||||
sub display_single {
|
||||
my ($self,$start,$id) = @_;
|
||||
my %args = (
|
||||
-status => 'posted',
|
||||
-id => $id,
|
||||
-headerref => [ 'From', 'Reply-To', 'Subject', 'Date', 'Newsgroups' ],
|
||||
-decisionref => [],
|
||||
-fullheader => 0,
|
||||
);
|
||||
$self->{'d'}->display_article(%args);
|
||||
return;
|
||||
}
|
||||
|
||||
131
MOD/ReadMail.pm
Normal file
131
MOD/ReadMail.pm
Normal file
|
|
@ -0,0 +1,131 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: ReadMail.pm 293 2011-06-21 16:01:33Z alba $
|
||||
#
|
||||
# Copyright 2009-2011 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::ReadMail;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw( confess );
|
||||
use News::Article();
|
||||
use Mail::SpamAssassin();
|
||||
use MOD::Spamfilter();
|
||||
use MOD::DBIUtils();
|
||||
|
||||
######################################################################
|
||||
sub new()
|
||||
######################################################################
|
||||
{
|
||||
my ( $class, $configref ) = @_;
|
||||
my $self = {};
|
||||
|
||||
$self->{'config'} = $configref || confess;
|
||||
$self->{'spamutil'} = MOD::Spamfilter->new($configref) || confess;
|
||||
$self->{'db'} = MOD::DBIUtils->new($configref) || confess;
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub run_spamassassin($$)
|
||||
{
|
||||
my ( $self, $article ) = @_;
|
||||
|
||||
my $spamutil = $self->{'spamutil'} || confess 'No "spamutil" in $self';
|
||||
|
||||
# Temporarily redirect STDOUT and STDERR to /dev/null to ignore
|
||||
# diagnostics printed by Spamassassin.
|
||||
# Note: SAVE_STDOUT and SAVE_STDERR must be handles.
|
||||
# ">&$savestdout" does not work, i.e. it will not restore stdout.
|
||||
|
||||
open(SAVE_STDOUT, ">&STDOUT") or warn "Failed to dup STDOUT: $!";
|
||||
open(SAVE_STDERR, ">&STDERR") or warn "Failed to dup STDOUT: $!";
|
||||
open(STDOUT, '/dev/null') or warn $!;
|
||||
open(STDERR, '/dev/null') or warn $!;
|
||||
my $score = $spamutil->spamfilter_spamassassin($article);
|
||||
open(STDOUT, ">&SAVE_STDOUT") or warn $!;
|
||||
open(STDERR, ">&SAVE_STDERR") or warn $!;
|
||||
close SAVE_STDOUT;
|
||||
close SAVE_STDERR;
|
||||
|
||||
return $score;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub add_article($$;$)
|
||||
######################################################################
|
||||
{
|
||||
my ( $self, $article, $status ) = @_;
|
||||
|
||||
# broken spam postings
|
||||
return 0 if ($article->bytes() <= 2);
|
||||
|
||||
my $config = $self->{'config'} || confess 'No "config" in $self';
|
||||
my $db = $self->{'db'} || confess 'No "db" in $self';
|
||||
my $spamutil = $self->{'spamutil'} || confess 'No "spamutil" in $self';
|
||||
|
||||
if (!defined($article->header('Newsgroups')))
|
||||
{
|
||||
my $group = $config->{'moderated_group'} || confess 'No "moderated_group" in config.';
|
||||
$article->set_headers('Newsgroups', $group);
|
||||
}
|
||||
|
||||
if ($config->{'followup_to'} && !$article->header('Followup-To'))
|
||||
{
|
||||
$article->set_headers('Followup-To', $config->{'followup_to'});
|
||||
}
|
||||
|
||||
my $score = 0;
|
||||
if (!$status)
|
||||
{
|
||||
if ($spamutil->blacklist($article))
|
||||
{
|
||||
$score = 100;
|
||||
$db->enter_table($article, 'spam', $score);
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ($config->{'spamassassin'})
|
||||
{
|
||||
$score += $self->run_spamassassin($article);
|
||||
}
|
||||
|
||||
if ($config->{'subjectcheck'} and
|
||||
$db->check_subject($article->header('subject')))
|
||||
{
|
||||
my $subjectscore = $config->{'subjectscore'};
|
||||
$article->add_headers('X-Subject-Test', $subjectscore);
|
||||
$score += $subjectscore;
|
||||
}
|
||||
|
||||
if ($config->{'attachmentcheck'})
|
||||
{
|
||||
$score += $spamutil->spamfilter_attachment($article);
|
||||
}
|
||||
|
||||
if ($config->{'langcheck'})
|
||||
{
|
||||
$score += $spamutil->spamfilter_language($article);
|
||||
}
|
||||
|
||||
$status = 'spam' if ($score >= 5);
|
||||
}
|
||||
|
||||
$status = 'pending' unless($status);
|
||||
my $rc = $db->enter_table($article, $status, $score);
|
||||
|
||||
return $rc == 1;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
142
MOD/Spamfilter.pm
Normal file
142
MOD/Spamfilter.pm
Normal file
|
|
@ -0,0 +1,142 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: Spamfilter.pm 147 2009-10-13 14:46:07Z alba $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# this is a spamfilter which checks incoming mails and marks them
|
||||
# as probable Spam.
|
||||
#
|
||||
# Heuristics are added as needed.
|
||||
#
|
||||
# The main function "spamfilter" returns
|
||||
# -1 -> discard (post do de.admin.news.announce)
|
||||
# 0-5 -> no spam,
|
||||
# >5 -> spam
|
||||
#
|
||||
######################################################################
|
||||
package MOD::Spamfilter;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use News::Article;
|
||||
use Mail::SpamAssassin;
|
||||
use Text::Language::Guess;
|
||||
|
||||
$MOD::Spamfilter::VERSION = 0.02;
|
||||
|
||||
sub spamfilter;
|
||||
sub blacklist;
|
||||
sub spamlearn;
|
||||
sub new($);
|
||||
1;
|
||||
|
||||
sub new($) {
|
||||
my (undef,$configref) = @_;
|
||||
my $self = {};
|
||||
$self->{'config'} = $configref;
|
||||
bless $self;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
sub spamfilter_attachment {
|
||||
my ($self,$article) = @_;
|
||||
my $score = 0;
|
||||
if (defined($article->header('Content-Type')) and $article->header('Content-Type') =~
|
||||
/^multipart\/(?:mixed|alternative);.+boundary="(.+?)"$/s) {
|
||||
my @parts = split($1,(join "\n",$article->body()));
|
||||
for my $part (@parts) {
|
||||
if ($part =~ /^\r?\n?Content-Type: (image|video|audio|application|text\/html)/) {
|
||||
$score = $self->{'config'}->{'attachmentscore'};
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
$article->add_headers('X-Attachment-Test',$score);
|
||||
return $score;
|
||||
}
|
||||
|
||||
|
||||
sub spamfilter_language {
|
||||
my ($self,$article) = @_;
|
||||
my $guesser = Text::Language::Guess->new(languages => ['en',$self->{'config'}->{'lang'}]);
|
||||
my @messagebody = $article->body();
|
||||
my $score = 0;
|
||||
my $lang = $guesser->language_guess_string(join "\n",@messagebody);
|
||||
if (!defined($lang) or $lang ne $self->{'config'}->{'lang'}) {
|
||||
$score = $self->{'config'}->{'langscore'};
|
||||
}
|
||||
$article->add_headers('X-Lang-Test',$score);
|
||||
return $score;
|
||||
}
|
||||
|
||||
sub spamfilter_spamassassin {
|
||||
my ($self,$article) = @_;
|
||||
# use spamassassin
|
||||
my $spamtest = Mail::SpamAssassin->new();
|
||||
my @messageheader = $article->headers();
|
||||
my @messagebody = $article->body();
|
||||
my $header = join "\n",@messageheader;
|
||||
my $body = join "\n",@messagebody;
|
||||
my $status = $spamtest->check_message_text($header . $body);
|
||||
my $score = $status->get_score();
|
||||
$article->add_headers('X-Spamassassin-Test',$score);
|
||||
return $score;
|
||||
}
|
||||
|
||||
sub blacklist {
|
||||
my ($self,$article) = @_;
|
||||
return 1 if ($article->header('Newsgroups') =~ /de.admin.news.announce/);
|
||||
return 1 if (defined($article->header('Newsgroups')) and
|
||||
$article->header('Newsgroups') !~ /$self->{'config'}->{'moderated_group'}/);
|
||||
return 1 if (!defined($article->header('From')));
|
||||
return 1 if (length($article->header('From')) < 2);
|
||||
return 1 if ($article->bytes() > 100*1024);
|
||||
# kaputte Postings
|
||||
for my $headerline (qw(From Reply-To Subject Message-ID)) {
|
||||
if (defined ($article->header($headerline)) and
|
||||
length($article->header($headerline)) > 1019) {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
if (defined $self->{'config'}->{'blacklistfile'}) {
|
||||
my $header = join "\n",$article->headers();
|
||||
open(my $blacklistfile, $self->{'config'}->{'blacklistfile'}) or die $!;
|
||||
while (<$blacklistfile>) {
|
||||
chomp;
|
||||
next if (length($_) <= 2);
|
||||
if ($header =~ /$_/s) {
|
||||
close $blacklistfile;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
close $blacklistfile;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub spamlearn {
|
||||
my ($input,$isspam) = @_;
|
||||
return;
|
||||
# my $message = Mail::SpamAssassin::Message->new({'message' => $input});
|
||||
# my $spamtest = new Mail::SpamAssassin ({
|
||||
# 'rules_filename' => '/etc/spamassassin.rules',
|
||||
# 'userprefs_filename' => $ENV{'HOME'}. '/.spamassassin/user_prefs'
|
||||
# });
|
||||
# my $mail = $spamtest->parse($message);
|
||||
# my $status = $spamtest->learn($mail,undef,$isspam,0);
|
||||
# $status->finish();
|
||||
|
||||
# my $spamobj = Mail::SpamAssassin->new();
|
||||
# print defined $spamobj,"\n";
|
||||
# $spamobj->learn($message,undef,$isspam,0);
|
||||
}
|
||||
245
MOD/Utils.pm
Normal file
245
MOD/Utils.pm
Normal file
|
|
@ -0,0 +1,245 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: Utils.pm 272 2010-05-28 19:46:29Z root $
|
||||
#
|
||||
# Copyright 2007-2009 Roman Racine
|
||||
# Copyright 2009-2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# This package contains some frequently used routines
|
||||
#
|
||||
######################################################################
|
||||
package MOD::Utils;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use Carp qw( confess );
|
||||
use News::Article();
|
||||
use I18N::AcceptLanguage();
|
||||
|
||||
use MOD::lang::en_us();
|
||||
|
||||
@MOD::Utils::ISA = qw(Exporter);
|
||||
@MOD::Utils::EXPORT = qw();
|
||||
@MOD::Utils::EXPORT_OK = qw(
|
||||
read_public_config
|
||||
read_private_config
|
||||
);
|
||||
|
||||
######################################################################
|
||||
|
||||
our @SUPPORTED_LANG;
|
||||
our %SUPPORTED_LANG;
|
||||
|
||||
# cache of public configuration file
|
||||
# key = filename, value = [ mtime, r_config ]
|
||||
our %CONFIG_CACHE;
|
||||
|
||||
######################################################################
|
||||
sub get_cache_entry($)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my $r_cache = $CONFIG_CACHE{$filename};
|
||||
return undef if (!$r_cache);
|
||||
|
||||
my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime,
|
||||
$mtime, $ctime, $blksize, $blocks) = stat($filename);
|
||||
die "Can't access $filename:$!" if (!$mtime);
|
||||
|
||||
return ($r_cache->[0] < $mtime) ? undef : $r_cache->[1];
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub add_cache_entry($$)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my $r_config = shift || confess 'No parameter $r_config';
|
||||
|
||||
$CONFIG_CACHE{$filename} = [ time(), $r_config ];
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub read_config_file($$)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my $r_hash = shift || confess 'No parameter $r_hash';
|
||||
|
||||
my $conf;
|
||||
open($conf, '<', $filename) ||
|
||||
die "Can't open configuration file: \n$!\n$filename";
|
||||
while(my $line = <$conf>)
|
||||
{
|
||||
next if ($line =~ /^\s*#/);
|
||||
my ($name, $val) = split (/[ \t]*=[ \t]*/, $line, 2);
|
||||
# ignore undefined $val and zero-length $val
|
||||
next if (!$val);
|
||||
$name =~ s/^\s+//;
|
||||
$val =~ s/\s+$//;
|
||||
$val =~ s/^"(.*)"$/$1/;
|
||||
$r_hash->{$name} = $val;
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# Read the public config file, returns a hash of settings.
|
||||
######################################################################
|
||||
sub read_public_config($)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my $r_config = get_cache_entry($filename);
|
||||
if ($r_config) { return %$r_config; }
|
||||
|
||||
my %config_vars =
|
||||
(
|
||||
'mysql_password' => $ENV{'mysql_password'}
|
||||
);
|
||||
read_config_file($filename, \%config_vars);
|
||||
add_cache_entry($filename, \%config_vars);
|
||||
return %config_vars;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# Read the private config file, returns a hash of settings.
|
||||
#
|
||||
# The function first reads the public file to read the values of
|
||||
# 'UID' and 'priv_config_file'.
|
||||
#
|
||||
# The function dies
|
||||
# - if 'UID' or 'priv_config_file' are not defined
|
||||
# - if user id (variable "$<") does not match the setting of "UID"
|
||||
# - if the private file cannot be opened
|
||||
######################################################################
|
||||
sub read_private_config($)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my %config_vars = read_public_config($filename);
|
||||
|
||||
my $cfg_uid = $config_vars{'UID'} ||
|
||||
die 'No "UID" in public configuration file $filename"';
|
||||
if ($< != $cfg_uid)
|
||||
{
|
||||
die "Execution of this function is not allowed for user ID $<!\n";
|
||||
}
|
||||
|
||||
my $priv_file = $config_vars{'priv_config_file'} ||
|
||||
die "No 'priv_config_file' in public configuration file $filename";
|
||||
read_config_file($priv_file, \%config_vars);
|
||||
return %config_vars;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_supported_translators()
|
||||
######################################################################
|
||||
{
|
||||
return @SUPPORTED_LANG if (@SUPPORTED_LANG);
|
||||
|
||||
my $pkgname = __PACKAGE__; # value of __PACKAGE__ is "MOD::Utils"
|
||||
$pkgname =~ s#.*::##g; # reduce to "Utils"
|
||||
my $pkgdir = __FILE__; # __FILE__ is "/srv/www/huhu/MOD/Utils.pm"
|
||||
$pkgdir =~ s#$pkgname\.pm$##; # reduce to "/srv/www/huhu/MOD/"
|
||||
$pkgdir .= 'lang';
|
||||
|
||||
# String constants in this software are written in American English.
|
||||
@SUPPORTED_LANG = ( 'en-us' );
|
||||
%SUPPORTED_LANG = ( 'en-us' => undef );
|
||||
|
||||
my $dirhandle;
|
||||
|
||||
opendir($dirhandle, $pkgdir) || die "opendir $pkgdir: $!";
|
||||
for my $lang( grep { /^\w+\.pm$/ && -f "$pkgdir/$_" } readdir($dirhandle) )
|
||||
{
|
||||
$lang =~ s#\.pm$##;
|
||||
# Perl dows not allow '-' in module names, so we use '_' instead.
|
||||
# The strings in HTTP_ACCEPT_LANGUAGE use '-', however.
|
||||
$lang =~ s#_#-#g;
|
||||
$SUPPORTED_LANG{$lang} = undef;
|
||||
push @SUPPORTED_LANG, $lang;
|
||||
}
|
||||
closedir($dirhandle);
|
||||
|
||||
return @SUPPORTED_LANG;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_translator_language($$)
|
||||
######################################################################
|
||||
{
|
||||
my $lang = shift;
|
||||
my $negotiate = shift;
|
||||
|
||||
get_supported_translators();
|
||||
|
||||
if ($negotiate && exists($ENV{ 'HTTP_ACCEPT_LANGUAGE' }))
|
||||
{
|
||||
# Sample value for HTTP_ACCEPT_LANGUAGE:
|
||||
# de-at,en-us;q=0.7,en;q=0.3
|
||||
my $a = I18N::AcceptLanguage->new( $lang );
|
||||
my $n = $a->accepts($ENV{HTTP_ACCEPT_LANGUAGE}, \@SUPPORTED_LANG);
|
||||
|
||||
$lang = $n if (defined($n) && exists($SUPPORTED_LANG{ $n }));
|
||||
}
|
||||
|
||||
if ($lang)
|
||||
{
|
||||
unless(exists($SUPPORTED_LANG{ $lang }))
|
||||
{
|
||||
die "Unsupported language '$lang' (choose one of " .
|
||||
join(', ', @SUPPORTED_LANG) . ')';
|
||||
}
|
||||
return $lang;
|
||||
}
|
||||
|
||||
return $SUPPORTED_LANG[0];
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_translator($)
|
||||
######################################################################
|
||||
{
|
||||
my $lang = shift;
|
||||
if ($lang)
|
||||
{
|
||||
unless(exists($SUPPORTED_LANG{ $lang }))
|
||||
{
|
||||
die "Unsupported language '$lang' (choose one of " .
|
||||
join(', ', @SUPPORTED_LANG) . ')';
|
||||
}
|
||||
|
||||
# Perl dows not allow '-' in module names, so we use '_' instead.
|
||||
# The strings in HTTP_ACCEPT_LANGUAGE use '-', however.
|
||||
$lang =~ s#-#_#g;
|
||||
|
||||
my $module = __PACKAGE__; # value of __PACKAGE__ is "MOD::Utils"
|
||||
$module =~ s#::[^:]+$##g; # reduce to "MOD"
|
||||
$module .= '::lang::' . $lang; # extend to "MOD::lang::en"
|
||||
|
||||
eval "use $module;";
|
||||
if (length($@) == 0)
|
||||
{
|
||||
no strict;
|
||||
my $get = eval '*{$' . $module . '::{"get_translator"}}{"CODE"}';
|
||||
if (length($@) == 0)
|
||||
{
|
||||
my $trans = return $get->($lang);
|
||||
return $trans if $trans;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return MOD::lang::en_us::get_translator($lang);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
104
MOD/lang/de.pm
Normal file
104
MOD/lang/de.pm
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
#####################################################################
|
||||
#
|
||||
# $Id: de.pm 298 2011-09-04 11:11:33Z root $
|
||||
#
|
||||
# Copyright 2009 Roman Racine
|
||||
# Copyright 2009-2011 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# This file is encoded in iso-8859-1
|
||||
#
|
||||
######################################################################
|
||||
package MOD::lang::de;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
######################################################################
|
||||
use constant TRANS =>
|
||||
######################################################################
|
||||
{
|
||||
'_ALREADY_HANDLED' => 'Dieser Eintrag wurde bereits von einem anderen Moderator bearbeitet.',
|
||||
'Approved Messages' => 'Zugelassene Postings',
|
||||
'Approved' => 'Zugelassen',
|
||||
'Approve' => 'Posten',
|
||||
'_ARRIVAL_NOTICE_BODY' => "In der Moderationsqueue sind noch eines oder mehrere Postings\nvon dir unbearbeitet. Dies ist eine automatische Nachricht.\n",
|
||||
'_ARRIVAL_NOTICE_SUBJECT' => '[%s] Eingangsbestaetigung',
|
||||
'article_sender' => 'Sender',
|
||||
'article_status' => 'Status',
|
||||
'article_subject' => 'Betreff',
|
||||
'Available Actions' => 'Mögliche Aktionen',
|
||||
'Back' => 'Zurück',
|
||||
'Brief Headers' => 'Header verbergen',
|
||||
_CROSSPOSTED => 'Vorsicht, dieses Posting ist in mehr als zwei NGs crossgepostet!',
|
||||
'Date' => 'Datum',
|
||||
'Decision Date' => 'Entscheidungsdatum',
|
||||
'Delete and save reason' => 'Löschen und Begründung speichern',
|
||||
'Delete and save reason' => 'Löschen und Begründung speichern',
|
||||
'Deleted' => 'Gelöscht',
|
||||
'Deleted Posts' => 'Gelöschte Postings',
|
||||
'Delete' => 'Löschen',
|
||||
'Delete Post' => 'Posting löschen',
|
||||
'error_count' => 'Fehleranzahl',
|
||||
'error_date' => 'Datum',
|
||||
'Error' => 'Fehler',
|
||||
_ERROR_GONE => 'Die Fehlermeldung liegt nicht mehr vor, der Fehler ist behoben.',
|
||||
_ERROR_INVALID_ADDRESS => 'Ungültige Adresse, Versand eines Mails nicht möglich.',
|
||||
'error_message' => 'Fehlermeldung',
|
||||
'Error Messages' => 'Fehlermeldungen',
|
||||
'_EXPLAIN_REASON' => 'Hier kann ein Grund für die Löschung des Artikels angegeben werden. Dieser Text ist nur für die übrigen Moderationsmitglieder sichtbar.',
|
||||
'Incoming Date' => 'Eingangsdatum',
|
||||
'Messages' => 'Postings',
|
||||
'Next page' => 'Vorwärts blättern',
|
||||
'No matching records available.' => 'Kein passender Datensatz vorhanden.',
|
||||
'No reason stored in database!' => 'Keine Begründung in der Datenbank vorhanden!',
|
||||
'No Spam' => 'Kein Spam',
|
||||
'No subject' => 'Kein Betreff',
|
||||
'Overview of Approved Posts' => 'Überblick über die zugelassenen Postings',
|
||||
'Pending' => 'Offen',
|
||||
'Pending Posts' => 'Offene Moderationsentscheidungen',
|
||||
'Posted' => 'Gesendet',
|
||||
'Posted Messages' => 'Gesendete Postings',
|
||||
'Previous page' => 'Zurück blättern',
|
||||
'Put back in queue' => 'In Moderationsqueue zurück',
|
||||
'Reason' => 'Begründung',
|
||||
'Rejected' => 'Abgewiesen',
|
||||
'Rejected Posts' => 'Zurückgewiesene Postings',
|
||||
'Reject Post' => 'Posting zurückweisen',
|
||||
'Reject' => 'Zurückweisen',
|
||||
'Reply' => 'Antwort',
|
||||
'Selected Article' => 'Gewählter Artikel',
|
||||
'Sender' => 'Absender',
|
||||
'Send Mail' => 'Mail verschicken',
|
||||
'Show' => 'Anzeigen',
|
||||
'Show Error Message' => 'Fehlermeldung anzeigen',
|
||||
'Show Post' => 'Posting anzeigen',
|
||||
'Show Reply' => 'Antwort anzeigen',
|
||||
'Spam Folder' => 'Spamordner',
|
||||
'Subject' => 'Betreff',
|
||||
'_SUBTITLE_APPROVED' => 'Zugelassene aber noch nicht gesendete Postings.',
|
||||
'_SUBTITLE_DELETED' => 'Ignorierte Postings.',
|
||||
'_SUBTITLE_ERROR' => 'Zugelassene Postings die nicht gesendet werden konnten. Wird automatisch wiederholt.',
|
||||
'_SUBTITLE_PENDING' => 'Postings die auf eine Entscheidung warten.',
|
||||
'_SUBTITLE_POSTED' => 'Zugelassene Postings die zum Newsserver gesendet wurden.',
|
||||
'_SUBTITLE_REJECTED' => 'Abgelehnte Postings, bei denen dem Sender eine Begründung geschickt wurde.',
|
||||
'_SUBTITLE_SPAM' => 'Postings die vom Spamfilter oder einem Moderator als Spam kategorisiert wurden.',
|
||||
'%s wrote:' => '%s schrieb:',
|
||||
'Your post regarding' => 'Dein Posting zum Thema',
|
||||
};
|
||||
|
||||
sub get_translator($)
|
||||
{
|
||||
return sub {
|
||||
my $result = TRANS->{$_[0]};
|
||||
return $result ? $result : $_[0];
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
42
MOD/lang/de_ch.pm
Normal file
42
MOD/lang/de_ch.pm
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: de_ch.pm 147 2009-10-13 14:46:07Z alba $
|
||||
#
|
||||
# Copyright 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# This file is encoded in iso-8859-1
|
||||
#
|
||||
######################################################################
|
||||
package MOD::lang::de_ch;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use Carp qw( confess );
|
||||
use MOD::lang::de();
|
||||
|
||||
use constant TRANS => {
|
||||
'Pending' => 'Pendent',
|
||||
'Pending Posts' => 'Pendente Moderationsentscheidungen',
|
||||
};
|
||||
|
||||
sub get_translator($)
|
||||
{
|
||||
my $de = MOD::lang::de::get_translator(@_) || confess;
|
||||
return sub {
|
||||
my $result = TRANS->{$_[0]};
|
||||
return $result if ($result);
|
||||
$result = $de->(@_);
|
||||
return $result if ($result);
|
||||
return $_[0];
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
22
MOD/lang/de_de.pm-disable
Normal file
22
MOD/lang/de_de.pm-disable
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
#!/usr/bin/perl -w
|
||||
#
|
||||
# $Id: de_de.pm-disable 64 2009-09-02 19:42:41Z alba $
|
||||
#
|
||||
# This file is encoded in iso-8859-1
|
||||
#
|
||||
package MOD::lang::de_de;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use MOD::lang::de_at();
|
||||
|
||||
@MOD::Utils::ISA = qw(Exporter);
|
||||
@MOD::Utils::EXPORT = qw();
|
||||
@MOD::Utils::EXPORT_OK = qw( get_translator );
|
||||
|
||||
sub get_translator($)
|
||||
{
|
||||
return MOD::lang::de_at::get_translator(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
54
MOD/lang/en_us.pm
Normal file
54
MOD/lang/en_us.pm
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: en_us.pm 273 2010-05-28 21:22:31Z root $
|
||||
#
|
||||
# Copyright 2009 Roman Racine
|
||||
# Copyright 2009-2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# This file is encoded in iso-8859-1
|
||||
#
|
||||
######################################################################
|
||||
package MOD::lang::en_us;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use constant TRANS => {
|
||||
'_ALREADY_HANDLED' => 'This entry was already handled by another moderator.',
|
||||
'_ARRIVAL_NOTICE_BODY' => "One or more of your posts are pending in the moderation queue.\nThis message was generated automatically.\n",
|
||||
'_ARRIVAL_NOTICE_SUBJECT' => '[%s] Post received',
|
||||
'article_sender' => 'Sender',
|
||||
'article_status' => 'Status',
|
||||
'article_subject' => 'Subject',
|
||||
'_CROSSPOSTED' => 'Note that this message is crossposted to more than two groups!',
|
||||
'error_count' => 'Error Count',
|
||||
'error_date' => 'Date',
|
||||
'_ERROR_GONE' => 'The error message is gone, probably because its cause is fixed.',
|
||||
'_ERROR_INVALID_ADDRESS' => 'Invalid address, can\'t send mail.',
|
||||
'error_message' => 'Error Message',
|
||||
'_EXPLAIN_REASON' => 'Here you can state a reason why the message was deleted. This text is visible only to other members of the moderation team.',
|
||||
'_SUBTITLE_APPROVED' => 'Approved posts that are not sent, yet.',
|
||||
'_SUBTITLE_DELETED' => 'Posts that are silently ignored.',
|
||||
'_SUBTITLE_ERROR' => 'Approved posts that could not be sent. Will be retried automatically.',
|
||||
'_SUBTITLE_PENDING' => 'Posts waiting for your decision.',
|
||||
'_SUBTITLE_POSTED' => 'Approved posts that were sent to the newsserver.',
|
||||
'_SUBTITLE_REJECTED' => 'Posts where the sender was sent a reason why they were not approved.',
|
||||
'_SUBTITLE_SPAM' => 'Posts classified as spam by the spam filter or a moderator.',
|
||||
};
|
||||
|
||||
sub get_translator($)
|
||||
{
|
||||
return sub {
|
||||
my $result = TRANS->{$_[0]};
|
||||
return $result ? $result : $_[0];
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
12
TODO
Normal file
12
TODO
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
- change to status "deleted" immediately, write reply in separate step, use set_reply()
|
||||
- trigger poster.pl through the web-interface (Unix socket?)
|
||||
- check whether crosspost is to a moderated group
|
||||
- make configuration file configurable at run time
|
||||
- provide internal user management and login form
|
||||
- installation program
|
||||
- warn about cancels and supersedes
|
||||
- lock down state of old posts (spam, deleted)
|
||||
- don't send mail to .invalid, .example, etc.
|
||||
- support utf-8 (database, HTML input, HTML output, mail output)
|
||||
- script to generate summary.txt from configuration files
|
||||
- announce incoming submissions to moderator, but go sure that only one mail per day is sent
|
||||
109
bin/autoreply.pl
Normal file
109
bin/autoreply.pl
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
#!/usr/bin/perl -sw
|
||||
######################################################################
|
||||
#
|
||||
# $Id: autoreply.pl 288 2011-02-18 22:45:59Z alba $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Mail::Sendmail();
|
||||
use MOD::DBIUtils();
|
||||
use MOD::Utils();
|
||||
|
||||
# Mail::Sendmail can handle Cc: and produces a detailed log
|
||||
# Mail::Mailer is inferior, don't use
|
||||
|
||||
|
||||
######################################################################
|
||||
sub get_strings($)
|
||||
######################################################################
|
||||
{
|
||||
my $r_config = shift || die;
|
||||
|
||||
my $lang = MOD::Utils::get_translator_language(
|
||||
$r_config->{'html_language'},
|
||||
undef
|
||||
);
|
||||
if ($::debug) { printf "get_translator_language=%s\n", $lang; }
|
||||
my $trans = MOD::Utils::get_translator($lang);
|
||||
|
||||
my %result = map { $_ => $trans->($_); }
|
||||
(
|
||||
'_ARRIVAL_NOTICE_BODY',
|
||||
'_ARRIVAL_NOTICE_SUBJECT'
|
||||
);
|
||||
if ($::debug)
|
||||
{
|
||||
while(my ($key, $value) = each %result)
|
||||
{ printf "%s => [%s]\n", $key, $value; }
|
||||
}
|
||||
return \%result;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub send_autoreply($$$)
|
||||
######################################################################
|
||||
{
|
||||
my $r_config = shift || die;
|
||||
my $r_strings = shift || die;
|
||||
my $address = shift;
|
||||
|
||||
chomp $address;
|
||||
return if ($address =~ /(,|\n)/s);
|
||||
|
||||
my $moderated_group = $r_config->{'moderated_group'};
|
||||
Mail::Sendmail::sendmail(
|
||||
'From' => $r_config->{'mailfrom'},
|
||||
'Subject' => sprintf(
|
||||
$r_strings->{_ARRIVAL_NOTICE_SUBJECT},
|
||||
$moderated_group
|
||||
),
|
||||
'To' => $address,
|
||||
'Message' => sprintf(
|
||||
$r_strings->{_ARRIVAL_NOTICE_BODY},
|
||||
$moderated_group
|
||||
),
|
||||
);
|
||||
if ($::debug) { print $Mail::Sendmail::log, "\n\n"; }
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# MAIN
|
||||
######################################################################
|
||||
|
||||
$::debug = 0 if (!$::debug);
|
||||
|
||||
die "Missing parameter '-config'" unless($::config);
|
||||
my %config = MOD::Utils::read_private_config($::config);
|
||||
my $dbi = MOD::DBIUtils->new(\%config);
|
||||
|
||||
my $r_strings = get_strings(\%config);
|
||||
my $address_rx = $Mail::Sendmail::address_rx;
|
||||
|
||||
my $dataref = $dbi->select_pending();
|
||||
while (my $ref = $dataref->fetchrow_arrayref)
|
||||
{
|
||||
my ($address) = @{$ref};
|
||||
if ($address =~ /$address_rx/o)
|
||||
{
|
||||
# my $address = $1;
|
||||
# my $user = $2;
|
||||
# my $domain = $3;
|
||||
if ($::debug) { printf "processing [%s]\n", $address; }
|
||||
send_autoreply(\%config, $r_strings, $address);
|
||||
}
|
||||
elsif ($::debug) {
|
||||
printf "invalid address [%s]\n", $address;
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
94
bin/fremdcancel.pl
Normal file
94
bin/fremdcancel.pl
Normal file
|
|
@ -0,0 +1,94 @@
|
|||
#!/usr/bin/perl
|
||||
######################################################################
|
||||
#
|
||||
# $Id: fremdcancel.pl 302 2011-09-30 00:09:02Z alba $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
BEGIN { push (@INC, $ENV{'HUHU_DIR'}); }
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Net::NNTP;
|
||||
use News::Article;
|
||||
use News::Article::Cancel;
|
||||
use MOD::Utils;
|
||||
|
||||
use constant NR_POSTS_TO_EXAMINE => 5;
|
||||
|
||||
######################################################################
|
||||
sub check_pgp($$$)
|
||||
######################################################################
|
||||
{
|
||||
my $article = shift || die;
|
||||
my $moderated_group = shift || die;
|
||||
my $pgp_keyid = shift || die;
|
||||
|
||||
my $mid = $article->header('message-id') || die 'No Message-ID';
|
||||
my $result = $article->verify_pgpmoose($moderated_group);
|
||||
|
||||
if (!$result)
|
||||
{
|
||||
printf "Checking %s, not signed.\n", $mid;
|
||||
return undef;
|
||||
}
|
||||
if ($result ne $pgp_keyid)
|
||||
{
|
||||
printf "Checking %s, signed with wrong key. Expected '%s', got '%s'.\n",
|
||||
$mid, $pgp_keyid, $result;
|
||||
return undef;
|
||||
}
|
||||
printf "Checking %s, ok\n", $mid;
|
||||
return 1;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# MAIN
|
||||
######################################################################
|
||||
|
||||
my %config = MOD::Utils::read_private_config($ARGV[0]);
|
||||
|
||||
my $moderated_group = $config{'moderated_group'};
|
||||
if (!$moderated_group)
|
||||
{
|
||||
printf "Missing configuration item 'moderated_group'.\n";
|
||||
exit(1);
|
||||
}
|
||||
|
||||
my $pgp_keyid = $config{'pgp_keyid'};
|
||||
if (!$pgp_keyid)
|
||||
{
|
||||
printf "Missing configuration item 'pgp_keyid'.\n";
|
||||
exit(1);
|
||||
}
|
||||
|
||||
my $nntp = new Net::NNTP($config{'nntp_server'}) or exit(0);
|
||||
$nntp->authinfo($config{'nntp_user'},$config{'nntp_pass'}) or exit(0);
|
||||
my ($articles,$first,$last,undef) = $nntp->group($config{'moderated_group'});
|
||||
|
||||
my $start = $last - NR_POSTS_TO_EXAMINE;
|
||||
if ($start < $first) { $start = $first; }
|
||||
|
||||
for my $id ($start .. $last)
|
||||
{
|
||||
my $articletext = $nntp->article($id);
|
||||
if (defined($articletext))
|
||||
{
|
||||
my $article = News::Article::Cancel->new($articletext);
|
||||
my $ok = check_pgp($article, $moderated_group, $pgp_keyid);
|
||||
if (!$ok)
|
||||
{
|
||||
next if ($article->header('Newsgroups') =~ /de.admin.news.announce/);
|
||||
my $cancel = $article->make_cancel($config{'approve_string'},'moderator','Gecancelt because of fake approval');
|
||||
$cancel->set_headers('Approved',$config{'approve_string'});
|
||||
$cancel->sign_pgpmoose($config{'moderated_group'},$config{'pgp_passphrase'},$config{'pgp_keyid'});
|
||||
$cancel->post($nntp);
|
||||
}
|
||||
}
|
||||
}
|
||||
261
bin/ircbot.pl
Normal file
261
bin/ircbot.pl
Normal file
|
|
@ -0,0 +1,261 @@
|
|||
#!/usr/bin/perl -sw
|
||||
######################################################################
|
||||
#
|
||||
# $Id: ircbot.pl 266 2010-05-18 15:14:08Z alba $
|
||||
#
|
||||
# Copyright 2009 Roman Racine
|
||||
# Copyright 2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw(confess);
|
||||
use Data::Dumper;
|
||||
use Net::IRC();
|
||||
|
||||
use MOD::DBIUtilsPublic();
|
||||
use MOD::Utils();
|
||||
use MOD::Displaylib();
|
||||
use MOD::NotificationSocket();
|
||||
|
||||
######################################################################
|
||||
|
||||
use constant DEBUG_TO_IRC => 0;
|
||||
use constant MIN_TIME_BETWEEN_QUERIES => 5;
|
||||
use constant MAX_TIME_BETWEEN_QUERIES => 30;
|
||||
|
||||
######################################################################
|
||||
|
||||
my Net::IRC $irc;
|
||||
my Net::IRC::Connection $conn;
|
||||
my MOD::DBIUtilsPublic $db;
|
||||
my MOD::Displaylib $display;
|
||||
|
||||
my $channel;
|
||||
my $last = 'none';
|
||||
my $pending = 'no';
|
||||
my $last_query_time = 0;
|
||||
|
||||
######################################################################
|
||||
sub on_connect
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift;
|
||||
$self->join($channel);
|
||||
$conn->privmsg($channel,'*huhu*');
|
||||
check_for_new(1);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub alarm_handler
|
||||
######################################################################
|
||||
{
|
||||
check_for_new(1);
|
||||
alarm(MAX_TIME_BETWEEN_QUERIES);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub on_public
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $event) = @_;
|
||||
my $msg = ($event->args)[0];
|
||||
if ($msg eq '!pending') {
|
||||
eval { print_pending(1); };
|
||||
warn $@ if ($@);
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub on_disconnect
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $event) = @_;
|
||||
while (1) {
|
||||
eval {
|
||||
$self->connect();
|
||||
}; if ($@) {
|
||||
sleep 60;
|
||||
} else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub do_connect($$)
|
||||
######################################################################
|
||||
{
|
||||
my $config = shift || confess;
|
||||
my Net::IRC $irc = shift || confess;
|
||||
|
||||
my $nick = $config->{'ircbot_nick'};
|
||||
my $realname = $config->{'ircbot_realname'};
|
||||
my $username = $config->{'ircbot_username'};
|
||||
my $server = $config->{'ircbot_server'};
|
||||
my $port = $config->{'ircbot_port'};
|
||||
|
||||
my $conn = $irc->newconn(
|
||||
Nick => $nick,
|
||||
Server => $server,
|
||||
Port => $port,
|
||||
Ircname => $realname,
|
||||
);
|
||||
confess if (!defined($conn));
|
||||
|
||||
$conn->add_global_handler('376', \&on_connect);
|
||||
$conn->add_global_handler('public', \&on_public);
|
||||
$conn->add_global_handler('disconnect', \&on_disconnect);
|
||||
return $conn;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub on_socket_read($)
|
||||
######################################################################
|
||||
{
|
||||
my $read_socket = shift || confess;
|
||||
|
||||
my $buffer;
|
||||
my $rc = sysread($read_socket, $buffer, 512);
|
||||
|
||||
if (!defined($rc))
|
||||
{
|
||||
if (DEBUG_TO_IRC) { $conn->privmsg($channel, "on_socket_read $!"); }
|
||||
return;
|
||||
}
|
||||
|
||||
if ($rc == 0)
|
||||
{
|
||||
if (DEBUG_TO_IRC) { $conn->privmsg($channel, 'on_socket_read close'); }
|
||||
|
||||
# Do not call close($read_socket), this will hang the process.
|
||||
# Socket is automatically closed when the last reference is freed.
|
||||
$irc->removefh($read_socket) || confess;
|
||||
return;
|
||||
}
|
||||
|
||||
$buffer =~ s/\s+$//;
|
||||
$conn->privmsg($channel, "sysread=$rc [$buffer]");
|
||||
if ($last_query_time + MIN_TIME_BETWEEN_QUERIES < time())
|
||||
{
|
||||
check_for_new(0);
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub on_socket_accept($)
|
||||
######################################################################
|
||||
{
|
||||
my $accept_socket = shift || confess;
|
||||
|
||||
if (DEBUG_TO_IRC)
|
||||
{
|
||||
$conn->privmsg($channel, 'on_socket_accept');
|
||||
}
|
||||
|
||||
my $new_socket;
|
||||
accept($new_socket, $accept_socket) || die "accept: $!";
|
||||
defined($new_socket) || die 'defined($new_socket)';
|
||||
$irc->addfh($new_socket, \&on_socket_read, 'r') || die "addfh: $!";
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub add_notify_sock($$)
|
||||
######################################################################
|
||||
{
|
||||
my $config = shift || confess;
|
||||
my Net::IRC $irc = shift || confess;
|
||||
|
||||
my $fh = MOD::NotificationSocket::socket_create_listening($config);
|
||||
if ($fh) { $irc->addfh($fh, \&on_socket_accept, 'r'); }
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub print_pending($)
|
||||
######################################################################
|
||||
{
|
||||
my $verbose = shift;
|
||||
my $result = eval
|
||||
{
|
||||
my @overview = qw(Sender Subject Datum);
|
||||
$db->displayrange('pending', 0, 10, \@overview);
|
||||
};
|
||||
if ($@) { warn $@; return; }
|
||||
$last_query_time = time();
|
||||
|
||||
my $ref;
|
||||
my $count = 0;
|
||||
while ($ref = $result->fetchrow_arrayref) {
|
||||
my @columns = @{$ref};
|
||||
my ($from,$subject,$date) = ($display->decode_line($columns[0]),$display->decode_line($columns[1]),
|
||||
$columns[2]);
|
||||
$conn->privmsg($channel,"$date; $from; $subject");
|
||||
sleep 1;
|
||||
$count++;
|
||||
}
|
||||
if (!$count && $verbose) {
|
||||
$conn->privmsg($channel,"No postings pending");
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub check_for_new($)
|
||||
######################################################################
|
||||
{
|
||||
my $verbose = shift;
|
||||
my $result = eval
|
||||
{
|
||||
my @overview = qw(Id Sender Subject Datum);
|
||||
$db->displayrange('pending', 0, 1, \@overview);
|
||||
};
|
||||
if ($@) { warn $@; return; }
|
||||
$last_query_time = time();
|
||||
|
||||
my $ref;
|
||||
if ($ref = $result->fetchrow_arrayref) {
|
||||
my @result = @{$ref};
|
||||
if ($last eq 'none' or $last < $result[0]) {
|
||||
my ($from,$subject,$date) = ($display->decode_line($result[1]),$display->decode_line($result[2]),
|
||||
$result[3]);
|
||||
$conn->privmsg($channel,"New posting: $date; $from; $subject");
|
||||
$pending = 'yes';
|
||||
$last = $result[0];
|
||||
}
|
||||
} elsif ($pending eq 'yes') {
|
||||
$conn->privmsg($channel,"No pending postings any more.");
|
||||
$pending = 'no';
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# main
|
||||
######################################################################
|
||||
|
||||
if ($::pidfile)
|
||||
{
|
||||
my $file;
|
||||
if (open($file, '>', $::pidfile))
|
||||
{ print $file $$, "\n"; }
|
||||
else
|
||||
{ warn "Can't open $::pidfile for writing: $!"; }
|
||||
}
|
||||
|
||||
die "Missing parameter '-config'" unless($::config);
|
||||
my %config = MOD::Utils::read_private_config($::config);
|
||||
$channel = $config{'ircbot_channel'} || die;
|
||||
$db = MOD::DBIUtilsPublic->new(\%config);
|
||||
$display = MOD::Displaylib->new(\%config,0);
|
||||
|
||||
$irc = new Net::IRC;
|
||||
add_notify_sock(\%config, $irc);
|
||||
$conn = do_connect(\%config, $irc);
|
||||
|
||||
$SIG{'ALRM'} = \&alarm_handler;
|
||||
alarm(MAX_TIME_BETWEEN_QUERIES);
|
||||
$irc->start;
|
||||
37
bin/ircbot.sh
Normal file
37
bin/ircbot.sh
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
#!/bin/sh
|
||||
######################################################################
|
||||
#
|
||||
# $Id: ircbot.sh 283 2011-02-18 00:17:33Z alba $
|
||||
#
|
||||
######################################################################
|
||||
export "LANG=C"
|
||||
export "LC_ALL=C"
|
||||
set -o nounset
|
||||
set -o errexit
|
||||
|
||||
pidfile="${HOME}/var/ircbot.pid"
|
||||
logfile="${HOME}/var/ircbot.log"
|
||||
config="${HOME}/etc/public.conf"
|
||||
|
||||
do_stop()
|
||||
{
|
||||
if [ -s "${pidfile}" ]; then
|
||||
kill $(cat "${pidfile}") || echo status=$?
|
||||
rm "${pidfile}"
|
||||
fi
|
||||
}
|
||||
|
||||
do_start()
|
||||
{
|
||||
${HUHU_DIR}/bin/ircbot.pl "-config=${config}" "-pidfile=${pidfile}" \
|
||||
> "${logfile}" 2>&1 &
|
||||
}
|
||||
|
||||
case "${1:-}" in
|
||||
start) do_start ;;
|
||||
restart) do_stop; do_start ;;
|
||||
stop) do_stop ;;
|
||||
*) echo "Usage: ircbot.sh {start|stop|restart}"
|
||||
exit 3
|
||||
;;
|
||||
esac
|
||||
100
bin/mailget.pl
Normal file
100
bin/mailget.pl
Normal file
|
|
@ -0,0 +1,100 @@
|
|||
#!/usr/bin/perl -w
|
||||
######################################################################
|
||||
#
|
||||
# $Id: mailget.pl 148 2009-10-13 15:02:22Z alba $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# Reads the mail from the moderator account checks it against
|
||||
# a spamfilter and either puts it into the "to_moderate" table
|
||||
# into the "spam" table or discards the mail completly.
|
||||
#
|
||||
######################################################################
|
||||
use strict;
|
||||
use warnings;
|
||||
use Net::POP3;
|
||||
|
||||
use News::Article;
|
||||
use MOD::Utils;
|
||||
use MOD::DBIUtils;
|
||||
use MOD::Spamfilter;
|
||||
|
||||
sub process($);
|
||||
sub enter_table($);
|
||||
sub enter_spam_table($);
|
||||
|
||||
my %config = MOD::Utils::read_private_config($ARGV[0]);
|
||||
my $spamutil = MOD::Spamfilter->new(\%config);
|
||||
|
||||
my $pop = Net::POP3->new($config{'mod_pop_server'}) or die $!;
|
||||
if ($pop->login($config{'mod_pop_username'}, $config{'mod_pop_pass'}) > 0) {
|
||||
my $msgnums = $pop->list;
|
||||
foreach my $msgnum (keys %{$msgnums}) {
|
||||
my $article = News::Article->new($pop->get($msgnum));
|
||||
if (defined($article)) {
|
||||
eval {
|
||||
process($article);
|
||||
}; if ($@) {
|
||||
print $@,"\n";
|
||||
}
|
||||
}
|
||||
$pop->delete($msgnum);
|
||||
}
|
||||
}
|
||||
$pop->quit;
|
||||
|
||||
|
||||
sub process($) {
|
||||
my $article = shift;
|
||||
my $dbi = MOD::DBIUtils->new(\%config);
|
||||
# broken spam postings
|
||||
return if ($article->bytes() <= 2);
|
||||
if (!defined($article->header('Newsgroups'))) {
|
||||
$article->set_headers('Newsgroups',$config{'moderated_group'});
|
||||
}
|
||||
my $score = 0;
|
||||
if ($spamutil->blacklist($article)) {
|
||||
# $score = 100;
|
||||
# $dbi->enter_table($article,'spam',$score);
|
||||
return;
|
||||
}
|
||||
if ($config{'spamassassin'}) {
|
||||
open(my $savestdout,">&STDOUT") or warn "Failed to dup STDOUT: $!";
|
||||
open(my $savestderr,">&STDERR") or warn "Failed to dup STDOUT: $!";
|
||||
open(STDOUT,'/dev/null') or warn $!;
|
||||
open(STDERR,'/dev/null') or warn $!;
|
||||
$score += $spamutil->spamfilter_spamassassin($article);
|
||||
open(STDOUT,">&$savestdout") or warn $!;
|
||||
open(STDERR,">&$savestderr") or warn $!;
|
||||
|
||||
}
|
||||
|
||||
if ($config{'subjectcheck'} and
|
||||
$dbi->check_subject($article->header('subject'))) {
|
||||
$article->add_headers('X-Subject-Test',
|
||||
$config{'subjectscore'});
|
||||
$score += $config{'subjectscore'};
|
||||
}
|
||||
|
||||
if ($config{'attachmentcheck'}) {
|
||||
$score += $spamutil->spamfilter_attachment($article);
|
||||
}
|
||||
|
||||
if ($config{'langcheck'}) {
|
||||
$score += $spamutil->spamfilter_language($article);
|
||||
}
|
||||
|
||||
if ($score < 5) {
|
||||
$dbi->enter_table($article,'pending',$score);
|
||||
} else {
|
||||
$dbi->enter_table($article,'spam',$score);
|
||||
}
|
||||
}
|
||||
55
bin/mk-gpg-key.sh
Normal file
55
bin/mk-gpg-key.sh
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
#!/bin/sh
|
||||
######################################################################
|
||||
#
|
||||
# $Id: mk-gpg-key.sh 291 2011-06-21 13:19:54Z alba $
|
||||
#
|
||||
######################################################################
|
||||
export "LANG=C"
|
||||
export "LC_ALL=C"
|
||||
set -o nounset
|
||||
set -o errexit
|
||||
|
||||
public="${HOME}/etc/public.conf"
|
||||
if [ ! -s "${public}" ]; then
|
||||
echo "ERROR: Public configuration file does not exist."
|
||||
echo "public=${public}"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
private=$(
|
||||
sed -ne '/^priv_config_file=/ { s///; p; q }' "${public}"
|
||||
)
|
||||
if [ ! -s "${private}" ]; then
|
||||
echo "ERROR: Private configuration file does not exist."
|
||||
echo "private=${private}"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
passphrase=$(
|
||||
sed -ne '/^pgp_passphrase=/ { s///; p; q }' "${private}"
|
||||
)
|
||||
name_real=$(
|
||||
sed -ne '/^pgp_keyid=\(.*\)<.*/ { s//\1/; s/ *$//; p; q }' "${private}"
|
||||
)
|
||||
name_email=$(
|
||||
sed -ne '/^pgp_keyid=.*<\([^>]*\)>.*/ { s//\1/; p; q }' "${private}"
|
||||
)
|
||||
|
||||
echo "passphrase=${passphrase}"
|
||||
echo "name_real=${name_real}"
|
||||
echo "name_email=${name_email}"
|
||||
|
||||
if [ -n "${name_real:-}" -a -n "${name_email:-}" ]; then
|
||||
(
|
||||
# See /usr/share/doc/gnupg/DETAILS.gz for parameter description
|
||||
echo "Key-Type: 1"
|
||||
echo "Key-Length: 2048"
|
||||
echo "Name-Real: ${name_real}"
|
||||
echo "Name-Email: ${name_email}"
|
||||
[ -n "${passphrase:-}" ] && echo "Passphrase: ${passphrase}"
|
||||
echo "Expire-Date: 10y"
|
||||
echo "%commit"
|
||||
echo "%echo done"
|
||||
) | gpg --gen-key --batch
|
||||
gpg --list-keys
|
||||
fi
|
||||
141
bin/mk-summary.pl
Normal file
141
bin/mk-summary.pl
Normal file
|
|
@ -0,0 +1,141 @@
|
|||
#!/usr/bin/perl -sw
|
||||
#######################################################################
|
||||
#
|
||||
# $Id: mk-summary.pl 249 2010-02-17 22:42:19Z alba $
|
||||
#
|
||||
# Copyright 2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
use strict;
|
||||
use Carp qw(confess);
|
||||
use MOD::Utils();
|
||||
|
||||
######################################################################
|
||||
sub get_param($)
|
||||
######################################################################
|
||||
{
|
||||
my $param_name = shift || confess;
|
||||
|
||||
my $r_value;
|
||||
{
|
||||
# man perlvar
|
||||
# $^W ... The current value of the warning switch, initially
|
||||
# true if -w was used.
|
||||
local $^W = 0;
|
||||
$r_value = eval '*{$::{"' . $param_name . '"}}{"SCALAR"}';
|
||||
}
|
||||
if (defined($r_value))
|
||||
{
|
||||
my $value = $$r_value;
|
||||
return $value if (defined($value));
|
||||
}
|
||||
my $var_name = 'HUHU_' . uc($param_name);
|
||||
my $value = $ENV{$var_name};
|
||||
return $value if (defined($value));
|
||||
die "Parameter -$param_name not specified and environment variable $var_name not defined.";
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# main
|
||||
######################################################################
|
||||
|
||||
die 'Argument -config=file missing' unless($::config);
|
||||
|
||||
# supress warnings
|
||||
$::email_domain = undef unless($::email_domain);
|
||||
$::www_base_dir = undef unless($::www_base_dir);
|
||||
$::www_base_url = undef unless($::www_base_url);
|
||||
|
||||
my $email_domain = get_param('email_domain');
|
||||
my $www_base_dir = get_param('www_base_dir');
|
||||
my $www_base_url = get_param('www_base_url');
|
||||
|
||||
my %config = MOD::Utils::read_private_config($::config);
|
||||
|
||||
my $MODERATED_GROUP = $config{'moderated_group'} || die;
|
||||
my $user_name = $MODERATED_GROUP;
|
||||
$user_name =~ s/\./-/g;
|
||||
my $SUBMISSION_EMAIL = $user_name . '@' . $email_domain;
|
||||
|
||||
my $APPROVE_STRING = $config{'approve_string'} || '';
|
||||
my $MID_FQDN = $config{'mid_fqdn'} || '';
|
||||
my $MAILFROM = $config{'mailfrom'} || '';
|
||||
my $NNTP_USER = $config{'nntp_user'} || '';
|
||||
my $NNTP_PASS = $config{'nntp_pass'} || '';
|
||||
my $NNTP_SERVER = $config{'nntp_server'} || '';
|
||||
|
||||
print <<EOF;
|
||||
== Email ==
|
||||
|
||||
The submission address is <$SUBMISSION_EMAIL>.
|
||||
|
||||
Messages are directly processed by procmail, so you cannot access it
|
||||
with POP or IMAP. (Messages are saved in a backup directory as plain
|
||||
files, though.)
|
||||
|
||||
You can test Huhu by sending posts directly to this address.
|
||||
When tests are finished you should send a message stating that
|
||||
<$SUBMISSION_EMAIL> is the new submission address of
|
||||
$MODERATED_GROUP to <moderators-request\@isc.org>.
|
||||
|
||||
== Web Interface ==
|
||||
|
||||
The web interface consists of two parts. The public part is accessible
|
||||
to everybody. It just displays the approved posts.
|
||||
|
||||
https://albasani.net/huhu/aus/legal/moderated/public.pl
|
||||
|
||||
And then there is the private part. This is protected with a login.
|
||||
using the HTTP digest system.
|
||||
|
||||
https://albasani.net/huhu/aus/legal/moderated/modtable.pl
|
||||
|
||||
HTTP digest is safe to use on unencrypted connections, but for additional
|
||||
paranoia above URLs are also available through https (with a self signed
|
||||
certificate).
|
||||
|
||||
There is currently no way to handle user management through the web
|
||||
interface. I created one account for you:
|
||||
|
||||
Username:
|
||||
Password:
|
||||
|
||||
== Test Mode ==
|
||||
|
||||
At the moment this instance of Huhu is in test mode. Approved messages
|
||||
are sent to albasani.test.moderated. This is an internal group, i.e.
|
||||
it is not sent to peers. You need an albasani-account to read it.
|
||||
|
||||
When you are satisfied with your tests please give me a note.
|
||||
I will then switch to $MODERATED_GROUP.
|
||||
|
||||
== Configurable Options ==
|
||||
|
||||
The following settings are set to default values.
|
||||
Please give me a note if you want to have them changed.
|
||||
|
||||
# Value of header "Approved:" in posts
|
||||
approve_string=$APPROVE_STRING
|
||||
|
||||
# Right hand side of message IDs in in posts.
|
||||
# Empty value means that the news server generates the ID.
|
||||
mid_fqdn=$MID_FQDN
|
||||
|
||||
# Value of header "From:" in rejection notices.
|
||||
mailfrom=$MAILFROM
|
||||
|
||||
== Usenet Account ==
|
||||
|
||||
Username: $NNTP_USER
|
||||
Password: $NNTP_PASS
|
||||
Server : $NNTP_SERVER
|
||||
|
||||
It has permissions to send approved posts to albasani.test.moderated
|
||||
and $MODERATED_GROUP. Use it to bypass the moderation (e.g. send FAQs
|
||||
or cancel messages) or to read the internal albasani.* groups.
|
||||
EOF
|
||||
24
bin/new-passwd.pl
Normal file
24
bin/new-passwd.pl
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
#!/usr/bin/perl -w
|
||||
#######################################################################
|
||||
#
|
||||
# $Id: new-passwd.pl 164 2009-11-03 20:21:38Z alba $
|
||||
#
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
use strict;
|
||||
use constant PRINTABLE =>
|
||||
'*+-./0123456789' .
|
||||
'ABCDEFGHIJKLMNOPQRSTUVWXYZ' .
|
||||
'abcdefghijklmnopqrstuvwxyz';
|
||||
|
||||
for(my $i = 1; $i <= 8; $i++)
|
||||
{
|
||||
print substr PRINTABLE, rand(length(PRINTABLE)), 1;
|
||||
}
|
||||
print "\n";
|
||||
225
bin/poster.pl
Normal file
225
bin/poster.pl
Normal file
|
|
@ -0,0 +1,225 @@
|
|||
#!/usr/bin/perl -w
|
||||
######################################################################
|
||||
#
|
||||
# $Id: poster.pl 303 2011-10-31 13:03:03Z root $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 - 2011 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
poster.pl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Dieses Programm liest die zu postenden Postings aus der
|
||||
Datenbank aus und postet sie ins Usenet. Sofern dies erfolgreich
|
||||
ist, setzt es das Bit "posted" in der Datenbank.
|
||||
|
||||
Wenn der Versand nicht erfolgreich ist, tut das Programm nichts,
|
||||
d.h, das Posten wird bei einem spaeteren Aufruf des Programms
|
||||
einfach nochmals versucht.
|
||||
|
||||
Dieses Programm sollte am besten via Cronjob laufen.
|
||||
|
||||
Das Programm wird mit
|
||||
./poster.pl <Pfad zum Configfile> aufgerufen
|
||||
Dasselbe Programm mit unterschiedlichen Konfigurationsfiles
|
||||
aufgerufen kann zur Moderation mehrerer Gruppen eingesetzt werden.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
Net::NNTP
|
||||
|
||||
News::Article
|
||||
|
||||
MOD::*
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Roman Racine <roman.racine@gmx.net>
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
10. Februar 2007
|
||||
|
||||
=cut
|
||||
|
||||
######################################################################
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw(confess);
|
||||
|
||||
use Net::NNTP();
|
||||
use News::Article;
|
||||
|
||||
use MOD::Utils;
|
||||
use MOD::DBIUtils;
|
||||
|
||||
use constant DEBUG => 0;
|
||||
|
||||
######################################################################
|
||||
sub connect_nntp($)
|
||||
######################################################################
|
||||
{
|
||||
my $r_config = shift || confess;
|
||||
|
||||
my $cfg_nntp_server = $r_config->{'nntp_server'} ||
|
||||
die 'No "nntp_server" in configuration file';
|
||||
my $nntp = new Net::NNTP($cfg_nntp_server, 'DEBUG' => DEBUG) ||
|
||||
die "Can't connect to news server $cfg_nntp_server";
|
||||
|
||||
my $cfg_nntp_user = $r_config->{'nntp_user'} ||
|
||||
die 'No "nntp_user" in configuration file';
|
||||
my $cfg_nntp_pass = $r_config->{'nntp_pass'} ||
|
||||
die 'No "nntp_pass" in configuration file';
|
||||
|
||||
# authinfo does not return a value
|
||||
$nntp->authinfo($cfg_nntp_user, $cfg_nntp_pass);
|
||||
|
||||
return $nntp;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# MAIN
|
||||
######################################################################
|
||||
|
||||
my %config = MOD::Utils::read_private_config($ARGV[0]);
|
||||
my $approve_string = $config{'approve_string'} ||
|
||||
die 'No "approve_string" in $config';
|
||||
|
||||
my $moderated_group = $config{'moderated_group'};
|
||||
my $pgp_passphrase = $config{'pgp_passphrase'};
|
||||
my $pgp_keyid = $config{'pgp_keyid'};
|
||||
my $sign_pgpmoose = ($moderated_group && $pgp_passphrase && $pgp_keyid);
|
||||
|
||||
if ($sign_pgpmoose && DEBUG > 1)
|
||||
{
|
||||
print "News::Article::sign_pgpmoose enabled.\n";
|
||||
}
|
||||
|
||||
my Net::NNTP $nntp = connect_nntp(\%config);
|
||||
my $dbi = MOD::DBIUtils->new(\%config) ||
|
||||
die "Can't connect to database";
|
||||
|
||||
# Select all posts that have been approved but not posted,
|
||||
# i.e. all posts in the state 'moderated'.
|
||||
my $dataref = $dbi->select_unposted();
|
||||
|
||||
#Schleife ueber alle selektierten Postings
|
||||
#Einlesen des Postings, Header anpassen,anschliessend posten
|
||||
#und das das posted-Bit in der Datenbank setzen.
|
||||
|
||||
while (my $ref = $dataref->fetchrow_arrayref)
|
||||
{
|
||||
my ($id,$posting) = @{$ref};
|
||||
next unless($dbi->set_status($id, 'sending', [ 'moderated' ]));
|
||||
|
||||
# Posting einlesen.
|
||||
my $article = News::Article->new(\$posting);
|
||||
next if (!defined($article->header('Newsgroups')));
|
||||
|
||||
{ # Save original date header
|
||||
my $date = $article->header('Date');
|
||||
if ($date)
|
||||
{ $article->set_headers('X-Huhu-Submission-Date', $date); }
|
||||
}
|
||||
|
||||
# Drop superfluous headers
|
||||
$article->drop_headers(
|
||||
'Approved',
|
||||
'Date',
|
||||
'Delivery-date',
|
||||
'Delivered-To',
|
||||
'Errors-To', # Mailman
|
||||
'Envelope-to',
|
||||
'Injection-Info', # defined by INN 2.6.x and Schnuerpel 2010
|
||||
'Lines', # defined by INN 2.5.x or older
|
||||
'NNTP-Posting-Date', # defined by INN 2.5.x or older
|
||||
'NNTP-Posting-Host', # defined by INN 2.5.x or older
|
||||
'Path',
|
||||
'Precedence', # Mailman
|
||||
'Received',
|
||||
'Status',
|
||||
'Return-Path',
|
||||
'To',
|
||||
'X-Antivirus',
|
||||
'X-Antivirus-Status',
|
||||
'X-Attachment-Test',
|
||||
'X-Beenthere', # Mailman
|
||||
'X-Complaints-To', # defined by INN 2.5.x or older
|
||||
'X-Lang-Test',
|
||||
'X-Mailman-Version', # Mailman
|
||||
'X-MSMail-Priority', # Outlook
|
||||
'X-NNTP-Posting-Host', # set by Schnuerpel 2009 or older
|
||||
'X-Originating-IP',
|
||||
'X-Priority', # Outlook
|
||||
'X-Provags-ID', # GMX/1&1
|
||||
'X-Spamassassin-Test',
|
||||
'X-Spam-Checker-Version',
|
||||
'X-Spam-Level',
|
||||
'X-Spam-Report',
|
||||
'X-Spam-Score',
|
||||
'X-Spam-Status',
|
||||
'X-Subject-Test',
|
||||
'X-Trace', # defined by INN 2.5.x or older
|
||||
'X-User-ID', # set by Schnuerpel 2009 or older
|
||||
'X-Virus-Scanned',
|
||||
'X-Y-Gmx-Trusted', # GMX/1&1
|
||||
'X-Zedat-Hint', # Uni Berlin/Individual?
|
||||
);
|
||||
|
||||
#albasani-workaround fuer @invalid
|
||||
if ($article->header('From') =~ /\@invalid[> ]/i) {
|
||||
my $newfrom = $article->header('From');
|
||||
$newfrom =~ s/\@invalid/\@invalid.invalid/i;
|
||||
$article->set_headers('From',$newfrom);
|
||||
}
|
||||
# albasani-workaround fuer leere User-Agent headerzeilen
|
||||
if (defined $article->header('User-Agent') and $article->header('User-Agent') !~ /\w/) {
|
||||
$article->drop_headers(('User-Agent'));
|
||||
}
|
||||
|
||||
#Neue Message-ID und Approved-Header erzeugen
|
||||
my $mid = defined($article->header('Message-ID')) ? $article->header('Message-ID') :
|
||||
'<' . substr (rand() . '-' . time(), 2) . '@' . $config{'mid_fqdn'} . '>';
|
||||
$article->set_headers('Message-ID', $mid, 'Approved', $approve_string);
|
||||
|
||||
#signieren
|
||||
if ($sign_pgpmoose)
|
||||
{
|
||||
my @msg = $article->sign_pgpmoose($moderated_group, $pgp_passphrase, $pgp_keyid);
|
||||
if (@msg)
|
||||
{
|
||||
print join("\n", 'News::Article::sign_pgpmoose ', @msg);
|
||||
}
|
||||
}
|
||||
|
||||
my @articleheaders = $article->header('References');
|
||||
eval {
|
||||
# Workaround fuer Buggy Software, die kaputte References erzeugt
|
||||
my @references = $article->header('References');
|
||||
if (@references > 1) {
|
||||
$article->set_headers('References', join "\n ", @references);
|
||||
}
|
||||
#posten
|
||||
$article->post($nntp) or die $!;
|
||||
#posted-Bit setzen, aktuelle MID in DB eintragen (wird in Zukunft vielleicht mal von einer Zusatzfunktion benoetigt)
|
||||
$dbi->set_posted_status($id,$mid);
|
||||
};
|
||||
# Fehler in Datenbank festhalten, sofern einer aufgetreten ist
|
||||
if ($@) {
|
||||
$dbi->increase_errorlevel($id, $@);
|
||||
$dbi->set_status($id, 'moderated', [ 'sending' ]);
|
||||
}
|
||||
}
|
||||
154
bin/read-mail.pl
Normal file
154
bin/read-mail.pl
Normal file
|
|
@ -0,0 +1,154 @@
|
|||
#!/usr/bin/perl -ws
|
||||
######################################################################
|
||||
#
|
||||
# $Id: read-mail.pl 306 2012-01-31 16:59:35Z root $
|
||||
#
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw(confess);
|
||||
use News::Article();
|
||||
use MOD::Utils();
|
||||
use MOD::ReadMail();
|
||||
|
||||
######################################################################
|
||||
sub parse_text($)
|
||||
######################################################################
|
||||
{
|
||||
my $text = shift || confess;
|
||||
|
||||
my $article = News::Article->new($text);
|
||||
if (!$article)
|
||||
{
|
||||
print STDERR "Error: Parsing mail with News::Article failed.\n";
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $bytes = $article->bytes();
|
||||
if ($bytes <= 2)
|
||||
{
|
||||
print STDERR "Error: Article too small, bytes=$bytes\n";
|
||||
return undef;
|
||||
}
|
||||
|
||||
return $article;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub skip_empty_lines($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($body, $start, $stop) = @_;
|
||||
|
||||
my @result;
|
||||
push(@result, $body->[$start - 1]) if ($start > 0);
|
||||
|
||||
for(my $i = $start; $i <= $stop; $i += 2)
|
||||
{
|
||||
if (length($body->[$i]) != 0)
|
||||
{
|
||||
printf STDERR "check_for_empty_lines i=%d %s\n", $i, $body->[$i];
|
||||
return undef;
|
||||
}
|
||||
push @result, $body->[$i + 1];
|
||||
}
|
||||
return \@result;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub test_article($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($rm, $article, $filename) = @_;
|
||||
|
||||
my $lines = $article->header('Lines');
|
||||
if (!$lines)
|
||||
{
|
||||
printf STDERR "Warning: No Lines header.\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
my @body = $article->body();
|
||||
my $delta = $lines * 2 - $#body;
|
||||
if (abs($delta) <= 2)
|
||||
{
|
||||
print $filename, "\n";
|
||||
printf "body: %d\n", $#body;
|
||||
printf "Lines: %d\n", $article->header('Lines');
|
||||
|
||||
my $new_body = skip_empty_lines(\@body, 1, $#body);
|
||||
if (!$new_body)
|
||||
{
|
||||
$new_body = skip_empty_lines(\@body, 0, $#body);
|
||||
return 0 if (!$new_body);
|
||||
}
|
||||
|
||||
printf "new_body=%d\n", $#$new_body;
|
||||
print join("\n", @$new_body);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub process_text($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($rm, $article, $filename) = @_;
|
||||
|
||||
my $rc = eval { $rm->add_article($article, $::status); };
|
||||
if ($@)
|
||||
{
|
||||
print STDERR "add_article failed, $@\n";
|
||||
return 0;
|
||||
}
|
||||
if (!$rc)
|
||||
{
|
||||
printf STDERR "add_article(%s) failed, rc=%s\n",
|
||||
$::status ? $::status : '',
|
||||
$rc;
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# MAIN
|
||||
######################################################################
|
||||
|
||||
die 'Argument -config=file missing' unless($::config);
|
||||
$::status = undef unless($::status); # to suppress warning
|
||||
$::stdin = undef unless($::stdin); # to suppress warning
|
||||
|
||||
my %config = MOD::Utils::read_private_config($::config);
|
||||
my $rm = MOD::ReadMail->new(\%config);
|
||||
|
||||
my $fn = $::test ? \&test_article : \&process_text;
|
||||
|
||||
if ($::stdin)
|
||||
{
|
||||
my $text = do { local $/; <STDIN>; };
|
||||
die "Error: No data on stdin" unless ($text);
|
||||
my $article = parse_text(\$text) || exit(1);
|
||||
$fn->($rm, $article, '<STDIN>');
|
||||
}
|
||||
else
|
||||
{
|
||||
for my $name(@ARGV)
|
||||
{
|
||||
my $file;
|
||||
open($file, '<', $name) || die "Error: Can't open $name\n$!";
|
||||
my $text = do { local $/; <$file>; };
|
||||
close($file);
|
||||
my $article = parse_text(\$text) || next;
|
||||
$fn->($rm, $article, $name);
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
74
bin/removeold.pl
Normal file
74
bin/removeold.pl
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
#!/usr/bin/perl
|
||||
######################################################################
|
||||
#
|
||||
# $Id: removeold.pl 148 2009-10-13 15:02:22Z alba $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw(confess);
|
||||
use MOD::Utils();
|
||||
use MOD::DBIUtils();
|
||||
use MOD::Spamfilter();
|
||||
|
||||
my %config = MOD::Utils::read_private_config($ARGV[0]);
|
||||
my $dbi = MOD::DBIUtils->new(\%config) || confess;
|
||||
|
||||
{
|
||||
#Zeige Postings an, die zwischen 0 und 1 Tagen alt sind
|
||||
#und den Status 'moderated' haben.
|
||||
my $dataref = $dbi->select_old_postings(0,1,'moderated');
|
||||
while (my $ref = $dataref->fetchrow_arrayref) {
|
||||
my ($id,$posting) = @{$ref};
|
||||
#Fuettere sie an Spamassassin als Ham (kein Spam)
|
||||
MOD::Spamfilter::spamlearn($posting,0);
|
||||
}
|
||||
}
|
||||
|
||||
#Zeige Postings an, die aelter als x Tage sind und den
|
||||
#Status 'spam' tragen, d.h. in den letzten x Tagen
|
||||
#entweder von einem Moderator als Spam klassifiziert
|
||||
#worden sind oder bereits als Spam erkannt wurden, ohne
|
||||
#dass ein Moderator sie im Nachhinein als "kein Spam" klassifiziert
|
||||
#haette.
|
||||
|
||||
my $delete_spam_after = $config{'delete_spam_after'};
|
||||
if ($delete_spam_after)
|
||||
{
|
||||
my $dataref = $dbi->select_old_postings($delete_spam_after, undef, 'spam');
|
||||
while (my $ref = $dataref->fetchrow_arrayref) {
|
||||
my ($id,$posting) = @{$ref};
|
||||
#Fuettere sie an Spamassassin als Spam
|
||||
MOD::Spamfilter::spamlearn($posting,1);
|
||||
#Loesche das Posting
|
||||
$dbi->delete_posting($id);
|
||||
}
|
||||
}
|
||||
|
||||
#Zeige Postings an, die aelter als x Tage sind
|
||||
my $delete_posting_after = $config{'delete_posting_after'};
|
||||
if ($delete_posting_after)
|
||||
{
|
||||
my $dataref = $dbi->select_old_postings($delete_posting_after, undef, undef);
|
||||
while (my $ref = $dataref->fetchrow_arrayref) {
|
||||
my ($id,$posting) = @{$ref};
|
||||
#Loesche sie aus der Datenbank
|
||||
$dbi->delete_posting($id);
|
||||
}
|
||||
}
|
||||
|
||||
my $delete_error_after = $config{'delete_error_after'};
|
||||
if ($delete_error_after)
|
||||
{
|
||||
$dbi->delete_old_errors($delete_error_after, undef);
|
||||
}
|
||||
|
||||
# End of file
|
||||
123
bin/statistics.pl
Normal file
123
bin/statistics.pl
Normal file
|
|
@ -0,0 +1,123 @@
|
|||
#!/usr/bin/perl -w
|
||||
######################################################################
|
||||
#
|
||||
# $Id: statistics.pl 148 2009-10-13 15:02:22Z alba $
|
||||
#
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
use strict;
|
||||
use warnings;
|
||||
use MOD::Utils();
|
||||
use MOD::DBIUtilsPublic();
|
||||
use Data::Dumper;
|
||||
|
||||
######################################################################
|
||||
sub format_time($)
|
||||
######################################################################
|
||||
{
|
||||
my ( $seconds ) = @_;
|
||||
|
||||
my $hours = $seconds / 3600;
|
||||
$seconds %= 3600;
|
||||
my $minutes = $seconds / 60;
|
||||
$seconds %= 60;
|
||||
|
||||
return sprintf '%02d:%02d:%02d', $hours, $minutes, $seconds;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub format_item($)
|
||||
######################################################################
|
||||
{
|
||||
my ( $r ) = @_;
|
||||
|
||||
return sprintf
|
||||
"%5d %9s %9s %9s %9s",
|
||||
$r->{'count'},
|
||||
format_time($r->{'min'}),
|
||||
format_time($r->{'max'}),
|
||||
format_time($r->{'avg'}),
|
||||
format_time($r->{'median'})
|
||||
;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub print_stats($$)
|
||||
######################################################################
|
||||
{
|
||||
my ( $status, $r_stats ) = @_;
|
||||
|
||||
return unless ($r_stats->{'total'}->{'count'});
|
||||
|
||||
print "\n";
|
||||
if ($status eq 'all')
|
||||
{ print " All posts.\n"; }
|
||||
else
|
||||
{ printf " Posts of type %s.\n", $status; }
|
||||
print "\n";
|
||||
|
||||
for my $year(sort keys %$r_stats)
|
||||
{
|
||||
next if ($year eq 'total');
|
||||
my $r_month = $r_stats->{$year};
|
||||
|
||||
for my $month(sort keys %$r_month)
|
||||
{
|
||||
next if ($month eq 'total');
|
||||
my $r_mday = $r_month->{$month};
|
||||
|
||||
print "yyyy-mm-dd posts min max avg median\n";
|
||||
print "========================================================\n";
|
||||
for my $mday(sort keys %$r_mday)
|
||||
{
|
||||
next if ($mday eq 'total');
|
||||
my $r = $r_mday->{$mday};
|
||||
printf "%04d-%02d-%02d %s\n", $year, $month, $mday, format_item($r);
|
||||
}
|
||||
|
||||
my $r = $r_mday->{'total'};
|
||||
print "--------------------------------------------------------\n";
|
||||
printf "%04d-%02d %s\n", $year, $month, format_item($r);
|
||||
print "\n";
|
||||
}
|
||||
|
||||
my $r = $r_month->{'total'};
|
||||
print "========================================================\n";
|
||||
printf "%04d %s\n", $year, format_item($r);
|
||||
print "========================================================\n";
|
||||
print "\n";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# MAIN
|
||||
######################################################################
|
||||
|
||||
my %config = MOD::Utils::read_private_config($ARGV[0]);
|
||||
my $db = MOD::DBIUtilsPublic->new(\%config);
|
||||
my $statistics = $db->get_statistics();
|
||||
|
||||
my $all = $statistics->{'all'};
|
||||
|
||||
for my $status(
|
||||
'all',
|
||||
'pending',
|
||||
'moderated',
|
||||
'spam',
|
||||
'rejected',
|
||||
'deleted',
|
||||
'posted')
|
||||
{
|
||||
print_stats($status, $statistics->{$status});
|
||||
}
|
||||
|
||||
# print Dumper($statistics);
|
||||
|
||||
1;
|
||||
12
cgi-bin/modtable.pl
Normal file
12
cgi-bin/modtable.pl
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
use warnings;
|
||||
use CGI::Carp 'fatalsToBrowser';
|
||||
|
||||
$ENV{'CONTENT_TYPE'} = "multipart/form-data";
|
||||
|
||||
BEGIN { push (@INC, $ENV{'HUHU_DIR'}); }
|
||||
|
||||
use MOD::Handler;
|
||||
my $h = MOD::Handler->new( $ENV{'HUHU_PUB_CONFIG'} );
|
||||
$h->run();
|
||||
13
cgi-bin/public.pl
Normal file
13
cgi-bin/public.pl
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
use warnings;
|
||||
use CGI::Carp 'fatalsToBrowser';
|
||||
|
||||
$ENV{'CONTENT_TYPE'} = "multipart/form-data";
|
||||
|
||||
BEGIN { push (@INC, $ENV{'HUHU_DIR'}); }
|
||||
|
||||
require MOD::PublicHandler;
|
||||
|
||||
my $h = MOD::PublicHandler->new( $ENV{'HUHU_PUB_CONFIG'} );
|
||||
$h->run();
|
||||
12
doc/CONTRIBUTORS
Normal file
12
doc/CONTRIBUTORS
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
The following is a list of the people (in roughly chronological order)
|
||||
who've helped out.
|
||||
|
||||
Roman Racine:
|
||||
Designed and wrote most of it.
|
||||
|
||||
Alexander Bartolich:
|
||||
Took over development in autumn 2009, added support for CSS,
|
||||
multiple languages and procmail.
|
||||
|
||||
Thomas Hochstein:
|
||||
X-Huhu-Submission-Date, option "Put back in queue" on delete
|
||||
63
doc/environment.txt
Normal file
63
doc/environment.txt
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
== Operation ==
|
||||
|
||||
Required by all commands.
|
||||
|
||||
HUHU_DIR
|
||||
|
||||
== Installation ==
|
||||
|
||||
Additional variables required by "sbin/create-procmail-user.sh".
|
||||
|
||||
DIR and URL point to the same location.
|
||||
|
||||
HUHU_WWW_BASE_DIR
|
||||
HUHU_WWW_BASE_URL
|
||||
|
||||
DIR and URL point to the same location, but in different ways.
|
||||
DIR is a file system path while URL is the base of the address
|
||||
used in a web browser.
|
||||
|
||||
Example:
|
||||
HUHU_WWW_BASE_DIR="/srv/www/albasani.net/html/huhu"
|
||||
HUHU_WWW_BASE_URL="http://albasani.net/huhu"
|
||||
|
||||
HUHU_EMAIL_DOMAIN
|
||||
|
||||
Right-hand part of the email address used to submit posts.
|
||||
|
||||
Example:
|
||||
HUHU_EMAIL_DOMAIN="albasani.net"
|
||||
|
||||
HUHU_EMAIL_LIST
|
||||
|
||||
This is a file name. If variable is defined then the submission
|
||||
address is appended to the file.
|
||||
|
||||
Example:
|
||||
HUHU_EMAIL_LIST="/etc/amavis/spam_lovers"
|
||||
|
||||
HUHU_EMAIL_POSTFIX_ALIAS
|
||||
|
||||
This is the name of a file defining virtual aliases for Postfix.
|
||||
If variable is defined then the submission address and the user
|
||||
name is appended to the file.
|
||||
|
||||
Example:
|
||||
HUHU_EMAIL_POSTFIX_ALIAS="/etc/postfix/maps/virtual_alias"
|
||||
|
||||
== Skeleton Templates ==
|
||||
|
||||
Used internally by "sbin/create-procmail-user.sh" when copying
|
||||
template files from directory "etc/skel".
|
||||
|
||||
MODERATED_GROUP
|
||||
MODERATED_GROUP_ABBR
|
||||
MYSQL_DB
|
||||
MYSQL_PASSWORD
|
||||
MYSQL_TABLE
|
||||
MYSQL_USERNAME
|
||||
TODAY
|
||||
USER_HOME
|
||||
USER_ID
|
||||
USER_NAME
|
||||
WWW_DIR
|
||||
7
doc/extra-modules.txt
Normal file
7
doc/extra-modules.txt
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
# Dependencies for CPAN modules
|
||||
apt-get install libnet-irc-perl
|
||||
apt-get install liblog-log4perl-perl
|
||||
|
||||
# Modules only available through CPAN
|
||||
cpan i News::Article::Cancel
|
||||
cpan i Text::Language::Guess
|
||||
36
doc/get-perl-modules.sh
Normal file
36
doc/get-perl-modules.sh
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
#!/bin/sh
|
||||
#
|
||||
# $Id: $
|
||||
#
|
||||
# Search for required Perl modules, translate to required package names.
|
||||
#
|
||||
export "LANG=C"
|
||||
export "LC_ALL=C"
|
||||
set -o nounset
|
||||
set -o errexit
|
||||
|
||||
req_modules="required-perl-modules.txt"
|
||||
req_deb="required-deb-packages.txt"
|
||||
req_rpm="required-rpm-packages.txt"
|
||||
|
||||
find "${HUHU_DIR}" -type f -name '*.p[lm]' -exec \
|
||||
gawk -F '[[:space:]();]+' '
|
||||
$1 == "use" && $2 ~ /::/ && $2 !~ /^MOD::/ { print $2 }
|
||||
' {} \+ |
|
||||
sort -u > "${req_modules}"
|
||||
|
||||
if [ -f /etc/debian_version ]; then
|
||||
xargs locate < "${req_modules}" |
|
||||
sort -u |
|
||||
xargs -n1 dpkg -S |
|
||||
sed -ne 's/: .*//p' |
|
||||
sort -u > "${req_deb}"
|
||||
elif [ -f /etc/redhat-release ]; then
|
||||
xargs locate < "${req_modules}" |
|
||||
sort -u |
|
||||
xargs rpm -qf |
|
||||
sed -e '/ /d' |
|
||||
sort -u > "${req_rpm}"
|
||||
fi
|
||||
|
||||
|
||||
208
doc/html/huhu.css
Normal file
208
doc/html/huhu.css
Normal file
|
|
@ -0,0 +1,208 @@
|
|||
@charset "ISO-8859-1";
|
||||
/*
|
||||
* $Id: huhu.css 286 2011-02-18 00:18:19Z alba $
|
||||
*
|
||||
* #d3d3d3 = lightgray
|
||||
*/
|
||||
body, html {
|
||||
height:100%;
|
||||
text-align:left;
|
||||
margin:0;
|
||||
padding:0;
|
||||
font-family:sans-serif;
|
||||
background-color:#ccccff;
|
||||
color:black;
|
||||
}
|
||||
|
||||
h1 {
|
||||
font-size:132%;
|
||||
}
|
||||
|
||||
table.huhuPostList,
|
||||
table.huhuArticle {
|
||||
border-collapse:separate;
|
||||
border-spacing:0;
|
||||
empty-cells:show;
|
||||
background-color:white;
|
||||
}
|
||||
|
||||
table.huhuPostList td,
|
||||
table.huhuPostList th,
|
||||
table.huhuArticle th,
|
||||
table.huhuArticle td {
|
||||
padding:2px;
|
||||
margin:0;
|
||||
border-left:1px #FFFFFF solid;
|
||||
border-top:1px #FFFFFF solid;
|
||||
border-right:1px #000000 solid;
|
||||
border-bottom:1px #000000 solid;
|
||||
}
|
||||
|
||||
table.huhuPostList th {
|
||||
text-align:center;
|
||||
background-color:#d3d3d3;
|
||||
}
|
||||
|
||||
div.huhuContents {
|
||||
display:block;
|
||||
float:left; /* to keep huhuVersion aligned on left border */
|
||||
width:84%;
|
||||
margin-top:0.5em;
|
||||
margin-left:0.5em;
|
||||
margin-right:0.5em;
|
||||
/* border:1px solid black; */
|
||||
}
|
||||
|
||||
ul.huhuMainMenu0 {
|
||||
width:12%;
|
||||
background-color:#d3d3d3;
|
||||
margin-left:0.5em;
|
||||
/* no margin-right, use margin-left of div.huhuContents instead */
|
||||
margin-top:0.5em;
|
||||
margin-bottom:0;
|
||||
padding:0;
|
||||
float:left; /* menu on the left, huhuContents on the right */
|
||||
/* border:1px solid black; */
|
||||
}
|
||||
|
||||
ul.huhuMainMenu0 span {
|
||||
padding-left:0.5em;
|
||||
padding-top:0.5ex;
|
||||
padding-right:0.5em;
|
||||
padding-bottom:0.5ex;
|
||||
display:block;
|
||||
font-weight:bold;
|
||||
}
|
||||
|
||||
ul.huhuMainMenu1 {
|
||||
margin:0;
|
||||
padding:0;
|
||||
}
|
||||
|
||||
ul.huhuMainMenu1 span {
|
||||
font-weight:normal;
|
||||
margin:0;
|
||||
padding:0;
|
||||
}
|
||||
|
||||
ul.huhuMainMenu0 li,
|
||||
ul.huhuMainMenu1 li {
|
||||
text-indent:0;
|
||||
list-style-type:none;
|
||||
}
|
||||
|
||||
ul.huhuMainMenu0 li {
|
||||
font-size:80%;
|
||||
border-top:1px #000000 solid;
|
||||
border-left:1px #000000 solid;
|
||||
border-right:1px #FFFFFF solid;
|
||||
border-bottom:1px #FFFFFF solid;
|
||||
}
|
||||
|
||||
ul.huhuMainMenu1 li {
|
||||
font-weight:normal;
|
||||
border-top:1px #FFFFFF solid;
|
||||
border-left:1px #FFFFFF solid;
|
||||
border-right:1px #000000 solid;
|
||||
border-bottom:1px #000000 solid;
|
||||
padding:4px;
|
||||
}
|
||||
|
||||
div.huhuNavigation {
|
||||
padding-top:0.5ex;
|
||||
padding-bottom:0;
|
||||
margin-top:1ex;
|
||||
margin-bottom:0;
|
||||
margin-left:0;
|
||||
margin-right:0;
|
||||
}
|
||||
|
||||
div.huhuNavigation span {
|
||||
border-top:1px #FFFFFF solid;
|
||||
border-left:1px #FFFFFF solid;
|
||||
border-right:1px #000000 solid;
|
||||
border-bottom:1px #000000 solid;
|
||||
font-size:80%;
|
||||
padding:4px;
|
||||
}
|
||||
|
||||
ul.huhuMainMenu0 li a,
|
||||
div.huhuNavigation span a {
|
||||
/* remove underlined attribute for "a href" */
|
||||
text-decoration:none;
|
||||
/* remove color distinction between visited and unvisited links */
|
||||
color:black;
|
||||
}
|
||||
|
||||
ul.huhuMainMenu0 li a:hover,
|
||||
div.huhuNavigation span a:hover {
|
||||
/* while mouse is hovering over "a href" */
|
||||
color:#FFFFFF;
|
||||
text-decoration:none;
|
||||
background-color:black;
|
||||
}
|
||||
|
||||
div.huhuVersion,
|
||||
div.huhuArticleInfo {
|
||||
margin-top:1ex;
|
||||
font-size:80%;
|
||||
font-style:italic;
|
||||
}
|
||||
|
||||
table.huhuArticle {
|
||||
/* Opera and IE applie margin above caption
|
||||
* Mozilla between caption and table */
|
||||
margin-top:2mm;
|
||||
|
||||
border-top:1px #000000 solid;
|
||||
border-left:1px #000000 solid;
|
||||
width:100%;
|
||||
}
|
||||
|
||||
table.huhuArticle th,
|
||||
table.huhuArticle td {
|
||||
padding-left:1ex;
|
||||
padding-right:1ex;
|
||||
}
|
||||
|
||||
tr.huhuArticleHeader th,
|
||||
tr.huhuArticleHeader td {
|
||||
border-bottom:1px #000000 solid;
|
||||
}
|
||||
|
||||
tr.huhuArticleHeader th {
|
||||
background-color:#d3d3d3;
|
||||
border-right:1px #000000 solid;
|
||||
text-align:right;
|
||||
width:10em;
|
||||
}
|
||||
|
||||
tr.huhuArticleHeader td {
|
||||
background-color:#FFFFCC;
|
||||
}
|
||||
|
||||
div.huhuReason,
|
||||
div.huhuErrorMessage {
|
||||
margin-bottom:1ex;
|
||||
padding:1ex;
|
||||
background-color:white;
|
||||
border:1px #000000 solid;
|
||||
}
|
||||
|
||||
tr.huhuFlag {
|
||||
background-color:#FFCCCC;
|
||||
}
|
||||
tr.huhuOdd {
|
||||
background-color:#FCFCFC;
|
||||
}
|
||||
tr.huhuEven {
|
||||
background-color:#FFFFCC;
|
||||
}
|
||||
td.huhuNoRows {
|
||||
background-color:#ccccff;
|
||||
}
|
||||
|
||||
div.huhuSubtitle {
|
||||
font-size:80%;
|
||||
margin-bottom:0.5ex;
|
||||
}
|
||||
89
doc/html/index.html
Normal file
89
doc/html/index.html
Normal file
|
|
@ -0,0 +1,89 @@
|
|||
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||||
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
|
||||
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
|
||||
<!-- $Id: index.html 301 2011-09-28 04:43:06Z alba $ -->
|
||||
<html xmlns="http://www.w3.org/1999/xhtml" lang="de" xml:lang="de">
|
||||
<head>
|
||||
<title>Huhu Overview</title>
|
||||
<style type="text/css" media="all">@import "huhu.css";</style>
|
||||
</head>
|
||||
<body><div id="huhuContents">
|
||||
|
||||
<h2>Huhu</h2>
|
||||
|
||||
<p>Huhu is a web application to moderate Usenet groups.</p>
|
||||
|
||||
<h3>Basic workflow</h3>
|
||||
<ol>
|
||||
<li>Emails are sent to the submission address</li>
|
||||
<li>Retrieved mails are stored in database</li>
|
||||
<li>The web application visualizes the stored mails</li>
|
||||
<li>Human moderators use the web application to classify mail:
|
||||
<ul>
|
||||
<li>Approved submissions are sent to the news server</li>
|
||||
<li>For rejected submissions a rejection notice is sent to the author via mail</li>
|
||||
<li>Submissions can also be silently ignored</li>
|
||||
<li>Mails classified as spam are silently ignored but also train the spamfilter</li>
|
||||
</ul></li>
|
||||
</ol>
|
||||
|
||||
<h3>Requirements</h3>
|
||||
<ul>
|
||||
<li>Some kind of Unix (Huhu is developed on Ubuntu Linux)</li>
|
||||
<li>A way to execute jobs in periodic intervals, e.g. crond</li>
|
||||
<li>perl 5 (and a list of additional perl modules)</li>
|
||||
<li>A web server cabaple of executing perl scripts (Huhu is developed on Apache/mod_perl)</li>
|
||||
<li>A MySQL database</li>
|
||||
<li>A mail box accessible through POP3 or procmail</li>
|
||||
<li>NNTP access to a news server that allows to set the header "Approved:"</li>
|
||||
</ul>
|
||||
|
||||
<h3>Features</h3>
|
||||
<ul>
|
||||
<li>Spam filtering with <tt>Mail::SpamAssassin</tt>.</li>
|
||||
<li>Articles can be signed with a PGP key, using <tt>News::Article::sign_pgpmoose</tt>.</li>
|
||||
<li>Submissions can be moderated automatically through procmail rules.</li>
|
||||
<li>An IRC bot that notifies an IRC channel about pending submissions.</li>
|
||||
<li>Multiple instances of Huhu can be run with a single installation.</li>
|
||||
</ul>
|
||||
|
||||
<h3>Missing features</h3>
|
||||
<ul>
|
||||
<li>Documentation. (Harald Mädl has written a
|
||||
<a href="http://usenet-moderation.net/moderation_software_huhu.htm"
|
||||
>German user's manual</a>, though.)</li>
|
||||
<li>UNICODE. (Huhu currently uses ISO-8859-1 throughout.)</li>
|
||||
<li>Web based installation. (Currently there is only <tt>sbin/create-procmail-user.sh</tt>).</li>
|
||||
</ul>
|
||||
|
||||
<h3>Licence</h3>
|
||||
<p>Huhu is free software; you can redistribute it and/or modify it under the terms
|
||||
of the GNU General Public License as published by the Free Software Foundation;
|
||||
either version 3 of the License, or (at your option) any later version.</p>
|
||||
|
||||
<h3>Availability</h3>
|
||||
<p>The code is stored in a <a href="http://subversion.tigris.org/">subversion</a>
|
||||
repository.</p>
|
||||
|
||||
<dl>
|
||||
<dt>Anonymous read-only access</dt>
|
||||
<!-- svn://albasani.net/huhu/trunk/ -->
|
||||
<dd><a href="svn://svn.schnuerpel.eu/huhu/trunk/"
|
||||
>svn://svn.schnuerpel.eu/huhu/trunk/</a></dd>
|
||||
|
||||
<dt>Web based revision browser</dt>
|
||||
<!-- http://albasani.net/viewvc.cgi/?root=huhu -->
|
||||
<dd><a href="http://svn.schnuerpel.eu/viewvc.cgi/?root=huhu"
|
||||
>http://svn.schnuerpel.eu/viewvc.cgi/?root=huhu</a></dd>
|
||||
|
||||
<dt>Project home page</dt>
|
||||
<!-- http://albasani.net/huhu/ -->
|
||||
<dd><a href="http://huhu.albasani.net/">http://huhu.albasani.net/</a></dd>
|
||||
</dl>
|
||||
|
||||
<h3>History</h3>
|
||||
<p>Roman Racine developed Huhu in 2007 to moderate de.soc.familie.vaeter.<br>
|
||||
In 2009 he adapted it to easily run multiple instances.<br>
|
||||
In autumn 2009 Alexander Bartolich took over development, adding support for CSS, multiple languages, and procmail.</p>
|
||||
|
||||
</div></body></html>
|
||||
8
doc/required-deb-packages.txt
Normal file
8
doc/required-deb-packages.txt
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
libdigest-sha1-perl
|
||||
libi18n-acceptlanguage-perl
|
||||
libmail-sendmail-perl
|
||||
libmailtools-perl
|
||||
libnet-irc-perl
|
||||
libnews-article-perl
|
||||
perl-doc
|
||||
spamassassin
|
||||
18
doc/required-perl-modules.txt
Normal file
18
doc/required-perl-modules.txt
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
CGI::Carp
|
||||
CGI::Pretty
|
||||
Data::Dumper
|
||||
Digest::SHA1
|
||||
I18N::AcceptLanguage
|
||||
MIME::Base64
|
||||
MIME::QuotedPrint
|
||||
Mail::Mailer
|
||||
Mail::Sendmail
|
||||
Mail::SpamAssassin
|
||||
Net::IRC
|
||||
Net::NNTP
|
||||
Net::POP3
|
||||
News::Article
|
||||
News::Article::Cancel
|
||||
News::Article::Response
|
||||
Text::Language::Guess
|
||||
Time::Local
|
||||
45
doc/security.txt
Normal file
45
doc/security.txt
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
SYSTEM USER ACCOUNTS
|
||||
|
||||
* UID_ROOT ... A priviledged user able to create other users.
|
||||
* UID_WWW ... The user id of the web server process.
|
||||
* UID_HUHU ... The user that executes cron scripts and procmail scripts.
|
||||
|
||||
DATABASE USER ACCOUNTS
|
||||
|
||||
* DB_UID_ROOT ... This account is used by UID_ROOT to set up huhu.
|
||||
* DB_UID_HUHU ... The account used by Huhu itself.
|
||||
|
||||
NEWS SERVER ACCOUNTS
|
||||
|
||||
* NNTP_UID_HUHU ... Used by UID_HUHU to post articles.
|
||||
|
||||
PROGRAMS
|
||||
|
||||
* Shell scripts executed as UID_ROOT
|
||||
Used to set up Huhu instances
|
||||
DB_UID_ROOT
|
||||
sbin/create-procmail-user.sh
|
||||
|
||||
* Procmail script executed as UID_HUHU
|
||||
DB_UID_HUHU
|
||||
bin/read-mail.pl
|
||||
|
||||
* Crontab scripts executed as UID_HUHU
|
||||
DB_UID_HUHU, NNTP_UID_HUHU
|
||||
bin/*
|
||||
|
||||
* Scripts executed by web server as UID_WWW
|
||||
Scripts can be run as true CGIs or within mod_perl
|
||||
DB_UID_HUHU
|
||||
cgi-bin/*
|
||||
|
||||
FLOW OF CONFIGURATION DATA
|
||||
|
||||
The path to the public configuration file is specified through environment
|
||||
variable HUHU_PUB_CONFIG.
|
||||
|
||||
TODO
|
||||
|
||||
Authentication is done by the web server. It is recommended to use
|
||||
"AuthType Digest", so that passwords are not transferred through the
|
||||
net in plain text.
|
||||
4
etc/skel/.bashrc
Normal file
4
etc/skel/.bashrc
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
#!/bin/bash
|
||||
export HUHU_DIR="@HUHU_DIR@"
|
||||
export PERL5LIB="${PERL5LIB:+$PERL5LIB:}${HUHU_DIR}"
|
||||
export PATH="${PATH}:${HUHU_DIR}/bin"
|
||||
10
etc/skel/.cshrc
Normal file
10
etc/skel/.cshrc
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#!/bin/csh -x
|
||||
setenv EDITOR /usr/bin/vim
|
||||
setenv GREP_OPTIONS '--color=auto'
|
||||
|
||||
setenv LC_CTYPE C
|
||||
setenv LANGUAGE en_US
|
||||
setenv LANG "${LANGUAGE}.iso885915"
|
||||
|
||||
setenv HUHU_DIR "@HUHU_DIR@"
|
||||
setenv PERL5LIB "${HUHU_DIR}"
|
||||
4
etc/skel/.forward
Normal file
4
etc/skel/.forward
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
#
|
||||
# Save this file as $HOME/.forward to enable $HOME/.procmailrc
|
||||
#
|
||||
"|exec /usr/bin/procmail"
|
||||
3
etc/skel/.my.cnf
Normal file
3
etc/skel/.my.cnf
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
[client]
|
||||
user=@MYSQL_USERNAME@
|
||||
password=@MYSQL_PASSWORD@
|
||||
18
etc/skel/.procmailrc
Normal file
18
etc/skel/.procmailrc
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
HUHU_DIR="@HUHU_DIR@"
|
||||
|
||||
CONFIG="${HOME}/etc/public.conf"
|
||||
LOGFILE="${HOME}/var/procmail.log"
|
||||
PATH="/usr/bin:/bin:${HUHU_DIR}/bin"
|
||||
PERL5LIB="${HUHU_DIR}"
|
||||
VERBOSE=yes
|
||||
|
||||
# save mails in backup directory
|
||||
:0 c
|
||||
backup
|
||||
|
||||
# trim backup directory
|
||||
:0 ic
|
||||
| cd backup && rm -f dummy `ls -t msg.* | sed -e 1,32d`
|
||||
|
||||
:0
|
||||
| "${HUHU_DIR}/bin/read-mail.pl" "-config=${CONFIG}" -stdin
|
||||
0
etc/skel/backup/EMPTY
Normal file
0
etc/skel/backup/EMPTY
Normal file
16
etc/skel/bin/poster.sh
Normal file
16
etc/skel/bin/poster.sh
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
#!/bin/sh
|
||||
#
|
||||
# This script tries to send all messages of status 'moderated' to the
|
||||
# news server. This should be a safe operation, i.e. it is not possible
|
||||
# to produce duplicates.
|
||||
#
|
||||
# Use this script for testing or after a configuration error.
|
||||
#
|
||||
export "LANG=C"
|
||||
export "LC_CTYPE=C"
|
||||
set -o nounset
|
||||
set -o errexit
|
||||
|
||||
export HUHU_DIR="@HUHU_DIR@"
|
||||
export PERL5LIB="${PERL5LIB:+$PERL5LIB:}${HUHU_DIR}"
|
||||
"${HUHU_DIR}/bin/poster.pl" "$HOME/etc/public.conf"
|
||||
16
etc/skel/bin/read-mail.sh
Normal file
16
etc/skel/bin/read-mail.sh
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
#!/bin/sh
|
||||
#
|
||||
# This script tries to load all messages in the backup directory into the
|
||||
# database. Because of the md5sum check this should be a safe operation,
|
||||
# i.e. it is not possible to produce duplicates.
|
||||
#
|
||||
# Use this script for testing or in case the procmail rules were defunct.
|
||||
#
|
||||
export "LANG=C"
|
||||
export "LC_CTYPE=C"
|
||||
set -o nounset
|
||||
set -o errexit
|
||||
|
||||
export HUHU_DIR="@HUHU_DIR@"
|
||||
export PERL5LIB="${PERL5LIB:+$PERL5LIB:}${HUHU_DIR}"
|
||||
"${HUHU_DIR}/bin/read-mail.pl" "-config=$HOME/etc/public.conf" "$HOME/backup"/*
|
||||
10
etc/skel/bin/statistics.sh
Normal file
10
etc/skel/bin/statistics.sh
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#!/bin/sh
|
||||
export "LANG=C"
|
||||
export "LC_CTYPE=C"
|
||||
set -o nounset
|
||||
set -o errexit
|
||||
|
||||
export HUHU_DIR="@HUHU_DIR@"
|
||||
export PERL5LIB="${PERL5LIB:+$PERL5LIB:}${HUHU_DIR}"
|
||||
HTMLDIR=@HUHU_WWW_BASE_DIR@/@WWW_DIR@
|
||||
"${HUHU_DIR}/bin/statistics.pl" "${HOME}/etc/public.conf" > "${HTMLDIR}/stats/stats.txt"
|
||||
0
etc/skel/etc/htdigest
Normal file
0
etc/skel/etc/htdigest
Normal file
2
etc/skel/etc/htdigest.sh
Normal file
2
etc/skel/etc/htdigest.sh
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
#!/bin/sh
|
||||
htdigest "@USER_HOME@/etc/htdigest" "@USER_NAME@" "$@"
|
||||
67
etc/skel/etc/private.conf
Normal file
67
etc/skel/etc/private.conf
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
# Private configuration file. Contains sensitive data.
|
||||
# Should be readable only by to the owner, i.e. by cronjobs
|
||||
# and the procmail-scripts.
|
||||
|
||||
# for removeold.pl
|
||||
delete_spam_after=7
|
||||
delete_error_after=3
|
||||
delete_posting_after=90
|
||||
|
||||
# Duplicates older than this number of days are OK,
|
||||
# Note: value must be less equal delete_posting_after.
|
||||
check_duplicates_age=7
|
||||
|
||||
# If the public configuration file does not have mysql_password
|
||||
# then list it here.
|
||||
mysql_password=@MYSQL_PASSWORD@
|
||||
|
||||
# for poster.pl
|
||||
nntp_user=
|
||||
nntp_pass=
|
||||
nntp_server=localhost
|
||||
|
||||
# For poster.pl. Note that both passphrase and keyid must be defined
|
||||
# to sign posts.
|
||||
pgp_passphrase=@MODERATED_GROUP_ABBR@@YEAR@
|
||||
pgp_keyid=Moderation of @MODERATED_GROUP@ <@SUBMISSION_EMAIL@>
|
||||
|
||||
# mailget.pl reads mails from this POP account. (Not used by read-mail.pl)
|
||||
mod_pop_server=
|
||||
mod_pop_username=
|
||||
mod_pop_pass=
|
||||
|
||||
# Use spamassassin: 1 -> Yes, 0 -> No.
|
||||
spamassassin=1
|
||||
|
||||
# Compare subject with subjects of classified spam posts?
|
||||
# subjectcheck: 1 -> Yes, 0 -> No.
|
||||
subjectcheck=1
|
||||
subjectscore=7
|
||||
|
||||
# Check for binaries and HTML attachments?
|
||||
# attachmentcheck: 1 -> Yes, 0 -> No.
|
||||
attachmentcheck=1
|
||||
attachmentscore=7
|
||||
|
||||
# Language of target group (de, en)
|
||||
lang=
|
||||
|
||||
# Check submissions whether they match the language of the target group
|
||||
# (works only with German).
|
||||
# langcheck: 1 -> Yes, 0 -> No.
|
||||
langcheck=0
|
||||
langscore=3
|
||||
|
||||
# autoreply.pl
|
||||
# Hours until author of pending post is notified by mail.
|
||||
min_time_until_autoreply=
|
||||
# Hours until pending posts are ignored by autoreply.pl
|
||||
max_time_until_autoreply=
|
||||
|
||||
# ircbot.pl
|
||||
ircbot_nick=@MODERATED_GROUP_ABBR@-bot
|
||||
ircbot_realname=ircbot.pl
|
||||
ircbot_username=@USER_NAME@
|
||||
ircbot_server=irc.freenode.net
|
||||
ircbot_port=6667
|
||||
ircbot_channel=#@USER_NAME@
|
||||
50
etc/skel/etc/public.conf
Normal file
50
etc/skel/etc/public.conf
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
# This is the public config file.
|
||||
# It must be readable by the CGI scripts, i.e. by the web server.
|
||||
# No sensitive data should be included here.
|
||||
|
||||
# path to the private config file
|
||||
priv_config_file=@USER_HOME@/etc/private.conf
|
||||
|
||||
# UID required to read private data
|
||||
UID=@USER_ID@
|
||||
|
||||
# Approved posts are posted to this group
|
||||
moderated_group=@MODERATED_GROUP@
|
||||
|
||||
# Note: Specifying mysql_password here is a security risk since every
|
||||
# script running in the context of the web server can read it. The
|
||||
# alternative is the set environment variable 'mysql_password' through
|
||||
# the Apache configuration.
|
||||
|
||||
mysql_host=localhost
|
||||
mysql_port=3306
|
||||
mysql_username=@MYSQL_USERNAME@
|
||||
mysql_table=@MYSQL_TABLE@
|
||||
mysql_db=@MYSQL_DB@
|
||||
|
||||
# posts listed per page
|
||||
display_per_page=20
|
||||
|
||||
# Value of header "Approved:" in posts
|
||||
approve_string=@SUBMISSION_EMAIL@
|
||||
|
||||
# Right hand side of message IDs in in posts.
|
||||
# Empty value means that the news server generates the ID.
|
||||
mid_fqdn=
|
||||
|
||||
# Value of header "From:" in rejection notices.
|
||||
mailfrom=@SUBMISSION_EMAIL@
|
||||
|
||||
html_content_type=iso-8859-15
|
||||
html_stylesheet_href=/huhu.css
|
||||
html_language=en-us
|
||||
http_negotiate_language=0
|
||||
|
||||
# Available methods
|
||||
# Digest ... Password are checked by Apache, password file is maintained
|
||||
# by 'htdigest', see samples/apache-digest.conf
|
||||
# None ... No password, IP address is taken for username
|
||||
http_authentication_method=Digest
|
||||
|
||||
# ircbot.pl
|
||||
ircbot_notify_sock=@USER_HOME@/var/ircbot.socket
|
||||
11
etc/skel/etc/samples/apache-digest.conf
Normal file
11
etc/skel/etc/samples/apache-digest.conf
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
<Directory "@HUHU_WWW_BASE_DIR@/@WWW_DIR@">
|
||||
SetEnv HUHU_PUB_CONFIG "@USER_HOME@/etc/public.conf"
|
||||
SetEnv mysql_password "@MYSQL_PASSWORD@"
|
||||
<Files "modtable.pl">
|
||||
AuthType Digest
|
||||
AuthName "@USER_NAME@"
|
||||
AuthDigestProvider file
|
||||
AuthUserFile "@USER_HOME@/etc/htdigest"
|
||||
Require valid-user
|
||||
</Files>
|
||||
</Directory>
|
||||
29
etc/skel/etc/samples/crontab
Normal file
29
etc/skel/etc/samples/crontab
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
#
|
||||
# Note: the right hand side of assignments is a literal string, i.e.
|
||||
# variable references like "$HOME" are not expanded.
|
||||
#
|
||||
# MAILTO=administrator@webinterface.site
|
||||
HUHU_DIR="@HUHU_DIR@"
|
||||
PERL5LIB="@HUHU_DIR@"
|
||||
CONFIG="@USER_HOME@/etc/public.conf"
|
||||
BINDIR="@HUHU_DIR@/bin"
|
||||
# HTMLDIR=/srv/www/html
|
||||
|
||||
# mailget.pl reads incoming mail via POP3, stores them in database.
|
||||
# If you use procmailrc then you don't need this.
|
||||
# */5 * * * * "$BINDIR/mailget.pl" "$CONFIG"
|
||||
|
||||
# Reads database, sends outgoing messages via NNTP.
|
||||
*/5 * * * * "$BINDIR/poster.pl" "$CONFIG"
|
||||
|
||||
# Show number of posts and reaction time.
|
||||
# 3 * * * * "$BINDIR/statistics.pl" "$CONFIG" > "$HTMLDIR/stats/stats.txt"
|
||||
|
||||
# Remove old records from database
|
||||
5 3 * * * "$BINDIR/removeold.pl" "$CONFIG"
|
||||
|
||||
# Reads database, sends reply to authors of pending messages.
|
||||
# 10 * * * * "$BINDIR/autoreply.pl" "$CONFIG"
|
||||
|
||||
# Reads database, announces incoming mail in IRC channel.
|
||||
# @reboot "$BINDIR/ircbot.sh" start
|
||||
17
etc/skel/etc/samples/huhu-directory.html
Normal file
17
etc/skel/etc/samples/huhu-directory.html
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
<table class="huhuPostList">
|
||||
<tr>
|
||||
<th>Group</th>
|
||||
<th>Language</th>
|
||||
<th colspan="2">Web Interface</th>
|
||||
<th>Statistics</th>
|
||||
<th>Established</th>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>@MODERATED_GROUP@</td>
|
||||
<td>en-us</td>
|
||||
<td><a href="@HUHU_WWW_BASE_URL@/@WWW_DIR@/public.pl">public</a></td>
|
||||
<td><a href="@HUHU_WWW_BASE_URL@/@WWW_DIR@/modtable.pl">private</a></td>
|
||||
<td><a href="@HUHU_WWW_BASE_URL@/@WWW_DIR@/stats/stats.txt">reaction time</a></td>
|
||||
<td>@TODAY@</td>
|
||||
</tr>
|
||||
</table>
|
||||
68
etc/skel/etc/samples/summary.txt
Normal file
68
etc/skel/etc/samples/summary.txt
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
== Email ==
|
||||
|
||||
The submission address is <@SUBMISSION_EMAIL@>.
|
||||
|
||||
Messages are directly processed by procmail, so you cannot access it
|
||||
with POP or IMAP. (Messages are saved in a backup directory as plain
|
||||
files, though.)
|
||||
|
||||
You can test Huhu by sending posts directly to this address.
|
||||
When tests are finished you should send a message stating that
|
||||
<@SUBMISSION_EMAIL@> is the new submission address of
|
||||
@MODERATED_GROUP@ to <moderators-request@isc.org>.
|
||||
|
||||
== Web Interface ==
|
||||
|
||||
The web interface consists of two parts. The public part is accessible
|
||||
to everybody. It just displays the approved posts.
|
||||
|
||||
@HUHU_WWW_BASE_URL@/@WWW_DIR@/public.pl
|
||||
|
||||
And then there is the private part. This is protected with a login.
|
||||
using the HTTP digest system.
|
||||
|
||||
@HUHU_WWW_BASE_URL@/@WWW_DIR@/modtable.pl
|
||||
|
||||
HTTP digest is safe to use on unencrypted connections, but for additional
|
||||
paranoia above URLs are also available through https (with a self signed
|
||||
certificate).
|
||||
|
||||
There is currently no way to handle user management through the web
|
||||
interface. I created one account for you:
|
||||
|
||||
Username:
|
||||
Password:
|
||||
|
||||
== Test Mode ==
|
||||
|
||||
At the moment this instance of Huhu is in test mode. Approved messages
|
||||
are sent to albasani.test.moderated. This is an internal group, i.e.
|
||||
it is not sent to peers. You need an albasani-account to read it.
|
||||
|
||||
When you are satisfied with your tests please give me a note.
|
||||
I will then switch to @MODERATED_GROUP@.
|
||||
|
||||
== Configurable Options ==
|
||||
|
||||
The following settings are set to default values.
|
||||
Please give me a note if you want to have them changed.
|
||||
|
||||
# Value of header "Approved:" in posts
|
||||
approve_string=@SUBMISSION_EMAIL@
|
||||
|
||||
# Right hand side of message IDs in in posts.
|
||||
# Empty value means that the news server generates the ID.
|
||||
mid_fqdn=
|
||||
|
||||
# Value of header "From:" in rejection notices.
|
||||
mailfrom=@SUBMISSION_EMAIL@
|
||||
|
||||
== Usenet Account ==
|
||||
|
||||
Username: @SUBMISSION_EMAIL@
|
||||
Password:
|
||||
Server : news.albasani.net
|
||||
|
||||
It has permissions to send approved posts to albasani.test.moderated
|
||||
and @MODERATED_GROUP@. Use it to bypass the moderation (e.g. send FAQs
|
||||
or cancel messages) or to read the internal albasani.* groups.
|
||||
0
etc/skel/var/EMPTY
Normal file
0
etc/skel/var/EMPTY
Normal file
24
samples/crontab
Normal file
24
samples/crontab
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
MAILTO=administrator@webinterface.site
|
||||
PERL5LIB=/srv/www/huhu
|
||||
CONFIG=/srv/www/SAMPLE/home/etc/SAMPLE_pub.config
|
||||
BINDIR=/srv/www/huhu/bin
|
||||
HTMLDIR=/srv/www/SAMPLE/html
|
||||
|
||||
# mailget.pl reads incoming mail via POP3, stores them in database.
|
||||
# If you use procmailrc then you don't need this.
|
||||
# */5 * * * * $BINDIR/mailget.pl $CONFIG
|
||||
|
||||
# Reads database, sends outgoing messages via NNTP.
|
||||
*/5 * * * * $BINDIR/poster.pl $CONFIG;
|
||||
|
||||
# Show number of posts and reaction time.
|
||||
3 * * * * $BINDIR/statistics.pl $CONFIG > $HTMLDIR/stats/stats.txt
|
||||
|
||||
# Remove old records from database
|
||||
5 3 * * * $BINDIR/removeold.pl $CONFIG
|
||||
|
||||
# Reads database, sends reply to sender of mail that message is in queue.
|
||||
# 10 * * * * $BINDIR/autoreply.pl $CONFIG
|
||||
|
||||
# Reads database, announces incoming mail in IRC channel.
|
||||
# @reboot $BINDIR/ircbot.pl $CONFIG
|
||||
15
samples/modtable.pl
Normal file
15
samples/modtable.pl
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
#!/usr/bin/perl -w
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
$ENV{'CONTENT_TYPE'} = "multipart/form-data";
|
||||
|
||||
use CGI::Carp 'fatalsToBrowser';
|
||||
|
||||
BEGIN {
|
||||
push (@INC,'/srv/www/huhu');
|
||||
}
|
||||
|
||||
use MOD::Handler;
|
||||
my $h = MOD::Handler->new('/srv/www/sample/home/etc/sample_pub.config');
|
||||
$h->run();
|
||||
86
samples/mysql/create.sql
Normal file
86
samples/mysql/create.sql
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
#
|
||||
# $Id: create.sql 304 2011-11-02 14:14:01Z root $
|
||||
#
|
||||
# Create statement for mysql. Replace @sample@ with your table prefix.
|
||||
# For example:
|
||||
# sed 's/@sample@/atm/g' < create.sql
|
||||
#
|
||||
CREATE TABLE @sample@ (
|
||||
ID bigint NOT NULL auto_increment,
|
||||
# 'spam' ... can be put back to 'pending' queue
|
||||
# 'moderated' ... tells poster.pl to send the message,
|
||||
# can be put back to 'pending' queue
|
||||
# 'rejected' ... a mail was sent to the author - cannot be undone
|
||||
# 'deleted' ... can be put back to 'pending' queue
|
||||
# 'posted' ... message was sent to server - cannot be undone
|
||||
# 'sending' ... poster.pl is trying to send article to server,
|
||||
# next state is 'moderated', 'posted', or 'broken'
|
||||
# 'broken' ... poster.pl encountered a fatal error
|
||||
Status ENUM(
|
||||
'pending',
|
||||
'spam',
|
||||
'moderated',
|
||||
'rejected',
|
||||
'deleted',
|
||||
'posted',
|
||||
'sending',
|
||||
'broken'
|
||||
) NOT NULL,
|
||||
Sender text NOT NULL,
|
||||
ReplyTo text,
|
||||
Subject text NOT NULL,
|
||||
MessageID text DEFAULT NULL,
|
||||
Datum DATETIME NOT NULL,
|
||||
Header longblob NOT NULL,
|
||||
Body longblob NOT NULL,
|
||||
Spamcount float DEFAULT 0.0,
|
||||
Moderator varchar(20),
|
||||
Moddatum DATETIME,
|
||||
checksum char(40) UNIQUE,
|
||||
flag bool DEFAULT 0,
|
||||
PRIMARY KEY (ID),
|
||||
KEY(status),
|
||||
KEY(Datum),
|
||||
KEY(Moddatum),
|
||||
KEY(checksum),
|
||||
KEY(subject(40)),
|
||||
KEY(flag)
|
||||
);
|
||||
|
||||
# DROP TABLE @sample@_error;
|
||||
CREATE TABLE @sample@_error (
|
||||
error_id BIGINT NOT NULL AUTO_INCREMENT,
|
||||
article_id BIGINT,
|
||||
error_date DATETIME NOT NULL,
|
||||
# Number of duplicate (article_id,error_message) tuples.
|
||||
error_count INT(2) DEFAULT 0 NOT NULL,
|
||||
error_message TEXT,
|
||||
PRIMARY KEY (error_id),
|
||||
UNIQUE(article_id, error_message(40)),
|
||||
FOREIGN KEY (article_id) REFERENCES @sample@(id) ON DELETE CASCADE
|
||||
);
|
||||
|
||||
CREATE OR REPLACE VIEW @sample@_error_view AS
|
||||
SELECT id,
|
||||
flag,
|
||||
sender AS article_sender,
|
||||
subject AS article_subject,
|
||||
status AS article_status,
|
||||
error_id,
|
||||
error_date,
|
||||
error_count,
|
||||
error_message
|
||||
FROM @sample@_error AS _error
|
||||
LEFT JOIN (@sample@ AS _article)
|
||||
ON _error.article_id = _article.id;
|
||||
|
||||
# DROP TABLE @sample@_reply;
|
||||
CREATE TABLE @sample@_reply (
|
||||
reply_id BIGINT NOT NULL AUTO_INCREMENT,
|
||||
article_id BIGINT,
|
||||
reply_date DATETIME NOT NULL,
|
||||
reply_message TEXT,
|
||||
PRIMARY KEY (reply_id),
|
||||
KEY(article_id),
|
||||
FOREIGN KEY (article_id) REFERENCES @sample@(id) ON DELETE CASCADE
|
||||
);
|
||||
17
samples/mysql/update-0.05-to-0.06.sql
Normal file
17
samples/mysql/update-0.05-to-0.06.sql
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
#
|
||||
# $Id: update-0.05-to-0.06.sql 102 2009-09-16 18:46:27Z alba $
|
||||
#
|
||||
# Update from version 0.05 to 0.06
|
||||
|
||||
# Check for errors (should return no rows)
|
||||
SELECT status,posted FROM @sample@ WHERE posted and status <> 'moderated';
|
||||
SELECT status,posted FROM @sample@ WHERE status = 0;
|
||||
|
||||
# Add value 'posted' to column 'status'.
|
||||
ALTER TABLE @sample@ CHANGE Status Status enum('pending','spam','moderated','rejected','deleted','posted');
|
||||
|
||||
# Transfer column 'posted' to column 'status'.
|
||||
UPDATE @sample@ SET Status = 'posted' WHERE posted;
|
||||
|
||||
# Remove column 'posted'.
|
||||
ALTER TABLE @sample@ DROP column posted;
|
||||
22
samples/mysql/update-0.06-to-0.07.sql
Normal file
22
samples/mysql/update-0.06-to-0.07.sql
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
#
|
||||
# $Id: update-0.06-to-0.07.sql 115 2009-09-20 10:09:22Z alba $
|
||||
#
|
||||
# Update from version 0.06 to 0.07
|
||||
|
||||
# First use create.sql to create table @sample@_error
|
||||
|
||||
# Copy columns errorcount and errormessage to table @sample@_error
|
||||
INSERT INTO @sample@_error
|
||||
(article_id, error_date, error_count, error_message)
|
||||
SELECT a.id, NOW(), a.errorcount, a.errormessage
|
||||
FROM @sample@ a
|
||||
WHERE errorcount > 0;
|
||||
|
||||
# Drop columns errorcount and errormessage
|
||||
ALTER TABLE @sample@ DROP column errorcount;
|
||||
ALTER TABLE @sample@ DROP column errormessage;
|
||||
|
||||
# Test record:
|
||||
# INSERT INTO @sample@_error (article_id, error_date, error_count, error_message) VALUES(10, NOW(), 17, 'huhu');
|
||||
# INSERT INTO @sample@_error (article_id, error_date, error_count, error_message) VALUES(11, NOW(), 3, 'berta');
|
||||
# SELECT * FROM @sample@_error;
|
||||
7
samples/mysql/update-0.07-0.08.sql
Normal file
7
samples/mysql/update-0.07-0.08.sql
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
#
|
||||
# $Id: update-0.07-0.08.sql 121 2009-09-20 15:32:22Z alba $
|
||||
#
|
||||
# Update from version 0.07 to 0.08
|
||||
|
||||
ALTER TABLE @sample@ CHANGE Status Status ENUM('pending','spam','moderated','rejected','deleted','posted','sending');
|
||||
|
||||
16
samples/mysql/update-0.08-0.09.sql
Normal file
16
samples/mysql/update-0.08-0.09.sql
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
#
|
||||
# $Id: update-0.08-0.09.sql 145 2009-10-11 20:00:45Z alba $
|
||||
#
|
||||
# Update from version 0.08 to 0.09
|
||||
|
||||
# First use create.sql to create table @sample@_reply
|
||||
|
||||
# Copy column Answer to table @sample@_reply
|
||||
INSERT INTO @sample@_reply
|
||||
(article_id, reply_date, reply_message)
|
||||
SELECT a.id, IFNULL(a.Moddatum, NOW()), a.answer
|
||||
FROM @sample@ a
|
||||
WHERE a.answer is not null;
|
||||
|
||||
# Drop column Answer
|
||||
ALTER TABLE @sample@ DROP COLUMN answer;
|
||||
8
samples/mysql/update-0.09-0.10.sql
Normal file
8
samples/mysql/update-0.09-0.10.sql
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
#
|
||||
# $Id: update-0.07-0.08.sql 121 2009-09-20 15:32:22Z alba $
|
||||
#
|
||||
# Update from version 0.07 to 0.08
|
||||
|
||||
ALTER TABLE @sample@ CHANGE COLUMN Status
|
||||
Status ENUM('pending','spam','moderated','rejected','deleted','posted','sending','broken') NOT NULL;
|
||||
|
||||
19
samples/procmailrc
Normal file
19
samples/procmailrc
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#
|
||||
# Save this file as $HOME/.procmailrc
|
||||
#
|
||||
LOGFILE=$HOME/procmail.log
|
||||
PATH=/usr/bin:/bin
|
||||
VERBOSE=yes
|
||||
PERL5LIB=/srv/www/huhu
|
||||
|
||||
# save mails in backup directory
|
||||
:0 c
|
||||
backup
|
||||
|
||||
# trim backup directory
|
||||
:0 ic
|
||||
| cd backup && rm -f dummy `ls -t msg.* | sed -e 1,32d`
|
||||
|
||||
# add incoming mail to database
|
||||
:0
|
||||
| /srv/www/huhu/bin/read-mail.pl /srv/www/SAMPLE/home/etc/SAMPLE_pub.config
|
||||
14
samples/public.pl
Normal file
14
samples/public.pl
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use CGI::Carp 'fatalsToBrowser';
|
||||
$ENV{'CONTENT_TYPE'} = "multipart/form-data";
|
||||
|
||||
BEGIN {
|
||||
push (@INC,'/srv/www/huhu/');
|
||||
}
|
||||
require MOD::PublicHandler;
|
||||
|
||||
my $h = MOD::PublicHandler->new('/srv/www/SAMPLE/home/etc/SAMPLE_pub.config');
|
||||
$h->run();
|
||||
123
sbin/create-functions.sh
Normal file
123
sbin/create-functions.sh
Normal file
|
|
@ -0,0 +1,123 @@
|
|||
#!/bin/sh
|
||||
#
|
||||
# $Id: create-functions.sh 290 2011-06-20 00:45:51Z alba $
|
||||
#
|
||||
set_mysql_vars()
|
||||
{
|
||||
moderated_group="$1"
|
||||
|
||||
# news.newusers.questions => nnq
|
||||
moderated_group_abbr=$( echo "${moderated_group}" |
|
||||
sed 's#\([a-zA-Z]\)[a-zA-Z]*\([^a-zA-Z]\|$\)#\1#g' )
|
||||
if [ -z "${moderated_group_abbr}" ]; then
|
||||
echo "${moderated_group} is not a valid newsgroup"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# news.newusers.questions => news/newusers/questions
|
||||
www_dir=$( echo "${moderated_group}" | tr . / )
|
||||
|
||||
# news.newusers.questions => news-newusers-questions
|
||||
mysql_db=$( echo "${moderated_group}" | tr . - )
|
||||
|
||||
mysql_password=$( "${HUHU_DIR}/bin/new-passwd.pl" )
|
||||
mysql_table="${moderated_group_abbr}"
|
||||
mysql_username="${mysql_db}"
|
||||
|
||||
length=$( echo "${mysql_username}" | wc -c )
|
||||
if [ "${length}" -gt 16 ]; then
|
||||
# http://dev.mysql.com/doc/refman/4.1/en/user-names.html
|
||||
# MySQL user names can be up to 16 characters long.
|
||||
mysql_username="${moderated_group_abbr}"
|
||||
fi
|
||||
|
||||
export today=$( date +%Y-%m-%d )
|
||||
export year=$( date +%Y )
|
||||
}
|
||||
|
||||
create_mysql()
|
||||
{
|
||||
local cmd="DROP USER '${mysql_username}'@'localhost'"
|
||||
|
||||
if echo "${cmd}" | mysql
|
||||
then echo "${cmd} succeeded."
|
||||
else echo "${cmd} failed."
|
||||
fi
|
||||
|
||||
mysqladmin create "${mysql_db}"
|
||||
(
|
||||
echo "CREATE USER '${mysql_username}'@'localhost' IDENTIFIED BY '${mysql_password}';"
|
||||
echo 'GRANT ALL ON `'${mysql_db}'`.* TO '"'${mysql_username}'@'localhost';"
|
||||
) | mysql
|
||||
|
||||
sed "s/@sample@/${mysql_table}/g" \
|
||||
< "${HUHU_DIR}/samples/mysql/create.sql" |
|
||||
mysql "${mysql_db}"
|
||||
|
||||
echo "mysql_db=${mysql_db}"
|
||||
echo "mysql_table=${mysql_table}"
|
||||
echo "mysql_username=${mysql_username}"
|
||||
echo "mysql_password=${mysql_password}"
|
||||
}
|
||||
|
||||
clean_new_home()
|
||||
{
|
||||
cd "${1}" || exit 1
|
||||
|
||||
# remove .svn or _svn directories copied from skeleton
|
||||
find . -type d -name '[._]svn' -exec rm -rf {} \+
|
||||
|
||||
# remove backup files
|
||||
find . -type f -name '*~' -exec rm {} \+
|
||||
|
||||
# property svn:executable is used to set the executable bit, so keep
|
||||
# u-permissions intact
|
||||
find . -type f -exec chmod o-rwx,g-rwx {} \+
|
||||
}
|
||||
|
||||
install_file()
|
||||
{
|
||||
permissions="$1"
|
||||
src="$2"
|
||||
dst="${user_home}/${src}"
|
||||
|
||||
# template file was copied from skeleton by useradd
|
||||
# set safe permissions before we write sensitive contents into it
|
||||
chmod "${permissions}" "${dst}"
|
||||
|
||||
awk '{
|
||||
gsub(/@HUHU_DIR@/, ENVIRON["HUHU_DIR"]);
|
||||
gsub(/@HUHU_WWW_BASE_DIR@/, ENVIRON["HUHU_WWW_BASE_DIR"]);
|
||||
gsub(/@HUHU_WWW_BASE_URL@/, ENVIRON["HUHU_WWW_BASE_URL"]);
|
||||
gsub(/@MODERATED_GROUP_ABBR@/, ENVIRON["moderated_group_abbr"]);
|
||||
gsub(/@MODERATED_GROUP@/, ENVIRON["moderated_group"]);
|
||||
gsub(/@MYSQL_DB@/, ENVIRON["mysql_db"]);
|
||||
gsub(/@MYSQL_PASSWORD@/, ENVIRON["mysql_password"]);
|
||||
gsub(/@MYSQL_TABLE@/, ENVIRON["mysql_table"]);
|
||||
gsub(/@MYSQL_USERNAME@/, ENVIRON["mysql_username"]);
|
||||
gsub(/@SUBMISSION_EMAIL@/, ENVIRON["user_name"] "@" ENVIRON["HUHU_EMAIL_DOMAIN"]);
|
||||
gsub(/@TODAY@/, ENVIRON["today"]);
|
||||
gsub(/@YEAR@/, ENVIRON["year"]);
|
||||
gsub(/@USER_HOME@/, ENVIRON["user_home"]);
|
||||
gsub(/@USER_ID@/, ENVIRON["user_id"]);
|
||||
gsub(/@USER_NAME@/, ENVIRON["user_name"]);
|
||||
gsub(/@WWW_DIR@/, ENVIRON["www_dir"]);
|
||||
print $0;
|
||||
}' "${skel_dir}/${src}" > "${dst}"
|
||||
}
|
||||
|
||||
create_www_home()
|
||||
{
|
||||
[ -n "${HUHU_WWW_BASE_DIR:-}" ] || return
|
||||
[ -n "${www_dir:-}" ] || return
|
||||
|
||||
local dir="${HUHU_WWW_BASE_DIR}/${www_dir}/stats"
|
||||
[ -d "${dir}" ] || mkdir -p "${dir}"
|
||||
|
||||
dir="${HUHU_WWW_BASE_DIR}/${www_dir}"
|
||||
(
|
||||
cd "${dir}"
|
||||
ln -s "${HUHU_DIR}/cgi-bin/modtable.pl"
|
||||
ln -s "${HUHU_DIR}/cgi-bin/public.pl"
|
||||
)
|
||||
}
|
||||
12
sbin/create-mysql.sh
Normal file
12
sbin/create-mysql.sh
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
#!/bin/sh
|
||||
#
|
||||
# $Id: create-mysql.sh 179 2009-11-07 15:19:03Z root $
|
||||
#
|
||||
export "LANG=C"
|
||||
export "LC_ALL=C"
|
||||
set -o nounset
|
||||
set -o errexit
|
||||
|
||||
. "${HUHU_DIR}/sbin/create-functions.sh"
|
||||
set_mysql_vars "$1"
|
||||
create_mysql
|
||||
74
sbin/create-procmail-user.sh
Normal file
74
sbin/create-procmail-user.sh
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
#!/bin/sh -x
|
||||
#
|
||||
# $Id: create-procmail-user.sh 290 2011-06-20 00:45:51Z alba $
|
||||
#
|
||||
export "LANG=C"
|
||||
export "LC_ALL=C"
|
||||
set -o nounset
|
||||
set -o errexit
|
||||
|
||||
if [ -z "${1:-}" ]; then
|
||||
echo "USAGE: create-procmail-user.sh <moderated_group>"
|
||||
exit 0
|
||||
fi
|
||||
|
||||
. "${HUHU_DIR}/sbin/create-functions.sh"
|
||||
set_mysql_vars "$1"
|
||||
create_mysql
|
||||
|
||||
# mysql_username may be an abbreviation, so use mysql_db
|
||||
user_name="${mysql_db}"
|
||||
|
||||
skel_dir="${HUHU_DIR}/etc/skel"
|
||||
if [ ! -d ${skel_dir} ]; then
|
||||
echo "Skeleton directory \$HUHU_DIR/etc/skel does not exist."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
user_home="${HUHU_HOME_BASE_DIR:-/home}/"$( echo "${user_name}" | sed 's#[-.]#/#g' )
|
||||
user_home_parent="${user_home%/*}"
|
||||
[ -d "${user_home_parent}" ] || mkdir -p "${user_home_parent}"
|
||||
useradd --home "${user_home}" --create-home --skel "${skel_dir}" "${user_name}"
|
||||
|
||||
user_home=$( awk -F: "/^${user_name}:/ { print \$6 }" /etc/passwd )
|
||||
|
||||
if [ ! -d "${user_home}" ]; then
|
||||
echo "Home directory of user ${user_name} does not exist."
|
||||
exit 1
|
||||
fi
|
||||
user_id=$( awk -F: "/^${user_name}:/ { print \$3 }" /etc/passwd )
|
||||
|
||||
clean_new_home "${user_home}"
|
||||
create_www_home
|
||||
|
||||
export moderated_group moderated_group_abbr
|
||||
export mysql_db mysql_password mysql_table mysql_username
|
||||
export user_home user_id user_name www_dir
|
||||
|
||||
if [ -n "${HUHU_EMAIL_DOMAIN:-}" ]; then
|
||||
if [ -n "${HUHU_EMAIL_LIST:-}" -a -w "${HUHU_EMAIL_LIST:-}" ]; then
|
||||
echo "${user_name}@${HUHU_EMAIL_DOMAIN}" >> "${HUHU_EMAIL_LIST}"
|
||||
fi
|
||||
if [ -n "${HUHU_POSTFIX_ALIAS:-}" -a -w "${HUHU_POSTFIX_ALIAS:-}" ]; then
|
||||
echo "${user_name}@${HUHU_EMAIL_DOMAIN} ${user_name}" >> "${HUHU_POSTFIX_ALIAS}"
|
||||
fi
|
||||
fi
|
||||
|
||||
install_file 600 .bashrc
|
||||
install_file 600 .cshrc
|
||||
install_file 600 etc/private.conf
|
||||
install_file 600 etc/samples/apache-digest.conf
|
||||
install_file 600 etc/samples/crontab
|
||||
install_file 600 etc/samples/summary.txt
|
||||
install_file 600 .forward
|
||||
install_file 600 .my.cnf
|
||||
install_file 600 .procmailrc
|
||||
install_file 644 etc/htdigest
|
||||
install_file 644 etc/public.conf
|
||||
install_file 644 etc/samples/huhu-directory.html
|
||||
install_file 755 bin/poster.sh
|
||||
install_file 755 bin/read-mail.sh
|
||||
install_file 755 bin/statistics.sh
|
||||
install_file 755 etc/htdigest.sh
|
||||
|
||||
crontab -u "${user_name}" "${user_home}/etc/samples/crontab"
|
||||
Loading…
Add table
Add a link
Reference in a new issue