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