chiark / gitweb /
Fix up search too long error message - really fix up
[ypp-sc-tools.main.git] / yarrg / web / query_routesearch
1 <%doc>
2
3  This is part of the YARRG website.  YARRG is a tool and website
4  for assisting players of Yohoho Puzzle Pirates.
5
6  Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
7  Copyright (C) 2009 Clare Boothby
8
9   YARRG's client code etc. is covered by the ordinary GNU GPL (v3 or later).
10   The YARRG website is covered by the GNU Affero GPL v3 or later, which
11    basically means that every installation of the website will let you
12    download the source.
13
14  This program is free software: you can redistribute it and/or modify
15  it under the terms of the GNU Affero General Public License as
16  published by the Free Software Foundation, either version 3 of the
17  License, or (at your option) any later version.
18
19  This program is distributed in the hope that it will be useful,
20  but WITHOUT ANY WARRANTY; without even the implied warranty of
21  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
22  GNU Affero General Public License for more details.
23
24  You should have received a copy of the GNU Affero General Public License
25  along with this program.  If not, see <http://www.gnu.org/licenses/>.
26
27  Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
28  are used without permission.  This program is not endorsed or
29  sponsored by Three Rings.
30
31
32  This Mason component generates the core of the `routesearch' query.
33
34
35 </%doc>
36 <%args>
37 $quri
38 $dbh
39 $baseqf
40 $queryqf
41 $islandstring => '';
42 $capacitystring => '';
43 $lossperleague => '';
44 $capitalstring => '';
45 $minprofitstring => '';
46 $distance => '';
47 $prselector
48 $someresults
49 $emsgokorprint
50 $allargs
51 </%args>
52
53 <%perl>
54 use BSD::Resource;
55
56 my $emsg;
57 my @warningfs;
58 my @islandids;
59
60 my $destspec;
61
62 my $maxmaxdist=35;
63 my $maxcpu=1;
64 my $concur_lim=5;
65
66 my $qa= \%ARGS;
67 my $routeparams= { EmsgRef => \$emsg, SayRequiredCapacity => 1 };
68 my $maxdist;
69 my $maxcountea=15;
70
71 </%perl>
72
73 <div class="query">
74 <h1>Find most profitable routes and trades</h1>
75
76 % if ($qa->{Dropdowns}) {
77 This feature is not available from the "drop down menus" interface.
78 % } else {
79
80 % $prselector->('RouteSearchType');
81
82 <form action="<% $quri->() |h %>" method="get">
83
84 <& enter_route, qa=>$qa, dbh=>$dbh, emsg_r=>\$emsg, warningfs_r=>\@warningfs,
85         enterwhat => 'Enter starting point(s)',
86         islandids_r => \@islandids, archipelagoes_r => undef
87  &>
88
89 % my $searchtype= $ARGS{RouteSearchType};
90 % if ($searchtype == 0) {
91 %       $destspec= 'any';
92 % } elsif ($searchtype == 1) {
93 %       $destspec= 'circ';
94 % } elsif ($searchtype == 2) {
95
96 Destination (one island only):
97 <& qtextstring, qa => $qa, dbh => $dbh, emsgstore => \$emsg,
98     thingstring => 'deststring',
99     prefix => 'ds', boxopts => 'size=40',
100     onresults => sub {
101 print STDERR "ONRESULTS @_\n";
102         return unless @_;
103         my ($canonname, $island, $arch) = @{ $_[0] };
104         die unless defined $island;
105         $destspec= $island;
106     }
107  &>
108
109 % } else {
110 %       die "$destspec ?";
111 % }
112
113 <&| enter_advrouteopts, qa=>$qa, dbh=>$dbh, routeparams=>$routeparams &>
114 <td>
115 &nbsp;
116 &nbsp;
117 <td>
118  Maximum distance:
119  <& qtextstring, qa => $qa, dbh => $dbh, prefix => 'ml',
120     thingstring => 'distance', emsgstore => \$emsg, boxopts => 'size=10',
121     onresults => sub { ($maxdist)= @_; }
122    &>
123 </&>
124
125 <input type=submit name=submit value="Search">
126 % my $ours= sub { $_[0] =~ m/^lossperleague|^islandstring|^deststring|^capitalstring|^capacitystring|^minprofitstring|^distance/; };
127 <& "lookup:formhidden", ours => $ours &>
128
129 % }
130
131 </form>
132 </div>
133 <div class="results">
134 <%perl>
135
136 if (!$emsg && $maxdist > $maxmaxdist) {
137         $emsg= "Searching for routes of more than $maxmaxdist leagues is not".
138                 " supported, sorry.";
139 }
140
141 print("</div>"), return
142      unless $emsgokorprint->($emsg)
143         and @islandids
144         and $allargs->{'submit'}
145         and defined $destspec
146         and (defined $routeparams->{MaxMass} or
147              defined $routeparams->{MaxVolume});
148
149 #---------- prepare island names ----------
150
151 my $islandname_stmt= $dbh->prepare(<<END);
152         SELECT islandname, archipelago
153           FROM islands
154          WHERE islandid = ?
155 END
156
157 my $isleinfo = sub {
158         my ($id) = @_;
159         $islandname_stmt->execute($id);
160         my $row= $islandname_stmt->fetchrow_hashref();
161         local $_= $row->{'islandname'};
162         s/ Island$//;
163         return $_, $row->{'islandname'}, $row->{'archipelago'};
164 };
165
166 #---------- compute the results ----------
167
168 my @rsargs= ($concur_lim, '-DN');
169 my $concur_fail;
170
171 foreach my $k (qw(MaxMass MaxVolume MaxCapital)) {
172         my $v= $routeparams->{$k};
173         push @rsargs, (defined $v ? $v : -1);
174 }
175 push @rsargs, defined $routeparams->{LossPerLeaguePct}
176         ? $routeparams->{LossPerLeaguePct}*0.01 : 1e-9;
177 push @rsargs, 0; #$routeparams->{MinProfit};
178 push @rsargs, 'search',$maxdist, $maxcountea,$maxcountea;
179 push @rsargs, $destspec;
180 push @rsargs, @islandids;
181
182 m/[^-.0-9a-zA-Z]/ and die "$_ $& ?" foreach @rsargs;
183
184 if ($qa->{'debug'}) {
185 </%perl>
186 [[ <% "@rsargs" |h %> ]]<br><pre>
187 <%perl>
188 }
189
190 unshift @rsargs,
191         'nice', sourcebasedir().'/yarrg/routesearch',
192         '-d', dbw_filename($qa->{'Ocean'}),
193         '-C', webdatadir().'/_concur.', '.lock';
194
195 # touch _concur.0{0,1,2,3,4}.lock
196 # really chgrp www-data _concur.0?.lock
197
198 my %results; # $results{$ap}{"5 6 9 10"} = { stuff }
199
200 my $fh= new IO::File;
201 my $child= $fh->open("-|"); defined $child or die $!;
202 if (!$child) {
203         my $cpu= BSD::Resource::RLIMIT_CPU;
204         my ($soft,$hard)= getrlimit($cpu);
205         setrlimit($cpu,$maxcpu,$hard) or die $! if $hard<=$maxcpu;
206         exec @rsargs;
207         die $!;
208 }
209
210 while (<$fh>) {
211         chomp;
212         if ($qa->{'debug'}) {
213 </%perl>
214 <% $_ |h %>
215 <%perl>
216         }
217         next unless m/^\s*\@/;
218         if (m/^\@\@\@ concurrency limit exceeded/) {
219                 $concur_fail= 1;
220                 last;
221         }
222         die unless m/^ \@ *\d+ ([ap])\# *\d+ \|.*\| *(\d+)lg *\| *\d+ +(\d+) +(\d+) *\| ([0-9 ]+)$/;
223         my ($ap,$isles) = (uc $1,$5);
224         next if $results{$ap} && %{$results{$ap}} >= $maxcountea;
225         my $item= { A => $3, P => $4, Leagues => $2 };
226         my (@i, @fi, @a);
227         foreach (split / /, $isles) {
228                 my ($name,$fullname,$arch)= $isleinfo->($_);
229                 push @i, $name;
230                 push @fi, $fullname;
231                 push @a, $arch unless @a && $a[-1] eq $arch;
232         }
233         $item->{Isles}= [ @i ];
234         $item->{Archs}= [ @a ];
235         $item->{Start}= $i[0];
236         $item->{Finish}= $i[-1];
237         $item->{Vias}= [ ];
238         my $i;
239         for ($i=1; $i < @i-1; $i++) {
240                 push @{ $item->{Vias} }, $i[$i];
241         }
242         my %linkqf= (%$baseqf, %$queryqf);
243         delete $linkqf{'query'};
244         $linkqf{'routestring'}= join ', ', @fi;
245         $item->{Url}= $quri->(%linkqf);
246         $item->{ArchesString}= join ', ', @a;
247         $item->{ViasString}= join ' ', map { $_.',' } @{ $item->{Vias} };
248         $item->{RouteSortString}= join ', ', @i;
249         $results{$ap}{$isles}= $item;
250 }
251
252 if ($qa->{'debug'}) {
253         print "</pre>\n";
254 }
255
256 $!=0;
257 if (!close $fh) {
258         die $! if $!;
259         die $? if $? != 24; # SIGXCPU but not in POSIX.pm :-/
260 </%perl>
261 % $someresults->('Search took too long and was terminated');
262
263 Sorry, but your query resulted in a search that took too long.
264 Searches are limited to <% $maxcpu |h %> seconds of CPU time to
265 avoid them consuming excessive resources on the server system, and to
266 make sure that shorter searches can still happen.
267
268 <p>
269 Please try a search with a smaller maximum distance, or place more
270 restrictions on the route.
271
272 </div>
273 <%perl>
274         return;
275 }
276
277 if ($concur_fail) {
278 </%perl>
279 % $someresults->('Server too busy');
280
281 Sorry, but there are already <% $concur_lim |h %> route searches
282 running.  We limit the number which can run at once to avoid
283 overloading the server system and to make sure that the rest of the
284 YARRG website still runs quickly.
285 <p>
286
287 If you submitted several searches and gave up on them (eg by hitting
288 "back" or "stop" in your browser), be aware that that doesn't
289 generally stop the search process at the server end.  So it's best to
290 avoid asking for large searches that you're not sure about.
291
292 <p>
293 Otherwise, please try later.  Searches are limited to <% $maxcpu |h %>
294 seconds of CPU time so more processing resources should be available soon.
295
296 </div>
297 <%perl>
298         return;
299 }
300
301 $someresults->();
302
303 </%perl>
304 % foreach my $ap (qw(A P)) {
305 %       if ($ap eq 'A') {
306 <h2>Best routes for total profit</h2>
307 %       } else {
308 <h2>Best routes for profit per league</h2>
309 %       }
310 <table class="data" rules=groups id="ap<% $ap %>_table">
311 <colgroup span=2>
312 <colgroup span=1>
313 <colgroup span=1>
314 <colgroup span=3>
315 <tr>
316 <th colspan=2>Profit
317 <th>Dist.
318 <th>Archipelagoes
319 <th>
320 <th>Route
321 <th>
322 <tr>
323 <th>Abs.
324 <th>Per.lg.
325 <th>
326 <th>(link to plan)
327 <th>Start
328 <th>Via
329 <th>Finish
330 <tr id="ap<% $ap %>_sortrow"><th><th><th><th><th><th><th>
331 %       my $datarow=0;
332 %       my %sortkeys;
333 %       foreach my $isles (sort {
334 %                       $results{$ap}{$b}{$ap} <=>
335 %                       $results{$ap}{$a}{$ap}
336 %               } keys %{$results{$ap}}) {
337 %               my $item= $results{$ap}{$isles};
338 %               my $ci=0;
339 %               my $rowid= "r${ap}$isles"; $rowid =~ y/ /_/;
340 %               foreach my $k (qw(A P Leagues ArchesString
341 %                                 Start RouteSortString Finish)) {
342 %                       $sortkeys{$ci}{$rowid}= $item->{$k};
343 %                       $ci++;
344 %               }
345 <tr class="datarow<% $datarow %>" id="<% $rowid %>">
346 <td align=right><% $item->{A} |h %>
347 <td align=right><% $item->{P} |h %>
348 <td align=right><% $item->{Leagues} |h %>
349 <td align=left><a href="<% $item->{Url} |h %>"><%
350                   $item->{ArchesString} |h %></a>
351 <td align=left><% $item->{Start} |h %>,
352 <td align=left><% $item->{ViasString} |h %>
353 <td align=left><% $item->{Finish} |h %>
354 </td>
355 %               $datarow ^= 1;
356 %       } # $isles
357 </table>
358 <&| tabsort,    table => "ap${ap}_table", sortkeys => "ap${ap}_sortkeys",
359                 throw => "ap${ap}_sortrow", rowclass => "datarow", cols => [
360                 { DoReverse => 1, Numeric => 1 },
361                 { DoReverse => 1, Numeric => 1 },
362                 { DoReverse => 1, Numeric => 1 },
363                 { },
364                 { },
365                 { },
366                 { },
367         ] &>
368   ap<% $ap %>_sortkeys= <% to_json_protecttags(\%sortkeys) %>;
369 </&tabsort>
370 % } # $ap
371
372 <p>
373
374 <h2>Notes</h2>
375
376 Per league values count each island visited as one
377 (additional) league; the "Dist." column is however the actual distance
378 to be sailed.  All profit figures are somewhat approximate; get a
379 complete trading plan for a route for accurate information.
380
381 </div>