server/ext/login.ext

#! perl # mandatory depends=highscore

# login handling

use Fcntl;
use Coro::AIO;
use Deliantra::Util ();

CONF MAX_DISCONNECT_TIME = 3600;

our $VALID_LOGIN = qr<^[a-zA-Z0-9][a-zA-Z0-9\-_]{2,19}\z>;
our %LOGIN_LOCK;

# utility function to send messages to the client before
# we have a player object to format them for. does not
# escape anything.
sub send_log ($$$) {
   $_[0]->send_packet ("msg $_[2] log $_[1]");
}

sub query {
   my ($ns, $flags, $text) = @_;

   $ns->query ($flags, $text, Coro::rouse_cb);
   Coro::rouse_wait
}

sub can_cleanup {
   # highscore list is not cleared out, rethink
   # also, admin accounts can be hacked this way, if unused for long.
   return 0;

   my ($pl, $mtime) = @_;

   my $age = time - $mtime;
   my $level = $pl->ob->level;

   ($level <= 3 && $age > 7 * 86400)            # 7 days for level 0..3
   || ($level <= 9 && $age > 90 * 86400)        # 3 months for level 4..9
   || ($level <= 20 && $age > 180 * 86400)      # 6 months for level 10..20
   #|| $age > 700 * 86400                        # 2 years for everybody else
}

# return a guard object for a lock on the given username, if available
sub login_guard {
   my ($user) = @_;

   exists $LOGIN_LOCK{$user}
      and return undef;

   cf::player::find_active $user
      and return undef;

   undef $LOGIN_LOCK{$user};
   Guard::guard { delete $LOGIN_LOCK{$user} }
}

sub safe_spot($) {
   my ($pl) = @_;
   
   my $ob = $pl->ob;

   my $m = $ob->map
      or return;
   my $x = $ob->x;
   my $y = $ob->y;

   # never happens normally, but helps when shell users make mistakes
   $m->linkable
      or return 1;

   scalar grep $_->type == cf::SAVEBED, $m->at ($x, $y)
}

sub enter_map {
   my ($pl) = @_;

   my $ob = $pl->ob;

   my ($map, $x, $y)
      = $ob->{_link_pos}
        ? @{delete $ob->{_link_pos}}
        : ($pl->maplevel, $ob->x, $ob->y);

   $ob->enter_link;

   my $m = cf::map::find $map;
   my $time = delete $pl->{unclean_save};

   if ($time && $m) {
      if ($time < $m->{instantiate_time}) {
         # the map was reset in the meantime
         my $age = $cf::RUNTIME - $time;

         cf::info $ob->name, " map reset after logout, logout age $age (>= $MAX_DISCONNECT_TIME)\n";#d#

         if ($age >= $MAX_DISCONNECT_TIME) {
            $ob->message (
               "You didn't use a bed to reality to leave this realm, leaving your body in great danger. "
             . "Unfortunately, nobody was near to help you when the monsters arrived to eat you. "
             . "Maybe you can find comfort in the thought that your body was quite satisfying in taste... "
             . "H<You disconnected too long without having used a savebed.>",
               cf::NDI_RED | cf::NDI_REPLY
            );
            # kill them.
            # reminds me of the famous badness 10000 syndrome...
            $ob->stats->hp (-10000); #] if they survive this they deserved to live
            my $killer = cf::arch::get "killer_login"; $pl->killer ($killer); $killer->destroy;
         } else {
            ($map, $x, $y) = $pl->savebed;

            $ob->message (
               "You didn't use a bed to reality to leave this realm, leaving your body in great danger. "
             . "Fortunately, some friendly dwellers found you, checked your passport, and brought you to safety. "
             . "Better use a savebed next time, much worse things could have happened... "
             . "H<You disconnected without having used a savebed. When you do that for too long, you might die.>",
               cf::NDI_RED | cf::NDI_REPLY
            );
         }
      } else {
         $ob->message (
            "You didn't use a bed to reality to leave this realm. This is very dangerous, "
          . "as lots of things could happen when you leave by other means, such as cave-ins, "
          . "or monsters suddenly snapping your body. Better use a savebed next time. "
          . "H<Always apply a bed of reality to disconnect from the server.>",
            cf::NDI_RED | cf::NDI_REPLY
         );
      }
   }

   $ob->goto ($map, $x, $y);
}

sub encode_password($) {
   unpack "H*", Deliantra::Util::hash_pw $_[0]
}

sub compare_password($$) {
   my ($pass, $token) = @_;

   if ($token =~ /!!(.*)/) {
      return +(substr $pass, 0, 8) eq pack "H*", $1;
   } elsif ($token =~ /!(.*)/) {
      return $pass eq pack "H*", $1;
   } else {
      return $token eq encode_password $pass;
   }
}

# delete a player directory
sub nuke_playerdir {
   my ($user) = @_;

   my $lock = cf::lock_acquire "ext::login::nuke_playerdir";

   my $temp = "$PLAYERDIR/~$Coro::current~deleting~";
   aio_rename "$PLAYERDIR/$user", $temp;
   IO::AIO::aio_rmtree $temp;
}

sub login {
   my ($pl) = @_;

   # handle character creation, if neccessary
   # the rest of this function is character creation

   my $ns = $pl->ns;
   my $ob = $pl->ob;

   if ($pl->{chargen} eq "init") {
      $ob->goto ($pl->maplevel, $ob->x, $ob->y);

      # create the playerdir, if necessary, as chargen_race_done did it before
      # presumably because of unique maps
      aio_mkdir playerdir $pl, 0770;
      delete $pl->{deny_save}; # set by new
      $pl->save;

      $pl->{chargen} = "stats";
   }

   if ($pl->{chargen} eq "stats") {
      while () {
         $ob->update_stats;
         $pl->save_stats;

         my $res = query $ns, cf::CS_QUERY_SINGLECHAR,
                      "[y] to roll new stats [n] to use stats\n[1-7] [1-7] to swap stats.\nRoll again (y/n/1-7)?";

         if ($res =~ /^[Nn]/) {
            last;
         } elsif ($res > 0 && $res <= 7) {
            my $swap = query $ns, cf::CS_QUERY_SINGLECHAR, "Swap stat with (will not roll new stats) [1-7]?";

            if ($swap > 0 && $swap <= 7) {
               $ob->swap_stats ($res - 1, $swap - 1);
            }
         } else {
            $ob->roll_stats;
         }

         Coro::Timer::sleep 0.05;
      }

      $ob->set_anim_frame (2);
      $ob->add_statbonus;

      $pl->{chargen} = "race";
   }

   if ($pl->{chargen} eq "race") {
      while () {
         $ns->send_msg ("chargen-race-title", ucfirst $pl->title, -1);
         my $msg = $ob->msg;
         $msg =~ s/(?<=\S)\n(?=\S)/ /g;
         $ns->send_msg ("chargen-race-description", $msg, cf::NDI_BLUE);

         my $res = query $ns, cf::CS_QUERY_SINGLECHAR,
                      "Now choose a character.\nPress any key to change outlook.\nPress `d' when you're pleased.\n";

         last if $res =~ /[dD]/;

         $pl->chargen_race_next;
         Coro::Timer::sleep 0.05;
      }

      $pl->chargen_race_done;
      $pl->{chargen} = "gender";
   }

   if ($pl->{chargen} eq "race") {
      while () {
         my $res = query $ns, cf::CS_QUERY_SINGLECHAR,
                      "Now choose a gender.\nPress 'f' to become female, and 'm' to become male.\n";

         if ($res =~ /^[fF]/) {
            $pl->gender (1);
            last;
         } elsif ($res =~ /^[mM]/) {
            $pl->gender (0);
            last;
         }
         Coro::Timer::sleep 0.05;
      }
      $pl->{chargen} = "done";
   }

   $ns->state (cf::ST_PLAYING);

   if ($pl->{chargen} eq "done") {
      # XXX: Workaround for delayed client ext protocol handshake
      $pl->esrv_new_player;

      $pl->{chargen} = "done";
   }

   $ns->update_command_faces;

   $ob->reply (undef, "Welcome to Deliantra!");

   if (0 < Coro::AIO::aio_load "$cf::CONFDIR/motd", my $motd) {
      $pl->ns->send_msg ("c/motd" => $motd, cf::NDI_CLEAR);
   }
}

sub chargen {
   my ($ns, $user, $hash) = @_;

   # just to make sure nothing is left over
   # normally, nothing is there.
   nuke_playerdir $user;

   my $pl = cf::player::new $user;
   $pl->password (unpack "H*", $hash);
   $pl->connect ($ns);

   $pl->{chargen} = "init";

   login $pl;
}

cf::client->attach (on_addme => sub {
   my ($ns) = @_;

   $ns->{addme}++ and return $ns->destroy;

   $ns->async (sub {
      $Coro::current->{desc} = "addme init";

      my ($user, $pass);

      $ns->send_packet ("addme_success");

      for (;;) {
         delete $ns->{login_guard};

         send_log $ns,
            "Please enter your username now. If you are a new user, "
          . "make one up that describes your character best. "
          . "Only letters and digits are allowed, though.",
            cf::NDI_BLUE | cf::NDI_REPLY
         ;

         # read username
         while () {
            $user = query $ns, 0, "What is your name? (login names are case-sensitive)\n:";

            if ($user =~ $VALID_LOGIN) {
               last;
            } else {
               send_log $ns,
                  "Your username contains illegal characters "
                . "(only a-z, A-Z and 0-9 are allowed), "
                . "or is not between 3 and 20 characters in length.",
                  cf::NDI_RED | cf::NDI_REPLY
               ;
            }
            Coro::Timer::sleep 0.4;
         }

         $Coro::current->{desc} = "addme($user)";

         send_log $ns,
            "Welcome $user, please enter your password now. "
          . "New users should now choose a password. "
          . "Anything your client lets you enter is fine.",
            cf::NDI_BLUE | cf::NDI_REPLY
         ;

         # read password
         while () {
            $pass = query $ns, cf::CS_QUERY_HIDEINPUT, "What is your password?\n:";
            last if $pass =~ /.../;
            send_log $ns,
               "Try to use at least three characters as your password please, "
             . "that cannot be too much to ask for :)",
               cf::NDI_RED | cf::NDI_REPLY
            ;
            Coro::Timer::sleep 0.4;
         }

         $ns->{login_guard} = login_guard $user
            or do {
               send_log $ns,
                  "That user is already logged in (or is logging in)."
                . "Chose another, or wait till the other session has ended.",
                  cf::NDI_RED | cf::NDI_REPLY
               ;
               next;
            };

         # try to read the user file and check the password
         if (my $pl = cf::player::find $user) {
            aio_stat $pl->path and next;
            my $mtime = (stat _)[9];
            my $token = $pl->password;

            if ($cf::CFG{ext_login_nocheck} or compare_password $pass, $token) {
               # player exists and passwords match - we can proceed

               # password matches, wonderful
               my $pl = cf::player::find $user or next;
               $pl->connect ($ns);
               enter_map $pl;
               login $pl;
               return;
            } elsif (can_cleanup $pl, $mtime) {
               Coro::Timer::sleep 1;

               send_log $ns,
                  "Player exists, but password does not match. If this is your account, "
                . "please try again. If not, you can now decide to take over this account "
                . "because it has not been in-use for some time.",
                  cf::NDI_RED | cf::NDI_REPLY
               ;

               (query $ns, cf::CS_QUERY_SINGLECHAR, "Delete existing account and create a new one (Y/N)?") =~ /^[yY]/
                  or next;

               # check if the file hasn't changed
               aio_stat cf::player::path $user and next;
               $mtime == (stat _)[9] or next;

               $pl->quit_character;

               # fall through to creation
            } else {
               Coro::Timer::sleep 1;

               send_log $ns,
                  "Wrong username or password. Please try again "
                . "(check for Numlock and other semi-obvious error sources).",
                  cf::NDI_RED | cf::NDI_REPLY
               ;
               next;
            }
         } else {
            # unable to load the playerfile:
            # check whether the player dir exists, which means the file is corrupted or
            # something very similar.
            if (!aio_stat cf::player::playerdir $user) {
               send_log $ns,
                  "Unable to retrieve this player. It might be a locked or broken account. "
                . "If this is your account, ask a dungeon master for assistance. "
                . "Otherwise choose a different login name.",
                  cf::NDI_RED | cf::NDI_REPLY
               ;
               next;
            }
         }

         my $pass2 = query $ns, cf::CS_QUERY_HIDEINPUT, "Please type your password again.";

         if ($pass2 ne $pass) {
            send_log $ns,
               "The passwords do not match, please try again.",
               cf::NDI_RED | cf::NDI_REPLY
            ;
            Coro::Timer::sleep 0.5;
            next;
         }

         last;
      }

      chargen $ns, $user, Deliantra::Util::hash_pw $pass;
   });
});

cf::client->attach (
   on_version => sub {
      my ($ns, $arg) = @_;

      # perl probably uses lrand48, which is not secure at all
      # maybe require linux and use /dev/urandom.
      $ns->{nonces} = [map { join "", map { chr rand 256 } 0..63  } 1..2];
      $ns->ext_msg (nonces => @{ $ns->{nonces} });
   },
);

cf::register_async_exticmd create_login => sub {
   my ($ns, $reply, $user, $pass) = @_;

   $ns->{addme}++ and return $ns->destroy;

   $ns->async (sub {
      my $fail = sub {
         $reply->(0, $_[0]);
         $ns->flush; # does not ensure that the data reaches the client - TODO
         # need to do this in another thread, as this one gets canceled
         Coro::async_pool {
            Coro::AnyEvent::sleep 0.1; # TODO, see above, extra hack
            $ns->destroy if $ns->valid;
         };
         Coro::schedule; # do the destroy, should not return
      };

      $user =~ $VALID_LOGIN
         or return $fail (
               "Your username contains illegal characters (only a-z, A-Z and 0-9 are allowed), "
             . "or is not between 3 and 20 characters in length."
            );

      $ns->{login_guard} = login_guard $user
         or return $fail->("User name '$user' is in use - try another login name.");

      cf::player::find $user
         and return $fail->("User name '$user' is already registered - choose another login name.");

      $reply->(1, "Account Created");

      chargen $ns, $user, $pass;
   });
};

cf::register_async_exticmd login => sub {
   my ($ns, $reply, $user, $hash) = @_;

   $ns->{addme}++ and return $ns->destroy;

   $ns->async (sub {
      $Coro::current->{desc} = "login($user)";

      my $fail = sub {
         $reply->(0, $_[0]);
         $ns->flush; # does not ensure that the data reaches the client - TODO
         # need to do this in another thread, as this one gets canceled
         Coro::async_pool {
            Coro::AnyEvent::sleep 0.1; # TODO, see above, extra hack
            $ns->destroy if $ns->valid;
         };
         Coro::schedule; # do the destroy, should not return
      };

      $ns->{login_guard} = login_guard $user
         or return $fail->("User '$user' is currently playing or logging in in another session. If that is your "
                           . "user name, make sure you are not running two clients. When in doubt, reboot.");

      # try to read the user file and check the password
      my $pl = cf::player::find $user
         or return $fail->("User '$user' does not exist - wrong spelling?");

      aio_stat $pl->path
         and return $ns->destroy;

      my $mtime = (stat _)[9];
      my $token = $pl->password;

      $token = $token =~ /^!/
               ? Deliantra::Util::hash_pw pack "H*", substr $token, 1
               : pack "H*", $token;

      $token = Deliantra::Util::auth_pw $token, $ns->{nonces}[0], $ns->{nonces}[1];

      $token eq $hash
         or $cf::CFG{ext_login_nocheck}
         or return $fail->("User exists, but the password doesn't match - check your spelling, NumLock/CapsLock etc.");
      
      # player exists and passwords match - we can proceed

      $reply->(1, "Success");

      $pl->connect ($ns);
      enter_map $pl;
      login $pl;
   });
};

cf::register_command password => sub {
   my ($pl, $arg) = @_;

   unless ($pl->flag (cf::FLAG_WIZ)) {
      $pl->message (
         "The password can currently only changed by a DM.",
         cf::NDI_UNIQUE | cf::NDI_REPLY);
      return;
   }

   $pl->message (#d#
      "Passwords cannot currently be changed.",#d#
      cf::NDI_UNIQUE | cf::NDI_REPLY);#d#
   return;#d#

   my (@args) = split /\s+/, $arg;
   my ($player, $new_pw) = @args;

   if ($pl->flag (cf::FLAG_WIZ) && $player eq '') {
      $pl->message (
         "Usage: password <player> [<new password>]",
         cf::NDI_UNIQUE | cf::NDI_REPLY);
      return;
   }

   if ($new_pw eq '') {
      $new_pw =
         join '',
            map { ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[(cf::rndm 64)] }
               1..9;
   }

   cf::async {
      my $plc = cf::player::find $player;
      if ($plc) {
         $plc->password (encode_password $new_pw);
         $pl->message (
            "Ok, changed password of '$player' to '$new_pw'!",
            cf::NDI_UNIQUE | cf::NDI_RED | cf::NDI_REPLY);
      } else {
         $pl->message (
            "Fail! Couldn't set password for '$player', "
            . "he doesn't seem to exist!",
            cf::NDI_UNIQUE | cf::NDI_RED | cf::NDI_REPLY);
      }
   };
};

cf::register_command quit => sub {
   my ($ob, $arg) = @_;

   $ob->send_msg (undef,
                  "Quitting will delete your character PERMANENTLY: It will be gone forever and any progress will be lost. "
                  . "If you are sure you want to do this, then use the quit_character command instead of quit.",
                  cf::NDI_UNIQUE | cf::NDI_RED | cf::NDI_REPLY);
};

cf::register_command quit_character => sub {
   my ($ob, $arg) = @_;

   my $pl = $ob->contr;

   $pl->ns->query (cf::CS_QUERY_SINGLECHAR, "Do you want to PERMANENTLY delete your character and all associated data (y/n)?", sub {
      if ($_[0] !~ /^[yY]/) {
         $ob->send_msg (undef, "Ok, not not quitting then.", cf::NDI_UNIQUE | cf::NDI_RED | cf::NDI_REPLY);
      } else {
         $ob->send_msg (undef, "Ok, quitting, hope to see you again.", cf::NDI_UNIQUE | cf::NDI_RED | cf::NDI_REPLY);
         cf::async {
            $pl->quit_character;
         };
      }
   });
};

cf::object->attach (
   type     => cf::SAVEBED,
   on_apply => sub {
      my ($bed, $ob) = @_;

      return cf::override 0 unless $ob->type == cf::PLAYER;

      my $pl = $ob->contr;

      # update respawn position
      $pl->savebed ($bed->map->path, $bed->x, $bed->y);

      cf::async {
         my $killer = cf::arch::get "killer_logout"; $pl->killer ($killer); $killer->destroy;
         ext::highscore::check $ob;

         $pl->save;

         $ob->send_msg ($cf::SAY_CHANNEL => "In the future, you will wake up here when you die.", cf::NDI_DEF | cf::NDI_REPLY);

         my $ns = $pl->ns
            or return;

         $ns->query (cf::CS_QUERY_SINGLECHAR, "Do you want to continue playing (y/n)?", sub {
            if ($_[0] !~ /^[yY]/) {
               $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1);
               $pl->deactivate;
               $pl->ns->destroy;
            }
         });
      };
   },
);

cf::player->attach (
   on_login  => sub {
      my ($pl) = @_;
      my $name = $pl->ob->name;

      $_->ob->message ("$name has entered the game.", cf::NDI_DK_ORANGE | cf::NDI_UNIQUE) for cf::player::list;
   },
   on_logout => sub {
      my ($pl, $cleanly) = @_;
      my $name = $pl->ob->name;

      if ($cleanly) {
         $_->ob->message ("$name left the game.", cf::NDI_DK_ORANGE | cf::NDI_UNIQUE) for cf::player::list;
      } else {
         $_->ob->message ("$name uncerimoniously disconnected.", cf::NDI_DK_ORANGE | cf::NDI_UNIQUE) for cf::player::list;
         $pl->{unclean_save} = $cf::RUNTIME
            unless safe_spot $pl;
      }
   },
);

Revision:	1.137
Committed:	Mon Dec 19 21:21:10 2022 UTC (16 months, 3 weeks ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.136:	+1 -1 lines
Log Message:	* empty log message *
#	Content
1	#! perl # mandatory depends=highscore
2
3	# login handling
4
5	use Fcntl;
6	use Coro::AIO;
7	use Deliantra::Util ();
8
9	CONF MAX_DISCONNECT_TIME = 3600;
10
11	our $VALID_LOGIN = qr<^[a-zA-Z0-9][a-zA-Z0-9\-_]{2,19}\z>;
12	our %LOGIN_LOCK;
13
14	# utility function to send messages to the client before
15	# we have a player object to format them for. does not
16	# escape anything.
17	sub send_log ($$$) {
18	$_[0]->send_packet ("msg $_[2] log $_[1]");
19	}
20
21	sub query {
22	my ($ns, $flags, $text) = @_;
23
24	$ns->query ($flags, $text, Coro::rouse_cb);
25	Coro::rouse_wait
26	}
27
28	sub can_cleanup {
29	# highscore list is not cleared out, rethink
30	# also, admin accounts can be hacked this way, if unused for long.
31	return 0;
32
33	my ($pl, $mtime) = @_;
34
35	my $age = time - $mtime;
36	my $level = $pl->ob->level;
37
38	($level <= 3 && $age > 7 * 86400) # 7 days for level 0..3
39	\|\| ($level <= 9 && $age > 90 * 86400) # 3 months for level 4..9
40	\|\| ($level <= 20 && $age > 180 * 86400) # 6 months for level 10..20
41	#\|\| $age > 700 * 86400 # 2 years for everybody else
42	}
43
44	# return a guard object for a lock on the given username, if available
45	sub login_guard {
46	my ($user) = @_;
47
48	exists $LOGIN_LOCK{$user}
49	and return undef;
50
51	cf::player::find_active $user
52	and return undef;
53
54	undef $LOGIN_LOCK{$user};
55	Guard::guard { delete $LOGIN_LOCK{$user} }
56	}
57
58	sub safe_spot($) {
59	my ($pl) = @_;
60
61	my $ob = $pl->ob;
62
63	my $m = $ob->map
64	or return;
65	my $x = $ob->x;
66	my $y = $ob->y;
67
68	# never happens normally, but helps when shell users make mistakes
69	$m->linkable
70	or return 1;
71
72	scalar grep $_->type == cf::SAVEBED, $m->at ($x, $y)
73	}
74
75	sub enter_map {
76	my ($pl) = @_;
77
78	my $ob = $pl->ob;
79
80	my ($map, $x, $y)
81	= $ob->{_link_pos}
82	? @{delete $ob->{_link_pos}}
83	: ($pl->maplevel, $ob->x, $ob->y);
84
85	$ob->enter_link;
86
87	my $m = cf::map::find $map;
88	my $time = delete $pl->{unclean_save};
89
90	if ($time && $m) {
91	if ($time < $m->{instantiate_time}) {
92	# the map was reset in the meantime
93	my $age = $cf::RUNTIME - $time;
94
95	cf::info $ob->name, " map reset after logout, logout age $age (>= $MAX_DISCONNECT_TIME)\n";#d#
96
97	if ($age >= $MAX_DISCONNECT_TIME) {
98	$ob->message (
99	"You didn't use a bed to reality to leave this realm, leaving your body in great danger. "
100	. "Unfortunately, nobody was near to help you when the monsters arrived to eat you. "
101	. "Maybe you can find comfort in the thought that your body was quite satisfying in taste... "
102	. "H<You disconnected too long without having used a savebed.>",
103	cf::NDI_RED \| cf::NDI_REPLY
104	);
105	# kill them.
106	# reminds me of the famous badness 10000 syndrome...
107	$ob->stats->hp (-10000); #] if they survive this they deserved to live
108	my $killer = cf::arch::get "killer_login"; $pl->killer ($killer); $killer->destroy;
109	} else {
110	($map, $x, $y) = $pl->savebed;
111
112	$ob->message (
113	"You didn't use a bed to reality to leave this realm, leaving your body in great danger. "
114	. "Fortunately, some friendly dwellers found you, checked your passport, and brought you to safety. "
115	. "Better use a savebed next time, much worse things could have happened... "
116	. "H<You disconnected without having used a savebed. When you do that for too long, you might die.>",
117	cf::NDI_RED \| cf::NDI_REPLY
118	);
119	}
120	} else {
121	$ob->message (
122	"You didn't use a bed to reality to leave this realm. This is very dangerous, "
123	. "as lots of things could happen when you leave by other means, such as cave-ins, "
124	. "or monsters suddenly snapping your body. Better use a savebed next time. "
125	. "H<Always apply a bed of reality to disconnect from the server.>",
126	cf::NDI_RED \| cf::NDI_REPLY
127	);
128	}
129	}
130
131	$ob->goto ($map, $x, $y);
132	}
133
134	sub encode_password($) {
135	unpack "H*", Deliantra::Util::hash_pw $_[0]
136	}
137
138	sub compare_password($$) {
139	my ($pass, $token) = @_;
140
141	if ($token =~ /!!(.*)/) {
142	return +(substr $pass, 0, 8) eq pack "H*", $1;
143	} elsif ($token =~ /!(.*)/) {
144	return $pass eq pack "H*", $1;
145	} else {
146	return $token eq encode_password $pass;
147	}
148	}
149
150	# delete a player directory
151	sub nuke_playerdir {
152	my ($user) = @_;
153
154	my $lock = cf::lock_acquire "ext::login::nuke_playerdir";
155
156	my $temp = "$PLAYERDIR/~$Coro::current~deleting~";
157	aio_rename "$PLAYERDIR/$user", $temp;
158	IO::AIO::aio_rmtree $temp;
159	}
160
161	sub login {
162	my ($pl) = @_;
163
164	# handle character creation, if neccessary
165	# the rest of this function is character creation
166
167	my $ns = $pl->ns;
168	my $ob = $pl->ob;
169
170	if ($pl->{chargen} eq "init") {
171	$ob->goto ($pl->maplevel, $ob->x, $ob->y);
172
173	# create the playerdir, if necessary, as chargen_race_done did it before
174	# presumably because of unique maps
175	aio_mkdir playerdir $pl, 0770;
176	delete $pl->{deny_save}; # set by new
177	$pl->save;
178
179	$pl->{chargen} = "stats";
180	}
181
182	if ($pl->{chargen} eq "stats") {
183	while () {
184	$ob->update_stats;
185	$pl->save_stats;
186
187	my $res = query $ns, cf::CS_QUERY_SINGLECHAR,
188	"[y] to roll new stats [n] to use stats\n[1-7] [1-7] to swap stats.\nRoll again (y/n/1-7)?";
189
190	if ($res =~ /^[Nn]/) {
191	last;
192	} elsif ($res > 0 && $res <= 7) {
193	my $swap = query $ns, cf::CS_QUERY_SINGLECHAR, "Swap stat with (will not roll new stats) [1-7]?";
194
195	if ($swap > 0 && $swap <= 7) {
196	$ob->swap_stats ($res - 1, $swap - 1);
197	}
198	} else {
199	$ob->roll_stats;
200	}
201
202	Coro::Timer::sleep 0.05;
203	}
204
205	$ob->set_anim_frame (2);
206	$ob->add_statbonus;
207
208	$pl->{chargen} = "race";
209	}
210
211	if ($pl->{chargen} eq "race") {
212	while () {
213	$ns->send_msg ("chargen-race-title", ucfirst $pl->title, -1);
214	my $msg = $ob->msg;
215	$msg =~ s/(?<=\S)\n(?=\S)/ /g;
216	$ns->send_msg ("chargen-race-description", $msg, cf::NDI_BLUE);
217
218	my $res = query $ns, cf::CS_QUERY_SINGLECHAR,
219	"Now choose a character.\nPress any key to change outlook.\nPress `d' when you're pleased.\n";
220
221	last if $res =~ /[dD]/;
222
223	$pl->chargen_race_next;
224	Coro::Timer::sleep 0.05;
225	}
226
227	$pl->chargen_race_done;
228	$pl->{chargen} = "gender";
229	}
230
231	if ($pl->{chargen} eq "race") {
232	while () {
233	my $res = query $ns, cf::CS_QUERY_SINGLECHAR,
234	"Now choose a gender.\nPress 'f' to become female, and 'm' to become male.\n";
235
236	if ($res =~ /^[fF]/) {
237	$pl->gender (1);
238	last;
239	} elsif ($res =~ /^[mM]/) {
240	$pl->gender (0);
241	last;
242	}
243	Coro::Timer::sleep 0.05;
244	}
245	$pl->{chargen} = "done";
246	}
247
248	$ns->state (cf::ST_PLAYING);
249
250	if ($pl->{chargen} eq "done") {
251	# XXX: Workaround for delayed client ext protocol handshake
252	$pl->esrv_new_player;
253
254	$pl->{chargen} = "done";
255	}
256
257	$ns->update_command_faces;
258
259	$ob->reply (undef, "Welcome to Deliantra!");
260
261	if (0 < Coro::AIO::aio_load "$cf::CONFDIR/motd", my $motd) {
262	$pl->ns->send_msg ("c/motd" => $motd, cf::NDI_CLEAR);
263	}
264	}
265
266	sub chargen {
267	my ($ns, $user, $hash) = @_;
268
269	# just to make sure nothing is left over
270	# normally, nothing is there.
271	nuke_playerdir $user;
272
273	my $pl = cf::player::new $user;
274	$pl->password (unpack "H*", $hash);
275	$pl->connect ($ns);
276
277	$pl->{chargen} = "init";
278
279	login $pl;
280	}
281
282	cf::client->attach (on_addme => sub {
283	my ($ns) = @_;
284
285	$ns->{addme}++ and return $ns->destroy;
286
287	$ns->async (sub {
288	$Coro::current->{desc} = "addme init";
289
290	my ($user, $pass);
291
292	$ns->send_packet ("addme_success");
293
294	for (;;) {
295	delete $ns->{login_guard};
296
297	send_log $ns,
298	"Please enter your username now. If you are a new user, "
299	. "make one up that describes your character best. "
300	. "Only letters and digits are allowed, though.",
301	cf::NDI_BLUE \| cf::NDI_REPLY
302	;
303
304	# read username
305	while () {
306	$user = query $ns, 0, "What is your name? (login names are case-sensitive)\n:";
307
308	if ($user =~ $VALID_LOGIN) {
309	last;
310	} else {
311	send_log $ns,
312	"Your username contains illegal characters "
313	. "(only a-z, A-Z and 0-9 are allowed), "
314	. "or is not between 3 and 20 characters in length.",
315	cf::NDI_RED \| cf::NDI_REPLY
316	;
317	}
318	Coro::Timer::sleep 0.4;
319	}
320
321	$Coro::current->{desc} = "addme($user)";
322
323	send_log $ns,
324	"Welcome $user, please enter your password now. "
325	. "New users should now choose a password. "
326	. "Anything your client lets you enter is fine.",
327	cf::NDI_BLUE \| cf::NDI_REPLY
328	;
329
330	# read password
331	while () {
332	$pass = query $ns, cf::CS_QUERY_HIDEINPUT, "What is your password?\n:";
333	last if $pass =~ /.../;
334	send_log $ns,
335	"Try to use at least three characters as your password please, "
336	. "that cannot be too much to ask for :)",
337	cf::NDI_RED \| cf::NDI_REPLY
338	;
339	Coro::Timer::sleep 0.4;
340	}
341
342	$ns->{login_guard} = login_guard $user
343	or do {
344	send_log $ns,
345	"That user is already logged in (or is logging in)."
346	. "Chose another, or wait till the other session has ended.",
347	cf::NDI_RED \| cf::NDI_REPLY
348	;
349	next;
350	};
351
352	# try to read the user file and check the password
353	if (my $pl = cf::player::find $user) {
354	aio_stat $pl->path and next;
355	my $mtime = (stat _)[9];
356	my $token = $pl->password;
357
358	if ($cf::CFG{ext_login_nocheck} or compare_password $pass, $token) {
359	# player exists and passwords match - we can proceed
360
361	# password matches, wonderful
362	my $pl = cf::player::find $user or next;
363	$pl->connect ($ns);
364	enter_map $pl;
365	login $pl;
366	return;
367	} elsif (can_cleanup $pl, $mtime) {
368	Coro::Timer::sleep 1;
369
370	send_log $ns,
371	"Player exists, but password does not match. If this is your account, "
372	. "please try again. If not, you can now decide to take over this account "
373	. "because it has not been in-use for some time.",
374	cf::NDI_RED \| cf::NDI_REPLY
375	;
376
377	(query $ns, cf::CS_QUERY_SINGLECHAR, "Delete existing account and create a new one (Y/N)?") =~ /^[yY]/
378	or next;
379
380	# check if the file hasn't changed
381	aio_stat cf::player::path $user and next;
382	$mtime == (stat _)[9] or next;
383
384	$pl->quit_character;
385
386	# fall through to creation
387	} else {
388	Coro::Timer::sleep 1;
389
390	send_log $ns,
391	"Wrong username or password. Please try again "
392	. "(check for Numlock and other semi-obvious error sources).",
393	cf::NDI_RED \| cf::NDI_REPLY
394	;
395	next;
396	}
397	} else {
398	# unable to load the playerfile:
399	# check whether the player dir exists, which means the file is corrupted or
400	# something very similar.
401	if (!aio_stat cf::player::playerdir $user) {
402	send_log $ns,
403	"Unable to retrieve this player. It might be a locked or broken account. "
404	. "If this is your account, ask a dungeon master for assistance. "
405	. "Otherwise choose a different login name.",
406	cf::NDI_RED \| cf::NDI_REPLY
407	;
408	next;
409	}
410	}
411
412	my $pass2 = query $ns, cf::CS_QUERY_HIDEINPUT, "Please type your password again.";
413
414	if ($pass2 ne $pass) {
415	send_log $ns,
416	"The passwords do not match, please try again.",
417	cf::NDI_RED \| cf::NDI_REPLY
418	;
419	Coro::Timer::sleep 0.5;
420	next;
421	}
422
423	last;
424	}
425
426	chargen $ns, $user, Deliantra::Util::hash_pw $pass;
427	});
428	});
429
430	cf::client->attach (
431	on_version => sub {
432	my ($ns, $arg) = @_;
433
434	# perl probably uses lrand48, which is not secure at all
435	# maybe require linux and use /dev/urandom.
436	$ns->{nonces} = [map { join "", map { chr rand 256 } 0..63 } 1..2];
437	$ns->ext_msg (nonces => @{ $ns->{nonces} });
438	},
439	);
440
441	cf::register_async_exticmd create_login => sub {
442	my ($ns, $reply, $user, $pass) = @_;
443
444	$ns->{addme}++ and return $ns->destroy;
445
446	$ns->async (sub {
447	my $fail = sub {
448	$reply->(0, $_[0]);
449	$ns->flush; # does not ensure that the data reaches the client - TODO
450	# need to do this in another thread, as this one gets canceled
451	Coro::async_pool {
452	Coro::AnyEvent::sleep 0.1; # TODO, see above, extra hack
453	$ns->destroy if $ns->valid;
454	};
455	Coro::schedule; # do the destroy, should not return
456	};
457
458	$user =~ $VALID_LOGIN
459	or return $fail (
460	"Your username contains illegal characters (only a-z, A-Z and 0-9 are allowed), "
461	. "or is not between 3 and 20 characters in length."
462	);
463
464	$ns->{login_guard} = login_guard $user
465	or return $fail->("User name '$user' is in use - try another login name.");
466
467	cf::player::find $user
468	and return $fail->("User name '$user' is already registered - choose another login name.");
469
470	$reply->(1, "Account Created");
471
472	chargen $ns, $user, $pass;
473	});
474	};
475
476	cf::register_async_exticmd login => sub {
477	my ($ns, $reply, $user, $hash) = @_;
478
479	$ns->{addme}++ and return $ns->destroy;
480
481	$ns->async (sub {
482	$Coro::current->{desc} = "login($user)";
483
484	my $fail = sub {
485	$reply->(0, $_[0]);
486	$ns->flush; # does not ensure that the data reaches the client - TODO
487	# need to do this in another thread, as this one gets canceled
488	Coro::async_pool {
489	Coro::AnyEvent::sleep 0.1; # TODO, see above, extra hack
490	$ns->destroy if $ns->valid;
491	};
492	Coro::schedule; # do the destroy, should not return
493	};
494
495	$ns->{login_guard} = login_guard $user
496	or return $fail->("User '$user' is currently playing or logging in in another session. If that is your "
497	. "user name, make sure you are not running two clients. When in doubt, reboot.");
498
499	# try to read the user file and check the password
500	my $pl = cf::player::find $user
501	or return $fail->("User '$user' does not exist - wrong spelling?");
502
503	aio_stat $pl->path
504	and return $ns->destroy;
505
506	my $mtime = (stat _)[9];
507	my $token = $pl->password;
508
509	$token = $token =~ /^!/
510	? Deliantra::Util::hash_pw pack "H*", substr $token, 1
511	: pack "H*", $token;
512
513	$token = Deliantra::Util::auth_pw $token, $ns->{nonces}[0], $ns->{nonces}[1];
514
515	$token eq $hash
516	or $cf::CFG{ext_login_nocheck}
517	or return $fail->("User exists, but the password doesn't match - check your spelling, NumLock/CapsLock etc.");
518
519	# player exists and passwords match - we can proceed
520
521	$reply->(1, "Success");
522
523	$pl->connect ($ns);
524	enter_map $pl;
525	login $pl;
526	});
527	};
528
529	cf::register_command password => sub {
530	my ($pl, $arg) = @_;
531
532	unless ($pl->flag (cf::FLAG_WIZ)) {
533	$pl->message (
534	"The password can currently only changed by a DM.",
535	cf::NDI_UNIQUE \| cf::NDI_REPLY);
536	return;
537	}
538
539	$pl->message (#d#
540	"Passwords cannot currently be changed.",#d#
541	cf::NDI_UNIQUE \| cf::NDI_REPLY);#d#
542	return;#d#
543
544	my (@args) = split /\s+/, $arg;
545	my ($player, $new_pw) = @args;
546
547	if ($pl->flag (cf::FLAG_WIZ) && $player eq '') {
548	$pl->message (
549	"Usage: password <player> [<new password>]",
550	cf::NDI_UNIQUE \| cf::NDI_REPLY);
551	return;
552	}
553
554	if ($new_pw eq '') {
555	$new_pw =
556	join '',
557	map { ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[(cf::rndm 64)] }
558	1..9;
559	}
560
561	cf::async {
562	my $plc = cf::player::find $player;
563	if ($plc) {
564	$plc->password (encode_password $new_pw);
565	$pl->message (
566	"Ok, changed password of '$player' to '$new_pw'!",
567	cf::NDI_UNIQUE \| cf::NDI_RED \| cf::NDI_REPLY);
568	} else {
569	$pl->message (
570	"Fail! Couldn't set password for '$player', "
571	. "he doesn't seem to exist!",
572	cf::NDI_UNIQUE \| cf::NDI_RED \| cf::NDI_REPLY);
573	}
574	};
575	};
576
577	cf::register_command quit => sub {
578	my ($ob, $arg) = @_;
579
580	$ob->send_msg (undef,
581	"Quitting will delete your character PERMANENTLY: It will be gone forever and any progress will be lost. "
582	. "If you are sure you want to do this, then use the quit_character command instead of quit.",
583	cf::NDI_UNIQUE \| cf::NDI_RED \| cf::NDI_REPLY);
584	};
585
586	cf::register_command quit_character => sub {
587	my ($ob, $arg) = @_;
588
589	my $pl = $ob->contr;
590
591	$pl->ns->query (cf::CS_QUERY_SINGLECHAR, "Do you want to PERMANENTLY delete your character and all associated data (y/n)?", sub {
592	if ($_[0] !~ /^[yY]/) {
593	$ob->send_msg (undef, "Ok, not not quitting then.", cf::NDI_UNIQUE \| cf::NDI_RED \| cf::NDI_REPLY);
594	} else {
595	$ob->send_msg (undef, "Ok, quitting, hope to see you again.", cf::NDI_UNIQUE \| cf::NDI_RED \| cf::NDI_REPLY);
596	cf::async {
597	$pl->quit_character;
598	};
599	}
600	});
601	};
602
603	cf::object->attach (
604	type => cf::SAVEBED,
605	on_apply => sub {
606	my ($bed, $ob) = @_;
607
608	return cf::override 0 unless $ob->type == cf::PLAYER;
609
610	my $pl = $ob->contr;
611
612	# update respawn position
613	$pl->savebed ($bed->map->path, $bed->x, $bed->y);
614
615	cf::async {
616	my $killer = cf::arch::get "killer_logout"; $pl->killer ($killer); $killer->destroy;
617	ext::highscore::check $ob;
618
619	$pl->save;
620
621	$ob->send_msg ($cf::SAY_CHANNEL => "In the future, you will wake up here when you die.", cf::NDI_DEF \| cf::NDI_REPLY);
622
623	my $ns = $pl->ns
624	or return;
625
626	$ns->query (cf::CS_QUERY_SINGLECHAR, "Do you want to continue playing (y/n)?", sub {
627	if ($_[0] !~ /^[yY]/) {
628	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1);
629	$pl->deactivate;
630	$pl->ns->destroy;
631	}
632	});
633	};
634	},
635	);
636
637	cf::player->attach (
638	on_login => sub {
639	my ($pl) = @_;
640	my $name = $pl->ob->name;
641
642	$_->ob->message ("$name has entered the game.", cf::NDI_DK_ORANGE \| cf::NDI_UNIQUE) for cf::player::list;
643	},
644	on_logout => sub {
645	my ($pl, $cleanly) = @_;
646	my $name = $pl->ob->name;
647
648	if ($cleanly) {
649	$_->ob->message ("$name left the game.", cf::NDI_DK_ORANGE \| cf::NDI_UNIQUE) for cf::player::list;
650	} else {
651	$_->ob->message ("$name uncerimoniously disconnected.", cf::NDI_DK_ORANGE \| cf::NDI_UNIQUE) for cf::player::list;
652	$pl->{unclean_save} = $cf::RUNTIME
653	unless safe_spot $pl;
654	}
655	},
656	);
657