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