Initial commit
[nethack-naodash.git] / lib / App / Web / NAOdash.pm
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
This page took 0.030367 seconds and 4 git commands to generate.