Commit | Line | Data |
b67ffc2e |
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.12'; |
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 ( $header, $body ) = @$args{qw/header body/}; |
93 | return [ 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 search { |
358 | my ( $self, $q, $query_params ) = @_; |
359 | my $query = lc "%$q%"; |
360 | return $self->dists($query_params)->search({ |
361 | -or => [ |
362 | { 'LOWER(me.name)' => { -like => $query } }, |
363 | { 'LOWER(me.first_author)' => { -like => $query } }, |
364 | { 'LOWER(me.latest_author)' => { -like => $query } }, |
365 | ], |
366 | }); |
367 | } |
368 | |
369 | dispatch { |
370 | subdispatch sub () { |
371 | $self->_build_request_obj_from($_[+PSGI_ENV]); |
372 | my $body; |
373 | [ |
374 | sub (/) { |
375 | $self->html_response({ body => $self->index_page_content }); |
376 | }, |
377 | |
378 | sub ( /about|/about/ ) { |
379 | my $about_filename = $self->template_filename_for('about'); |
380 | my $about_st = stat($about_filename) |
381 | or $self->log(error_die => "No $about_filename: $!"); |
382 | $self->html_response({ |
383 | header => { |
384 | 'Last-Modified' => $about_st->mtime, |
385 | }, |
386 | body => $self->slurp($about_filename), |
387 | }); |
388 | }, |
389 | |
390 | sub ( /releases|/releases/ + ?* ) { |
391 | my $release_rs = $self->releases($_[1]); |
392 | if ( $release_rs->count ) { |
393 | $body = $self->releases_page_content($release_rs) |
394 | ->select('#nav-releases')->add_to_attribute(class => 'active'); |
395 | } |
396 | else { |
397 | $body = $self->error_404; |
398 | } |
399 | $self->html_response({ body => $body }); |
400 | }, |
401 | |
402 | sub ( /dists|/dists/ + ?* ) { |
403 | my $dist_rs = $self->dists($_[1]); |
404 | if ( $dist_rs->count ) { |
405 | $body = $self->dists_page_content($dist_rs) |
406 | ->select('#nav-dists')->add_to_attribute(class => 'active'); |
407 | } |
408 | else { |
409 | $body = $self->error_404; |
410 | } |
411 | $self->html_response({ body => $body }); |
412 | }, |
413 | |
414 | sub ( /distribution/*|/distribution/*/ + ?* ) { |
415 | if ( my $dist = $self->get_dist($_[1]) ) { |
416 | $body = $self->dist_info_page_content($dist, $_[2]); |
417 | } |
418 | else { |
419 | $body = $self->error_404; |
420 | } |
421 | $self->html_response({ body => $body }); |
422 | }, |
423 | |
424 | sub ( /authors|/authors/ + ?* ) { |
425 | if ( my $authors = $self->authors($_[1]) ) { |
426 | $body = $self->authors_page_content($authors) |
427 | ->select('#nav-authors')->add_to_attribute(class => 'active'); |
428 | } |
429 | else { |
430 | $body = $self->error_404; |
431 | } |
432 | $self->html_response({ body => $body }); |
433 | }, |
434 | |
435 | sub ( /search|/search/ + ?q=&* ) { |
436 | my $dist_rs = $self->search(@_[1,2]); |
437 | if ( $dist_rs->count ) { |
438 | $body = $self->dists_page_content($dist_rs); |
439 | } |
440 | else { |
441 | $body = $self->error_404; |
442 | } |
443 | $self->html_response({ body => $body }); |
444 | }, |
445 | ], |
446 | }, |
447 | }; |
448 | |
449 | sub as_psgi_app { |
450 | my $class = shift; |
451 | my $app = $class->SUPER::as_psgi_app; |
452 | return builder { |
453 | enable_if { $ENV{PLACK_ENV} ne 'deployment' } |
454 | sub { |
455 | my $mw_prefix = 'Plack::Middleware'; |
456 | my $mw_class = Plack::Util::load_class('Static', $mw_prefix); |
457 | $app = $mw_class->wrap($app, |
458 | path => qr{^/static}, |
459 | root => './root/', |
460 | ); |
461 | $mw_class = Plack::Util::load_class('Debug', $mw_prefix); |
462 | $app = $mw_class->wrap($app, |
463 | panels => [qw(DBITrace Memory Timer Environment Response)], |
464 | ); |
465 | $app; |
466 | }; |
467 | enable 'ContentLength'; |
468 | enable 'ConditionalGET'; |
469 | enable 'ErrorDocument', |
470 | 500 => 'root/html/error_500.html', |
471 | 404 => 'root/html/error_404.html'; |
472 | enable 'HTTPExceptions'; |
473 | enable 'Head'; |
474 | enable 'AccessLog', |
475 | format => 'combined', |
476 | logger => sub { get_logger('accesslog')->info(@_) }; |
477 | enable 'Log4perl', conf => 'log/log.conf'; |
478 | $app; |
479 | }; |
480 | } |
481 | |
482 | =head1 AUTHOR |
483 | |
484 | Wallace Reis, C<< <wreis at cpan.org> >> |
485 | |
486 | =head1 LICENSE AND COPYRIGHT |
487 | |
488 | Copyright 2010 Wallace Reis. |
489 | |
490 | =cut |
491 | |
492 | __PACKAGE__->run_if_script; |