source: trunk/lib/OpenGuides/Utils.pm @ 1240

Last change on this file since 1240 was 1240, checked in by Dominic Hargreaves, 13 years ago

Add the ability to whitelist hosts who can change moderated nodes
without explicit moderation - thanks Oliver (fixes #203)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.6 KB
Line 
1package OpenGuides::Utils;
2
3use strict;
4use vars qw( $VERSION );
5$VERSION = '0.11';
6
7use Carp qw( croak );
8use Wiki::Toolkit;
9use Wiki::Toolkit::Formatter::UseMod;
10use Wiki::Toolkit::Plugin::RSS::Reader;
11use URI::Escape;
12use MIME::Lite;
13use Net::Netmask;
14use List::Util qw( first );
15use Data::Validate::URI qw( is_web_uri );
16
17=head1 NAME
18
19OpenGuides::Utils - General utility methods for OpenGuides scripts.
20
21=head1 DESCRIPTION
22
23Provides general utility methods for OpenGuides scripts.  Distributed
24and installed as part of the OpenGuides project, not intended for
25independent installation.  This documentation is probably only useful
26to OpenGuides developers.
27
28=head1 SYNOPSIS
29
30  use OpenGuide::Config;
31  use OpenGuides::Utils;
32
33  my $config = OpenGuides::Config->new( file => "wiki.conf" );
34  my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );
35
36=head1 METHODS
37
38=over 4
39
40=item B<make_wiki_object>
41
42  my $config = OpenGuides::Config->new( file => "wiki.conf" );
43  my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );
44
45Croaks unless an C<OpenGuides::Config> object is supplied.  Returns a
46C<Wiki::Toolkit> object made from the given config file on success,
47croaks if any other error occurs.
48
49The config file needs to define at least the following variables:
50
51=over
52
53=item *
54
55dbtype - one of C<postgres>, C<mysql> and C<sqlite>
56
57=item *
58
59dbname
60
61=item *
62
63indexing_directory - for the L<Search::InvertedIndex> or L<Plucene> files to go
64
65=back
66
67=cut
68
69sub make_wiki_object {
70    my ($class, %args) = @_;
71    my $config = $args{config} or croak "No config param supplied";
72    croak "config param isn't an OpenGuides::Config object"
73        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
74
75    # Require in the right database module.
76    my $dbtype = $config->dbtype;
77
78    my %wiki_toolkit_exts = (
79                          postgres => "Pg",
80                          mysql    => "MySQL",
81                          sqlite   => "SQLite",
82                        );
83
84    my $wiki_toolkit_module = "Wiki::Toolkit::Store::" . $wiki_toolkit_exts{$dbtype};
85    eval "require $wiki_toolkit_module";
86    croak "Can't 'require' $wiki_toolkit_module.\n" if $@;
87
88    # Make store.
89    my $store = $wiki_toolkit_module->new(
90        dbname  => $config->dbname,
91        dbuser  => $config->dbuser,
92        dbpass  => $config->dbpass,
93        dbhost  => $config->dbhost,
94        dbport  => $config->dbport,
95        charset => $config->dbencoding,
96    );
97
98    # Make search.
99    my $search;
100    if ( $config->use_plucene
101         && ( lc($config->use_plucene) eq "y"
102              || $config->use_plucene == 1 )
103       ) {
104        require Wiki::Toolkit::Search::Plucene;
105        $search = Wiki::Toolkit::Search::Plucene->new(
106                                       path => $config->indexing_directory,
107                                                 );
108    } else {
109        require Wiki::Toolkit::Search::SII;
110        require Search::InvertedIndex::DB::DB_File_SplitHash;
111        my $indexdb = Search::InvertedIndex::DB::DB_File_SplitHash->new(
112            -map_name  => $config->indexing_directory,
113            -lock_mode => "EX"
114        );
115        $search = Wiki::Toolkit::Search::SII->new( indexdb => $indexdb );
116    }
117
118    # Make formatter.
119    my $script_name = $config->script_name;
120    my $search_url = $config->script_url . "search.cgi";
121
122    my %macros = (
123        '@SEARCHBOX' =>
124            qq(<form action="$search_url" method="get"><input type="text" size="20" name="search"><input type="submit" name="Go" value="Search"></form>),
125        qr/\@INDEX_LINK\s+\[\[(Category|Locale)\s+([^\]|]+)\|?([^\]]+)?\]\]/ =>
126            sub {
127                  # We may be being called by Wiki::Toolkit::Plugin::Diff,
128                  # which doesn't know it has to pass us $wiki - and
129                  # we don't use it anyway.
130                  if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
131                      shift; # just throw it away
132                  }
133                  my $link_title = $_[2] || "View all pages in $_[0] $_[1]";
134                  return qq(<a href="$script_name?action=index;index_type=) . uri_escape(lc($_[0])) . qq(;index_value=) . uri_escape($_[1]) . qq(">$link_title</a>);
135                },
136        qr/\@INDEX_LIST\s+\[\[(Category|Locale)\s+([^\]]+)]]/ =>
137             sub {
138                   my ($wiki, $type, $value) = @_;
139
140                   # We may be being called by Wiki::Toolkit::Plugin::Diff,
141                   # which doesn't know it has to pass us $wiki
142                   unless ( UNIVERSAL::isa( $wiki, "Wiki::Toolkit" ) ) {
143                       return "(unprocessed INDEX_LIST macro)";
144                   }
145
146                   my @nodes = sort $wiki->list_nodes_by_metadata(
147                       metadata_type  => $type,
148                       metadata_value => $value,
149                       ignore_case    => 1,
150                   );
151                   unless ( scalar @nodes ) {
152                       return "\n* No pages currently in "
153                              . lc($type) . " $value\n";
154                   }
155                   my $return = "\n";
156                   foreach my $node ( @nodes ) {
157                       $return .= "* "
158                               . $wiki->formatter->format_link(
159                                                                wiki => $wiki,
160                                                                link => $node,
161                                                              )
162                                . "\n";
163                   }
164                   return $return;
165                 },
166        qr/\@MAP_LINK\s+\[\[(Category|Locale)\s+([^\]|]+)\|?([^\]]+)?\]\]/ =>
167                sub {
168                      if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
169                          shift; # don't need $wiki
170                      }
171                      my $link_title = $_[2]
172                                       || "View map of pages in $_[0] $_[1]";
173                      return qq(<a href="$script_name?action=index;format=map;index_type=) . uri_escape(lc($_[0])) . qq(;index_value=) . uri_escape($_[1]) . qq(">$link_title</a>);
174                },
175        qr/\@RANDOM_PAGE_LINK(?:\s+\[\[(Category|Locale)\s+([^\]|]+)\|?([^\]]+)?\]\])?/ =>
176                sub {
177                      if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
178                          shift; # don't need $wiki
179                      }
180                      my ( $type, $value, $link_title ) = @_;
181                      my $link = "$script_name?action=random";
182
183                      if ( $type && $value ) {
184                          $link .= ";" . lc( uri_escape( $type ) ) . "="
185                                . lc( uri_escape( $value ) );
186                          $link_title ||= "View a random page in $type $value";
187                      } else {
188                          $link_title ||= "View a random page on this guide";
189                      }
190                      return qq(<a href="$link">$link_title</a>);
191                },
192        qr/\@INCLUDE_NODE\s+\[\[([^\]|]+)\]\]/ => 
193            sub {
194                  my ($wiki, $node) = @_;
195                  my %node_data = $wiki->retrieve_node( $node );
196                  return $node_data{content};
197                },
198        qr/\@RSS\s+(.+)/ => sub {
199                    # We may be being called by Wiki::Toolkit::Plugin::Diff,
200                    # which doesn't know it has to pass us $wiki - and
201                    # we don't use it anyway.
202                    if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
203                        shift; # just throw it away
204                    }
205
206                    my $url = shift;
207
208                    # The URL will already have been processed as an inline
209                    # link, so transform it back again.
210                    if ( $url =~ m/href="([^"]+)/ ) {
211                        $url = $1;
212                    }
213
214                    my $rss = Wiki::Toolkit::Plugin::RSS::Reader->new(url => $url);
215                    my @items = $rss->retrieve;
216
217                    # Ten items only at this till.
218                    $#items = 10 if $#items > 10;
219
220                    # Make a UseMod-formatted list with them - macros are
221                    # processed *before* UseMod formatting is applied but
222                    # *after* inline links like [http://foo/ bar]
223                    my $list = "\n";
224                    foreach (@items) {
225                        my $link        = $_->{link};
226                        my $title       = $_->{title};
227                        my $description = $_->{description};
228                        $list .= qq{* <a href="$link">$title</a>};
229                        $list .= " - $description" if $description;
230                        $list .= "\n";
231                    }
232                    $list .= "</ul>\n";
233        },
234    );
235
236    my $formatter = Wiki::Toolkit::Formatter::UseMod->new(
237        extended_links      => 1,
238        implicit_links      => 0,
239        allowed_tags        => [qw(a p b strong i em pre small img table td
240                                   tr th br hr ul li center blockquote kbd
241                                   div code strike sub sup font)],
242        macros              => \%macros,
243        pass_wiki_to_macros => 1,
244        node_prefix         => "$script_name?",
245        edit_prefix         => "$script_name?action=edit;id=",
246        munge_urls          => 1,
247    );
248
249    my %conf = ( store     => $store,
250                 search    => $search,
251                 formatter => $formatter );
252
253    my $wiki = Wiki::Toolkit->new( %conf );
254    return $wiki;
255}
256
257=item B<get_wgs84_coords>
258
259Returns coordinate data suitable for use with Google Maps (and other GIS
260systems that assume WGS-84 data).
261
262    my ($wgs84_long, $wgs84_lat) = OpenGuides::Utils->get_wgs84_coords(
263                                        longitude => $longitude,
264                                        latitude => $latitude,
265                                        config => $config
266                                   );
267
268=cut
269
270sub get_wgs84_coords {
271    my ($self, %args) = @_;
272    my ($longitude, $latitude, $config) = ($args{longitude}, $args{latitude},
273                                           $args{config})
274       or croak "No longitude supplied to get_wgs84_coords";
275    croak "geo_handler not defined!" unless $config->geo_handler;
276
277    if ($config->force_wgs84) {
278        # Only as a rough approximation, good enough for large scale guides
279        return ($longitude, $latitude);
280    }
281
282    # If we don't have a lat and long, return undef right away
283    unless($args{longitude} || $args{latitude}) {
284        return undef;
285    }
286
287    # Try to load a provider of Helmert Transforms
288    my $helmert;
289    # First up, try the MySociety Geo::HelmertTransform
290    unless($helmert) {
291        eval {
292            require Geo::HelmertTransform;
293            $helmert = sub($$$) {
294                my ($datum,$oldlat,$oldlong) = @_;
295                if ($datum eq 'Airy') {
296                    $datum = 'Airy1830';
297                }
298                my $datum_helper = new Geo::HelmertTransform::Datum(Name=>$datum);
299                my $wgs84_helper = new Geo::HelmertTransform::Datum(Name=>'WGS84');
300                unless($datum_helper) {
301                    croak("No convertion helper for datum '$datum'");
302                    return undef;
303                }
304
305                my ($lat,$long,$h) = 
306                    Geo::HelmertTransform::convert_datum($datum_helper,$wgs84_helper,$oldlat,$oldlong,0);
307                return ($long,$lat);
308            };
309        };
310    }
311    # Give up, return undef
312    unless($helmert) {
313       return undef; 
314    }
315   
316
317    if ($config->geo_handler == 1) {
318        # Do conversion here
319        return &$helmert('Airy1830',$latitude,$longitude);
320    } elsif ($config->geo_handler == 2) {
321        # Do conversion here
322        return &$helmert('Airy1830Modified',$latitude,$longitude);
323    } elsif ($config->geo_handler == 3) {
324        if ($config->ellipsoid eq "WGS-84") {
325            return ($longitude, $latitude);
326        } else {
327            # Do conversion here
328            return &$helmert($config->ellipsoid,$latitude,$longitude);
329        }
330    } else {
331        croak "Invalid geo_handler config option $config->geo_handler";
332    }
333}
334
335=item B<detect_redirect>
336
337    $redir = OpenGuides::Utils->detect_redirect( content => "foo" );
338
339Checks the content of a node to see if the node is a redirect to another
340node.  If so, returns the name of the node that this one redirects to.  If
341not, returns false.
342
343(Also returns false if no content is provided.)
344
345=cut
346
347sub detect_redirect {
348    my ( $self, %args ) = @_;
349    return unless $args{content};
350
351    if ( $args{content} =~ /^#REDIRECT\s+(.+?)\s*$/ ) {
352        my $redirect = $1;
353
354        # Strip off enclosing [[ ]] in case this is an extended link.
355        $redirect =~ s/^\[\[//;
356        $redirect =~ s/\]\]\s*$//;
357
358        return $redirect;
359    }
360}
361
362=item B<validate_edit>
363
364    my $fails = OpenGuides::Utils->validate_edit(
365        id       => $node,
366        cgi_obj  => $q
367    );
368
369Checks supplied content for general validity. If anything is invalid,
370returns an array ref of errors to report to the user.
371
372=cut
373
374sub validate_edit {
375    my ( $self, %args ) = @_;
376    my $q = $args{cgi_obj};
377    my @fails;
378    push @fails, "Content missing" unless $q;
379    return \@fails if @fails;
380
381    # Now do our real validation
382    foreach my $var (qw(os_x os_y)) {
383        if ($q->param($var) and $q->param($var) !~ /^-?\d+$/) {
384            push @fails, "$var must be integer, was: " . $q->param($var);
385        }
386    }
387
388    foreach my $var (qw(latitude longitude)) {
389        if ($q->param($var) and $q->param($var) !~ /^-?\d+\.?(\d+)?$/) {
390            push @fails, "$var must be numeric, was: " . $q->param($var);
391        }
392    }
393
394    if ( $q->param('website') and $q->param('website') ne 'http://' ) {
395        unless ( is_web_uri( $q->param('website') ) ) {
396            push @fails, $q->param('website') . ' is not a valid web URI';
397        }
398    }
399
400    return \@fails;
401
402};
403
404=item B<parse_change_comment>
405
406    my $change_comment = parse_change_comment($string, $base_url);
407   
408Given a base URL (for example, C<http://example.com/wiki.cgi?>), takes a string,
409replaces C<[[page]]> and C<[[page|titled link]]> with
410
411    <a href="http://example.com/wiki.cgi?page">page</a>
412
413and
414
415    <a href="http://example.com/wiki.cgi?page">titled link</a>
416
417respectively, and returns it. This is a limited subset of wiki markup suitable for
418use in page change comments.
419
420=cut
421
422sub parse_change_comment {   
423    my ($comment, $base_url) = @_;
424
425    my @links = $comment =~ m{\[\[(.*?)\]\]}g;
426
427    # It's not all that great having to reinvent the wheel in this way, but
428    # Text::WikiFormat won't let you specify the subset of wiki notation that
429    # you're interested in. C'est la vie.
430    foreach (@links) {
431        if (/(.*?)\|(.*)/) {
432            my ($page, $title) = ($1, $2);
433            $comment =~ s{\[\[$page\|$title\]\]}
434                         {<a href="$base_url$page">$title</a>};
435        } else {
436            my $page = $_;
437            $comment =~ s{\[\[$page\]\]}
438                         {<a href="$base_url$page">$page</a>};
439        }
440    }
441
442    return $comment;
443}
444
445=item B<send_email>
446
447    eval { OpenGuides::Utils->send_email(
448            config        => $config,
449            subject       => "Subject",
450            body          => "Test body",
451            admin         => 1,
452            nobcc         => 1,
453            return_output => 1
454    ) };
455
456    if ($@) {
457        print "Error mailing admin: $@\n";
458    } else {
459        print "Mailed admin\n";
460    }
461
462Send out email. If C<admin> is true, the email will be sent to the site
463admin. If C<to> is defined, email will be sent to addresses in that
464arrayref. If C<nobcc> is true, there will be no Bcc to the admin.
465
466C<subject> and C<body> are mandatory arguments.
467
468Debugging: if C<return_output> is true, the message will be returned as
469a string instead of being sent by email.
470
471=cut
472
473
474sub send_email {
475    my ( $self, %args ) = @_;
476    my $config = $args{config} or die "config argument not supplied";
477    my @to;
478    @to = @{$args{to}} if $args{to};
479    my @bcc;
480    push @to, $config->contact_email if $args{admin};
481    die "No recipients specified" unless $to[0];
482    die "No subject specified" unless $args{subject};
483    die "No body specified" unless $args{body};
484    my $to_str = join ',', @to;
485    push @bcc, $config->contact_email unless $args{nobcc};
486    my $bcc_str = join ',', @bcc;
487    my $msg = MIME::Lite->new(
488        From    => $config->contact_email,
489        To      => $to_str,
490        Bcc     => $bcc_str,
491        Subject => $args{subject},
492        Data    => $args{body}
493    );
494
495    if ( $args{return_output} ) {
496        return $msg->as_string;
497    } else {
498        $msg->send or die "Couldn't send mail!";
499    }
500}
501
502=item B<in_moderate_whitelist>
503
504 if (OpenGuides::Utils->in_moderate_whitelist( '127.0.0.1' )) {
505     # skip moderation and apply new verson to published site
506 }
507
508Admins can supply a comma separated list of IP addresses or CIDR-notation
509subnets indicating the hosts which can bypass enforced moderation. Any
510values which cannot be parsed by C<NetAddr::IP> will be ignored.
511
512=cut
513
514sub in_moderate_whitelist {
515    my ($self, $config, $ip) = @_;
516    return undef if not defined $ip;
517
518    # create NetAddr::IP object of the test IP
519    my $addr = Net::Netmask->new2($ip) or return undef;
520
521    # load the configured whitelist
522    my @whitelist
523        = split ',', $config->moderate_whitelist;
524
525    # test each entry in the whitelist
526    return eval{
527        first { Net::Netmask->new2($_)->match($addr->base) } @whitelist
528    };
529}
530
531=back
532
533=head1 AUTHOR
534
535The OpenGuides Project (openguides-dev@lists.openguides.org)
536
537=head1 COPYRIGHT
538
539     Copyright (C) 2003-2008 The OpenGuides Project.  All Rights Reserved.
540
541This module is free software; you can redistribute it and/or modify it
542under the same terms as Perl itself.
543
544=cut
545
5461;
Note: See TracBrowser for help on using the repository browser.