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 =~ /(\d+):(\d+):(\d+)\*?\s+(\d+):(\d+):(\d+)\s+([^:]*\S+)\s+(?:Ter|Cat|Xan|Zik|Etd)\s+([\d,]+)\s+Attack\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 @missions;
 558         $missions =~ s/,//g;
 559         if ($missions =~ m/
 560                 Ships \s?\t Cla \s?\t T1 \s?\t T2 \s?\t T3 \s?\t Base\ \(i\) \s (?<name>.+?)\ \(i\) \s?\t (?<name>.+?)\ \(i\) \s?\t (?<name>.+?)\ \(i\) \s?\t TOTAL \W+
 561                 (?<ships>.+?)
 562                 \QTotal Ships in Fleet\E \s?\t (\d+) \s?\t (?<amount>\d+) \s?\t (?<amount>\d+) \s?\t (?<amount>\d+) \W+
 563                 Mission: \t (?<mission>\w*) \t (?<mission>\w*) \t (?<mission>\w*) \W+
 564                 Target: \t (?<targets>((\d+:\d+:\d+)?\t)*) \W+
 565                 \QLaunch Tick:\E \t (?<lts>(\d*\t)*) \W+
 566                 ETA: \t? (?<etas>([^\t]+\t?)*)
 567                 /sx){
 568                 my %match = %-;
 569                 my @etas = split /\t/, $+{etas};
 570                 my @targets = split /\t/, $+{targets};
 571                 my @lts = split /\t/, $+{lts};
 572                 for my $i (0..2){
 573                         my %mission = (
 574                                 name => $match{name}->[$i],
 575                                 mission => $match{mission}->[$i],
 576                                 amount => $match{amount}->[$i],
 577                                 num => $i,
 578                                 ships => []
 579                         );
 580                         if      ($mission{amount} == 0){
 581                                 push @missions,\%mission;
 582                                 next;
 583                         }
 584
 585                         $mission{target} = shift @targets;
 586                         $mission{lt} = shift @lts;
 587                         given(shift @etas){
 588                                 when(/^(\d+) (\s+ \(\+\d+\))? \W+
 589                                                 Arrival:\ (\d+) \W+
 590                                                 \QReturn ETA: \E(Instant|\d+)/sx){
 591                                         $mission{tick} = $3;
 592                                         $mission{eta} = $1 + $4;
 593                                         $mission{back} = $3 + $mission{eta} - 1;
 594                                 }
 595                                 when(/^(\d+) \W+
 596                                         Arrival:\ (\d+)/sx){
 597                                         $mission{tick} = $2;
 598                                         $mission{eta} = $1;
 599                                         $mission{back} = $2;
 600                                 }
 601                         }
 602                         push @missions,\%mission;
 603                 }
 604                 push @missions,{
 605                         name => 'Main',
 606                         num => 3,
 607                         mission => 'Full fleet',
 608                         tick => $tick,
 609                         amount => 0,
 610                         ships => []
 611                 };
 612                 while ($match{ships}->[0] =~ m/((?:\w+ )*\w+)\s+(FI|CO|FR|DE|CR|BS)[^\d]+([\d\s]+)/g){
 613                         my $ship = $1;
 614                         my @amounts = split /\D+/, $3;
 615                         my $amount = shift @amounts;
 616                         die "Ships don't sum up properly" if $amounts[3] != $amount + $amounts[0] + $amounts[1] + $amounts[2];
 617                         for my $i (0..3){
 618                                 push @{$missions[$i]->{ships}},{ship => $ship, amount => $amounts[$i]} if $amounts[$i] > 0;
 619                         }
 620                         $missions[3]->{amount} += $amounts[3];
 621                 }
 622         }
 623         return @missions;
 624 }
 625
 626 sub findDuplicateFleet : Private {
 627         my ( $self, $c, $m ) = @_;
 628         my $dbh = $c->model;
 629
 630         my $findfleet = $dbh->prepare(q{
 631 SELECT fid FROM fleets f
 632         LEFT JOIN launch_confirmations lc USING (fid)
 633 WHERE f.pid = (SELECT pid FROM users WHERE uid = $1) AND mission = $3 AND amount = $4 AND
 634         COALESCE(uid = $1 AND num = $2 AND lc.pid = $5 AND landing_tick = $6, TRUE)
 635                 });
 636         my $fid = $dbh->selectrow_array($findfleet,undef,$c->user->id,$m->{num}
 637                 ,$m->{mission},$m->{amount}, $m->{pid}, $m->{tick});
 638         $c->forward("matchShips", [$m,$fid]);
 639         $m->{fid} = $fid if $m->{match};
 640 }
 641
 642 sub addAttackFleet : Private {
 643         my ( $self, $c, $m ) = @_;
 644         my $dbh = $c->model;
 645
 646         my $findattacktarget = $dbh->prepare(q{
 647 SELECT c.target,c.wave,c.launched
 648 FROM  raid_claims c
 649         JOIN raid_targets t ON c.target = t.id
 650         JOIN raids r ON t.raid = r.id
 651 WHERE c.uid = ? AND r.tick+c.wave-1 = ? AND t.pid = ?
 652         AND r.open AND not r.removed
 653                 });
 654         my $launchedtarget = $dbh->prepare(q{
 655 UPDATE raid_claims SET launched = TRUE
 656 WHERE uid = ? AND target = ? AND wave = ?
 657                 });
 658         my $claim = $dbh->selectrow_hashref($findattacktarget,undef,$c->user->id,$m->{tick},$m->{pid});
 659         if ($claim->{launched}){
 660                 $m->{warning} = "Already launched on this target:$claim->{target},$claim->{wave},$claim->{launched}";
 661         }elsif(defined $claim->{launched}){
 662                 $launchedtarget->execute($c->user->id,$claim->{target},$claim->{wave});
 663                 $m->{warning} = "OK:$claim->{target},$claim->{wave},$claim->{launched}";
 664         }else{
 665                 $m->{warning} = "You haven't claimed this target";
 666         }
 667 }
 668
 669 sub addDefendFleet : Private {
 670         my ( $self, $c, $m ) = @_;
 671         my $dbh = $c->model;
 672
 673         my $finddefensetarget = $dbh->prepare(q{
 674 SELECT call FROM calls c
 675         JOIN users u USING (uid)
 676 WHERE u.pid = $1 AND c.landing_tick = $2
 677         });
 678         my $informDefChannel = $dbh->prepare(q{
 679 INSERT INTO defense_missions (fleet,call) VALUES (?,?)
 680                 });
 681         my $call = $dbh->selectrow_hashref($finddefensetarget,undef,$m->{pid},$m->{tick});
 682         if ($call->{call}){
 683                 $informDefChannel->execute($m->{fleet},$call->{call});
 684         }else{
 685                 $m->{warning} = "No call for $m->{target} landing tick $m->{tick}";
 686         }
 687 }
 688
 689 sub addReturnFleet : Private {
 690         my ( $self, $c, $m ) = @_;
 691         my $dbh = $c->model;
 692
 693         my $findfleet = $dbh->prepare(q{
 694 SELECT fid FROM fleets f
 695         JOIN launch_confirmations lc USING (fid)
 696 WHERE uid = $1 AND num = $2  AND amount = $3
 697         AND back >= $4
 698                 });
 699         my $fid = $dbh->selectrow_array($findfleet,undef,$c->user->id,$m->{num}
 700                 ,$m->{amount}, $m->{tick});
 701         $c->forward("matchShips", [$m,$fid]);
 702         if ($m->{match}){
 703                 $m->{fid} = $fid;
 704                 $m->{warning} = "Return fleet, changed back tick to match the return eta.";
 705         } else {
 706                 $m->{warning} = "Couldn't find a fleet matching this returning fleet, so adding a new fleet that is returning";
 707         }
 708 }
 709
 710 sub matchShips : Private {
 711         my ( $self, $c, $m, $fid ) = @_;
 712         return unless $fid;
 713         my $dbh = $c->model;
 714
 715         my $ships = $dbh->prepare(q{
 716 SELECT ship, amount FROM fleet_ships WHERE fid = $1 ORDER BY num
 717                 });
 718         $ships->execute($fid);
 719         for my $s (@{$m->{ships}}){
 720                 my $s2 = $ships->fetchrow_hashref;
 721                 return unless $s->{ship} eq $s2->{ship} && $s->{amount} == $s2->{amount};
 722         }
 723         $m->{match} = 1;
 724
 725 }
 726
 727 sub defenders : Local {
 728         my ( $self, $c, $order ) = @_;
 729         my $dbh = $c->model;
 730
 731         my $defenders = $dbh->prepare(q{
 732 SELECT uid,pid AS planet,username, to_char(NOW() AT TIME ZONE timezone,'HH24:MI') AS time
 733         ,sms_note, call_if_needed, race, timezone
 734 FROM users u
 735         JOIN current_planet_stats p USING (pid)
 736 WHERE uid IN (SELECT uid FROM groupmembers WHERE gid = 'M')
 737 ORDER BY call_if_needed DESC, username
 738                 });
 739         $defenders->execute;
 740
 741         my $available = $dbh->prepare(q{
 742 SELECT ship,amount FROM available_ships WHERE pid = $1
 743                 });
 744
 745         my @members;
 746         while (my $member = $defenders->fetchrow_hashref){
 747
 748                 $member->{fleets} = member_fleets($dbh, $member->{uid}, $member->{planet});
 749                 $available->execute($member->{planet});
 750                 my $fleet = {fid => $member->{username}, mission => 'Available', name => 'At home'
 751                         , ships => $available->fetchall_arrayref({})
 752                 };
 753                 push @{$member->{fleets}}, $fleet;
 754                 push @members,$member;
 755         }
 756         $c->stash(members => \@members);
 757 }
 758
 759 sub member_fleets {
 760         my ( $dbh, $uid, $planet ) = @_;
 761
 762         my $query = $dbh->prepare(q{
 763 (
 764         SELECT DISTINCT ON (mission,name) fid,name,tick, NULL AS eta
 765                 ,amount, NULL AS coords, pid AS target, NULL AS back
 766                 ,NULL AS recalled, mission
 767         FROM fleets f
 768         WHERE pid = $2 AND tick <= tick() AND tick >= tick() -  24
 769                 AND name IN ('Main','Advanced Unit') AND mission = 'Full fleet'
 770         ORDER BY mission,name,tick DESC, fid DESC
 771 ) UNION (
 772         SELECT fid,name,landing_tick AS tick, eta, amount
 773                 , coords(x,y,z), lc.pid AS target, back
 774                 , (back <> landing_tick + eta - 1) AS recalled
 775                 ,CASE WHEN landing_tick <= tick() OR (back <> landing_tick + eta - 1)
 776                         THEN 'Returning' ELSE mission END AS mission
 777         FROM  launch_confirmations lc
 778                 LEFT OUTER JOIN current_planet_stats t USING (pid)
 779                 JOIN fleets f USING (fid)
 780         WHERE uid = $1 AND f.pid = $2 AND back > tick()
 781                 AND landing_tick - eta - 12 < tick()
 782 )
 783                 });
 784
 785         my $ships = $dbh->prepare(q{SELECT ship,amount FROM fleet_ships
 786                 WHERE fid = ? ORDER BY num
 787                 });
 788
 789         $query->execute($uid,$planet);
 790         my @fleets;
 791         while (my $fleet = $query->fetchrow_hashref){
 792                 my @ships;
 793                 $ships->execute($fleet->{fid});
 794                 while (my $ship = $ships->fetchrow_hashref){
 795                         push @ships,$ship;
 796                 }
 797                 $fleet->{ships} = \@ships;
 798                 push @fleets,$fleet;
 799         }
 800         return \@fleets;
 801 }
 802
 803 =head1 AUTHOR
 804
 805 Michael Andreen (harv@ruin.nu)
 806
 807 =head1 LICENSE
 808
 809 GPL 2.0, or later.
 810
 811 =cut
 812
 813 1;