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