| 1 | package App::Web::NAOdash; |
| 2 | |
| 3 | use 5.014000; |
| 4 | use strict; |
| 5 | use warnings; |
| 6 | use re '/saa'; |
| 7 | use parent qw/Plack::Component/; |
| 8 | |
| 9 | our $VERSION = '0.001'; |
| 10 | |
| 11 | use Digest::SHA qw/sha256_base64/; |
| 12 | use File::Slurp; |
| 13 | use HTML::TreeBuilder; |
| 14 | use JSON::MaybeXS qw/encode_json/; |
| 15 | use NetHack::NAOdash qw/naodash_user/; |
| 16 | |
| 17 | my ($dash, $css, $css_hash); |
| 18 | |
| 19 | { |
| 20 | $css = read_file 'web/dash.css'; |
| 21 | $css =~ y/\n\t//d; |
| 22 | $css =~ s/([):]) /$1/g; |
| 23 | $css =~ s/ ([{(])/$1/g; |
| 24 | $css_hash = 'sha256-' . sha256_base64($css) . '='; |
| 25 | my $tb = HTML::TreeBuilder->new; |
| 26 | $tb->ignore_unknown(0); |
| 27 | $dash = $tb->parse_file('web/dash.html'); |
| 28 | $dash->find('link')->postinsert([style => $css])->detach; |
| 29 | } |
| 30 | |
| 31 | sub format_time { |
| 32 | my ($time) = @_; |
| 33 | return unless defined $time; |
| 34 | my %units = ( |
| 35 | s => 60, |
| 36 | m => 60, |
| 37 | h => 24, |
| 38 | d => 7, |
| 39 | w => 1e9, |
| 40 | ); |
| 41 | my @parts; |
| 42 | for (qw/s m h d w/) { |
| 43 | use integer; |
| 44 | last unless $time; |
| 45 | unshift @parts, ($time % $units{$_}) . $_; |
| 46 | $time /= $units{$_}; |
| 47 | } |
| 48 | join ' ', @parts; |
| 49 | } |
| 50 | |
| 51 | sub make_html { |
| 52 | my ($name, $result) = @_; |
| 53 | my @checks = @{$result->{checks}}; |
| 54 | my %numbers = %{$result->{numbers}}; |
| 55 | $numbers{totalrealtime} = format_time $numbers{totalrealtime}; |
| 56 | $numbers{minrealtime} = format_time $numbers{minrealtime}; |
| 57 | |
| 58 | my $tree = $dash->clone; |
| 59 | $tree->find('title')->delete_content->push_content("Dashboard for $name"); |
| 60 | $tree->find('a')->attr(href => $tree->find('a')->attr('href') . $name); |
| 61 | $tree->find('a')->delete_content->push_content($name); |
| 62 | for (@checks) { |
| 63 | my $el = $tree->look_down(id => $_); |
| 64 | warn "No element for check $_" unless $el; ## no critic (RequireCarping) |
| 65 | $el->attr(class => 'done') if $el; |
| 66 | } |
| 67 | while (my ($id, $num) = each %numbers) { |
| 68 | next unless defined $num; |
| 69 | my $el = $tree->look_down(id => $id); |
| 70 | warn "No element for check $id" unless $el; ## no critic (RequireCarping) |
| 71 | $el->delete_content->push_content($num); |
| 72 | } |
| 73 | $tree->as_HTML; |
| 74 | } |
| 75 | |
| 76 | sub reply { |
| 77 | my ($code, $message, $type) = @_; |
| 78 | $type //= 'text/plain'; |
| 79 | [$code, [ |
| 80 | 'Cache-Control' => ($code < 500 ? 'max-age=86400' : 'no-cache'), |
| 81 | 'Content-Type' => "$type; charset=utf-8", |
| 82 | 'Content-Length' => length $message, |
| 83 | # Safari implements CSP Level 1 but not CSP Level 2 |
| 84 | # 'Content-Security-Policy' => "default-src 'none'; style-src '$css_hash';", |
| 85 | ], [$message]] |
| 86 | } |
| 87 | |
| 88 | sub call { |
| 89 | my ($self, $env) = @_; |
| 90 | return reply 400, 'Bad request: user contains characters outside [a-zA-Z0-9_]' unless $env->{PATH_INFO} =~ m{^/(\w+)$}; |
| 91 | my $name = $1; |
| 92 | my $result = eval { naodash_user $name } or return reply 500, $@; |
| 93 | |
| 94 | return reply 200, encode_json($result), 'application/json' if $self->{json}; |
| 95 | return reply 200, make_html($name, $result), 'text/html'; |
| 96 | } |
| 97 | |
| 98 | 1; |
| 99 | __END__ |
| 100 | |
| 101 | =encoding utf-8 |
| 102 | |
| 103 | =head1 NAME |
| 104 | |
| 105 | App::Web::NAOdash - Analyze NetHack xlogfiles and extract statistics (web interface) |
| 106 | |
| 107 | =head1 SYNOPSIS |
| 108 | |
| 109 | # In app.psgi |
| 110 | use App::Web::NAOdash; |
| 111 | use Plack::Builder; |
| 112 | |
| 113 | builder { |
| 114 | mount '/dash/' => App::Web::NAOdash->new->to_app; |
| 115 | mount '/json/' => App::Web::NAOdash->new(json => 1)->to_app; |
| 116 | ... |
| 117 | } |
| 118 | |
| 119 | =head1 DESCRIPTION |
| 120 | |
| 121 | App::Web::NAOdash is a web interface to L<NetHack::NAOdash>. |
| 122 | |
| 123 | It handles URLs of the form C</username>, where I<username> is a NAO |
| 124 | username. It retrieves the xlogfile from NAO and returns the result of |
| 125 | the analysis. |
| 126 | |
| 127 | The constructor takes a single named parameter, I<json>, that is false |
| 128 | by default. The result will be returned as HTML is I<json> is false, |
| 129 | as JSON if I<json> is true. |
| 130 | |
| 131 | =head1 SEE ALSO |
| 132 | |
| 133 | L<NetHack::NAOdash>, L<App::NAOdash> |
| 134 | |
| 135 | =head1 AUTHOR |
| 136 | |
| 137 | Marius Gavrilescu, E<lt>marius@ieval.roE<gt> |
| 138 | |
| 139 | =head1 COPYRIGHT AND LICENSE |
| 140 | |
| 141 | Copyright (C) 2015 by Marius Gavrilescu |
| 142 | |
| 143 | This library is free software; you can redistribute it and/or modify |
| 144 | it under the same terms as Perl itself, either Perl version 5.20.2 or, |
| 145 | at your option, any later version of Perl 5 you may have available. |
| 146 | |
| 147 | |
| 148 | =cut |