]>
Commit | Line | Data |
---|---|---|
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 |