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