paulj/hpr-tools
1
0
Fork 0
forked from HPR/hpr-tools
Code Pull Requests Activity
Files
db9b491324a43b0feba28fec3f084e9366e4472d
hpr-tools/Comment_system/process_comments

2344 lines
77 KiB
Perl
Executable File
Raw Blame History

#!/usr/bin/env perl
#===============================================================================
#
# FILE: process_comments
#
# USAGE: ./process_comments [-help] [-docmentation|manpage] [-debug=N]
# [-[no]dry-run] [-verbose ...] [-[no]verify] [-[no]live]
# [-[no]json] [-config=FILE]
#
# DESCRIPTION: Read new comments received as mail messages (or as JSON files)
# and perform moderation actions on them before possibly adding
# them to the HPR database.
#
# OPTIONS: ---
# REQUIREMENTS: ---
# BUGS: ---
# NOTES: 2023-12-23 enabled the experimental::try feature and removed
# the use of 'Try::Tiny'. Revert by removing "use feature 'try'"
# and 'no warnings "experimental::try"'. Remove the '($e)' from
# each 'catch' and end the 'catch' braces with a semicolon. Add
# back 'use Try::Tiny'.
#
# AUTHOR: Dave Morriss (djm), Dave.Morriss@gmail.com
# VERSION: 0.3.3
# CREATED: 2017-09-04 18:06:49
# REVISION: 2024-01-10 13:02:51
#
#===============================================================================
use v5.36; # say and try/catch
use feature 'try';
use strict;
use warnings;
no warnings "experimental::try";
use utf8;
use Carp;
use Getopt::Long;
use Pod::Usage;
use Config::General;
use List::Util qw{max};
use HTML::Parser;
use HTML::Restrict;
use HTML::Entities;
use File::Find::Rule;
use File::Copy;
use File::Slurper 'read_text';
#use IO::All;
use JSON;
use Mail::Address;
use Mail::Field;
use Mail::Internet;
use MIME::Parser;
use Encode qw(decode encode);
use DateTime::Format::ISO8601;
use IO::Prompter;
use Template;
use SQL::Abstract;
use LWP::UserAgent;
#use TryCatch; # Failing 2020-05-31 due to a problem in Devel::Declare
#use Try::Tiny; # Using in-built experimental try/catch
use Log::Handler;
use DBI;
use Data::Dumper;
#
# Version number (manually incremented)
#
our $VERSION = '0.3.3';
#
# Script and directory names
#
( my $PROG = $0 ) =~ s|.*/||mx;
( my $DIR = $0 ) =~ s|/?[^/]*$||mx;
$DIR = '.' unless $DIR;
#-------------------------------------------------------------------------------
# Declarations
#-------------------------------------------------------------------------------
#
# Constants and other declarations
#
my $basedir = "$ENV{HOME}/HPR/Comment_system";
my $configfile = "$basedir/.${PROG}.cfg";
my ( $dbh, $sth1, $h1 );
my ( @ignore, @files );
my ($comment, %updates, $shortfile);
#
# The MIME part we're looking for
#
my $target_mimetype = 'application/json';
#
# All of the keys in the JSON we're interested in (when checking and adding to
# the database)
#
my @json_keys = (
"eps_id", "comment_timestamp",
"comment_author_name", "comment_title",
"comment_text",
);
#
# Keys we need to clean
#
my @cleanable_keys = (
"comment_author_name", "comment_title",
"comment_text",
);
#
# Enable Unicode mode
#
binmode STDOUT, ":encoding(UTF-8)";
binmode STDERR, ":encoding(UTF-8)";
#-------------------------------------------------------------------------------
# Options and arguments
#-------------------------------------------------------------------------------
my $DEF_DEBUG = 0;
my $DEF_LIVE = 0; # Gets edited on borg
#
# Process options
#
my %options;
Options( \%options );
#
# Default help
#
pod2usage( -msg => "$PROG version $VERSION\n", -verbose => 0, -exitval => 1 )
if ( $options{'help'} );
#
# Full documentation if requested with -doc
#
pod2usage(
-msg => "$PROG version $VERSION\n",
-verbose => 2,
-exitval => 1,
-noperldoc => 0,
) if ( $options{'documentation'} );
#
# Collect options
#
my $DEBUG = ( defined( $options{debug} ) ? $options{debug} : $DEF_DEBUG );
my $cfgfile
= ( defined( $options{config} ) ? $options{config} : $configfile );
my $live = ( defined( $options{live} ) ? $options{live} : $DEF_LIVE );
my $verify = ( defined( $options{verify} ) ? $options{verify} : 0 );
my $dry_run = ( defined( $options{'dry-run'} ) ? $options{'dry-run'} : 0 );
my $verbose = ( defined( $options{verbose} ) ? $options{verbose} : 0 );
my $jsonmode = ( defined( $options{json} ) ? $options{json} : 0 );
#
# Report on the options if requested
#
if ($DEBUG > 0) {
_debug(1, 'Options');
_debug(1,
'-config=' . $cfgfile,
($live eq 0 ? '-nolive ' : '-live'),
($verify eq 0 ? '-noverify ' : '-verify'),
($dry_run eq 0 ? '-nodry-run ' : '-dry-run'),
'-verbose=[' . $verbose . ']',
($jsonmode eq 0 ? '-nojson ' : '-json'),
);
_debug(1, '');
}
#
# Sanity checks
#
die "Unable to find configuration file: $cfgfile\n" unless ( -e $cfgfile );
#-------------------------------------------------------------------------------
# Configuration file - load data
#-------------------------------------------------------------------------------
my $conf = Config::General->new(
-ConfigFile => $cfgfile,
-InterPolateVars => 1,
-InterPolateEnv => 1,
-ExtendedAccess => 1,
);
my %config = $conf->getall();
_debug($DEBUG > 2, 'Configuration settings:', Dumper(\%config));
my $logfile = $config{settings}->{logfile};
my $template = $config{settings}->{template};
my $maildrop = $config{settings}->{maildrop};
my $processed = $config{settings}->{processed};
my $rejected = $config{settings}->{rejected};
my $banned = $config{settings}->{banned};
my $jsondir = $config{settings}->{jsondir};
my $jprocessed = $config{settings}->{jprocessed};
my $jrejected = $config{settings}->{jrejected};
my $jbanned = $config{settings}->{jbanned};
my $callback_template = $config{settings}->{callback_template};
my ($cb_user, $cb_password) = split(":",$config{cms}->{user});
#-------------------------------------------------------------------------------
# Moderation responses and the arguments associated with them (from the
# configuration data).
#-------------------------------------------------------------------------------
#
# key => [ 3 element array ]
#
# - key is the menu element from do_moderation
# - the array contains:
# - text to be used in messages
# - anonymous subroutine which returns the directory into which to place
# the file; call it with the $jsonmode variable
# - action keyword to send back to the server
#
my %moderation_keys = (
'Approve' => [
'processed',
sub { ( $_[0] ? $jprocessed : $processed ) },
'approve'
],
'Ban' => [
'banned',
sub { ( $_[0] ? $jbanned : $banned ) },
'block'
],
'Reject' => [
'rejected',
sub { ( $_[0] ? $jrejected : $rejected ) },
'delete'
],
);
#
# Make a RE from the keys
#
my $mkeys = join('|',keys(%moderation_keys));
my $mkeys_re = qr{^$mkeys$};
#-------------------------------------------------------------------------------
# Connect to the database
#-------------------------------------------------------------------------------
my $dbhost = $config{database}->{host} // '127.0.0.1';
my $dbport = $config{database}->{port} // 3306;
my $dbname = $config{database}->{name};
my $dbuser = $config{database}->{user};
my $dbpwd = $config{database}->{password};
$dbh = DBI->connect( "dbi:mysql:host=$dbhost;port=$dbport;database=$dbname",
$dbuser, $dbpwd, { AutoCommit => 1 } )
or croak $DBI::errstr;
#$dbh = DBI->connect( "DBI:MariaDB:database=$dbname;host=$dbhost;port=$dbport",
# $dbuser, $dbpwd, { AutoCommit => 1 } )
# or croak $DBI::errstr;
#
# Enable client-side UTF8
#
$dbh->{mysqlenable_utf8} = 1;
#
# Set the local timezone to UTC for this connection
#
$dbh->do("set time_zone = '+00:00'") or carp $dbh->errstr;
#-------------------------------------------------------------------------------
# Set up logging keeping the default log layout except for the date
#-------------------------------------------------------------------------------
my $log = Log::Handler->new();
$log->add(
file => {
timeformat => "%F %H:%M:%S (%s)",
filename => $logfile,
maxlevel => 7,
minlevel => 0
}
);
#-------------------------------------------------------------------------------
# If mode JSON is selected with -json option we'll check the defined 'json'
# directory, otherwise we'll look for work in the maildrop.
#-------------------------------------------------------------------------------
if ($jsonmode) {
#
# Look for JSON files
#
@ignore = ( '*~', '.*.swp', 'banned', 'processed', 'rejected' );
my $jsonfileRE = qr{(\.(?i:json)|[^.]+)$};
#<<<
@files = File::Find::Rule
->file()
->name($jsonfileRE)
->not( File::Find::Rule->new->name(@ignore) )
->maxdepth(1)
->in($jsondir);
#>>>
if ( $DEBUG > 1 ) {
_debug(1,
"Files found in $jsondir",
Dumper( \@files ),
);
}
#
# There may be nothing there
#
die "No JSON files found; nothing to do\n" unless (@files);
#
# Convert the JSON files into the %updates hash
#
do_JSON_process( \@files, \%updates, $log, $dry_run, $verbose );
}
else {
#
# Look for mail files
#
@ignore = ( '*~', '.*.swp', 'banned', 'processed', 'rejected' );
my $mailfileRE = qr{(\.(?i:eml)|[^.]+)$};
#<<<
@files = File::Find::Rule
->file()
->name($mailfileRE)
->not( File::Find::Rule->new->name(@ignore) )
->maxdepth(1)
->in($maildrop);
#>>>
if ( $DEBUG > 1 ) {
_debug(1,
"Files found in $maildrop",
Dumper( \@files ),
);
}
#
# There may be nothing there
#
unless (@files) {
warn "No mail found; nothing to do\n";
exit;
}
#
# Convert the mail messages into the %updates hash
#
do_mail_process( \@files, \%updates, $log, $dry_run, $verbose );
}
#-------------------------------------------------------------------------------
# Check that comments aren't already in the database
#-------------------------------------------------------------------------------
do_database_check( $dbh, \%updates, $log, $verify, $dry_run );
#-------------------------------------------------------------------------------
# Perform the moderation pass
#-------------------------------------------------------------------------------
do_moderation( $dbh, \%updates, $template, $log, $verify, $dry_run );
#
# Dump the data structure if requested
#
_debug($DEBUG > 1, '%updates: ' . Dumper(\%updates));
#-------------------------------------------------------------------------------
# For the comments which are valid and approved, add them to the database
#-------------------------------------------------------------------------------
print '-' x 80, "\n" if $verbose > 0;
do_update( $dbh, \%updates, $log, $dry_run, $verbose );
#-------------------------------------------------------------------------------
# Walk the captured data reporting what happened (would happen) moving the
# files to the appropriate places and telling the server to do things to the
# originals (if appropriate)
#-------------------------------------------------------------------------------
foreach my $file ( sort_by_timestamp( \%updates ) ) {
#
# Deal with each file depending on the selected action (from the set
# 'Approve', 'Ban' and 'Reject')
#
if ( $updates{$file}->{action} =~ $mkeys_re ) {
#
# Get the elements we need for the function arguments below.
# NOTE: Apologies! This is obscure. The action key will be 'Approve',
# 'Ban' or 'Reject', and the lookup will return the name of the
# destination (for messages), an anonymous subroutine reference which determines
# the directory, and a keyword to send to the web server to dispose of
# the comment. The subref must be called with $jsonmode as the
# argument to get the destination which is different depending on
# whether we're in mail or JSON mode. This really needs to be made
# simpler and easier to understand when this code is revisited!
#
my ( $name, $destsub, $serverac )
= ( @{ $moderation_keys{ $updates{$file}->{action} } } );
my $dest = &$destsub($jsonmode);
#
# Print moderation settings
#
_debug($DEBUG > 1,
'$name: ' . $name,
'$dest: ' . $dest,
'$serverac: ' . $serverac,
);
#
# Report what we're doing with the file and do it if appropriate
#
report_action( $updates{$file}, $name, $dest, $log,
$dry_run, $verbose );
#
# Tell the server what to do, but only if this is the live instance
# and we're not in dry-run mode
#
if ($live) {
unless (
call_back(
$callback_template, $updates{$file}->{JSON}->{key},
$serverac, $cb_user, $cb_password, $log, $dry_run, $verbose
)
)
{
print "Server update failed\n" if $verbose > 0;
}
}
else {
unless ($dry_run) {
print "Not live; no server action taken\n" if $verbose > 0;
}
}
}
elsif ( $updates{$file}->{action} eq 'Ignore' ) {
#
# The action here is 'Ignore' which means just leave it alone. Since
# only the moderator can choose this, or the failure to find the
# episode in the database, we know it's not a broken mail message or
# bad JSON.
#
if ( $verbose > 0 ) {
print "File '$file' ignored\n";
print_errors( $updates{$file}->{errors} );
}
}
elsif ( $updates{$file}->{skip} > 0 ) {
#
# The comment was found to be already in the database so we are
# skipping it. We want to report this and move the file to the
# 'processed' directory.
#
$shortfile = $updates{$file}->{shortfile};
unless ($dry_run) {
if ( $verbose > 0 ) {
print "Moving '$shortfile' to 'processed'\n";
print "Reason: comment is already in the database\n";
print_errors( $updates{$file}->{errors} );
}
$log->info("Moving $file to 'processed'");
unless ( moveFile( $file, ($jsonmode ? $jprocessed : $processed) ) ) {
warn "Unable to move $file\n";
$log->error("Failed to move $file");
}
}
else {
if ( $verbose > 0 ) {
print "Would move '$shortfile' to 'processed' (dry run)\n";
print "Reason: comment is already in the database\n";
print_errors( $updates{$file}->{errors} );
}
}
}
else {
#
# We aborted this one early in the processing and validation, so it's
# really messed up. We're going to reject it outright with error
# messages. We can't tell the server because we don't have the
# key to do it.
#
$shortfile = $updates{$file}->{shortfile};
unless ($dry_run) {
if ( $verbose > 0 ) {
print "Moving $shortfile to 'rejected'\n";
print "Reason: failed validation\n";
print_errors( $updates{$file}->{errors} );
}
$log->info("Moving $file to 'rejected'");
unless ( moveFile( $file, ($jsonmode ? $jrejected : $rejected) ) ) {
warn "Unable to move $file\n";
$log->error("Failed to move $file");
}
}
else {
if ( $verbose > 0 ) {
print "Would move $shortfile to 'rejected' (dry run)\n";
print "Reason: failed validation\n";
print_errors( $updates{$file}->{errors} );
}
}
}
print '.' x 80, "\n" if $verbose > 0;
}
exit;
#=== FUNCTION ================================================================
# NAME: do_JSON_process
# PURPOSE: Process any pending JSON files found in a directory search
# PARAMETERS: $files arrayref containing the JSON files found
# $updates hashref to contain the details collected from
# the JSON files
# $log log handle
# $dry_run Boolean flagging dry-run mode
# $verbose Integer level of verbosity
# RETURNS: Nothing
# DESCRIPTION: The files containing JSON comments have been found earlier and
# passed to this function. They are processed in sorted order.
# The JSON is decoded into a hash and is validated, and the
# elements cleaned up. The JSON is stored for later in the
# $updates structure. If all tests and checks are passed the
# entry for this file in the $updates structure is marked as
# valid. If anything fails the entry is marked as invalid for
# the next stages of processing.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub do_JSON_process {
my ( $files, $updates, $log, $dry_run, $verbose ) = @_;
my ( $shortfile, $dt );
my $json = JSON->new;
#
# Examine the files we found
#
foreach my $file ( sort(@$files) ) {
print ">> $file\n" if $verbose > 0;
$log->notice("Processing $file") unless $dry_run;
#
# Initialise for this file, marking it as invalid by default.
#
$updates->{$file} = {};
$updates->{$file}->{valid} = 0;
$updates->{$file}->{moderated} = 0;
$updates->{$file}->{errors} = [];
$updates->{$file}->{action} = '';
$updates->{$file}->{file} = $file; # For convenience
$updates->{$file}->{shortfile} = $shortfile = abbreviate_filename($file);
#
# Open the nominated file and load its contents into a scalar. Because
# 'read_text' does its own internal error handling we need try/catch to
# intercept it and provide our own.
#
my $json_text;
try {
$json_text = read_text($file);
}
catch ($e){
warn "Failed to read JSON file $file\n";
next;
}
#
# Decode and process the JSON, returning FALSE if it fails so we get
# a log entry (unless it's dry run mode)
#
unless (
convert_JSON(
$json, $json_text, $updates, $file,
$log, $dry_run, $verbose
)
)
{
$log->warning("JSON decode failure; aborting '$shortfile'")
unless $dry_run;
}
}
}
#=== FUNCTION ================================================================
# NAME: do_mail_process
# PURPOSE: Process any pending email found in a directory search
# PARAMETERS: $files arrayref containing the mail files found
# $updates hashref to contain the details collected from
# the mail files
# $log log handle
# $dry_run Boolean flagging dry-run mode
# $verbose Integer level of verbosity
# RETURNS: Nothing
# DESCRIPTION: The files containing email have been found earlier and passed
# to this function. They are processed in sorted order. Each
# file is parsed as a mail file and the various destination
# addresses collected. (TODO Check these against permitted
# addresses). Each message is expected to be in MIME format with
# an attachment, which is extracted. The target mimetype
# (application/json) is checked for (TODO This is a global and
# shouldn't be). The JSON it contains is decoded into a hash and
# is validated, and the elements cleaned up. The JSON is stored
# for later in the $updates structure. If all tests and checks
# are passed the entry for this file in the $updates structure
# is marked as valid. If anything fails the entry is marked as
# invalid for the next stages of processing.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub do_mail_process {
my ( $files, $updates, $log, $dry_run, $verbose ) = @_;
my ( $shortfile, $dt );
#
# Prepare for parsing mail and JSON
#
my $parser = MIME::Parser->new;
$parser->output_under("/tmp");
my $json = JSON->new;
#
# Examine the files we found
#
foreach my $file ( sort(@$files) ) {
print ">> $file\n" if $verbose > 0;
$log->notice("Processing $file") unless $dry_run;
#
# Initialise for this file, marking it as invalid by default.
#
$updates->{$file} = {};
$updates->{$file}->{valid} = 0;
$updates->{$file}->{moderated} = 0;
$updates->{$file}->{errors} = [];
$updates->{$file}->{action} = '';
$updates->{$file}->{file} = $file; # For convenience
$updates->{$file}->{shortfile} = $shortfile = abbreviate_filename($file);
#
# Open the current file and load its contents into a Mail::Internet object
# TODO: Consider using IO::All
#
open( my $mfh, '<', $file )
or die "Failed to open input file '$file' : $!\n";
my $mi_obj = Mail::Internet->new($mfh);
close($mfh)
or warn "Failed to close input file '$file' : $!\n";
#
# This should be to comments@hackerpublicradio.org in one of these headers
#
my @addresses = (
Mail::Address->parse( $mi_obj->head->get('Resent-to') ),
Mail::Address->parse( $mi_obj->head->get('Resent-cc') )
);
if ( !@addresses ) {
@addresses = (
Mail::Address->parse( $mi_obj->head->get('To') ),
Mail::Address->parse( $mi_obj->head->get('Cc') )
);
}
#
# Report the headers we're interested in if requested
#
if ($verbose > 1) {
foreach my $addr (@addresses) {
my $dest = lc( $addr->address );
print "To: $dest\n";
}
print '~ ' x 40,"\n";
}
#
# TODO Check the message is actually for us
#
my ( $ct, $cte, @body, $body, $results );
#
# Parse the message in the assumption it's MIME. Report any errors and
# warnings.
#
my $entity = $parser->parse_data( $mi_obj->as_string() );
unless ($entity) {
$results = $parser->results;
foreach my $pmsg ( $results->msgs ) {
print STDERR "$pmsg\n";
}
}
#
# If we got multiple MIME parts then look for the first 'application/json'
# element and save it as the body we'll work on.
#
if ( scalar( $entity->parts ) > 0 ) {
#
# MIME message
#
if ( $DEBUG > 1 ) {
_debug(1, 'Message is MIME with multiple parts');
foreach my $ent ( $entity->parts ) {
_debug(1, "Type: " . $ent->mime_type);
}
}
#
# Get the first MIME part of the type we want and turn it into an
# array.
# TODO: Might it be better to make a string here since later we simply
# convert the array to a string again.
#
foreach my $ent ( $entity->parts ) {
if ( $ent->mime_type eq $target_mimetype ) {
$ct = $ent->mime_type;
#
# FIXME: Using 'bodyhandle' is supposed to decode the entity
# body, but this is untested. Also, we have to use 'as_string'
# then split on "\n" and stick the newlines back on the array
# elements, which seems a bit weird. Have to monitor this to
# see how it behaves.
#
#@body = @{ $ent->body() };
@body = map {"$_\n"}
split( "\n", $ent->bodyhandle->as_string );
_debug($DEBUG > 1,
'Length of body = ' . scalar(@body) . ' lines'
);
#
# If we got a non-empty body then exit the loop
#
last if @body;
}
}
#
# We found no suitable part so there's nothing to process here. We'll
# let the later phases detect this though
#
unless (@body) {
saveError( "MIME message has no valid '$target_mimetype' element",
$updates->{$file}->{errors} , $log, $dry_run, $verbose );
next;
}
}
else {
#
# The message has no MIME parts
#
saveError( "Message has no attachment",
$updates->{$file}->{errors}, $log, $dry_run, $verbose );
next;
}
#
# Display the body unless we're not very verbose
#
$body = join( "", @body );
print "$body\n" if $verbose > 2;
#
# Decode and process the JSON, returning FALSE if it fails so we get
# a log entry (unless it's dry run mode)
#
unless (
convert_JSON(
$json, $body, $updates, $file,
$log, $dry_run, $verbose
)
)
{
$log->warning("JSON decode failure; aborting '$shortfile'")
unless $dry_run;
}
}
continue {
print '-' x 80, "\n" if $verbose > 0;
}
return;
}
#=== FUNCTION ================================================================
# NAME: do_database_check
# PURPOSE: Look to see if the collected comments are already in the
# database
# PARAMETERS: $dbh database handle
# $updates structure (hashref) holding collected
# information about the files and comments in
# them
# $log log handle
# $verify Boolean flagging the need to verify
# TODO: Is this right?
# $dry_run Boolean flagging dry-run mode
# RETURNS: Nothing
# DESCRIPTION: Looks for each comment in %$updates in the database. The
# search criteria are the comment timestamp (in database format)
# and the comment author name. The timestamp is expected to have
# been converted from full ISO format (2024-01-10T11:16:11Z) to
# the format MySQL likes (2024-01-10 11:16:11). the original
# date is in the element 'orig_timestamp'. If there is a match
# in the database then the comment is to be skipped, and we mark
# the element appropriately and display and log a message. If no
# match we can proceed without skipping;
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub do_database_check {
my ( $dbh, $updates, $log, $verify, $dry_run ) = @_;
my ( $sth1, $h1, $shortfile, $message );
#
# Look for a comment with details matching an incoming one. If found
# someone else has approved it so we need to skip it.
#
$sth1 = $dbh->prepare(
q{SELECT id FROM comments
WHERE comment_timestamp = ?
AND comment_author_name = ?}
) or die $DBI::errstr;
if ( $dbh->err ) {
warn $dbh->errstr;
}
foreach my $file ( sort_by_timestamp($updates) ) {
#
# Make a shortcut to the JSON part, and collect the short form of the
# filename.
#
my $ptr = $updates->{$file}->{JSON};
#my $errors = $updates->{$file}->{errors};
$shortfile = $updates{$file}->{shortfile};
#
# Look for the comment in the database
#
$sth1->execute( $ptr->{comment_timestamp},
$ptr->{comment_author_name} );
if ( $dbh->err ) {
warn $dbh->errstr;
}
#
# Did we find it?
#
if ( $h1 = $sth1->fetchrow_hashref() ) {
#
# Found in the database. Mark this comment to be skipped and save
# an error report
#
#$updates->{$file}->{valid} = 0;
$updates->{$file}->{skip} = 1;
$message = "Comment in file '$shortfile' is already in the database";
print "$message\n" if $verbose > 0;
$log->warn($message) unless $dry_run;
}
else {
#
# Not found
#
$updates->{$file}->{skip} = 0;
}
}
}
#=== FUNCTION ================================================================
# NAME: do_moderation
# PURPOSE: Moderate all the valid comments in the 'updates' structure
# PARAMETERS: $dbh database handle
# $updates structure (hashref) holding collected
# information about the files and comments in
# them
# $tt_template path to the template we're using
# $log log handle
# $verify Boolean flagging the need to verify
# $dry_run Boolean flagging dry-run mode
# RETURNS: Nothing
# DESCRIPTION: Performs the moderation pass on the accumulated comments in
# the $updates structure. This is a hash (referenced by
# $updates) containing the filename as the key. Each of these
# lead to a hashref containing the JSON data (in a hashref), an
# arrayref of error messages and various flags denoting whether
# the comment is valid, has been moderated and what action the
# moderator took.
# The flags and error messages are manipulated here depending on
# what choice is made during the moderation process.
# The contents of the JSON hash (or a subset thereof) and the
# data about the show returned from a database query are
# displayed for the moderator using a template, and a menu of
# 'Approve', 'Ban', 'Reject', Ignore' is presented.
# On exit the structure referenced by $updates has been modified
# to signal what should be done with each of the comments.
# THROWS: No exceptions
# COMMENTS: TODO: References globals and should not.
# SEE ALSO: N/A
#===============================================================================
sub do_moderation {
my ( $dbh, $updates, $tt_template, $log, $verify, $dry_run ) = @_;
my ( $sth1, $h1, $cdt, $age );
my $agelimit = 60 * 60 * 24;
#
# We'll get details of the show each comment is associated with using this
# query. It will be passed to the TT² template.
#
$sth1 = $dbh->prepare(
q{SELECT e.id, e.date, e.title, h.host FROM eps e
JOIN hosts h ON e.hostid = h.hostid
WHERE e.id = ?}
) or die $DBI::errstr;
if ( $dbh->err ) {
warn $dbh->errstr;
}
#
# We'll display each comment with a TT² template
#
my $tt = Template->new(
{ ABSOLUTE => 1,
ENCODING => 'utf8',
INCLUDE_PATH => $basedir,
}
);
my $vars = {};
my $choice;
#
# Process the valid comments, and not marked as 'skip'
#
foreach my $file ( sort_by_timestamp($updates) ) {
if ( $updates->{$file}->{valid} > 0 && $updates->{$file}->{skip} == 0 ) {
#
# Make shortcuts
#
my $ptr = $updates->{$file}->{JSON};
my $errors = $updates->{$file}->{errors};
#
# Check the age of the comment if we're verifying, and ignore if
# less than the age limit. The original timestamp should have been
# reserved even though we had to reformat for MySQL/MariaDB.
#
if ($verify) {
$cdt = DateTime::Format::ISO8601->parse_datetime(
$ptr->{orig_timestamp}
);
$age = DateTime->now->epoch - $cdt->epoch;
if ($age < $agelimit) {
print "Choice 'Ignore' auto-selected due to comment age\n";
$updates->{$file}->{action} = 'Ignore';
$log->info("Ignored comment in $file")
unless $dry_run;
$updates->{$file}->{moderated} = 0;
next;
}
}
#
# Get the show details from the database
#
$sth1->execute( $ptr->{eps_id} );
if ( $dbh->err ) {
warn $dbh->errstr;
}
#
# Do we know this episode?
# NOTE: If the database we're using is the clone this might fail
# because it's out of step with the live one
#
if ( $h1 = $sth1->fetchrow_hashref() ) {
#
# Populate the variables for the template
#
$vars->{file} = $file;
$vars->{db} = $h1;
$vars->{comment} = $ptr;
#
# Call the template and print the result
#
my $document;
$tt->process( $tt_template, $vars, \$document,
{ binmode => ':utf8' } )
|| die $tt->error(), "\n";
print $document;
#
# Prompt for moderation. Note: these prompts are used to flag
# the choice in the %updates hash, so don't change them unless
# you also change them elsewhere.
#
$choice = prompt(
'Choose...',
-menu => [ 'Approve', 'Ban', 'Reject', 'Ignore' ],
'>'
);
if ($choice) {
print "Choice '$choice' selected\n";
if ( $choice eq 'Approve' ) {
$updates->{$file}->{action} = $choice;
$log->info("Approved comment in $file")
unless $dry_run;
$updates->{$file}->{moderated} = 1;
}
elsif ( $choice eq 'Ban' ) {
$updates->{$file}->{action} = $choice;
saveError(
"Comment in '$file' banned by the moderator",
$errors,
$log, $dry_run, 0
);
$updates->{$file}->{valid} = 0;
$updates->{$file}->{moderated} = 1;
}
elsif ( $choice eq 'Reject' ) {
$updates->{$file}->{action} = $choice;
saveError(
"Comment in '$file' rejected by the moderator",
$errors,
$log, $dry_run, 0
);
$updates->{$file}->{valid} = 0;
$updates->{$file}->{moderated} = 1;
}
elsif ( $choice eq 'Ignore' ) {
$updates->{$file}->{action} = $choice;
$log->info("Ignored comment in $file")
unless $dry_run;
$updates->{$file}->{moderated} = 0;
}
}
else {
print "\n";
undef $choice; # Seem to need this after aborting 'prompt'
print "Ignored this comment\n";
$log->info("Ignored comment in $file (default action)")
unless $dry_run;
$updates->{$file}->{moderated} = 0;
}
#print "\n";
}
else {
#
# We couldn't find the episode in the database
#
printf "Episode %s is not known\n", $ptr->{eps_id};
$updates->{$file}->{action} = 'Ignore';
saveError(
"Episode referenced in '$file' is not known",
$errors,
$log, $dry_run, 0
);
$updates->{$file}->{moderated} = 0;
}
}
}
}
#=== FUNCTION ================================================================
# NAME: do_update
# PURPOSE: Add valid, approved comments to the database (or pretend to do
# so if in dry-run mode)
# PARAMETERS: $dbh database handle
# $updates structure (hashref) holding collected
# information about the files and comments in
# them
# $log log handle
# $dry_run Boolean flagging dry-run mode
# $verbose Integer level of verbosity
# RETURNS: Nothing
# DESCRIPTION: Performs a database update for all valid approved comments in
# the structure referenced by $updates unless in dry-run mode
# where what would be done will be reported.
# THROWS: No exceptions
# COMMENTS: TODO: References globals and should not.
# SEE ALSO: N/A
#===============================================================================
sub do_update {
my ( $dbh, $updates, $log, $dry_run, $verbose ) = @_;
my $sql = SQL::Abstract->new;
my ( $stmt, @bind, $show, $count );
$count = 0;
foreach my $file ( sort_by_timestamp($updates) ) {
if ( $updates->{$file}->{valid} > 0
&& $updates->{$file}->{action} eq 'Approve' )
{
$count++;
$show = $updates->{$file}->{JSON}->{eps_id};
my $shortfile = $updates{$file}->{shortfile};
#
# Build the statement
# NOTE: The JSON keys we wish to use match the column names in the
# 'comments' table. The second argument to 'insert' needs to be
# a hashref, so we use @json_keys to list the keys we need, with
# the whole expression returning an anonymous hash (hashref)
#
( $stmt, @bind )
= $sql->insert( 'comments',
{ %{ $updates->{$file}->{JSON} }{@json_keys} } );
#
# Display the statement we constructed if requested
#
_debug($DEBUG > 1,
"$stmt\n'",
join( "','", @bind )
);
#
# Take action or report potential changes
#
unless ($dry_run) {
#
# Apply the SQL
#
$dbh->do( $stmt, undef, @bind );
if ( $dbh->err ) {
#
# Something broke during the database update. Warn about
# it, save the error and make the action 'Ignore' so the
# file is kept for further investigation (or to be
# edited). Marking the file as invalid may be overkill.
#
warn $dbh->errstr;
saveError(
$dbh->errstr,
$updates{$file}->{errors},
$log, $dry_run, $verbose
);
# $updates{$file}->{valid} = 0;
$updates->{$file}->{action} = 'Ignore';
}
else {
$log->info("$file: inserted comment for show $show");
if ( $verbose > 0 ) {
print "Updated show $show from file $shortfile\n";
}
}
}
else {
print
"Would have added comment for show $show from file $shortfile\n"
if $verbose > 0;
}
}
}
if ($verbose > 0 && $count > 0) {
print "\n", '-' x 80, "\n";
}
}
#=== FUNCTION ================================================================
# NAME: convert_JSON
# PURPOSE: Converts the JSON from a file or an email into an internal
# data structure
# PARAMETERS: $json JSON object
# $jtext JSON in text format
# $updates hashref to contain the details collected from
# the JSON and elsewhere
# $file the file we're processing (hash key)
# $log log handle
# $dry_run Boolean flagging dry-run mode
# $verbose Integer level of verbosity
# RETURNS:
# DESCRIPTION:
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub convert_JSON {
my ( $json, $jtext, $updates, $file, $log, $dry_run, $verbose ) = @_;
my ($comment, $dt, $shortfile);
$shortfile = $updates{$file}->{shortfile};
#
# Decode the JSON into a hashref
#
try {
$comment = $json->decode($jtext);
}
#
# If the JSON decode failed we have a problem
#
catch ($e){
saveError(
"JSON in file '$shortfile' failed to decode",
$updates->{$file}->{errors},
$log, $dry_run, $verbose
);
return 0;
}
#
# Validate the comment fields: do we have all we expected?
#
unless (validate_comment($comment)) {
saveError(
"JSON in file '$shortfile' failed to validate",
$updates->{$file}->{errors},
$log, $dry_run, $verbose
);
return 0;
}
#
# Perform some cleaning
#
foreach my $key (@cleanable_keys) {
$comment->{$key} = clean_comment_field( $comment->{$key} );
}
#
# ISO 8601 timestamps cause MySQL problems (or have started to) so we
# parse them and convert to an acceptable format. We keep the original
# format in $verify is set and we have to check its age.
#
try {
$dt = DateTime::Format::ISO8601->parse_datetime(
$comment->{comment_timestamp} );
}
catch ($e){
die "Failed to parse comment timestamp\n";
}
$comment->{orig_timestamp} = $comment->{comment_timestamp};
$comment->{comment_timestamp} = $dt->ymd . ' ' . $dt->hms;
#
# Stash the JSON for later
#
$updates->{$file}->{JSON} = $comment;
#
# This file is valid we think
#
$updates->{$file}->{valid} = 1;
$log->info("$file seems valid") unless $dry_run;
return 1;
}
#=== FUNCTION ================================================================
# NAME: report_action
# PURPOSE: Does all of the necessary reporting as the email or JSON files
# are being acted upon
# PARAMETERS: $struct hashref holding collected comment data for
# a given mail file
# $destname name of destination
# $dest destination directory
# $log log handle
# $dry_run Boolean flagging dry-run mode
# $verbose Integer level of verbosity
# RETURNS: Nothing
# DESCRIPTION: In dry run mode reports what would have been done along with
# any errors, but only in verbose mode. Otherwise reports the
# action (in verbose mode) and logs it too. It also moves the
# mail file to the requested directory.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub report_action {
my ( $struct, $destname, $dest, $log, $dry_run, $verbose ) = @_;
#
# Get values with a hashref slice
#
my ( $file, $shortfile ) = @$struct{ 'file', 'shortfile' };
unless ($dry_run) {
if ($verbose > 0) {
print "Moving '$shortfile' to '$destname'\n";
print_errors($struct->{$file}->{errors});
}
$log->info("Moving '$file' to '$destname'");
unless ( moveFile( $file, $dest ) ) {
warn "Unable to move $shortfile\n";
$log->error("Failed to move $shortfile");
}
}
else {
if ($verbose > 0) {
print "Would move '$shortfile' to '$destname' (dry run)\n";
print_errors($struct->{$file}->{errors});
}
}
return;
}
#=== FUNCTION ================================================================
# NAME: call_back
# PURPOSE: Invokes a PHP interface on the HPR server through which
# a comment can be marked as fully processed
# PARAMETERS: $format sprintf template for building the URL
# $key the key from the JSON
# $action the action to be taken
# $user the username from the configuration
# $pass the password from the configuration
# $log log handle
# $dry_run Boolean flagging dry-run mode
# $verbose Integer level of verbosity
# RETURNS: True (1) if the call performed as it should, otherwise false
# (0)
# DESCRIPTION: Checks that the correct parameters have been supplied, then
# builds the URL we're going to use from the format string, key
# and action. If in dry-run mode this URL is reported and
# nothing more. Otherwise the URL is queried with an HTTP 'GET'.
# If the response shows success then the action is considered to
# have been taken. The returned message is displayed (in verbose
# mode) and success is logged. If the 'GET' failed then
# a warning message is generated along with a warning log entry.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub call_back {
my ( $format, $key, $action, $user, $pass, $log, $dry_run, $verbose ) = @_;
my ( $ua, $url, $response, $code, $message, $content );
#
# Check calling parameters
#
unless ($key) {
warn "Invalid call to 'call_back' subroutine; missing key\n";
return 0;
}
unless ( $action =~ /^(approve|block|delete)$/ ) {
warn "Invalid call to 'call_back' subroutine; invalid action\n";
return 0;
}
#
# Build the URL
#
$url = sprintf( $format, $key, $action );
#
# Perform the call to clean up the JSON files, etc, or just say what would
# have been done
#
unless ($dry_run) {
print "Making the server call:\nGET $url\n" if $verbose > 0;
$ua = LWP::UserAgent->new;
$ua->timeout(180); # Module default is 180 sec = 3 mins
$ua->credentials("hub.hackerpublicradio.org:443", "cms", $user, $pass);
$response = $ua->get($url);
if ( $response->is_success ) {
#
# Server call succeeded
#
$code = $response->code;
$message = $response->message;
$content = $response->decoded_content;
if ($verbose > 0) {
print "Success: $code/$message\n";
print "Content: $content\n" if $content;
}
$log->info("Successful server message $key/$action: " .
$response->status_line);
return 1;
}
else {
#
# Server call failed
#
warn $response->status_line . "\n";
$log->error("Failed server message $key/$action: " .
$response->status_line);
# Try to log as much as possible
$log->error( $response->decoded_content )
if $response->decoded_content;
return 0;
}
}
else {
#
# Always a success in dry-run mode
#
print "Would have made the server call:\nGET $url\n" if $verbose > 0;
return 1;
}
}
#=== FUNCTION ================================================================
# NAME: print_errors
# PURPOSE: Prints the contents of the error array if there's anything in
# it (i.e. not empty)
# PARAMETERS: $errors arrayref possibly containing errors
# RETURNS: Nothing
# DESCRIPTION: Simplifies printing in the case when there's nothing to print
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub print_errors {
my ($errors) = @_;
return unless defined($errors);
print "Errors: ", join( "\n", @{$errors} ), "\n"
if @{$errors};
}
#=== FUNCTION ================================================================
# NAME: saveError
# PURPOSE: Saves an error message in an error structure and logs it if in
# live mode
# PARAMETERS: $message error message text
# $struct structure (arrayref) to hold the text
# $log log handle
# $dry_run Boolean flagging dry-run mode
# $verbose Integer level of verbosity
# RETURNS: Nothing
# DESCRIPTION: Simplifies the saving of an error message and logging it
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub saveError {
my ( $message, $struct, $log, $dry_run, $verbose ) = @_;
$log->warn($message) unless $dry_run;
push( @{$struct}, $message );
print "$message\n" if $verbose > 0;
}
#=== FUNCTION ================================================================
# NAME: validate_comment
# PURPOSE: Checks that all of the required fields are present in the
# JSON comment
# PARAMETERS: $comment - a pointer to the JSON hash
# RETURNS: True (1) if valid, otherwise false (0)
# DESCRIPTION:
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub validate_comment {
my ($comment) = @_;
foreach my $key (@json_keys) {
return 0 unless defined($comment->{$key});
}
return 1;
}
#=== FUNCTION ================================================================
# NAME: count_tags
# PURPOSE: Counts the number of start tags in what might be HTML
# PARAMETERS: $string String to examine
# RETURNS: An integer count of the number of start tags found
# DESCRIPTION: Uses HTML::Parser to parse the input string. A handler is
# defined which accumulates start and end tags in an array. The
# number of start tags found is returned to the caller.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub count_tags {
my ($string) = @_;
my @accum;
chomp($string);
return 0 unless $string;
my $p = HTML::Parser->new(
api_version => 3,
handlers => {
start => [ \@accum, "event,text" ],
end => [ \@accum, "event,text" ]
}
);
$p->parse($string);
$p->eof;
return scalar(@accum);
}
#=== FUNCTION ================================================================
# NAME: clean_comment_field
# PURPOSE: Cleans a string field from the comment
# PARAMETERS: $field - the field to be cleaned
# RETURNS: The cleaned string
# DESCRIPTION: We want to remove all HTML. We also want to add HTML entities
# where these may be needed. If there are already entities in
# the data we will decode them first then re-encode so we don't
# get double encoding.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub clean_comment_field {
my ($field) = @_;
#
# Remove all HTML
#
my $hr = HTML::Restrict->new();
$field = $hr->process($field);
#
# Entities. Make sure all existing entities are decoded first, then encode
# the result. Note that the unsafe characters are the reverse of what's
# listed. The second argument to encode_entities uses regular expression
# character class syntax (as if in [] in a RE). The set is all non-plain
# ASCII exclusing newline, carriage return and '<>&'.
#
decode_entities($field);
$field
= encode_entities( $field, '^\n\r\x20-\x25\x27-\x3b\x3d\x3f-\x7e' );
return $field;
}
#=== FUNCTION ================================================================
# NAME: moveFile
# PURPOSE: Moves a file (renames it) taking account of whether the name
# exists at the destination
# PARAMETERS: $file file to move
# $dest destination of the file
# RETURNS: True (1) if the move succeeded, otherwise false (0)
# DESCRIPTION: A wrapper around the File::Copy 'move' function. If the target
# file exists then a version number is appended to the name so
# that the original is not clobbered.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub moveFile {
my ( $file, $dest ) = @_;
my ( $target, $basename, $prefix, $vsn );
return 0 unless -e $file;
#
# Handle a destination directory
#
if ( -d $dest ) {
( $basename = $file ) =~ s|.*/||mx;
$target = "$dest/$basename";
}
else {
$target = $dest;
}
#
# If the target exists we'll have to do some work, otherwise just do the
# move
#
if ( -e $target ) {
if ( ( $prefix, $vsn ) = ( $target =~ /(\.)(\d+)$/ ) ) {
while ( -e "$prefix$vsn" ) {
$vsn++;
$target = "$prefix$vsn";
}
return move( $file, $target );
}
else {
$vsn = 1;
$prefix = $target;
$target = "$prefix.$vsn";
while ( -e "$prefix.$vsn" ) {
$vsn++;
$target = "$prefix.$vsn";
}
return move( $file, $target );
}
}
else {
return move( $file, $dest );
}
}
#=== FUNCTION ================================================================
# NAME: abbreviate_filename
# PURPOSE: Abbreviates a long pathname by shrinking the directory names.
# PARAMETERS: $filename The name of the file
# RETURNS: A string containing the abbreviated name
# DESCRIPTION: Splits the filename, assembles the directories as just their
# first character, and then appends the filename. A bit
# primitive but it works.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub abbreviate_filename {
my ($filename) = @_;
my @elements = split('/',$filename);
my @shortened = map {substr($_,0,1)} @elements[0..$#elements-1];
return join('/',@shortened,$elements[-1]);
}
#=== FUNCTION ================================================================
# NAME: sort_by_timestamp
# PURPOSE: Sorts the main hash by timestamp rather than the normal sort
# by key
# PARAMETERS: $struct hashref pointing to the main structure
# RETURNS: A list of hash keys in order of timestamp
# DESCRIPTION: Generates a list of keys by sorting based on the comment
# timestamp in the JSON hash. Performs the sort by doing
# a string comparison since the dates are in ISO8601
# 'YYYY-MM-DDTHH:MM:SSZ' format (e.g. 2017-10-06T06:22:55Z).
# This seems to be safe.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub sort_by_timestamp {
my ($struct) = @_;
my @result = sort {
$struct->{$a}->{JSON}->{comment_timestamp}
cmp $struct->{$b}->{JSON}->{comment_timestamp}
} keys(%$struct);
return @result;
}
#=== FUNCTION ================================================================
# NAME: _debug
# PURPOSE: Prints debug reports
# PARAMETERS: $active Boolean: 1 for print, 0 for no print
# @messages List of messages to print
# RETURNS: Nothing
# DESCRIPTION: Outputs messages to STDERR if $active is true. For each
# message it removes any trailing newline and then adds one in
# the 'print' so the caller doesn't have to bother. Prepends
# each message with 'D> ' to show it's a debug message.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub _debug {
my ( $active, @messages ) = @_;
return unless $active;
foreach my $msg (@messages) {
chomp($msg);
print STDERR "D> $msg\n";
}
}
#=== FUNCTION ================================================================
# NAME: Options
# PURPOSE: Processes command-line options
# PARAMETERS: $optref Hash reference to hold the options
# RETURNS: Undef
# DESCRIPTION:
# THROWS: no exceptions
# COMMENTS: none
# SEE ALSO: n/a
#===============================================================================
sub Options {
my ($optref) = @_;
my @options = (
"help", "documentation|manpage",
"debug=i", "dry-run!",
"verbose+", "verify!",
"live!", "json!",
"config=s",
);
if ( !GetOptions( $optref, @options ) ) {
pod2usage( -msg => "$PROG version $VERSION\n", -exitval => 1 );
}
return;
}
__END__
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Application Documentation
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#{{{
=head1 NAME
process_comments
=over 4
Process incoming comment files as email messages or JSON files
=back
=head1 VERSION
This documentation refers to process_comments version 0.3.3
=head1 USAGE
./process_comments [-help] [-doc] [-debug=N] [-[no]dry-run]
[-verbose ...] [-[no]live] [-[no]json] [-config=FILE]
./process_comments -dry-run
./process_comments -debug=3 -dry-run
./process_comments -verbose -verbose
./process_comments -help
./process_comments -documentation
./process_comments -json
./process_comments -verb -live -config=.process_comments_live.cfg
=head1 OPTIONS
=over 8
=item B<-help>
Prints a brief help message describing the usage of the program, and then exits.
=item B<-documentation> or B<-manpage>
Prints the entire embedded documentation for the program, then exits.
=item B<-debug=N>
Enables debugging mode when N > 0 (zero is the default). The levels are:
=over 4
=item B<1>
Reports on the options chosen. Running with the B<-dry-run> option prevents
problems with comments if any options have been incorrectly used.
=item B<2>
Prints all of the information described at the previous level.
Prints the names of files found in the mail or JSON spool areas.
Prints the internal details of the email, listing the MIME parts (if there are any).
Prints the length of the MIME part matching the desired type, in lines.
Prints the entirety of the internal structure holding details of the mail file
and the comment it contains. This follows the moderation pass.
Prints the SQL that has been constructed to update the database.
=item B<3>
Prints all of the information described at the previous levels.
Prints the contents of the B<%config> hash built from the configuration file.
=back
=item B<-[no]dry-run>
Controls the program's B<dry-run> mode. It is off by default. In dry-run mode
the program reports what it would do but makes no changes. When off the
program makes all the changes it is designed to perform.
=item B<-verbose>
This option may be repeated. For each repetition the level of verbosity is
increased. By default no verbosity is in effect and the program prints out the
minimal amount of information.
Verbosity levels:
=over 4
=item B<1>
Prints the name of each mail (or JSON) file as it's processed.
Prints any error messages during message validation, which are also being
logged (unless in dry-run mode) and saved for reporting later.
Prints a notification if the comment is added to the database (or that this
would have happened in dry-run mode).
Prints messages about the moving of each mail (or JSON) file from the
processing area, along with any errors accumulated for that file. In dry-run
mode simply indicates what would have happened.
Prints the response code received from the server when invoking the interface
for updating comment files there. If in dry-run mode the message produced
merely indicates what would have happened.
If validation failed earlier on then further information is produced about the
final actions taken on these files.
=item B<2>
Prints the addresses each mail message is being sent to (unless in JSON mode).
=item B<3>
Prints the JSON contents of each mail message (or of each JSON file).
=back
=item B<-[no]verify>
This option controls whether the script imposes a delay on comments. The idea
is that if the comment feature is used to rant on a subject or to pass
misinformation, delaying them will help to defuse the situation.
The default state is B<-noverify>; a delay is not imposed. Selecting
B<-verify> means that comments have to be at least 24 hours old before they
are processed. The length of the delay cannot currently be changed without
altering the script.
This feature of the script has hardly been used and is perhaps against the
spirit of HPR, so it will probably be removed in a future version.
=item B<-[no]live>
This option determines whether the program runs in live mode or not. The
default varies depending on which system it is being run on.
IT SHOULD NOT USUALLY BE NECESSARY TO USE THIS!
In live mode the program makes changes to the live database and sends messages
to the live web interface when a comment has been processed. With live mode
off the program assumes it is writing to a clone of the database and it does
not inform the webserver that a comment has been processed.
The default for the copy of the program on borg is that live mode is ON.
Otherwise the default is that live mode is OFF. The setting is determined by
the sed script called B<fixup.sed> on borg. This needs to be run whenever
a new version of the program is released. This is done as follows:
sed -i -f fixup.sed process_comments
=item B<-[no]json>
This option selects JSON mode, which makes the script behave in a different
way from the default mode (B<-nojson> or MAIL mode) where it processes email
containing comments.
In JSON mode the script looks in a sub-directory called B<json/> where it
expects to find JSON files. The normal way in which these files arrive in this
directory is by using B<scp> to copy them from the HPR server (the directory
is B</home/hpr/comments>). This is a provision in case the normal route of
sending out email messages has failed for some reason. It also saves the user
from setting up the mail handling infrastructure that would otherwise be
needed.
In JSON mode the mail handling logic is not invoked, files are searched for in
the B<json/> directory and each file is processed, moderation is requested and
the comment is added to the database. In `B<-live>` mode the server is informed
that the comment has been processed.
The B<json/> directory needs to have three sub-directories: B<processed>,
B<banned> and B<rejected>. The script will place the processed files into
these sub-directories according to the moderation choice made. This makes it
easier to see what actions were taken and helps avoid repeated processing of
the same comment.
=item B<-config=FILE>
This option defines a configuration file other than the default
B<.hpr_db.cfg>. The file must be formatted as described below in the section
B<CONFIGURATION AND ENVIRONMENT>.
=back
=head1 DESCRIPTION
A script to process new comments, moderate them and add them to the HPR
database.
In the new HPR comment system (released September 2017) a new web form is
presented in association with each show. The form can be used to submit
a comment on the show in question and takes some standard fields: the name of
the commenter, the title of the comment and the body of the comment itself.
Once the comment has been submitted its contents are formatted as a JSON
object and are sent as a mail attachment to the address
B<comments@hackerpublicradio.org>.
Recipients of these mail messages can then perform actions on the comments
they contain to cause them to be added to the HPR database. These actions are:
approve the comment, block it (because it is inappropriate or some form of
Spam and we want to prevent any further messages from the associated IP
address), or reject it (delete it). There is also an ignore option which skips
the current comment in this run of the script so it can be revisited later.
This script can process an entire email message which has been saved to a file
or a file containing the JSON object (as in the email attachment). When
processing email it is expected that it will be found in a maildrop directory,
and when finished the messages will be placed in sub-directories according to
what actions were carried out. A similar logic is used for JSON files; they
are expected to be in a drop area and are moved to sub-directories after
processing.
The directories used as spool areas are defined in the configuration file(s)
described below.
=head2 CHANGES
=head3 2024
An alternative method of comment approval has been added using PHP on the
server B<https://hub.hackerpublicradio.org>. This script was originally
designed around receiving email messages containing JSON or collecting JSON
files. The assumption was that it was the sole agent processing these messages
or files and would therefore be the only way that comments could enter the
database.
With the new server route it became possible for an emailed comment to be
received when that comment was already in the database.
As of version B<0.3.2> the script has been enhanced to check whether comments
received as mail messages (or JSON files) have already been processed. If this
is found to be the case the incoming data is skipped and stored in the
'B<processed>' directory (because the comment has been approved elsewhere).
There is still scope for confusion - if for example, a comment has been
rejected on the server, the script will see it as a potential addition to the
database. The moderators need to coordinate their decisions!
The ultimate solution will be to have just one way of moderating and
installing comments which is available to any of the "Janitors".
=head2 MAIL HANDLING
One way of handling incoming mail is to use a mail client which is capable of
saving messages sent to the above address in the spool area mentioned earlier.
For example, Thunderbird can do this by use of a filter and a plugin. Other
MUA's will have similar capabilities.
When this script is run on the mail spool area it will process all of the
files it finds. For each file it will check its validity in various ways,
display the comment then offer a moderation menu. The moderation options are
described below.
=head3 APPROVE
If a comment is approved then it will be added to the database, the associated
mail file will be moved to a sub-directory (by default called 'B<processed>'),
and the HPR server will be notified of this action.
=head3 BAN
If a comment is banned then it will not be added to the database. The mail
file will be moved to the sub-directory 'B<banned>' and the HPR server will be
informed that the IP address associated with the comment should be placed on
a black list.
=head3 REJECT
If a comment is rejected it is not written to the database, the mail file is
moved to the sub-directory 'B<rejected>' and the HPR server informed that the
comment can be deleted.
=head3 IGNORE
If a comment is ignored it is simply left in the mail spool and no further
processing done on it. It will be eligible for processing again when the
script is next run.
=head2 JSON FILE HANDLING
As described under the description of the B<-[no]json> option, the script
allows the processing of a multiple JSON files, each containing a single
comment. These files are expected to be in another spool area (defined int he
configuration file). The JSON is checked and all of the comment fields are
validated, then the moderation process is begun.
Moderation in this case consists of the same steps as described above except
that no mail file actions are taken and the JSON file is moved to
a sub-directory after processing.
=head1 DIAGNOSTICS
=over 4
=item B<Unable to find configuration file ...>
Type: fatal
The nominated configuration file referenced in B<-config=FILE> was not found.
=item B<No mail found; nothing to do>
Type: fatal
No mail files were found in the mail spool area requiring processing.
=item B<No JSON files found; nothing to do>
Type: fatal
No JSON files were found in the JSON spool area requiring processing.
=item B<Failed to read JSON file '...' ...>
Type: fatal
A JSON file in the spool area could not be read with a JSON parser.
=item B<Failed to parse comment timestamp ...>
Type: fatal
The timestamp must be converted to a format compatible with MySQL/MariaDB but
during this process the parse failed.
=item B<Failed to open input file '...' ...>
Type: fatal
A mail file in the spool area could not be opened.
=item B<Failed to move ...>
Type: warning
A mail file could not be moved to the relevant sub-directory.
=item B<Failed to close input file '...' ...>
Type: warning
A mail file in the spool area could not be closed.
=item B<Various error messages from the database subsystem>
Type: fatal, warning
An action on the database has been flagged as an error.
=item B<Various error messages from the Template toolkit>
Type: fatal
An action relating to the template used for the display of the comment has
been flagged as an error.
=item B<Invalid call to 'call_back' subroutine; missing key>
Type: warning
The routine 'call_back' was called incorrectly. The key was missing.
=item B<Invalid call to 'call_back' subroutine; invalid action>
Type: warning
The routine 'call_back' was called incorrectly. The action was invalid.
=item B<Error from remote server indicating failure>
Type: warning
While attempting to send an action to the remote server with the 'call_back'
subroutine an error message was received.
=back
=head1 CONFIGURATION AND ENVIRONMENT
=head2 CONFIGURATION
The configuration file design was changed for version B<0.2.7> and beyond.
The script expects a configuration file to provide it with various program
settings, database credentials and HPR CMS credentials.
The default configuration file name is B<.process_comments.cfg> and is for use
with the local clone of the hpr database.
This file has the general structure:
<<include .process_comments_settings.cfg>>
<<include .hpr_db.cfg>>
<cms>
user = "dummy:dummy"
</cms>
It uses B<Config::General> 'B<include>' directives to include the file
B<.process_comments_settings.cfg> which holds the program settings. It then
includes the file B<.hpr_db.cfg> which containss credentials for the cloned
database. Finally it defines dummy credentials for the HPR CMS since this
feature is not used by default.
The more useful configuration is in B<.process_comments_live.cfg>:
<<include .process_comments_settings.cfg>>
<<include .hpr_livedb.cfg>>
<cms>
<<include .hpradmin_curlrc>>
</cms>
The basic format of the main configuration data after the inclusions have been
performed is then:
<settings>
# Holds program settings
</settings>
<database>
# Holds database settings
</database>
<cms>
# Holds CMS credentials
</cms>
=head3 CONTENTS OF B<.process_comments_settings.cfg>:
This section is enclosed in '<settings>' tags:
<settings>
PROG = process_comments
#
# Defaults
#
basedir = "$HOME/HPR/Comment_system"
configfile = "$basedir/.hpr_db.cfg"
logfile = "$basedir/logs/${PROG}.log"
template = "$basedir/${PROG}.tpl"
#
# Mail message stash area
#
maildrop = "$HOME/HPR/CommentDrop"
processed = "$maildrop/processed"
rejected = "$maildrop/rejected"
banned = "$maildrop/banned"
#
# JSON stash area
#
jsondir = "$basedir/json"
jprocessed = "$jsondir/processed"
jrejected = "$jsondir/rejected"
jbanned = "$jsondir/banned"
#
# How to tell the server the comment's processed
#
callback_template = \
"https://hackerpublicradio.org/comment_process.php?key=%s&action=%s"
</settings>
=head3 CONTENTS OF B<.hpr_db.cfg> AND B<.hpr_livedb.cfg>
The default file providing this part is just for use with the default
database. The section is enclosed in '<database>' tags:
<database>
host = 127.0.0.1
port = PORT
name = DATABASE
user = USERNAME
password = PASSWORD
</database>
These settings can alternatively be used to connect to an SSH tunnel which has
been connected from a remote system (like borg) to the live database.
Assuming the port chosen for this is 3307 something like the following could
be used:
<database>
host = 127.0.0.1
port = 3307
name = hpr_hpr
user = hpr_hpr
password = "**censored**"
</database>
A typical Bash script for opening a tunnel might be:
#!/bin/bash
SSHPORT=22
LOCALPORT=3307
REMOTEPORT=3306
ssh -p ${SSHPORT} -f -N -L localhost:${LOCALPORT}:localhost:${REMOTEPORT} hpr@hackerpublicradio.org
=head3 CONTENTS OF B<.hpradmin_curlrc>
This is a file used by the 'curl' command to contain credentials to access the
CMS on the HPR server. The format needs to be:
user = hpradmin:**censored**
This is one of the formats allowed by 'curl' and is also compatible with the
B<Config::General> module used by this script.
=head2 TEMPLATE
The program displays the comment that is currently being processed for
moderation. It uses a template along with the Perl B<Template> module to do
this. By default this template is called B<process_comments.tpl>. This can be
changed by changing the line in the "settings" configuration file which sets
the 'template' variable.
The template is provided with the following data:
file a scalar containing the name of the file being processed
db a hash containing the details of the show to which the
comment relates, returned from a database query:
id the episode number
date the date of the episode
title the episode title
host the host name
comment a hash containing the fields from the comment:
eps_id the episode number
comment_timestamp date and time of the comment
comment_author_name comment author
comment_title comment title
comment_text comment text
justification justification for posting (if
relevant)
key unique comment key
=head1 DEPENDENCIES
Carp
Config::General
DBI
Data::Dumper
DateTime::Format::ISO8601
Encode
File::Copy
File::Find::Rule
File::Slurper
Getopt::Long
HTML::Entities
HTML::Restrict
IO::Prompter
JSON
LWP::UserAgent
List::Util
Log::Handler
MIME::Parser
Mail::Address
Mail::Field
Mail::Internet
Pod::Usage
SQL::Abstract
Template
The Perl B<experimental:try> option is used instead of the original
B<Try::Tiny> package.
=head1 BUGS AND LIMITATIONS
There are no known bugs in this module.
Please report problems to Dave Morriss (Dave.Morriss@gmail.com)
Patches are welcome.
=head1 AUTHOR
Dave Morriss (Dave.Morriss@gmail.com)
=head1 LICENCE AND COPYRIGHT
Copyright (c) 2017 - 2024 Dave Morriss (Dave.Morriss@gmail.com). All rights
reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See perldoc perlartistic.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
=cut
#}}}
# [zo to open fold, zc to close]
# vim: syntax=perl:ts=8:sw=4:et:ai:tw=78:fo=tcrqn21:fdm=marker
View Git Blame Copy Permalink