[usenet/newsstats.git] / bin / parsedb.pl

#! /usr/bin/perl
#
# parsedb.pl
#
# This script will parse a database with raw header information
# from a INN feed to a structured database.
#
# It is part of the NewsStats package.
#
# Copyright (c) 2013 Thomas Hochstein <thh@inter.net>
#
# It can be redistributed and/or modified under the same terms under
# which Perl itself is published.

BEGIN {
  our $VERSION = "0.01";
  use File::Basename;
  # we're in .../bin, so our module is in ../lib
  push(@INC, dirname($0).'/../lib');
}
use strict;
use warnings;

use NewsStats qw(:DEFAULT :TimePeriods :SQLHelper);

use DBI;
use Getopt::Long qw(GetOptions);
Getopt::Long::config ('bundling');

################################# Definitions ##################################

# define header names with separate database fields
my %DBFields = ('date'                      => 'date',
                'references'                => 'refs',
                'followup-to'               => 'fupto',
                'from'                      => 'from_',
                'sender'                    => 'sender',
                'reply-to'                  => 'replyto',
                'subject'                   => 'subject',
                'organization'              => 'organization',
                'lines'                     => 'linecount',
                'approved'                  => 'approved',
                'supersedes'                => 'supersedes',
                'expires'                   => 'expires',
                'user-agent'                => 'useragent',
                'x-newsreader'              => 'xnewsreader',
                'x-mailer'                  => 'xmailer',
                'x-no-archive'              => 'xnoarchive',
                'content-type'              => 'contenttype',
                'content-transfer-encoding' => 'contentencoding',
                'cancel-lock'               => 'cancellock',
                'injection-info'            => 'injectioninfo',
                'x-trace'                   => 'xtrace',
                'nntp-posting-host'         => 'postinghost');

# define field list for database
my @DBFields = qw/day mid refs date path newsgroups fupto from_ from_parsed
                 from_name from_address sender sender_parsed sender_name
                 sender_address replyto replyto_parsed replyto_name
                 replyto_address subject subject_parsed organization linecount
                 approved supersedes expires useragent xnewsreader xmailer
                 xnoarchive contenttype contentencoding cancellock injectioninfo
                 xtrace postinghost headers disregard/;

################################# Main program #################################

### read commandline options
my ($OptDay,$OptDebug,$OptParseDB,$OptRawDB,$OptTest,$OptConfFile);
GetOptions ('d|day=s'         => \$OptDay,
            'debug!'          => \$OptDebug,
            'parsedb=s'       => \$OptParseDB,
            'rawdb=s'         => \$OptRawDB,
            't|test!'         => \$OptTest,
            'conffile=s'      => \$OptConfFile,
            'h|help'          => \&ShowPOD,
            'V|version'       => \&ShowVersion) or exit 1;

### read configuration
my %Conf = %{ReadConfig($OptConfFile)};

### override configuration via commandline options
my %ConfOverride;
$ConfOverride{'DBTableRaw'}   = $OptRawDB if $OptRawDB;
$ConfOverride{'DBTableParse'} = $OptParseDB if $OptParseDB;
&OverrideConfig(\%Conf,\%ConfOverride);

### get time period
### and set $Period for output and expression for SQL 'WHERE' clause
my ($Period,$SQLWherePeriod) = &GetTimePeriod($OptDay,'day');
# bail out if --month is invalid or "all"
&Bleat(2,"--day option has an invalid format - please use 'YYYY-MM-DD' or ".
         "'YYYY-MM-DD:YYYY-MM-DD'!") if (!$Period or $Period eq 'all time');

### init database
my $DBHandle = InitDB(\%Conf,1);

### get & write data
&Bleat(1,'Test mode. Database is not updated.') if $OptTest;

# create $SQLWhereClause
my $SQLWhereClause = SQLBuildClause('where',$SQLWherePeriod,'NOT disregard');

# delete old data for current period
if (!$OptTest) {
  print "----------- Deleting old data ... -----------\n" if $OptDebug;
  my $DBQuery = $DBHandle->do(sprintf("DELETE FROM %s.%s %s",
                                     $Conf{'DBDatabase'},$Conf{'DBTableParse'},
                                     $SQLWhereClause))
      or &Bleat(2,sprintf("Can't delete old parsed data for %s from %s.%s: ".
                          "$DBI::errstr\n",$Period,
                          $Conf{'DBDatabase'},$Conf{'DBTableParse'}));
};

# read from DBTableRaw
print "-------------- Reading data ... -------------\n" if $OptDebug;
my $DBQuery = $DBHandle->prepare(sprintf("SELECT id, day, mid, peer, path, ".
                                         "newsgroups, headers, disregard ".
                                         "FROM %s.%s %s", $Conf{'DBDatabase'},
                                         $Conf{'DBTableRaw'}, $SQLWhereClause));
$DBQuery->execute()
  or &Bleat(2,sprintf("Can't get data for %s from %s.%s: ".
                      "$DBI::errstr\n",$Period,
                      $Conf{'DBDatabase'},$Conf{'DBTableRaw'}));

# set output and database connection to UTF-8
# as we're going to write decoded header contents containing UTF-8 chars
binmode(STDOUT, ":utf8");
$DBHandle->do("SET NAMES 'utf8'");

# parse data in a loop and write it out
print "-------------- Parsing data ... -------------\n" if $OptDebug;
while (my $HeadersR = $DBQuery->fetchrow_hashref) {
  my %Headers = %{$HeadersR};

  # parse $Headers{'headers'} ('headers' from DBTableRaw)
  # merge continuation lines
  # from Perl Cookbook, 1st German ed. 1999, pg. 91
  $Headers{'headers'} =~ s/\n\s+/ /g;
  # split headers in single lines
  my $OtherHeaders;
  for (split(/\n/,$Headers{'headers'})) {
    # split header lines in header name and header content
    my ($key,$value) = split(/:/,$_,2);
    $key =~ s/\s*//;
    $value =~ s/^\s*(.+)\s*$/$1/;
    # save each header, separate database fields in %Headers,
    # the rest in $OtherHeaders (but not Message-ID, Path, Peer
    # and Newsgroups as those do already exist)
    if (defined($DBFields{lc($key)})) {
      $Headers{$DBFields{lc($key)}} = $value;
    } else {
      $OtherHeaders .= sprintf("%s: %s\n",$key,$value)
        if lc($key) !~ /^(message-id|path|peer|newsgroups)$/;
    }
  }
  # replace old (now parsed) $Headers{'headers'} with remanining $OtherHeaders
  chomp($OtherHeaders);
  $Headers{'headers'} = $OtherHeaders;

  # order output for database entry: fill @SQLBindVars
  print "-------------- Next entry:\n" if $OptDebug;
  my @SQLBindVars;
  foreach (@DBFields) {
    if (defined($Headers{$_}) and $Headers{$_} ne '') {
      push (@SQLBindVars,$Headers{$_});
      printf ("FOUND: %s -> %s\n",$_,$Headers{$_}) if $OptDebug;
    } else {
      push (@SQLBindVars,undef);
    }
  }

  # write data to DBTableParse
  if (!$OptTest) {
    print "-------------- Writing data ... -------------\n" if $OptDebug;
    my $DBWrite =
       $DBHandle->prepare(sprintf("INSERT INTO %s.%s (%s) VALUES (%s)",
                                  $Conf{'DBDatabase'},
                                  $Conf{'DBTableParse'},
                                  # get field names from @DBFields
                                  join(', ',@DBFields),
                                  # create a list of '?' for each DBField
                                  join(', ',
                                       split(/ /,'? ' x scalar(@DBFields)))
                                ));
  $DBWrite->execute(@SQLBindVars)
      or &Bleat(2,sprintf("Can't write parsed data for %s to %s.%s: ".
                          "$DBI::errstr\n",$Period,
                          $Conf{'DBDatabase'},$Conf{'DBTableParse'}));
    $DBWrite->finish;
  }
};
$DBQuery->finish;

### close handles
$DBHandle->disconnect;

print "------------------- DONE! -------------------\n" if $OptDebug;
__END__

################################ Documentation #################################

=head1 NAME

parsedb - parse raw data and save it to a database

=head1 SYNOPSIS

B<parsedb> [B<-Vht>] [B<--day> I<YYYY-MM-DD> | I<YYYY-MM-DD:YYYY-MM-DD>] [B<--rawdb> I<database table>] [B<--parsedb> I<database table>] [B<--conffile> I<filename>] [B<--debug>]

=head1 REQUIREMENTS

See L<doc/README>.

=head1 DESCRIPTION

...

=head2 Configuration

...

=head1 OPTIONS

=over 3

=item B<-V>, B<--version>

Print out version and copyright information and exit.

=item B<-h>, B<--help>

Print this man page and exit.

=item B<--debug>

Output (rather much) debugging information to STDOUT while processing.

=item B<-t>, B<--test>

Do not write results to database. You should use B<--debug> in
conjunction with B<--test> ... everything else seems a bit pointless.

=item B<-d>, B<--day> I<YYYY-MM-DD[:YYYY-MM-DD]>

Set processing period to a single day in YYYY-MM-DD format or to a time
period between two days in YYYY-MM-DD:YYYY-MM-DD format (two days, separated
by a colon).

Defaults to yesterday.

=item B<--rawdb> I<table> (raw data table)

Override I<DBTableRaw> from F<newsstats.conf>.

=item B<--parsedb> I<table> (parsed data table)

Override I<DBTableParse> from F<newsstats.conf>.

=item B<--conffile> I<filename>

Load configuration from I<filename> instead of F<newsstats.conf>.

=back

=head1 INSTALLATION

See L<doc/INSTALL>.

=head1 EXAMPLES

...

=head1 FILES

=over 4

=item F<bin/parsedb.pl>

The script itself.

=item F<lib/NewsStats.pm>

Library functions for the NewsStats package.

=item F<etc/newsstats.conf>

Runtime configuration file.

=back

=head1 BUGS

Please report any bugs or feature requests to the author or use the
bug tracker at L<http://bugs.th-h.de/>!

=head1 SEE ALSO

=over 2

=item -

L<doc/README>

=item -

L<doc/INSTALL>

=back

This script is part of the B<NewsStats> package.

=head1 AUTHOR

Thomas Hochstein <thh@inter.net>

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2013 Thomas Hochstein <thh@inter.net>

This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.

=cut
Commit	Line	Data
6d72dad2 TH	1	#! /usr/bin/perl
	2	#
	3	# parsedb.pl
	4	#
	5	# This script will parse a database with raw header information
	6	# from a INN feed to a structured database.
	7	#
	8	# It is part of the NewsStats package.
	9	#
	10	# Copyright (c) 2013 Thomas Hochstein <thh@inter.net>
	11	#
	12	# It can be redistributed and/or modified under the same terms under
	13	# which Perl itself is published.
	14
	15	BEGIN {
	16	our $VERSION = "0.01";
	17	use File::Basename;
	18	# we're in .../bin, so our module is in ../lib
	19	push(@INC, dirname($0).'/../lib');
	20	}
	21	use strict;
	22	use warnings;
	23
	24	use NewsStats qw(:DEFAULT :TimePeriods :SQLHelper);
	25
	26	use DBI;
	27	use Getopt::Long qw(GetOptions);
	28	Getopt::Long::config ('bundling');
	29
	30	################################# Definitions ##################################
	31
	32	# define header names with separate database fields
	33	my %DBFields = ('date' => 'date',
	34	'references' => 'refs',
	35	'followup-to' => 'fupto',
	36	'from' => 'from_',
	37	'sender' => 'sender',
	38	'reply-to' => 'replyto',
	39	'subject' => 'subject',
	40	'organization' => 'organization',
	41	'lines' => 'linecount',
	42	'approved' => 'approved',
	43	'supersedes' => 'supersedes',
	44	'expires' => 'expires',
	45	'user-agent' => 'useragent',
	46	'x-newsreader' => 'xnewsreader',
	47	'x-mailer' => 'xmailer',
	48	'x-no-archive' => 'xnoarchive',
	49	'content-type' => 'contenttype',
	50	'content-transfer-encoding' => 'contentencoding',
	51	'cancel-lock' => 'cancellock',
	52	'injection-info' => 'injectioninfo',
	53	'x-trace' => 'xtrace',
	54	'nntp-posting-host' => 'postinghost');
	55
	56	# define field list for database
	57	my @DBFields = qw/day mid refs date path newsgroups fupto from_ from_parsed
	58	from_name from_address sender sender_parsed sender_name
	59	sender_address replyto replyto_parsed replyto_name
	60	replyto_address subject subject_parsed organization linecount
	61	approved supersedes expires useragent xnewsreader xmailer
	62	xnoarchive contenttype contentencoding cancellock injectioninfo
	63	xtrace postinghost headers disregard/;
	64
65	################################# Main program #################################
66
67	### read commandline options
68	my ($OptDay,$OptDebug,$OptParseDB,$OptRawDB,$OptTest,$OptConfFile);
69	GetOptions ('d\|day=s' => \$OptDay,
70	'debug!' => \$OptDebug,
71	'parsedb=s' => \$OptParseDB,
72	'rawdb=s' => \$OptRawDB,
73	't\|test!' => \$OptTest,
74	'conffile=s' => \$OptConfFile,
75	'h\|help' => \&ShowPOD,
76	'V\|version' => \&ShowVersion) or exit 1;
77
78	### read configuration
79	my %Conf = %{ReadConfig($OptConfFile)};
80
81	### override configuration via commandline options
82	my %ConfOverride;
83	$ConfOverride{'DBTableRaw'} = $OptRawDB if $OptRawDB;
84	$ConfOverride{'DBTableParse'} = $OptParseDB if $OptParseDB;
85	&OverrideConfig(\%Conf,\%ConfOverride);
86
87	### get time period
88	### and set $Period for output and expression for SQL 'WHERE' clause
89	my ($Period,$SQLWherePeriod) = &GetTimePeriod($OptDay,'day');
90	# bail out if --month is invalid or "all"
91	&Bleat(2,"--day option has an invalid format - please use 'YYYY-MM-DD' or ".
92	"'YYYY-MM-DD:YYYY-MM-DD'!") if (!$Period or $Period eq 'all time');
93
94	### init database
95	my $DBHandle = InitDB(\%Conf,1);
96
97	### get & write data
98	&Bleat(1,'Test mode. Database is not updated.') if $OptTest;
99
100	# create $SQLWhereClause
101	my $SQLWhereClause = SQLBuildClause('where',$SQLWherePeriod,'NOT disregard');
102
103	# delete old data for current period
104	if (!$OptTest) {
105	print "----------- Deleting old data ... -----------\n" if $OptDebug;
106	my $DBQuery = $DBHandle->do(sprintf("DELETE FROM %s.%s %s",
107	$Conf{'DBDatabase'},$Conf{'DBTableParse'},
108	$SQLWhereClause))
109	or &Bleat(2,sprintf("Can't delete old parsed data for %s from %s.%s: ".
110	"$DBI::errstr\n",$Period,
111	$Conf{'DBDatabase'},$Conf{'DBTableParse'}));
112	};
113
114	# read from DBTableRaw
115	print "-------------- Reading data ... -------------\n" if $OptDebug;
116	my $DBQuery = $DBHandle->prepare(sprintf("SELECT id, day, mid, peer, path, ".
117	"newsgroups, headers, disregard ".
118	"FROM %s.%s %s", $Conf{'DBDatabase'},
119	$Conf{'DBTableRaw'}, $SQLWhereClause));
120	$DBQuery->execute()
121	or &Bleat(2,sprintf("Can't get data for %s from %s.%s: ".
122	"$DBI::errstr\n",$Period,
123	$Conf{'DBDatabase'},$Conf{'DBTableRaw'}));
124
125	# set output and database connection to UTF-8
126	# as we're going to write decoded header contents containing UTF-8 chars
127	binmode(STDOUT, ":utf8");
128	$DBHandle->do("SET NAMES 'utf8'");
129
130	# parse data in a loop and write it out
131	print "-------------- Parsing data ... -------------\n" if $OptDebug;
132	while (my $HeadersR = $DBQuery->fetchrow_hashref) {
133	my %Headers = %{$HeadersR};
134
135	# parse $Headers{'headers'} ('headers' from DBTableRaw)
136	# merge continuation lines
137	# from Perl Cookbook, 1st German ed. 1999, pg. 91
138	$Headers{'headers'} =~ s/\n\s+/ /g;
139	# split headers in single lines
140	my $OtherHeaders;
141	for (split(/\n/,$Headers{'headers'})) {
142	# split header lines in header name and header content
143	my ($key,$value) = split(/:/,$_,2);
144	$key =~ s/\s*//;
145	$value =~ s/^\s(.+)\s$/$1/;
146	# save each header, separate database fields in %Headers,
147	# the rest in $OtherHeaders (but not Message-ID, Path, Peer
148	# and Newsgroups as those do already exist)
149	if (defined($DBFields{lc($key)})) {
150	$Headers{$DBFields{lc($key)}} = $value;
151	} else {
152	$OtherHeaders .= sprintf("%s: %s\n",$key,$value)
153	if lc($key) !~ /^(message-id\|path\|peer\|newsgroups)$/;
154	}
155	}
156	# replace old (now parsed) $Headers{'headers'} with remanining $OtherHeaders
157	chomp($OtherHeaders);
158	$Headers{'headers'} = $OtherHeaders;
159
160	# order output for database entry: fill @SQLBindVars
161	print "-------------- Next entry:\n" if $OptDebug;
162	my @SQLBindVars;
163	foreach (@DBFields) {
164	if (defined($Headers{$_}) and $Headers{$_} ne '') {
165	push (@SQLBindVars,$Headers{$_});
166	printf ("FOUND: %s -> %s\n",$_,$Headers{$_}) if $OptDebug;
167	} else {
168	push (@SQLBindVars,undef);
169	}
170	}
171
172	# write data to DBTableParse
173	if (!$OptTest) {
174	print "-------------- Writing data ... -------------\n" if $OptDebug;
175	my $DBWrite =
176	$DBHandle->prepare(sprintf("INSERT INTO %s.%s (%s) VALUES (%s)",
177	$Conf{'DBDatabase'},
178	$Conf{'DBTableParse'},
179	# get field names from @DBFields
180	join(', ',@DBFields),
181	# create a list of '?' for each DBField
182	join(', ',
183	split(/ /,'? ' x scalar(@DBFields)))
184	));
185	$DBWrite->execute(@SQLBindVars)
186	or &Bleat(2,sprintf("Can't write parsed data for %s to %s.%s: ".
187	"$DBI::errstr\n",$Period,
188	$Conf{'DBDatabase'},$Conf{'DBTableParse'}));
189	$DBWrite->finish;
190	}
191	};
192	$DBQuery->finish;
193
194	### close handles
195	$DBHandle->disconnect;
196
197	print "------------------- DONE! -------------------\n" if $OptDebug;
198	__END__
199
200	################################ Documentation #################################
201
202	=head1 NAME
203
204	parsedb - parse raw data and save it to a database
205
206	=head1 SYNOPSIS
207
208	B<parsedb> [B<-Vht>] [B<--day> I<YYYY-MM-DD> \| I<YYYY-MM-DD:YYYY-MM-DD>] [B<--rawdb> I<database table>] [B<--parsedb> I<database table>] [B<--conffile> I<filename>] [B<--debug>]
209
210	=head1 REQUIREMENTS
211
212	See L<doc/README>.
213
214	=head1 DESCRIPTION
215
216	...
217
218	=head2 Configuration
219
220	...
221
222	=head1 OPTIONS
223
224	=over 3
225
226	=item B<-V>, B<--version>
227
228	Print out version and copyright information and exit.
229
230	=item B<-h>, B<--help>
231
232	Print this man page and exit.
233
234	=item B<--debug>
235
236	Output (rather much) debugging information to STDOUT while processing.
237
238	=item B<-t>, B<--test>
239
240	Do not write results to database. You should use B<--debug> in
241	conjunction with B<--test> ... everything else seems a bit pointless.
242
243	=item B<-d>, B<--day> I<YYYY-MM-DD[:YYYY-MM-DD]>
244
245	Set processing period to a single day in YYYY-MM-DD format or to a time
246	period between two days in YYYY-MM-DD:YYYY-MM-DD format (two days, separated
247	by a colon).
248
249	Defaults to yesterday.
250
251	=item B<--rawdb> I<table> (raw data table)
252
253	Override I<DBTableRaw> from F<newsstats.conf>.
254
255	=item B<--parsedb> I<table> (parsed data table)
256
257	Override I<DBTableParse> from F<newsstats.conf>.
258
259	=item B<--conffile> I<filename>
260
261	Load configuration from I<filename> instead of F<newsstats.conf>.
262
263	=back
264
265	=head1 INSTALLATION
266
267	See L<doc/INSTALL>.
268
269	=head1 EXAMPLES
270
271	...
272
273	=head1 FILES
274
275	=over 4
276
277	=item F<bin/parsedb.pl>
278
279	The script itself.
280
281	=item F<lib/NewsStats.pm>
282
283	Library functions for the NewsStats package.
284
285	=item F<etc/newsstats.conf>
286
287	Runtime configuration file.
288
289	=back
290
291	=head1 BUGS
292
293	Please report any bugs or feature requests to the author or use the
294	bug tracker at L<http://bugs.th-h.de/>!
295
296	=head1 SEE ALSO
297
298	=over 2
299
300	=item -
301
302	L<doc/README>
303
304	=item -
305
306	L<doc/INSTALL>
307
308	=back
309
310	This script is part of the B<NewsStats> package.
311
312	=head1 AUTHOR
313
314	Thomas Hochstein <thh@inter.net>
315
316	=head1 COPYRIGHT AND LICENSE
317
318	Copyright (c) 2013 Thomas Hochstein <thh@inter.net>
319
320	This program is free software; you may redistribute it and/or modify it
321	under the same terms as Perl itself.
322
323	=cut