lib/BackPAN/Web.pm

   1 package BackPAN::Web;
   2
   3 use Web::Simple __PACKAGE__;
   4 use Plack::Request;
   5 use Plack::Builder;
   6 use Plack::Util;
   7 use HTML::Zoom;
   8 use HTML::Zoom::FilterBuilder::Template;
   9 use BackPAN::Index;
  10 use Data::Page;
  11 use Data::Page::FlickrLike;
  12 use File::stat;
  13 use DateTime;
  14 use Log::Log4perl 'get_logger';
  15
  16 our $VERSION = '0.13';
  17
  18 default_config(
  19     template_dir => 'root/html',
  20     backpan_url => 'http://backpan.perl.org/',
  21     cpan_search_url => 'http://search.cpan.org/',
  22 );
  23
  24 sub _build_request_obj_from {
  25     my ( $self, $env ) = @_;
  26     return $self->request(Plack::Request->new($env));
  27 }
  28
  29 sub request {
  30     my $self = shift;
  31     $self->{'request'} = shift if @_;
  32     return $self->{'request'};
  33 }
  34
  35 sub req { return shift->request(@_) }
  36
  37 sub log {
  38     my ( $self, $level, $msg ) = @_;
  39     chomp $msg;
  40     $self->request->{'env'}->{'psgix.logger'}->({
  41         level => $level,
  42         message => $msg,
  43     });
  44 }
  45
  46 sub backpan_index {
  47     return $_[0]->{'backpan_index'} ||= BackPAN::Index->new({
  48         update => 0,
  49         debug => 0,
  50         cache_dir => 'index',
  51         releases_only_from_authors => 1,
  52     });
  53 }
  54
  55 sub slurp {
  56     my ( $self, $filename ) = @_;
  57     return do { local (@ARGV, $/) = $filename; <> };
  58 }
  59
  60 sub template_filename_for {
  61     my ( $self, $name ) = @_;
  62     return $self->config->{'template_dir'} . "/${name}.html";
  63 }
  64
  65 sub layout_zoom {
  66     my $self = shift;
  67     return $self->{'template_zoom_for_template'}{'layout'} ||= HTML::Zoom->from_file(
  68         $self->template_filename_for('layout')
  69     );
  70 }
  71
  72 sub template_zoom_for {
  73     my ( $self, $template_name ) = @_;
  74     $self->{'template_zoom_for_template'}{$template_name} ||= do {
  75         my @body;
  76         HTML::Zoom->from_file(
  77             $self->template_filename_for($template_name)
  78         )->select('#content')->collect_content({ into => \@body })->run;
  79         $self->layout_zoom
  80         ->select('#content')->replace_content(\@body)
  81         ->memoize;
  82     };
  83 }
  84
  85 sub error_404 {
  86     my $self = shift;
  87     return $self->slurp( $self->template_filename_for('error_404') );
  88 }
  89
  90 sub html_response {
  91     my ( $self, $args ) = @_;
  92     my ( $status, $header, $body ) = @$args{qw/status_code header body/};
  93     return [ $status || 200, [
  94         $header ? ( %$header ) : (),
  95         'Content-type' => 'text/html',
  96     ], ref $body ? $body->to_fh : [ $body ] ];
  97 }
  98
  99 sub add_listing {
 100     my ( $self, $resultset, $row_data_cb ) = @_;
 101     my $req_base = $self->req->base;
 102     my $i = 1;
 103     return sub {
 104         $_->select('.main-list')
 105         ->repeat_content([
 106             map { my $row = $_;
 107                 my ( $name, $label, $href ) = $self->$row_data_cb($row);
 108                 sub {
 109                     my $zoom = $_;
 110                     $zoom = $zoom->select('li')->add_to_attribute(class => 'even')
 111                         if $i++ % 2 == 0;
 112                     if ( $href =~ m/http/i ) {
 113                         $zoom = $zoom->select('a')->add_to_attribute(href => $href)
 114                             ->then
 115                             ->add_to_attribute(target => '_blank')
 116                             ->then;
 117                     }
 118                     else {
 119                         $zoom = $zoom->select('a')->add_to_attribute(
 120                             href => $req_base . "${href}/${name}/"
 121                         )->then;
 122                     }
 123                     $zoom->replace_content($label);
 124                 }
 125             } ( ref $resultset eq 'ARRAY' ? @$resultset : $resultset->all )
 126         ]);
 127     };
 128 }
 129
 130 sub add_paging_ordering {
 131     my ( $self, $pager, $ordering_options ) = @_;
 132     return sub {
 133         $_->apply($self->add_paging($pager))
 134         ->apply($self->add_ordering($ordering_options));
 135     };
 136 }
 137
 138 sub add_paging {
 139     my ( $self, $pager ) = @_;
 140     my ( $curr_page, $curr_page_size )
 141         = ( $pager->current_page, $pager->entries_per_page );
 142     my $paging_uri = $self->req->uri;
 143     return sub {
 144         $_->select('#pages')
 145         ->repeat_content([
 146             map { my $page_number = $_;
 147                 $page_number == 0 ?
 148                     sub {
 149                         $_->select('span')->replace_content('...');
 150                     }
 151                     : sub {
 152                         $paging_uri->query_form({
 153                             $paging_uri->query_form,
 154                             page => $page_number,
 155                             rows => $curr_page_size,
 156                         });
 157                         $_->select('a')->add_to_attribute(href => $paging_uri)
 158                           ->then
 159                           ->replace_content($page_number);
 160                     }
 161             } $pager->navigations
 162         ])
 163         ->select('.paging-desc')
 164         ->replace_content(
 165             join(q{ }, 'Page', $curr_page, 'of', $pager->last_page) . q{.}
 166         )
 167         ->select('.entries')
 168         ->replace_content($pager->total_entries . ' entries.')
 169         ->select('.page-size-options')
 170         ->repeat_content([
 171             map {
 172                 my $page_size = $_; sub {
 173                     $paging_uri->query_form({
 174                         $paging_uri->query_form,
 175                         page => $curr_page,
 176                         rows => $page_size,
 177                     });
 178                     $_->select('a')->add_to_attribute(href => $paging_uri)
 179                       ->then
 180                       ->replace_content($page_size);
 181                 }
 182             } qw/10 20 30 50 100 200/
 183         ]);
 184     };
 185 }
 186
 187 sub add_ordering {
 188     my ( $self, $options ) = @_;
 189     my $ordering_uri = $self->req->uri;
 190     return sub {
 191         $_->select('.ordering-options')
 192         ->repeat_content([
 193             map { my $order_by = $_; sub {
 194                     $ordering_uri->query_form({
 195                         $ordering_uri->query_form,
 196                         order_by => $order_by,
 197                     });
 198                     my $order_by_label = join(q{ }, map ucfirst, split(/\_/, $order_by));
 199                     $_->select('a')->add_to_attribute(href => $ordering_uri)
 200                       ->then
 201                       ->replace_content($order_by_label);
 202                 }
 203             } @$options
 204         ]);
 205     };
 206 }
 207
 208 sub index_page_content {
 209     my $self = shift;
 210     return $self->template_zoom_for('index')
 211         ->apply($self->add_listing(scalar $self->releases, sub {
 212             return ((map { $_[1]->$_ } qw/dist distvname/), 'distribution');
 213         }));
 214 }
 215
 216 sub validate_paging_params {
 217     my ( $self, $args ) = @_;
 218     my ( $page, $rows ) = @$args{qw/page rows/};
 219     $page = 1 unless $page && $page =~ /^\d+$/;
 220     $rows = 25 unless $rows && $rows =~ /^\d+$/;
 221     return ( $page, $rows );
 222 }
 223
 224 sub releases {
 225     my ( $self, $args ) = @_;
 226     my ( $order_by, $page, $rows )
 227         = ( $args->{'order_by'}, $self->validate_paging_params($args) );
 228     return $self->backpan_index->releases->search({}, {
 229         order_by => { -desc => 'date' },
 230         page => $page,
 231         rows => $rows,
 232     });
 233 }
 234
 235 sub releases_page_content {
 236     my ( $self, $release_rs ) = @_;
 237     return $self->template_zoom_for('listing')
 238         ->apply($self->add_listing($release_rs, sub {
 239             return ((map { $_[1]->$_ } qw/dist distvname/), 'distribution');
 240         }))
 241         ->apply($self->add_paging($release_rs->pager));
 242 }
 243
 244 sub dists {
 245     my ( $self, $args ) = @_;
 246     my ( $order_by, $page, $rows )
 247         = ( $args->{'order_by'}, $self->validate_paging_params($args) );
 248     return $self->backpan_index->dists->search({}, {
 249         order_by => 'name',
 250         page => $page,
 251         rows => $rows,
 252     });
 253 }
 254
 255 sub get_dist { return shift->backpan_index->dist(@_) }
 256
 257 sub format_dist_name { return join(q{::}, split /-/, $_[1] ) }
 258
 259 sub dists_page_content {
 260     my ( $self, $dist_rs ) = @_;
 261     return $self->template_zoom_for('listing')
 262         ->apply($self->add_listing($dist_rs, sub {
 263             my $dist_name = $_[1]->name;
 264             return (
 265                 $dist_name, $self->format_dist_name($dist_name), 'distribution'
 266             );
 267         }))
 268         ->apply($self->add_paging($dist_rs->pager));
 269 }
 270
 271 sub dist_info_page_content {
 272     my ( $self, $dist, $query_params ) = @_;
 273     my ( $page, $rows ) = $self->validate_paging_params($query_params);
 274     my $release_rs = $dist->releases->search({}, {
 275         order_by => { -desc => 'date' },
 276         page => $page,
 277         rows => $rows,
 278     });
 279     my ( $f_release, $l_release )
 280         = ( $dist->first_release, $dist->latest_release );
 281     my @maints = $dist->authors;
 282     my $config = $self->config;
 283     my ( $backpan_url, $cpan_search_url )
 284         = ( $config->{'backpan_url'}, $config->{'cpan_search_url'} );
 285     return $self->template_zoom_for('dist')
 286         ->select('#dist')->template_text_raw({
 287             name => $self->format_dist_name($dist->name),
 288             num_releases => $dist->num_releases,
 289             f_release_label => $f_release->distvname,
 290             l_release_label => $l_release->distvname,
 291         })
 292         ->select('.f_rel_link')->add_to_attribute(
 293             href => $backpan_url . $f_release->path->path,
 294         )
 295         ->select('.l_rel_link')->add_to_attribute(
 296             href => $backpan_url . $l_release->path->path,
 297         )
 298         ->select('.maintainer-list')->repeat_content([
 299             map { my $cpanid = $_; sub {
 300                     $_->select('a')->add_to_attribute(
 301                         href => $cpan_search_url . lc "~${cpanid}"
 302                     )->then
 303                     ->add_to_attribute(target => '_blank')
 304                     ->then
 305                     ->replace_content($cpanid);
 306                 }
 307             } @maints
 308         ])
 309         ->apply($self->add_listing($release_rs, sub {
 310             my $release = $_;
 311             return (
 312                 $release->distvname,
 313                 join(q{ | }, $release->distvname,
 314                     DateTime->from_epoch({ epoch => $release->date })
 315                         ->strftime('%b %d, %Y - %T')),
 316                 $backpan_url . $release->path->path,
 317             );
 318         }))
 319         ->apply($self->add_paging($release_rs->pager));
 320 }
 321
 322 sub authors {
 323     my ( $self, $args ) = @_;
 324     my ( $page, $rows ) = $self->validate_paging_params($args);
 325     my @authors = $self->backpan_index->releases->search({}, {
 326         group_by => 'cpanid',
 327         order_by => 'cpanid',
 328     })->get_column('cpanid')->all;
 329     my $pager = Data::Page->new;
 330     $pager->total_entries(scalar @authors);
 331     $pager->entries_per_page($rows);
 332     if ( $page > $pager->last_page ) {
 333         return undef;
 334     }
 335     else {
 336         $pager->current_page($page);
 337         return {
 338             list => [ splice @authors, ($page-1) * $rows, $rows ],
 339             pager => $pager,
 340         };
 341     }
 342 }
 343
 344 sub authors_page_content {
 345     my ( $self, $authors ) = @_;
 346     return $self->template_zoom_for('listing')
 347         ->apply($self->add_listing($authors->{'list'}, sub {
 348             my $cpanid = $_[1];
 349             return (
 350                 $cpanid, $cpanid,
 351                 $self->config->{'cpan_search_url'} . lc "~${cpanid}"
 352             );
 353         }))
 354         ->apply($self->add_paging($authors->{'pager'}));
 355 }
 356
 357 sub _mangle_query_string {
 358     my ( $self, $q ) = @_;
 359     $q =~ s{\s+|::|\+}{-}g;
 360     $q =~ s{-$}{};
 361     return $q =~ s{\*}{}g ? "$q%" : "%$q%";
 362 }
 363
 364 sub search {
 365     my ( $self, $q, $query_params ) = @_;
 366     my $query_str = lc $self->_mangle_query_string($q);
 367     return $self->dists($query_params)->search({
 368         -or => [
 369             { 'LOWER(me.name)' => { -like => $query_str } },
 370             { 'LOWER(me.first_author)' => { -like => $query_str } },
 371             { 'LOWER(me.latest_author)' => { -like => $query_str } },
 372         ],
 373     });
 374 }
 375
 376 dispatch {
 377     subdispatch sub () {
 378         $self->_build_request_obj_from($_[+PSGI_ENV]);
 379         [
 380             sub (/) {
 381                 $self->html_response({ body => $self->index_page_content });
 382             },
 383
 384             sub ( /about|/about/ ) {
 385                 my $about_filename = $self->template_filename_for('about');
 386                 my $about_st = stat($about_filename)
 387                     or $self->log(error_die => "No $about_filename: $!");
 388                 $self->html_response({
 389                     header => {
 390                         'Last-Modified' => $about_st->mtime,
 391                     },
 392                     body => $self->slurp($about_filename),
 393                 });
 394             },
 395
 396             sub ( /releases|/releases/ + ?* ) {
 397                 my $release_rs = $self->releases($_[1]);
 398                 if ( $release_rs->count ) {
 399                     my $body = $self->releases_page_content($release_rs)
 400                         ->select('#nav-releases')->add_to_attribute(class => 'active');
 401                     return $self->html_response({ body => $body });
 402                 }
 403                 else {
 404                     return $self->html_response({
 405                         status_code => 404,
 406                         body => $self->error_404,
 407                     });
 408                 }
 409             },
 410
 411             sub ( /dists|/dists/ + ?* ) {
 412                 my $dist_rs = $self->dists($_[1]);
 413                 if ( $dist_rs->count ) {
 414                     my $body = $self->dists_page_content($dist_rs)
 415                         ->select('#nav-dists')->add_to_attribute(class => 'active');
 416                     return $self->html_response({ body => $body });
 417                 }
 418                 else {
 419                     return $self->html_response({
 420                         status_code => 404,
 421                         body => $self->error_404,
 422                     });
 423                 }
 424             },
 425
 426             sub ( /distribution/*|/distribution/*/ + ?* ) {
 427                 if ( my $dist = $self->get_dist($_[1]) ) {
 428                     my $body = $self->dist_info_page_content($dist, $_[2]);
 429                     return $self->html_response({ body => $body });
 430                 }
 431                 else {
 432                     return $self->html_response({
 433                         status_code => 404,
 434                         body => $self->error_404,
 435                     });
 436                 }
 437             },
 438
 439             sub ( /authors|/authors/ + ?* ) {
 440                 if ( my $authors = $self->authors($_[1]) ) {
 441                     my $body = $self->authors_page_content($authors)
 442                         ->select('#nav-authors')->add_to_attribute(class => 'active');
 443                     return $self->html_response({ body => $body });
 444                 }
 445                 else {
 446                     return $self->html_response({
 447                         status_code => 404,
 448                         body => $self->error_404,
 449                     });
 450                 }
 451             },
 452
 453             sub ( /search|/search/ + ?q=&* ) {
 454                 my ( $self, $query_str, $query_params ) = @_;
 455                 my $dist_rs = $self->search($query_str, $query_params);
 456                 if ( $dist_rs->count ) {
 457                     my $body = $self->dists_page_content($dist_rs)
 458                         ->select('#q')->add_to_attribute(
 459                             value => $query_str
 460                         );
 461                     return $self->html_response({ body => $body });
 462                 }
 463                 else {
 464                     return $self->html_response({
 465                         status_code => 404,
 466                         body => $self->error_404,
 467                     });
 468                 }
 469             },
 470         ],
 471     },
 472 };
 473
 474 sub as_psgi_app {
 475     my $class = shift;
 476     my $app = $class->SUPER::as_psgi_app;
 477     return builder {
 478         enable_if { $ENV{PLACK_ENV} ne 'deployment' }
 479             sub {
 480                 my $mw_prefix = 'Plack::Middleware';
 481                 my $mw_class = Plack::Util::load_class('Static', $mw_prefix);
 482                 $app = $mw_class->wrap($app,
 483                     path => qr{^/static},
 484                     root => './root/',
 485                 );
 486                 $mw_class = Plack::Util::load_class('Debug', $mw_prefix);
 487                 $app = $mw_class->wrap($app,
 488                     panels => [qw(DBITrace Memory Timer Environment Response)],
 489                 );
 490                 $app;
 491             };
 492         enable 'ContentLength';
 493         enable 'ConditionalGET';
 494         enable 'ErrorDocument',
 495             500 => 'root/html/error_500.html',
 496             404 => 'root/html/error_404.html';
 497         enable 'HTTPExceptions';
 498         enable 'Head';
 499         enable 'AccessLog',
 500             format => 'combined',
 501             logger => sub { get_logger('accesslog')->info(@_) };
 502         enable 'Log4perl', conf => 'log/log.conf';
 503         $app;
 504     };
 505 }
 506
 507 =head1 AUTHOR
 508
 509 Wallace Reis, C<< <wreis at cpan.org> >>
 510
 511 =head1 LICENSE AND COPYRIGHT
 512
 513 Copyright 2010 Wallace Reis.
 514
 515 =cut
 516
 517 __PACKAGE__->run_if_script;