lib/NDWeb/Controller/Members.pm

   1 package NDWeb::Controller::Members;
   2
   3 use strict;
   4 use warnings;
   5 use feature ":5.10";
   6 use Try::Tiny;
   7 use parent 'Catalyst::Controller';
   8
   9 use NDWeb::Include;
  10
  11 =head1 NAME
  12
  13 NDWeb::Controller::Members - Catalyst Controller
  14
  15 =head1 DESCRIPTION
  16
  17 Catalyst Controller.
  18
  19 =head1 METHODS
  20
  21 =cut
  22
  23
  24 =head2 index
  25
  26 =cut
  27
  28 sub index : Path : Args(0) {
  29         my ( $self, $c, $order ) = @_;
  30         my $dbh = $c->model;
  31
  32         $c->stash(error => $c->flash->{error});
  33
  34         $c->stash(u => $dbh->selectrow_hashref(q{SELECT pid AS planet,defense_points
  35                         ,attack_points,scan_points,humor_points
  36                         , (attack_points+defense_points+scan_points/20)::NUMERIC(5,1) as total_points
  37                         , sms,rank,hostmask,call_if_needed,sms_note,defprio
  38                 FROM users_defprio WHERE uid = ?
  39                         },undef,$c->user->id)
  40         );
  41
  42         $c->stash(groups => $dbh->selectrow_array(q{SELECT array_agg(groupname)
  43                 FROM groups g NATURAL JOIN groupmembers gm
  44                 WHERE uid = $1
  45                         },undef,$c->user->id)
  46         );
  47
  48         $c->stash(p => $dbh->selectrow_hashref(q{SELECT pid AS id,x,y,z, ruler, planet,race,
  49                 size, size_gain, size_gain_day,
  50                 score,score_gain,score_gain_day,
  51                 value,value_gain,value_gain_day,
  52                 xp,xp_gain,xp_gain_day,
  53                 sizerank,sizerank_gain,sizerank_gain_day,
  54                 scorerank,scorerank_gain,scorerank_gain_day,
  55                 valuerank,valuerank_gain,valuerank_gain_day,
  56                 xprank,xprank_gain,xprank_gain_day
  57                 from current_planet_stats_full p
  58                         WHERE pid = ?
  59                         },undef,$c->user->planet)
  60         );
  61
  62         my $calls = $dbh->prepare(q{
  63 SELECT * FROM defcalls
  64 WHERE uid = $1 AND landing_tick >= tick()
  65 ORDER BY landing_tick DESC
  66                 });
  67         $calls->execute($c->user->id);
  68         $c->stash(calls => $calls->fetchall_arrayref({}) );
  69
  70         $c->stash(fleets => member_fleets($dbh, $c->user->id,$c->user->planet));
  71
  72         my $announcements = $dbh->prepare(q{SELECT ft.ftid, u.username,ft.subject,
  73                 count(NULLIF(COALESCE(fp.time > ftv.time,TRUE),FALSE)) AS unread,count(fp.fpid) AS posts,
  74                 date_trunc('seconds',max(fp.time)::timestamp) as last_post,
  75                 min(fp.time)::date as posting_date, ft.sticky
  76                 FROM forum_threads ft JOIN forum_posts fp USING (ftid)
  77                         JOIN users u ON u.uid = ft.uid
  78                         LEFT OUTER JOIN (SELECT * FROM forum_thread_visits WHERE uid = $1) ftv ON ftv.ftid = ft.ftid
  79                 WHERE ft.fbid = 1
  80                 GROUP BY ft.ftid, ft.subject,ft.sticky,u.username
  81                 HAVING count(NULLIF(COALESCE(ft.sticky OR fp.time > ftv.time,TRUE),FALSE)) >= 1
  82                 ORDER BY sticky DESC,last_post DESC
  83                 });
  84         $announcements->execute($c->user->id);
  85         $c->stash(announcements => $announcements->fetchall_arrayref({}) );
  86 }
  87
  88 sub posthostupdate : Local {
  89         my ( $self, $c ) = @_;
  90         my $dbh = $c->model;
  91
  92         $dbh->do(q{UPDATE users SET hostmask = ? WHERE uid = ?
  93                 },undef, html_escape $c->req->param('hostname'), $c->user->id);
  94
  95         $c->res->redirect($c->uri_for(''));
  96 }
  97
  98 sub postsmsupdate : Local {
  99         my ( $self, $c ) = @_;
 100         my $dbh = $c->model;
 101
 102         my $callme = $c->req->param('callme') || 0;
 103         $dbh->do(q{
 104 UPDATE users SET sms = $1, call_if_needed =  $2, sms_note = $3 WHERE uid = $4
 105                 },undef, html_escape $c->req->param('sms'),$callme
 106                 ,$c->req->param('smsnote'), $c->user->id);
 107
 108         $c->res->redirect($c->uri_for(''));
 109 }
 110
 111 sub postowncoords : Local {
 112         my ( $self, $c ) = @_;
 113         my $dbh = $c->model;
 114
 115         if ($c->user->planet){
 116                 $c->flash(error => 'You already have a planet set.'
 117                         .' Contact a HC if they need to be changed');
 118         }elsif (my ($x,$y,$z) = $c->req->param('planet') =~ m/(\d+)\D+(\d+)\D+(\d+)/){
 119                 my $planet = $dbh->selectrow_array(q{SELECT planetid($1,$2,$3,TICK())
 120                         },undef,$x,$y,$z);
 121
 122                 if ($planet){
 123                         eval {
 124                                 $dbh->do(q{UPDATE users SET pid = ? WHERE uid = ?
 125                                         },undef, $planet , $c->user->id);
 126                         };
 127                         given ($@){
 128                                 when (''){}
 129                                 when (/duplicate key value violates/){
 130                                         $c->flash(error => "The coords $x:$y:$z are already in use. Talk to hc if these are really your coords.")
 131                                 }
 132                                 default {
 133                                         $c->flash(error => $@)
 134                                 }
 135                         }
 136                 }else{
 137                         $c->flash(error => "No planet at coords: $x:$y:$z");
 138                 }
 139         }else{
 140                 $c->flash(error => $c->req->param('planet') . " are not valid coords.");
 141         }
 142
 143         $c->res->redirect($c->uri_for(''));
 144 }
 145
 146 sub postfleetsupdates : Local {
 147         my ( $self, $c ) = @_;
 148         my $dbh = $c->model;
 149
 150         my $log = $dbh->prepare(q{INSERT INTO forum_posts (ftid,uid,message) VALUES(
 151                 (SELECT ftid FROM users WHERE uid = $1),$1,$2)
 152                 });
 153         $dbh->begin_work;
 154         if ($c->req->param('cmd') eq 'Recall Fleets'){
 155                 my $updatefleets = $dbh->prepare(q{UPDATE launch_confirmations
 156                         SET back = tick() + (tick() - (landing_tick - eta))
 157                         WHERE uid = ? AND fid = ? AND back >= tick()+eta
 158                 });
 159
 160                 for my $param ($c->req->param()){
 161                         if ($param =~ /^change:(\d+)$/){
 162                                 $updatefleets->execute($c->user->id,$1);
 163                                 $log->execute($c->user->id,"Member recalled fleet $1");
 164                         }
 165                 }
 166         }elsif ($c->req->param('cmd') eq 'Change Fleets'){
 167                 my $updatefleets = $dbh->prepare(q{UPDATE launch_confirmations
 168                         SET back = ? WHERE uid = ? AND fid = ?});
 169
 170                 for my $param ($c->req->param()){
 171                         if ($param =~ /^change:(\d+)$/){
 172                                 my $back = $c->req->param("back:$1");
 173                                 $updatefleets->execute($back,$c->user->id,$1);
 174                                 $log->execute($c->user->id,"Member set fleet $1 to be back tick: $back");
 175                         }
 176                 }
 177         }
 178         $dbh->commit;
 179
 180         $c->res->redirect($c->uri_for(''));
 181 }
 182
 183 sub ircrequest : Local {
 184         my ( $self, $c ) = @_;
 185         my $dbh = $c->model;
 186
 187         $c->stash(reply => $c->flash->{reply});
 188         $c->stash(channels => ['scan','members','def']);
 189 }
 190
 191 sub postircrequest : Local {
 192         my ( $self, $c ) = @_;
 193         my $dbh = $c->model;
 194
 195         if ($c->req->param('channel')){
 196                 my $query = $dbh->prepare(q{
 197 INSERT INTO irc_requests (uid,channel,message) VALUES($1,$2,$3)
 198                 });
 199                 $query->execute($c->user->id,$c->req->param('channel'),$c->req->param('message'));
 200                 $c->signal_bots;
 201
 202                 $c->flash(reply => "Msg sent to: ".$c->req->param('channel'));
 203                 $c->res->redirect($c->uri_for('ircrequest'));
 204         }else{
 205                 $c->stash(ircmessage => $c->req->param('message'));
 206                 $c->go('ircrequest');
 207         }
 208 }
 209
 210 sub points : Local {
 211         my ( $self, $c, $order ) = @_;
 212         my $dbh = $c->model;
 213
 214         $order //= 'total_points';
 215         if ($order ~~ /^((?:defense|attack|total|humor|scan|raid)_points)$/
 216                         || $order ~~ /^(defprio)$/){
 217                 $order = "$1 DESC";
 218         }else{
 219                 $order = 'total_points DESC';
 220         }
 221
 222         my $limit = 'LIMIT 10';
 223         $limit = '' if $c->check_user_roles(qw/members_points_nolimit/);
 224
 225         my $query = $dbh->prepare(q{
 226 SELECT username,defense_points,attack_points
 227         ,scan_points,humor_points,defprio
 228         ,(attack_points+defense_points+scan_points/20)::NUMERIC(4,0) as total_points
 229         , count(NULLIF(rc.launched,FALSE)) AS raid_points
 230 FROM users_defprio u LEFT OUTER JOIN raid_claims rc USING (uid)
 231 WHERE uid IN (SELECT uid FROM groupmembers WHERE gid = 'M')
 232 GROUP BY username,defense_points,attack_points,scan_points,humor_points,defprio
 233 ORDER BY } . "$order $limit"
 234         );
 235         $query->execute;
 236         $c->stash(members => $query->fetchall_arrayref({}));
 237 }
 238
 239 sub stats : Local {
 240         my ( $self, $c, $order ) = @_;
 241         my $dbh = $c->model;
 242
 243         $order //= 'score';
 244         if ($order ~~ /^(scre|value|xp|size|race)$/){
 245                 $order = "$1rank";
 246         }else{
 247                 $order = 'scorerank';
 248         }
 249         $order .= ',race' if $order eq 'racerank';
 250
 251         my $limit = 'LIMIT 10';
 252         $limit = '' if $c->check_user_roles(qw/members_points_nolimit/);
 253
 254         my ($races) = $dbh->selectrow_array(q{SELECT enum_range(null::race)::text[]});
 255         $c->stash(races => $races);
 256         my $query = $dbh->prepare(q{
 257 SELECT nick
 258         ,rank() OVER(ORDER BY score DESC) AS scorerank
 259         ,rank() OVER(ORDER BY value DESC) AS valuerank
 260         ,rank() OVER(ORDER BY xp DESC) AS xprank
 261         ,rank() OVER(ORDER BY size DESC) AS sizerank
 262         ,rank() OVER(PARTITION BY race ORDER BY score DESC) AS racerank
 263         ,race
 264 FROM current_planet_stats
 265 WHERE alliance = 'NewDawn'
 266         AND race = ANY($1)
 267 ORDER BY } . "$order $limit");
 268         my @race = $c->req->param('race');
 269         my %race = map { $_ => 1 } @race;
 270         $c->stash(race => \%race);
 271         unless (@race){
 272                 @race = @$races;
 273         }
 274         $query->execute(\@race);
 275         $c->stash(members => $query->fetchall_arrayref({}));
 276 }
 277
 278 sub addintel : Local {
 279         my ( $self, $c, $order ) = @_;
 280
 281         $c->stash(intel => $c->flash->{intel});
 282         $c->stash(scans => $c->flash->{scans});
 283         $c->stash(intelmessage => $c->flash->{intelmessage});
 284 }
 285
 286 sub postintel : Local {
 287         my ( $self, $c, $order ) = @_;
 288
 289         $c->forward('insertintel');
 290
 291         $c->res->redirect($c->uri_for('addintel'));
 292 }
 293
 294 sub postintelmessage : Local {
 295         my ( $self, $c, $order ) = @_;
 296
 297         unless ($c->req->param('subject')){
 298                 if ($c->req->param('message') =~ /(.*\w.*)/){
 299                         $c->req->param(subject => $1);
 300                 }
 301         }
 302
 303         my ($coords,$tick) = $c->model->selectrow_array(q{
 304 SELECT coords(x,y,z), tick() FROM current_planet_stats WHERE pid = $1
 305                 }, undef, $c->user->planet);
 306
 307         $c->req->param(message => "[i]Posted by $coords at tick $tick [/i]\n\n" . $c->req->param('message'));
 308         $c->forward('/forum/insertThread',[12]);
 309         $c->forward('/forum/insertPost',[$c->stash->{thread}]);
 310         $c->flash(intelmessage => 1);
 311
 312         $c->forward('insertintel');
 313
 314         $c->res->redirect($c->uri_for('addintel'));
 315 }
 316
 317 sub insertintel : Private {
 318         my ( $self, $c, $order ) = @_;
 319         my $dbh = $c->model;
 320
 321         $dbh->begin_work;
 322         my $findscan = $dbh->prepare(q{SELECT scan_id FROM scans
 323                 WHERE scan_id = LOWER(?) AND tick >= tick() - 168 AND groupscan = ?
 324                 });
 325         my $addscan = $dbh->prepare(q{INSERT INTO scans (scan_id,tick,uid,groupscan)
 326                 VALUES (LOWER(?),tick(),?,?)
 327                 });
 328         my $addpoint = $dbh->prepare(q{UPDATE users SET scan_points = scan_points + 1
 329                 WHERE uid = ?
 330                 });
 331         my @scans;
 332         my $intel = $c->req->param('message');
 333         while ($intel =~ m{http://[\w.]+/.+?scan(_id|_grp)?=(\w+)}g){
 334                 my $groupscan = (defined $1 && $1 eq '_grp') || 0;
 335                 my %scan;
 336                 $scan{id} = $2;
 337                 $scan{group} = $groupscan;
 338                 $findscan->execute($2,$groupscan);
 339                 if ($findscan->rows == 0){
 340                         if ($addscan->execute($2,$c->user->id,$groupscan)){
 341                                 $addpoint->execute($c->user->id) unless $groupscan;
 342                                 $scan{added} = 1;
 343                         }
 344                 }else{
 345                         $scan{message} = 'already exists';
 346                 }
 347                 push @scans,\%scan;
 348         }
 349         my $tick = $c->req->param('tick');
 350         unless ($tick =~ /^(\d+)$/){
 351                 $tick = $c->stash->{game}->{tick};
 352         }
 353         my $addintel = $dbh->prepare(q{INSERT INTO intel
 354                 (name,mission,tick,target,sender,eta,amount,ingal,back,uid)
 355                 VALUES($1,$2,$3,planetid($4,$5,$6,$10),planetid($7,$8,$9,$10)
 356                         ,$11,$12,$13,$14,$15)
 357         });
 358         my @intel;
 359         while ($intel =~ m/(\d+):(\d+):(\d+)\*?\s+(\d+):(\d+):(\d+)
 360                 \*?\s+(.+)(?:Ter|Cat|Xan|Zik|Etd)?
 361                 \s+(\d+)\s+(Attack|Defend)\s+(\d+)/gx){
 362                 my $ingal = ($1 == $4 && $2 == $5) || 0;
 363                 my $lt = $tick + $10;
 364                 my $back = ($ingal ? $lt + 4 : undef);
 365                 eval {
 366                         $addintel->execute($7,$9,$lt,$1,$2,$3,$4,$5,$6,$tick,$10,$8
 367                                 ,$ingal,$back, $c->user->id);
 368                         push @intel,"Added $&";
 369                 };
 370                 if ($@){
 371                         push @intel,"Couldn't add $&: ".$dbh->errstr;
 372                 }
 373         }
 374         $dbh->commit;
 375         $c->flash(intel => \@intel);
 376         $c->flash(scans => \@scans);
 377 }
 378
 379 sub addincs : Local {
 380         my ( $self, $c ) = @_;
 381         $c->stash(incs => $c->flash->{incs});
 382
 383 }
 384
 385 sub postincs : Local {
 386         my ( $self, $c ) = @_;
 387         my $dbh = $c->model;
 388
 389         my @incs;
 390
 391         my $user = $dbh->prepare(q{
 392 SELECT uid FROM users u
 393 WHERE pid = planetid($1,$2,$3,tick())
 394         AND uid IN (SELECT uid FROM groupmembers WHERE gid = 'M')
 395                 });
 396         my $call = $dbh->prepare(q{
 397 SELECT call
 398 FROM calls WHERE uid = $1 AND landing_tick = tick() + $2
 399                 });
 400         my $fleet = $dbh->prepare(q{
 401 SELECT pid
 402 FROM incomings i
 403 WHERE pid = planetid($1,$2,$3,tick()) AND amount = $4 and fleet = $5 AND call = $6
 404                 });
 405         my $irc = $dbh->prepare(q{
 406 INSERT INTO irc_requests (uid,channel,message) VALUES($1,'def',$2)
 407                 });
 408
 409         my $msg = $c->req->param('message');
 410         while ($msg =~ /expand\s+(\d+):(\d+):(\d+)\*?\s+(\d+):(\d+):(\d+)\s+([^:]*\S+)\s+(?:Ter|Cat|Xan|Zik|Etd)\s+([\d,]+)\s+(\d+)/gc
 411                         || $msg =~ /(\d+):(\d+):(\d+)\s+(\d+):(\d+):(\d+)\s+\((?:Ter|Cat|Xan|Zik|Etd)\)\s+([^,]*\S+)\s+([\d,]+)\s+(\d+)\s+\(\d+\)/gc){
 412
 413                 my $inc = {message => $&};
 414                 my $amount = $8;
 415                 {
 416                         $amount =~ s/,//g;
 417                 }
 418                 try {
 419                         my $uid = $dbh->selectrow_array($user,undef,$1,$2,$3);
 420                         die '<i>No user with these coords</i>' unless $uid;
 421
 422                         my $call = $dbh->selectrow_array($call,undef,$uid,$9);
 423                         if ($call){
 424                                 my $pid = $dbh->selectrow_hashref($fleet,undef,$4,$5,$6,$amount,$7,$call);
 425                                 die '<i>Duplicate</i>' if $pid;
 426
 427                         }
 428
 429                         $irc->execute($c->user->id, $inc->{message});
 430                         $inc->{status} = '<b>Added</b>';
 431
 432                 } catch {
 433                         when (m(^(<i>.*</i>) at )){
 434                                 $inc->{status} = $1;
 435                         }
 436                         default {
 437                                 $inc->{status} = $_;
 438                         }
 439                 };
 440                 push @incs, $inc;
 441         }
 442
 443         $c->signal_bots if @incs;
 444         $c->flash(incs => \@incs);
 445         $c->res->redirect($c->uri_for('addincs'));
 446 }
 447
 448 sub launchConfirmation : Local {
 449         my ( $self, $c ) = @_;
 450
 451         $c->stash(error => $c->flash->{error});
 452         $c->stash(missions => $c->flash->{missions});
 453 }
 454
 455 sub postconfirmation : Local {
 456         my ( $self, $c ) = @_;
 457         my $dbh = $c->model;
 458
 459         try {
 460                 my $findplanet = $dbh->prepare(q{SELECT planetid(?,?,?,tick())});
 461                 my $addfleet = $dbh->prepare(q{INSERT INTO fleets
 462                         (name,mission,pid,tick,amount)
 463                         VALUES ($2,$3,(SELECT pid FROM users WHERE uid = $1),tick(),$4)
 464                         RETURNING fid
 465                         });
 466                 my $updatefleet = $dbh->prepare(q{
 467 UPDATE launch_confirmations SET back = $2 WHERE fid = $1
 468                         });
 469                 my $addconfirmation = $dbh->prepare(q{INSERT INTO launch_confirmations
 470                         (fid,uid,pid,landing_tick,eta,back,num) VALUES ($1,$2,$3,$4,$5,$6,$7)
 471                         });
 472                 my $addships = $dbh->prepare(q{INSERT INTO fleet_ships (fid,ship,amount)
 473                         VALUES (?,?,?)
 474                         });
 475                 my $log = $dbh->prepare(q{INSERT INTO forum_posts (ftid,uid,message) VALUES(
 476                         (SELECT ftid FROM users WHERE uid = $1),$1,$2)
 477                         });
 478                 my $return = $dbh->prepare(q{
 479 UPDATE launch_confirmations SET back = tick()
 480 WHERE uid = $1 AND num = $2 AND back > tick()
 481                         });
 482                 my $fullfleet = $dbh->prepare(q{INSERT INTO full_fleets
 483                                         (fid,uid) VALUES (?,?)});
 484                 $dbh->begin_work;
 485                 my @missions = parseconfirmations($c->req->param('mission'), $c->stash->{TICK});
 486                 for my $m (@missions){
 487                         if ($m->{mission} eq 'Return'){
 488                                 $c->forward("addReturnFleet", [$m]);
 489                                 if($m->{fid}){
 490                                         $updatefleet->execute($m->{fid},$m->{back});
 491                                         next;
 492                                 }else{
 493                                         $m->{pid} = $c->user->planet;
 494                                 }
 495                         }elsif ($m->{target} =~ /^(\d+):(\d+):(\d+)$/) {
 496                                 $m->{pid} = $dbh->selectrow_array($findplanet,undef,$1,$2,$3);
 497                                 unless ($m->{pid}){
 498                                         $m->{warning} = "No planet at $m->{target}, try again next tick.";
 499                                         next;
 500                                 }
 501                         }
 502
 503                         #Recall fleets with same slot number
 504                         $return->execute($c->user->id,$m->{num});
 505
 506                         unless ($m->{mission}){
 507                                 $m->{warning} = "Not on a mission, but matching fleets recalled";
 508                                 next;
 509                         }
 510
 511                         $c->forward("findDuplicateFleet", [$m]);
 512                         if ($m->{match}){
 513                                 $m->{warning} = "Already confirmed this fleet, updating changed information";
 514                                 $updatefleet->execute($m->{fid},$m->{back}) if $m->{pid};
 515                                 next;
 516                         }
 517
 518
 519                         $m->{fleet} = $dbh->selectrow_array($addfleet,undef,$c->user->id,$m->{name}
 520                                 ,$m->{mission},$m->{amount});
 521
 522                         if ($m->{mission} eq 'Full fleet'){
 523                                 $fullfleet->execute($m->{fleet},$c->user->id);
 524                         }else{
 525                                 $addconfirmation->execute($m->{fleet},$c->user->id,$m->{pid},$m->{tick},$m->{eta},$m->{back},$m->{num});
 526                         }
 527
 528                         if ($m->{mission} eq 'Attack'){
 529                                 $c->forward("addAttackFleet", [$m]);
 530                         }elsif ($m->{mission} eq 'Defend'){
 531                                 $c->forward("addDefendFleet", [$m]);
 532                         }
 533
 534                         for my $ship (@{$m->{ships}}){
 535                                 $addships->execute($m->{fleet},$ship->{ship},$ship->{amount});
 536                         }
 537                         $log->execute($c->user->id,"Pasted confirmation for $m->{mission} mission to $m->{target}, landing tick $m->{tick}");
 538                 }
 539                 $c->flash(missions => \@missions);
 540                 $dbh->commit;
 541                 $c->signal_bots;
 542         } catch {
 543                 $dbh->rollback;
 544                 when (/insert or update on table "fleet_ships" violates foreign key constraint "fleet_ships_ship_fkey"\s+DETAIL:\s+Key \(ship\)=\(([^)]+)\)/){
 545                         $c->flash( error => "'$1' is NOT a valid ship");
 546                 }
 547                 default{
 548                         $c->flash( error => $_);
 549                 }
 550         };
 551         $c->res->redirect($c->uri_for('launchConfirmation'));
 552 }
 553
 554 sub parseconfirmations {
 555         my ( $missions, $tick ) = @_;
 556         return unless $missions;
 557         my @slots;
 558         $missions =~ s/\s?,\s?//g;
 559         $missions =~ s/\s*([:+])\s*/$1/g;
 560         $missions =~ s/\(\s/(/g;
 561         $missions =~ s/\s\)/)/g;
 562         my $returnetare = qr/(\d+) \s+
 563                 Arrival:(\d+)/sx;
 564         my $missionetare = qr/(\d+) (\s+ \(\+\d+\))? \s+
 565                 Arrival:(\d+) \s+
 566                 \QReturn ETA:\E\s*(?:(?<eta>Instant) \s+ Cancel \s+ Order
 567                         | (?<eta>\d+) \s+ Ticks \s+ Recall \s+ Fleet)/sx;
 568         my $etare = qr/(Galaxy:\d+Universe:\d+(?:Alliance:\d+)?
 569                 |$missionetare
 570                 |$returnetare)\s*/x;
 571         my $missre = qr/((?:Fake\ )?\w+)\s*/x;
 572         if ($missions =~ m/
 573                 Ships \s+ Cla \s+ T\s?1 \s+ T\s?2 \s+ T\s?3 \s+ Base \s+ \(i\) \s (?<name>.+?) \s+ \(i\) \s+ (?<name>.+?) \s+ \(i\) \s+ (?<name>.+?) \s+ \(i\) \s+ TOTAL \s+
 574                 (?<ships>.+?)
 575                 \QTotal Ships in Fleet\E \s+ (\d+) \s+ (?<amount>\d+) \s+ (?<amount>\d+) \s+ (?<amount>\d+) \s+
 576                 Mission: \s* (?<missions>(?:$missre)*)  \s*
 577                 Target: \s* (?<targets>((\d+:\d+:\d+)?\s)*) \s*
 578                 \QLaunch Tick:\E \s* (?<lts>(\d+\s+)*) \s*
 579                 ETA: \s* (?<etas>(?:$etare)*)
 580                 /sx){
 581                 my %match = %-;
 582                 my @targets = split /\s+/, $+{targets};
 583                 my @lts = split /\s+/, $+{lts};
 584                 my @etas;
 585                 my $_ = $+{etas};
 586                 while(/$etare/sxg){
 587                         push @etas, $1;
 588                 }
 589                 my @missions ;
 590                 $_ = $+{missions};
 591                 while(/$missre/sxg){
 592                         push @missions, $1;
 593                 }
 594                 for my $i (0..2){
 595                         my %mission = (
 596                                 name => $match{name}->[$i],
 597                                 mission => '' ,
 598                                 amount => $match{amount}->[$i],
 599                                 num => $i,
 600                                 ships => []
 601                         );
 602                         if ($mission{amount} == 0){
 603                                 push @slots,\%mission;
 604                                 next;
 605                         }
 606
 607                         given(shift @etas){
 608                                 $mission{name} .= " $_";
 609                                 when(/$missionetare/sx){
 610                                         $mission{tick} = $3;
 611                                         $mission{eta} = $1 + $+{eta};
 612                                         $mission{back} = $3 + $mission{eta} - 1;
 613                                         $mission{target} = shift @targets;
 614                                         $mission{lt} = shift @lts;
 615                                         $mission{mission} = shift @missions;
 616                                 }
 617                                 when(/$returnetare/sx){
 618                                         $mission{tick} = $2;
 619                                         $mission{eta} = $1;
 620                                         $mission{back} = $2;
 621                                         $mission{target} = shift @targets;
 622                                         $mission{lt} = shift @lts;
 623                                         $mission{mission} = shift @missions;
 624                                         die 'Did you forget some at the end?' if $mission{mission} ne 'Return';
 625                                 }
 626                         }
 627                         push @slots,\%mission;
 628                 }
 629                 push @slots,{
 630                         name => 'Main',
 631                         num => 3,
 632                         mission => 'Full fleet',
 633                         tick => $tick,
 634                         amount => 0,
 635                         ships => []
 636                 };
 637                 while ($match{ships}->[0] =~ m/(\w+)\s+(FI|CO|FR|DE|CR|BS)[^\d]+((?:\d+\s*){5})/g){
 638                         my $ship = $1;
 639                         my @amounts = split /\D+/, $3;
 640                         my $base = shift @amounts;
 641                         die "Ships don't sum up properly" if $amounts[3] != $base + $amounts[0] + $amounts[1] + $amounts[2];
 642                         for my $i (0..3){
 643                                 push @{$slots[$i]->{ships}},{ship => $ship, amount => $amounts[$i]} if $amounts[$i] > 0;
 644                         }
 645                         $slots[3]->{amount} += $amounts[3];
 646                 }
 647         }
 648         return @slots;
 649 }
 650
 651 sub findDuplicateFleet : Private {
 652         my ( $self, $c, $m ) = @_;
 653         my $dbh = $c->model;
 654
 655         my $findfleet = $dbh->prepare(q{
 656 SELECT fid FROM fleets f
 657         LEFT JOIN launch_confirmations lc USING (fid)
 658 WHERE f.pid = (SELECT pid FROM users WHERE uid = $1)
 659         AND mission = $3 AND amount = $4 AND (mission <> 'Full fleet' OR tick > $6 - 6)
 660         AND COALESCE(uid = $1 AND num = $2 AND lc.pid = $5 AND landing_tick = $6, TRUE)
 661                 });
 662         my $fid = $dbh->selectrow_array($findfleet,undef,$c->user->id,$m->{num}
 663                 ,$m->{mission},$m->{amount}, $m->{pid}, $m->{tick});
 664         $c->forward("matchShips", [$m,$fid]);
 665         $m->{fid} = $fid if $m->{match};
 666 }
 667
 668 sub addAttackFleet : Private {
 669         my ( $self, $c, $m ) = @_;
 670         my $dbh = $c->model;
 671
 672         my $findattacktarget = $dbh->prepare(q{
 673 SELECT c.target,c.wave,c.launched
 674 FROM  raid_claims c
 675         JOIN raid_targets t ON c.target = t.id
 676         JOIN raids r ON t.raid = r.id
 677 WHERE c.uid = ? AND r.tick+c.wave-1 = ? AND t.pid = ?
 678         AND r.open AND not r.removed
 679                 });
 680         my $launchedtarget = $dbh->prepare(q{
 681 UPDATE raid_claims SET launched = TRUE
 682 WHERE uid = ? AND target = ? AND wave = ?
 683                 });
 684         my $claim = $dbh->selectrow_hashref($findattacktarget,undef,$c->user->id,$m->{tick},$m->{pid});
 685         if ($claim->{launched}){
 686                 $m->{warning} = "Already launched on this target:$claim->{target},$claim->{wave},$claim->{launched}";
 687         }elsif(defined $claim->{launched}){
 688                 $launchedtarget->execute($c->user->id,$claim->{target},$claim->{wave});
 689                 $m->{warning} = "OK:$claim->{target},$claim->{wave},$claim->{launched}";
 690         }else{
 691                 $m->{warning} = "You haven't claimed this target";
 692         }
 693 }
 694
 695 sub addDefendFleet : Private {
 696         my ( $self, $c, $m ) = @_;
 697         my $dbh = $c->model;
 698
 699         my $finddefensetarget = $dbh->prepare(q{
 700 SELECT call FROM calls c
 701         JOIN users u USING (uid)
 702 WHERE u.pid = $1 AND c.landing_tick = $2
 703         });
 704         my $informDefChannel = $dbh->prepare(q{
 705 INSERT INTO defense_missions (fleet,call) VALUES (?,?)
 706                 });
 707         my $call = $dbh->selectrow_hashref($finddefensetarget,undef,$m->{pid},$m->{tick});
 708         if ($call->{call}){
 709                 $informDefChannel->execute($m->{fleet},$call->{call});
 710         }else{
 711                 $m->{warning} = "No call for $m->{target} landing tick $m->{tick}";
 712         }
 713 }
 714
 715 sub addReturnFleet : Private {
 716         my ( $self, $c, $m ) = @_;
 717         my $dbh = $c->model;
 718
 719         my $findfleet = $dbh->prepare(q{
 720 SELECT fid FROM fleets f
 721         JOIN launch_confirmations lc USING (fid)
 722 WHERE uid = $1 AND num = $2  AND amount = $3
 723         AND back >= $4
 724                 });
 725         my $fid = $dbh->selectrow_array($findfleet,undef,$c->user->id,$m->{num}
 726                 ,$m->{amount}, $m->{tick});
 727         $c->forward("matchShips", [$m,$fid]);
 728         if ($m->{match}){
 729                 $m->{fid} = $fid;
 730                 $m->{warning} = "Return fleet, changed back tick to match the return eta.";
 731         } else {
 732                 $m->{warning} = "Couldn't find a fleet matching this returning fleet, so adding a new fleet that is returning";
 733         }
 734 }
 735
 736 sub matchShips : Private {
 737         my ( $self, $c, $m, $fid ) = @_;
 738         return unless $fid;
 739         my $dbh = $c->model;
 740
 741         my $ships = $dbh->prepare(q{
 742 SELECT ship, amount FROM fleet_ships WHERE fid = $1 ORDER BY num
 743                 });
 744         $ships->execute($fid);
 745         for my $s (@{$m->{ships}}){
 746                 my $s2 = $ships->fetchrow_hashref;
 747                 return unless $s->{ship} eq $s2->{ship} && $s->{amount} == $s2->{amount};
 748         }
 749         $m->{match} = 1;
 750
 751 }
 752
 753 sub defenders : Local {
 754         my ( $self, $c, $order ) = @_;
 755         my $dbh = $c->model;
 756
 757         my $defenders = $dbh->prepare(q{
 758 SELECT uid,pid AS planet,username, to_char(NOW() AT TIME ZONE timezone,'HH24:MI') AS time
 759         ,sms_note, call_if_needed, race, timezone
 760 FROM users u
 761         JOIN current_planet_stats p USING (pid)
 762 WHERE uid IN (SELECT uid FROM groupmembers WHERE gid = 'M')
 763 ORDER BY call_if_needed DESC, username
 764                 });
 765         $defenders->execute;
 766
 767         my $available = $dbh->prepare(q{
 768 SELECT ship,amount FROM available_ships WHERE pid = $1
 769                 });
 770
 771         my @members;
 772         while (my $member = $defenders->fetchrow_hashref){
 773
 774                 $member->{fleets} = member_fleets($dbh, $member->{uid}, $member->{planet});
 775                 $available->execute($member->{planet});
 776                 my $fleet = {fid => $member->{username}, mission => 'Available', name => 'At home'
 777                         , ships => $available->fetchall_arrayref({})
 778                 };
 779                 push @{$member->{fleets}}, $fleet;
 780                 push @members,$member;
 781         }
 782         $c->stash(members => \@members);
 783 }
 784
 785 sub member_fleets {
 786         my ( $dbh, $uid, $planet ) = @_;
 787
 788         my $query = $dbh->prepare(q{
 789 (
 790         SELECT DISTINCT ON (mission,name) fid,name,tick, NULL AS eta
 791                 ,amount, NULL AS coords, pid AS target, NULL AS back
 792                 ,NULL AS recalled, mission
 793         FROM fleets f
 794         WHERE pid = $2 AND tick <= tick() AND tick >= tick() -  24
 795                 AND name IN ('Main','Advanced Unit') AND mission = 'Full fleet'
 796         ORDER BY mission,name,tick DESC, fid DESC
 797 ) UNION (
 798         SELECT fid,name,landing_tick AS tick, eta, amount
 799                 , coords(x,y,z), lc.pid AS target, back
 800                 , (back <> landing_tick + eta - 1) AS recalled
 801                 ,CASE WHEN landing_tick <= tick() OR (back <> landing_tick + eta - 1)
 802                         THEN 'Returning' ELSE mission END AS mission
 803         FROM  launch_confirmations lc
 804                 LEFT OUTER JOIN current_planet_stats t USING (pid)
 805                 JOIN fleets f USING (fid)
 806         WHERE uid = $1 AND f.pid = $2 AND back > tick()
 807                 AND landing_tick - eta - 12 < tick()
 808 )
 809                 });
 810
 811         my $ships = $dbh->prepare(q{SELECT ship,amount FROM fleet_ships
 812                 WHERE fid = ? ORDER BY num
 813                 });
 814
 815         $query->execute($uid,$planet);
 816         my @fleets;
 817         while (my $fleet = $query->fetchrow_hashref){
 818                 my @ships;
 819                 $ships->execute($fleet->{fid});
 820                 while (my $ship = $ships->fetchrow_hashref){
 821                         push @ships,$ship;
 822                 }
 823                 $fleet->{ships} = \@ships;
 824                 push @fleets,$fleet;
 825         }
 826         return \@fleets;
 827 }
 828
 829 =head1 AUTHOR
 830
 831 Michael Andreen (harv@ruin.nu)
 832
 833 =head1 LICENSE
 834
 835 GPL 2.0, or later.
 836
 837 =cut
 838
 839 1;