src/FROGS/DataBase.pm

   1 ##########################################################################
   2 #
   3 #   Copyright (c) 2003-2012 Aymargeddon Development Team
   4 #
   5 #   This file is part of "Last days of Aymargeddon" - a massive multi player
   6 #   onine game of strategy
   7 #
   8 #        This program is free software: you can redistribute it and/or modify
   9 #        it under the terms of the GNU Affero General Public License as
  10 #        published by the Free Software Foundation, either version 3 of the
  11 #        License, or (at your option) any later version.
  12 #
  13 #        This program is distributed in the hope that it will be useful,
  14 #        but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 #        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  16 #
  17 #    See the GNU Affero General Public License for more details.
  18 #
  19 #    You should have received a copy of the GNU Affero General Public License
  20 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21 #
  22 ###########################################################################
  23 #
  24
  25 #
  26 # Generell database methods are gathered here.
  27 use strict;
  28 use DBI;
  29 use POSIX qw(floor);
  30 use FROGS::Config qw($conf);
  31 use FROGS::Util;
  32 use Date::Parse qw(str2time);
  33 use Date::Calc qw(Time_to_Date Delta_DHMS);
  34
  35 package DataBase;
  36
  37 # the constructor connects to the DB
  38 sub new{
  39   my ($class,$dbh) = @_;
  40   my $self = {};
  41   if (defined $dbh){
  42     $self->{-dbh} = $dbh;
  43   }else{
  44         $self->{-dbh} = DBI->connect("dbi:$::conf->{-DB_SOURCE}",
  45                                        $::conf->{-DB_USER},
  46                                        $::conf->{-DB_PASSWD},
  47                                        {'RaiseError' => 1, 'AutoCommit' => 0}
  48                                                               );
  49   }
  50   #TODO: should specify iso date and time format explicitly for the session!!
  51
  52   $self->{-lang} = $self->{-dbh}->quote($::conf->{-DEFAULT_LANGUAGE});
  53
  54   bless ($self,$class);
  55 }
  56
  57 sub commit{
  58   my $self = shift;
  59   unless(defined $self->{-nowrite}){
  60     $self->{-dbh}->commit();
  61     Util::log('committed.',2);
  62   }
  63 }
  64
  65 sub nowrite{
  66   my $self = shift;
  67   Util::log("DataBase: nowrite activated!",1);
  68   $self->{-nowrite} = 1;
  69 }
  70
  71 # automaticly called destructor
  72 sub DESTROY{
  73   my $self = shift;
  74   $self->{-dbh}->disconnect();
  75 }
  76
  77 # wrapper for database functions:
  78
  79 sub quote{
  80   my ($self, $text) = @_;
  81   return $self->{-dbh}->quote($text);
  82 }
  83
  84 sub quote_all{
  85   my ($self, @plain) = @_;
  86   my @quoted;
  87   for my $s (@plain){
  88     push @quoted, $self->{-dbh}->quote($s);
  89   }
  90   return @quoted;
  91 }
  92
  93 # this does not support any possible SQL-conditions
  94 # just a small subset
  95 # TODO: this function is really ugly :-(
  96 # TODO: just use an escape-character in calls to mark, which fields should be
  97 # TODO: quoted
  98 sub quote_condition{
  99   my ($self, $cond) = @_;
 100
 101   Util::log("condition: $cond",2);
 102
 103   my @bracket = ('(',')');
 104   my @bool = ('AND', 'OR');
 105   my @ops = ('=', '!=');
 106   my @noops = ('<'); # forbidden substrings of pairs. ugly workaround for "time < now()"
 107
 108   # split string at boolean operators
 109   my $splitstring = '';
 110   for my $bool (@bool){
 111     $splitstring .= '\b'.$bool.'\b|';
 112   }
 113   $splitstring =~ s/(.*)\|/$1/;
 114
 115   #Util::log("splitstring: $splitstring\n",2);
 116
 117   my @pairs = split /\s$splitstring\s/, $cond;
 118
 119   Util::log("pairs: @pairs",2);
 120
 121   my $opstring = '';
 122   for my $o (@ops){
 123     $opstring .= "$o|";
 124   }
 125   $opstring =~ s/(.*)\|/$1/;
 126
 127   my $noopstring = '';
 128   for my $no (@noops){
 129     $noopstring .= "$no|";
 130   }
 131   $noopstring =~ s/(.*)\|/$1/;
 132
 133   # quote right hand of operator if necessary
 134   for my $pair (@pairs){
 135     next if $pair =~ /$noopstring/;
 136     my ($left,$right) = split /$opstring/, $pair;
 137     #Util::log("1 left: $left, right: $right",2);
 138     $right =~ s/^\(*-?([\w\s].*)$/$1/; # remove leading brackets
 139     #Util::log("2 left: $left, right: $right",2);
 140     $right =~ s/-?(.*[\w\s])\)*$/$1/; # remove trailing brackets
 141     #Util::log("3 left: $left, right: $right",2);
 142     $right =~ s/^\s*-?(\S.*)/$1/; # remove leading whitespace
 143     #Util::log("4 left: $left, right: $right",2);
 144     $right =~ s/(.*\S)\s*$/$1/; # remove trailing whitespace
 145     #Util::log("5 left: $left, right: $right",2);
 146
 147     next if $right =~ /^\d+$/;
 148     # this could be misfunctional in some SQL-Dialect. We assume single-quotes
 149     my $qright = ($right =~ /^\'.*\'/) ? $right : $self->quote($right);
 150
 151     # Util::log("qright: $qright",2);
 152     next if $cond =~ /$qright/;
 153     $cond =~ s/($opstring\s*)$right/$1$qright/;
 154   }
 155   Util::log("new condition: $cond",2);
 156   return $cond;
 157 }
 158
 159 # assumes that a single row is returned from database
 160 # returns a list of selected columns
 161 sub single_select{
 162   my ($self,$stmt) = @_;
 163
 164   Util::log("single_select: $stmt",2);
 165   my $dat = $self->{-dbh}->selectall_arrayref($stmt);
 166   return () if not defined $dat or not defined $dat->[0];
 167   return @{$dat->[0]};
 168 }
 169
 170 sub single_hash_select{
 171         my ($self,$table,$cond) = @_;
 172
 173         $cond = $self->quote_condition($cond);
 174         my $stmt = "SELECT * FROM $table where $cond";
 175         Util::log("single_hash_select: $stmt",2);
 176         return $self->{-dbh}->selectrow_hashref($stmt);
 177 }
 178
 179 sub select_hash{
 180   my ($self, $table, $key, $fields, $cond) = @_;
 181
 182   my $stmt = $fields ? "SELECT $key, $fields FROM $table"
 183                      : "SELECT $key FROM $table";
 184   $stmt .= " WHERE $cond" if $cond;
 185   return $self->{-dbh}->selectall_hashref($stmt, $key);
 186 }
 187
 188 sub select_array{
 189   my ($self, $table, $fields, $cond, $order) = @_;
 190   my $stmt = "SELECT $fields FROM $table";
 191   if( $cond){
 192     $cond = $self->quote_condition($cond);
 193     $stmt .= " WHERE $cond";
 194     if(defined $order){
 195       $stmt .= " ORDER BY $order";
 196     }
 197   }
 198
 199   Util::log("select_array: $stmt",2);
 200   return $self->{-dbh}->selectall_arrayref($stmt);
 201 }
 202
 203 # returns number of fields with given condition
 204 sub count{
 205   my ($self, $table, $cond) = @_;
 206   my $array = $self->select_array($table,'*',$cond);
 207   my @a = @$array;
 208   my $count = $#a + 1;
 209   Util::log("counted $cond in $table: $count",1);
 210   return $count;
 211 }
 212
 213 # insert a row in one table of the database
 214 #
 215 # parameterlist:
 216 #   table: the database-table we work on
 217 #   hash:  give here a hash with the new values
 218 #   noquote: if hash, than dont quote all keys which are in this hash,
 219 #            if no hash but defined, than we dont quote all the new values
 220 #            (useful for things simmilar to COUNT = COUNT + 1)
 221 sub insert_hash{
 222   my ($self, $table, $hash,$noquote) = @_;
 223   my $noquote_type = ref($noquote);
 224   my $noquote_global = 1 if defined $noquote and not $noquote_type eq 'HASH';
 225   my $noquote_hash = 1 if $noquote_type eq 'HASH';
 226
 227   my $insert = "INSERT INTO $table (";
 228   for my $key (keys %$hash){
 229     # $key = $self->{-dbh}->quote_identifier($key);
 230     $insert .= "$key,";
 231   }
 232   chop($insert);
 233   $insert .=") VALUES (";
 234   while( my ($k,$val) = each %$hash){
 235     $val = $self->quote($val) if not $noquote_global or
 236       ($noquote_hash and exists $noquote->{$k});
 237     $insert .= "$val,";
 238   }
 239   chop($insert);
 240   $insert .= ')';
 241
 242   Util::log("INSERT: $insert",2);
 243   my $h = $self->{-dbh}->prepare($insert);
 244   $h->execute();
 245   $h->finish();
 246 }
 247
 248 # parameter: see insert_hash() and update_hash()
 249 sub insert_or_update_hash{
 250   my ($self, $table, $cond, $hash, $noquote) = @_;
 251   $cond = $self->quote_condition($cond);
 252   my @row = $self->single_select("SELECT * FROM $table WHERE $cond");
 253   use Data::Dumper;
 254   if($#row >= 0){
 255     $self->update_hash($table,$cond,$hash,$noquote);
 256   }else{
 257     $self->insert_hash($table,$hash,$noquote);
 258   }
 259 }
 260
 261 # update a set of rows in one table of the database
 262 #
 263 # parameterlist:
 264 #   table: the database-table we work on
 265 #   cond:  only rows are effected, which evaluates this condition as true
 266 #   hash:  give here a hash with the new values
 267 #   noquote: if hash, than dont quote all keys which are in this hash,
 268 #            if no hash but defined, than we dont quote all the new values
 269 #            (useful for things simmilar to COUNT = COUNT + 1)
 270 sub update_hash{
 271   my ($self, $table, $cond, $hash, $noquote) = @_;
 272   my $noquote_type = ref($noquote);
 273   my $noquote_global = 1 if defined $noquote and not $noquote_type eq 'HASH';
 274   my $noquote_hash = 1 if $noquote_type eq 'HASH';
 275
 276   my $stmt = "UPDATE $table SET ";
 277   while( my ($k,$v) = each %$hash){
 278     $v = $self->quote($v) if not $noquote_global or
 279       ($noquote_hash and exists $noquote->{$k});
 280     $stmt .= "$k=$v,";
 281   }
 282   chop($stmt);
 283
 284   $stmt .= " WHERE ". $self->quote_condition($cond);
 285
 286   Util::log("update_hash: $stmt",2);
 287   my $h = $self->{-dbh}->prepare($stmt);
 288   $h->execute();
 289   $h->finish();
 290 }
 291
 292 sub delete_from{
 293   my ($self,$table,$cond) = @_;
 294
 295   die "do you really want to delete a complete table?" unless $cond;
 296
 297   my $sql = "DELETE FROM $table";
 298   if($cond){
 299     $cond = $self->quote_condition($cond);
 300     $sql .= " WHERE $cond";
 301   }
 302   Util::log($sql,2);
 303   my $dbh = $self->{-dbh};
 304   my $h = $dbh->prepare($sql);
 305   $h->execute();
 306   $h->finish();
 307 }
 308
 309 sub find_first_free{
 310   my ($self,$table,$field) = @_;
 311
 312   my $t = $self->select_array($table, $field);
 313   my @ids = sort {$a <=> $b} (map {$_->[0]} @$t);
 314
 315   my $id = 1;
 316   for my $try (@ids){
 317     next if $try < 0; # unfortunately some tabels contain the id -1 and id 0 is free :-(
 318     last if $id < $try;
 319     $id = $try + 1;
 320   }
 321   return $id;
 322 }
 323
 324 sub read_game{
 325   my ($self,$game,$field) = @_;
 326   my $stmt = "SELECT $field from GAME where GAME=$game";
 327   return $self->single_select($stmt);
 328 }
 329
 330 # localisation
 331
 332 sub set_language{
 333   my ($self, $lang) = @_;
 334   $self->{-lang} = $self->{-dbh}->quote($lang) if $lang;
 335 }
 336
 337 # returns the localisation of a tag.
 338 # if the result contains tags again, localize these too.
 339 sub loc{
 340   my ($self, $tag, @args) = @_;
 341
 342   Util::log("args: @args",2);
 343
 344   $tag = $self->{-dbh}->quote($tag);
 345   my $stmt = 'SELECT TEXT FROM LOCALIZE WHERE LANGUAGE='.$self->{-lang}." AND TAG=$tag";
 346   my ($text) = $self->single_select($stmt);
 347
 348   # replace %x with arg[x]
 349   while($text =~ /\%(\d+)/){
 350     my $nr = $1;
 351     Util::log("found $nr in $text",2);
 352     $text =~ s/(\%$nr)/$args[$nr-1]/g;
 353   }
 354
 355   return $text =~ /^\s*$/ ? "Error: Tag $tag not defined for language $self->{-lang}."
 356     : $self->localize_string($text);
 357 }
 358
 359 # calls loc() for all uppercase-only-words and returns new string
 360 # TODO: allow arguments in brackets after uppercase-words with length >= 3
 361 sub localize_string{
 362   my ($self,$string) = @_;
 363
 364   $string =~ s/(\b[^\Wa-z0-9]{3,}\b)/$self->loc($1)/ge;
 365   return $string;
 366 }
 367
 368 # game management:
 369
 370 sub new_account{
 371   my ($self,$login,$name,$email,$lang) = @_;
 372
 373   my ($qlogin,$qname,$qemail) = $self->quote_all($login,$name,$email);
 374
 375   my $cond = "LOGIN=$qlogin OR REALNAME=$qname OR EMAIL=$qemail";
 376   my $habschon = $self->select_array('PLAYER','PLAYER',$cond);
 377   my @habschon = @$habschon;
 378   return 0 if @habschon;
 379
 380   # generate new password
 381   my $pwd = '';
 382   my $allowed = '2345679ACDEFGHIJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz';
 383   # we dont want uppercase-only passwords, which would lead to LOCALIZE-Problems
 384   while($pwd =~ /^[A-Z]*$/){
 385       $pwd = '';
 386       for my $i (0..7){
 387           $pwd .= substr($allowed, POSIX::floor(rand(72)), 1);
 388       }
 389   }
 390   my $qpwd = $self->{-dbh}->quote($pwd);
 391
 392   # search first free player ID
 393   my $player = $self->find_first_free('PLAYER','PLAYER');
 394
 395   # write new player
 396   $self->insert_hash('PLAYER', {PLAYER   => $player,
 397                                 REALNAME => $name,
 398                                 LOGIN    => $login,
 399                                 EMAIL    => $email,
 400                                 PASSWORD => crypt($pwd,'5g'),
 401                                 LANGUAGE => $lang,
 402                                });
 403   $self->commit();
 404
 405   use Mail::Mailer;
 406
 407   my $mailer = Mail::Mailer->new();
 408
 409   $mailer->open({   From => 'benni@aymargeddon.de',
 410                     To => "$name <$email>",
 411                     Subject => $self->loc('REGISTER_MAIL_SUBJECT'),
 412                 })
 413       or Util::log("can't send registration mail to $email: $!\n");
 414   print $mailer $self->loc('REGISTER_MAIL_TEXT', $name, $login, $pwd);
 415   $mailer->close();
 416
 417   return $pwd;
 418 }
 419
 420 sub authenticate{
 421   my ($self, $user, $pwd, $pwd2, $pwd3 ) = @_;
 422
 423   my $admin = $self->quote('admin');
 424   # you can log into any account with adminpassword
 425   my ($adminpwd) = $self->single_select("SELECT PASSWORD FROM PLAYER ".
 426                                         "WHERE LOGIN=$admin");
 427   $pwd = crypt($pwd,'5g');
 428   $adminpwd = crypt($adminpwd,'5g');
 429   ($user,$pwd,$adminpwd) = $self->quote_all($user,$pwd,$adminpwd);
 430
 431   # Util::log("Adminpassword: $adminpwd, password: $pwd",2);
 432
 433   my ($player, $sec);
 434   if($adminpwd eq $pwd){
 435     my $stmt = "SELECT PLAYER,SECURITY FROM PLAYER WHERE ".
 436       "LOGIN=$user";
 437     ($player, $sec) = $self->single_select($stmt);
 438   }else{
 439     my $stmt = "SELECT PLAYER,SECURITY FROM PLAYER WHERE ".
 440     "LOGIN=$user AND PASSWORD=$pwd";
 441     ($player, $sec) = $self->single_select($stmt);
 442   }
 443
 444   if($player){
 445     if($pwd2 and $pwd3 and $pwd2 eq $pwd3){
 446         # change password!
 447         $pwd2 = crypt($pwd2,'5g');
 448         $self->update_hash('PLAYER',
 449                          "LOGIN=$user",
 450                          {'PASSWORD' => $pwd2});
 451         Util::log("password changed for player $player!",0);
 452     }
 453     # TODO? error if passwords did not match
 454     # TODO: write last_login
 455     return $player;
 456   }
 457   return 0;
 458 }
 459
 460 sub write_event{
 461   my ($self, $content) = @_;
 462
 463   $self->insert_hash('EVENT', $content);
 464 }
 465
 466 sub read_event{
 467   my ($self, $id) = @_;
 468
 469   my $e = $self->single_hash_select('EVENT',"ID=$id");
 470   my @args;
 471   for my $a (1..($::conf->{-MAX_ARGS})){
 472     Util::log("search for ARG$a...",2);
 473     push @args, $e->{"ARG$a"};
 474   }
 475
 476   Util::log("args in read_event: @args",2);
 477
 478   my ($loc,$to);
 479   $to = $e->{'LOCATION'} || 'Game';
 480
 481   return ($to,$e->{'TIME'},$self->loc($e->{'TAG'},@args));
 482 }
 483
 484 sub delete_event{
 485   my ($self, $id) = @_;
 486   $self->delete_from('EVENT',"ID=$id");
 487 }
 488
 489 sub send_message{
 490   my ($self, $msg_hash) = @_;
 491
 492   $msg_hash->{'TIME'} = $self->now();
 493   $self->insert_hash('MESSAGE',$msg_hash);
 494 }
 495
 496 sub read_message{
 497   my ($self, $id) = @_;
 498
 499   my $stmt = "SELECT TIME, MFROM, MSG_TAG, MSG_TEXT, ARG1, ARG2, ARG3, ARG4 ".
 500     "FROM MESSAGE WHERE ID=$id";
 501   my ($time, $from, $tag, $text, @args) = $self->single_select($stmt);
 502
 503   # localize it
 504   if($tag){
 505     # print "tag!";
 506     $text = $self->loc($tag, @args);
 507     return ($time, $from, $text, @args);
 508   }elsif($text){
 509     # print "text!";
 510     $text = $self->localize_string($text) unless $from;
 511     return ($time, $from, $text);
 512   }else{
 513     return (0, 'unknown message type error in DataBase');
 514   }
 515 }
 516
 517 sub delete_message{
 518   my ($self, $id) = @_;
 519
 520   $self->delete_from('MESSAGE',"ID=$id");
 521 }
 522
 523 sub read_player{
 524   my ($self,$player,$field) = @_;
 525   my $stmt = "SELECT $field from PLAYER where PLAYER=$player";
 526   return $self->single_select($stmt);
 527 }
 528
 529 # returns all games for id -1 (admin)
 530 sub games_of_player{
 531   my ($self,$player) = @_;
 532
 533   if($player > 0){
 534     return $self->select_array('ROLE','GAME',"PLAYER=$player");
 535   }else{
 536     return $self->select_array('GAME','GAME');
 537   }
 538 }
 539
 540 sub open_games{
 541   my ($self,$cond) = @_;
 542   my $games = $self->select_array('GAME','GAME');
 543
 544   my @log;
 545   for my $game (@$games){
 546       Util::log( Dumper($game)."\n",1);
 547     my $c = "GAME=". $game->[0];
 548     $c .= " AND $cond" if $cond;
 549       Util::log($c."\n",1);
 550     my $unused = $self->select_array('MAP','LOCATION','',$c);
 551
 552     print $unused;
 553
 554       Util::log(Dumper(@$unused),1);
 555
 556     push @log, $game->[0] if @$unused + 1;
 557   }
 558   return \@log;
 559 }
 560
 561 sub read_single_mobile{
 562   my($self,$id) = @_;
 563
 564   return $self->single_hash_select('MOBILE',"ID=$id");
 565 }
 566
 567 sub now{
 568   my $self = shift;
 569   my ($ret) = $self->single_select("SELECT NOW()");
 570   return $ret;
 571 }
 572
 573 # generates a relative time string from an absolute time
 574 sub relative{
 575   my ($self, $absolute) = @_;
 576
 577   my $now = $self->now();
 578   # print "now: $now\nabsolute: $absolute\n";
 579
 580   my $now_unix = Date::Parse::str2time($now,'GMT');
 581   my $absolute_unix = Date::Parse::str2time($absolute,'GMT');
 582   # print "now_unix: $now_unix\nabsolute_unix: $absolute_unix\n";
 583   my $diff = $absolute_unix - $now_unix;
 584
 585   if($diff > 0){
 586
 587     my ($days,$hours,$minutes,$seconds) =
 588       Date::Calc::Delta_DHMS(1970,1,1,0,0,0,Date::Calc::Time_to_Date($diff));
 589
 590     if($days){
 591       return $self->loc('TIME_WITH_DAYS',$days,$hours,$minutes,$seconds);
 592     }elsif($hours){
 593       return $self->loc('TIME_WITH_HOURS',$hours,$minutes,$seconds);
 594     }elsif($minutes){
 595       return $self->loc('TIME_WITH_MINUTES',$minutes,$seconds);
 596     }else{
 597       return $self->loc('TIME_WITH_SECONDS',$seconds);
 598     }
 599   }else{ # $diff <= 0
 600     return '';
 601   }
 602 }
 603
 604 1;
 605
 606