{
  The Grendel Project - Win32 MUD Server
  Copyright (c) 2000,2001 by Michiel Rook (Grimlord)

  Contact information:
  Webpage:            http://grendel.mudcenter.com/
  E-Mail:             druid@takeover.nl

  Please observe LICENSE.TXT prior to using this software.

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License, Version 2,
  as published by the Free Software Foundation.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details (LICENSE.TXT).

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

  $Id: grendel.dpr,v 1.25 2001/04/20 12:17:03 druid Exp $
}

program grendel;

{$DESCRIPTION 'The Grendel Project - Win32 MUD Server. Copyright (c) 2000,2001 by Michiel Rook.'}
{$APPTYPE CONSOLE}

{$W+}

{%File 'include\command.inc'}
{%File 'include\cmd_comm.inc'}
{%File 'include\cmd_fight.inc'}
{%File 'include\cmd_imm.inc'}
{%File 'include\cmd_info.inc'}
{%File 'include\cmd_magic.inc'}
{%File 'include\cmd_move.inc'}
{%File 'include\cmd_obj.inc'}
{%File 'include\cmd_shops.inc'}
{%File 'include\cmd_skill.inc'}
{%File 'include\cmd_build.inc'}

uses
  SysUtils,
  Windows,
  mudsystem in 'units\mudsystem.pas',
  constants in 'units\constants.pas',
  dtypes in 'units\dtypes.pas',
  conns in 'units\conns.pas',
  util in 'units\util.pas',
  Strip in 'units\strip.pas',
  area in 'units\area.pas',
  fsys in 'units\fsys.pas',
  mudthread in 'units\mudthread.pas',
  AnsiIO in 'units\ansiio.pas',
  chars in 'units\chars.pas',
  race in 'units\race.pas',
  fight in 'units\fight.pas',
  skills in 'units\skills.pas',
  mudhelp in 'units\mudhelp.pas',
  magic in 'units\magic.pas',
  update in 'units\update.pas',
  clan in 'units\clan.pas',
  clean in 'units\clean.pas',
  Winsock2 in 'units\winsock2.pas',
  progs in 'units\progs.pas',
  md5 in 'units\md5.pas',
  MemCheck in 'units\MemCheck.pas',
  timers in 'units\timers.pas',
  debug in 'units\debug.pas',
  mudspell in 'units\mudspell.pas',
  LibXmlParser in 'units\LibXmlParser.pas',
  NameGen in 'units\NameGen.pas',
  bulletinboard in 'units\bulletinboard.pas';

const pipeName : pchar = '\\.\pipe\grendel';
const use_ipv4 : boolean = false;
      use_ipv6 : boolean = false;


var
   hWSAData : TWSAData;

   listenv4, listenv6 : TSocket;

   addrv4 : TSockAddrIn;
   addrv6 : TSockAddr6;
   ssv6 : TSockAddr_Storage;
   addrv6p : PSockAddr;

   client_addr : TSockAddr_Storage;

   old_exitproc : pointer;


procedure detect_protocols;
var
   a, t : dword;
   lp : array[0..1] of integer;
   prot : pointer;
   pprot : LPWSAProtocol_Info;
   buf : string;
begin
  t := 0;
  lp[0] := IPPROTO_TCP;
  lp[1] := 0;

  WSAEnumProtocols(@lp, nil, t);

  getmem(prot, t);
  pprot := prot;

  t := WSAEnumProtocols(@lp, pprot, t);

  for a := 0 to t - 1 do
    begin
    pprot := pointer(integer(prot) + (a * sizeof(TWSAProtocol_Info)));

    if (pprot^.iAddressFamily = AF_INET) then
      use_ipv4 := true
    else
    if (pprot^.iAddressFamily = AF_INET6) then
      use_ipv6 := true;
    end;

  buf := 'Supported address families:';

  if (use_ipv4) then
    buf := buf + ' IPv4';

  if (use_ipv6) then
    buf := buf + ' IPv6';

  write_console(buf);

  freemem(prot, t);
end;

procedure startup_winsock;
var rc : integer;
    ver : integer;
begin
  ver := WINSOCK_VERSION;

  if (WSAStartup(ver, hWSAData) <> 0) then
    write_console('ERROR: WSAStartup failed.');

  detect_protocols;

  { IPv4 }
  if (use_ipv4) then
    begin
    listenv4 := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);

    if (listenv4 = INVALID_SOCKET) then
      write_console('ERROR: Could not create IPv4 socket.');

    addrv4.sin_family := AF_INET;
    addrv4.sin_port := htons(system_info.port);
    addrv4.sin_addr.s_addr := system_info.bind_ip;

    if (bind(listenv4, TSockaddr(addrv4), sizeof(addrv4)) = -1) then
      begin
      closesocket(listenv4);
      write_console('ERROR: Could not bind to IPv4, port ' + inttostr(system_info.port));
      halt;
      end;

    rc := listen(listenv4, 15);

    if (rc > 0) then
      write_console('ERROR: Could not listen on IPv4 socket.')
    else
      write_console('IPv4 bound on port ' + inttostr(system_info.port) + '.');
    end;

  { IPv6 }
  if (use_ipv6) then
    begin
    listenv6 := socket(AF_INET6, SOCK_STREAM, IPPROTO_TCP);

    if (listenv6 = INVALID_SOCKET) then
      write_console('ERROR: Could not create IPv6 socket.');

    fillchar(addrv6, sizeof(TSockAddr6), 0);

    addrv6.sin6_family := AF_INET6;
    addrv6.sin6_port := htons(system_info.port);

    move(addrv6, ssv6, sizeof(addrv6));

    addrv6p := @ssv6;

    if (bind(listenv6, addrv6p^, 128) = -1) then
      begin
      rc := WSAGetLastError;

      writeln(rc);

      closesocket(listenv6);
      write_console('ERROR: Could not bind to IPv6, port ' + inttostr(system_info.port));
      end;

    rc := listen(listenv6, 15);

    if (rc > 0) then
      write_console('ERROR: Could not listen on IPv6 socket.')
    else
      write_console('IPv6 bound on port ' + inttostr(system_info.port) + '.');
    end;
end;

procedure flushConnections;
var
   ch : GCharacter;
   node : GListNode;
begin
  node := char_list.head;

  while (node <> nil) do
    begin
    ch := node.element;
    node := node.next;

    if (not ch.IS_NPC) then
      ch.quit;
    end;
end;

procedure cleanup_mud;
var
   node : GListNode;
begin
  mud_booted := false;

  timer_thread.Terminate;
  clean_thread.Terminate;

  write_console('Releasing allocated memory...');

  try
    node := char_list.tail;
    while (node <> nil) do
      begin
      GCharacter(node.element).extract(true);
      node := char_list.tail;
      end;

    node := object_list.tail;
    while (node <> nil) do
      begin
      GObject(node.element).extract;
      node := object_list.tail;
      end;

    cleanChars;
    cleanObjects;

    char_list.Free;
    object_list.Free;

    // clean up rooms and all
    area_list.clean;
    room_list.clean;
    shop_list.clean;
    teleport_list.clean;
    extracted_object_list.clean;
    extracted_chars.clean;
    npc_list.clean;
    obj_list.Clean;
    race_list.clean;
    clan_list.clean;
    help_files.clean;
    dm_msg.clean;
    notes.clean;

    notes.Free;
    area_list.Free;
    room_list.Free;
    shop_list.Free;
    teleport_list.Free;
    extracted_object_list.Free;
    extracted_chars.Free;
    npc_list.Free;
    obj_list.Free;
    race_list.Free;
    clan_list.Free;
    help_files.Free;
    dm_msg.Free;

    skill_table.Free;

    socials.Free;
    str_hash.Free;
    auction_good.Free;
    auction_evil.Free;
    banned_masks.Free;

    connection_list.clean;
    connection_list.Free;
    commands.Free;
  except
    on E : EExternal do
    begin
      bugreport('cleanup', 'grendel.dpr', 'something went wrong',
                'A procedure in the cleanup cycle failed. Contact Grimlord.');
      outputError(E);
    end;
  end;

  if (use_ipv4) then
    begin
    closesocket(listenv4);
    listenv4 := -1;
    end;

  if (use_ipv6) then
    begin
    closesocket(listenv6);
    listenv6 := -1;
    end;

  WSACleanup;
  write_console('Cleanup complete.');
  if (TTextRec(logfile).mode = fmOutput) then
    CloseFile(LogFile);
end;

procedure reboot_mud;
var SI: TStartupInfo;
    PI: TProcessInformation;
    s : TDateTime;
    msg:TMsg;
begin
  write_console('Server rebooting...');
  try

    if MUD_Booted then
      flushConnections;

    { wait for users to logout }
    s := Time+StrToTime('0:0:01');
    repeat
      PeekMessage(msg,0,0,0,PM_NOREMOVE);
    until Time>=s;
  except
    write_console('... wrong');
  end;

  cleanup_mud;

  FillChar(SI, SizeOf(SI), 0);
  SI.cb := SizeOf(SI);
  SI.wShowWindow := sw_show;

  if not CreateProcess('grendel.exe',Nil, Nil, Nil, False, NORMAL_PRIORITY_CLASS or CREATE_NEW_CONSOLE, Nil, Nil, SI, PI) then
    bugreport('reboot_mud', 'grendel.dpr', 'could not execute grendel.exe',
              'The server could not be rebooted! Please check your settings!');
end;

procedure copyover_mud;
var
   SI: TStartupInfo;
   PI: TProcessInformation;
   pipe : THandle;
   node, node_next : GListNode;
   conn : GConnection;
   w, len : cardinal;
   prot : TWSAProtocol_Info;
   name : array[0..1023] of char;
begin
  write_console('Server starting copyover...');

  node := connection_list.head;

  while (node <> nil) do
    begin
    conn := node.element;
    node_next := node.next;

    if (conn.state = CON_PLAYING) then
      begin
      stopfighting(conn.ch);
  		conn.ch.emptyBuffer;
      conn.send(#13#10'Slowly, you feel the world as you know it fading away in wisps of steam...'#13#10#13#10);
      end
    else
      begin
      conn.send(#13#10'This server is rebooting, please continue in a few minutes.'#13#10#13#10);
      conn.thread.terminate;
      end;

    node := node_next;
    end;

  FillChar(SI, SizeOf(SI), 0);
  SI.cb := SizeOf(SI);
  SI.wShowWindow := sw_show;

  if (not CreateProcess('copyover.exe', nil, Nil, Nil, False, NORMAL_PRIORITY_CLASS or CREATE_NEW_CONSOLE, Nil, Nil, SI, PI)) then
    begin
    bugreport('copyover_mud', 'grendel.dpr', 'Could not execute copyover.exe',
              'The copyover could not be started! Please check your settings!');
    reboot_mud;
    end;

  pipe := CreateNamedPipe(pipeName, PIPE_ACCESS_DUPLEX, PIPE_WAIT or PIPE_TYPE_BYTE or PIPE_READMODE_BYTE, 10, 0, 0, 1000, nil);

  if (pipe = INVALID_HANDLE_VALUE) then
    begin
    writeln('Could not create pipe: ', GetLastError);
    exit;
    end;

  if (not ConnectNamedPipe(pipe, nil)) then
    begin
    bugreport('copyover_mud', 'grendel.dpr', 'Pipe did not initialize correctly!', 'The IPC pipe for copyover could not be created.');
    reboot_mud;
    end;

  node := connection_list.head;

  while (node <> nil) do
    begin
    conn := node.element;
    node_next := node.next;

    if (WSADuplicateSocket(conn.socket, PI.dwProcessId, @prot) = -1) then
      begin
      bugreport('copyover_mud', 'grendel.dpr', 'WSADuplicateSocket failed', 'Error code: ' + IntToStr(WSAGetLastError));
      reboot_mud;
      end;

    if (not WriteFile(pipe, prot, sizeof(prot), w, nil)) then
      begin
      bugreport('copyover_mud', 'grendel.dpr', 'Broken pipe', 'Could not send socket info through IPC pipe');
      reboot_mud;
      end;

		strpcopy(name, conn.ch.name^);
    len := strlen(name);

    if (not WriteFile(pipe, len, 4, w, nil)) then
      begin
      bugreport('copyover_mud', 'grendel.dpr', 'Broken pipe', 'Could not send socket info through IPC pipe');
      reboot_mud;
      end;

    if (not WriteFile(pipe, name, len, w, nil)) then
      begin
      bugreport('copyover_mud', 'grendel.dpr', 'Broken pipe', 'Could not send socket info through IPC pipe');
      reboot_mud;
      end;

    conn.ch.save(conn.ch.name^);
    conn.thread.terminate;

    node := node_next;
    end;

  Sleep(500);

  CloseHandle(pipe);

  cleanup_mud;
end;

procedure shutdown_mud;
var
    s : TDateTime;
    msg:TMsg;
begin
  write_console('Server shutting down...');
  try

    if MUD_Booted then
      flushConnections;

    { wait for users to logout }
    s := Time+StrToTime('0:0:01');
    repeat
      PeekMessage(msg,0,0,0,PM_NOREMOVE);
    until Time>=s;
  except
    write_console('... wrong');
  end;

  cleanup_mud;
end;

procedure sendtoall(s : string);
var
   node : GListNode;
   conn : GConnection;
begin
  node := connection_list.head;

  while (node <> nil) do
    begin
    conn := node.element;

    conn.send(s);

    node := node.next;
    end;
end;

{ our exit procedure, catches the server when unstable }
{ This is one of the most important pieces of code: the exit handler.
  These lines make sure that if the server crashes (due to illegal memory
  access, file operations, overload, etc.) the players are logged out
  and their data is saved properly. Also, this routine makes sure the
  server reboots automatically, no script needed! - Grimlord }
procedure reboot_exitproc;far;
var msg:TMsg;
    s:single;
begin
  { okay, so we crashed :) }
  if (not grace_exit) then
    begin
    sendtoall('------ GAME CRASH DETECTED! ---- Saving all players.'#13#10#13#10);
    sendtoall('The server should be back online in less than a minute.'#13#10);
    sendtoall('If the server doesn''t auto-reboot, please notify'#13#10);
    sendtoall(pchar('the administration, '+system_info.admin_email+'.'#13#10));

    { save all characters and try to unlog before quitting }
    flushConnections;

    { wait for users to logout }
    s:=Time+StrToTime('0:0:01');

    repeat
      PeekMessage(msg,0,0,0,PM_NOREMOVE);
    until Time>=s;

    { give operator/logfile a message }
    bugreport('CRASH', 'grendel.dpr', 'CRASH WARNING',
              'The system encountered a fatal error and will reboot.');

    write_console('---- CRASH TERMINATE. REBOOTING SERVER ----');

    { close logfile }
    if TTextRec(logfile).mode=fmOutput then
      CloseFile(LogFile);
    boot_type := BOOTTYPE_REBOOT;
    end;

  exitproc:=old_exitproc;

  { reboot }
  if (boot_type = BOOTTYPE_REBOOT) then
    reboot_mud
  else
  { copyover }
  if (boot_type = BOOTTYPE_COPYOVER) then
    begin
		if (connection_list.getSize > 0) then
      copyover_mud
    else
      reboot_mud;
    end
  else
    shutdown_mud;
end;


procedure boot_mud;
var s : string;
begin
  { open a standard log file, filename is given by current system time }
  TimeSeparator := '_';
  AssignFile(LogFile, 'log\' + TimeToStr(time) + '_' + DateToStr(date) + '.log');
  TimeSeparator := ':';

  {$I-}
  rewrite(LogFile);
  {$I+}

  if (IOResult <> 0) then
    write_console('NOTE: Could not open logfile. Messages are not being logged.');

  SetConsoleTitle(version_info + ', ' + version_number + '(Booting)');

  write_direct(version_info + ', ' + version_number + '.');
  write_direct(version_copyright + '.');
  write_direct('This is free software, with ABSOLUTELY NO WARRANTY; view LICENSE.TXT.'#13#10);
  write_console('Booting server...');

  load_system;

  s := FormatDateTime('ddddd', Now);
  write_console('Booting "' + system_info.mud_name + '" database, ' + s + '.');

  clean_thread := GCleanThread.Create;

  write_console('Loading races...');
  load_races;
  // write_console('Loading professions...');
  // load_profs;
  write_console('Loading clans...');
  load_clans;
  write_console('Loading skills...');
  load_skills;
  write_console('Loading texts...');
  registerCommands;
  load_commands;
  load_socials;
  load_damage;
  write_console('Loading areas...');
  load_areas;
  write_console('Loading help...');
  load_help('help.dat');
  write_console('Loading namegenerator data...');
  loadNameTables(NameTablesDataFile);
  write_console('Loading noteboards...');
  load_notes('boards.dat');

  write_console('String hash stats: ');
  str_hash.hashStats;

  randomize;

  startup_winsock;

  ExitProc := @reboot_exitproc;

  BootTime := Now;

  update_time;

  time_info.day := 1;
  time_info.month := 1;
  time_info.year := 1;

  boot_type := 0;
  bg_info.count := -1;
  boot_info.timer := -1;
  mud_booted:=true;


  registerTimer('teleports', update_teleports, 1, true);
  registerTimer('fighting', update_fighting, CPULSE_VIOLENCE, true);
  registerTimer('battleground', update_battleground, CPULSE_VIOLENCE, true);
  registerTimer('objects', update_objects, CPULSE_TICK, true);
  registerTimer('characters', update_chars, CPULSE_TICK, true);
  registerTimer('gametime', update_time, CPULSE_GAMETIME, true);

  timer_thread := GTimerThread.Create;

  calculateonline;
end;

function send_to_socket(sock : TSocket; s : string) : integer;
begin
  send_to_socket := send(sock, s[1], length(s), 0);
end;

procedure accept_connection(list_sock : TSocket);
var
   ac : TSocket;
   cl : PSockAddr;
   len : integer;
begin
  cl := @client_addr;
  len := 128;
  ac := accept(list_sock, cl^, len);

  // set non-blocking mode

  len := 1;
  len := ioctlsocket(ac, FIONBIO, len);

  if (boot_info.timer >= 0) then
    begin
    send_to_socket(ac, system_info.mud_name+#13#10#13#10);
    send_to_socket(ac, 'Currently, this server is in the process of a reboot.'#13#10);
    send_to_socket(ac, 'Please try again later.'#13#10);
    send_to_socket(ac, 'For more information, mail the administration, '+system_info.admin_email+'.'#13#10);
    closesocket(ac);
    end
  else
  if system_info.deny_newconns then
    begin
    send_to_socket(ac, system_info.mud_name+#13#10#13#10);
    send_to_socket(ac, 'Currently, this server is refusing new connections.'#13#10);
    send_to_socket(ac, 'Please try again later.'#13#10);
    send_to_socket(ac, 'For more information, mail the administration, '+system_info.admin_email+'.'#13#10);
    closesocket(ac);
    end
  else
  if (connection_list.getSize >= MAX_CONNS) then
    begin
    send_to_socket(ac, system_info.mud_name+#13#10#13#10);
    send_to_socket(ac, 'Currently, this server is too busy to accept new connections.'#13#10);
    send_to_socket(ac, 'Please try again later.'#13#10);
    send_to_socket(ac, 'For more information, mail the administration, '+system_info.admin_email+'.'#13#10);
    closesocket(ac);
    end
  else
    GGameThread.Create(ac, client_addr, false, '');
end;

procedure game_loop;
var msg : TMsg;
    accept_set : PFDSet;
    accept_val : PTimeVal;
begin
  new(accept_set);
  new(accept_val);

  while (true) do
    begin
    if (PeekMessage(msg,0,0,0,PM_REMOVE)) then
      begin
      TranslateMessage(msg);
      DispatchMessage(msg);
      end;

    if (use_ipv4) and (listenv4 > 0) then
      begin
      accept_set^.fd_array[0] := listenv4;
      accept_set^.fd_count:=1;
      accept_val^.tv_sec:=0;
      accept_val^.tv_usec:=0;

      if (select(1,accept_set,nil,nil,accept_val) <> 0) then
        accept_connection(listenv4);
      end;

    if (use_ipv6) and (listenv6 > 0) then
      begin
      accept_set^.fd_array[0] := listenv6;
      accept_set^.fd_count:=1;
      accept_val^.tv_sec:=0;
      accept_val^.tv_usec:=0;

      if (select(1,accept_set,nil,nil,accept_val) <> 0) then
        accept_connection(listenv6);
      end;

    sleep(500);
    end;

  dispose(accept_set);
  dispose(accept_val);
end;

function ctrl_handler(event:dword):boolean;
begin
  ctrl_handler:=true;
  grace_exit:=true;
  SetConsoleCtrlHandler(@ctrl_handler, false);
  halt;
end;

procedure from_copyover;
var
   pipe : THandle;
   w, len : cardinal;
   prot : TWSAProtocol_Info;
	 g : array[0..1023] of char;
	 suc : boolean;
   sock : TSocket;
   cl : PSockAddr;
   l : integer;
begin
  pipe := INVALID_HANDLE_VALUE;

  while (true) do
    begin
    pipe := CreateFile(pipeName, GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);

		if (pipe <> INVALID_HANDLE_VALUE) then
      break;

    if (GetLastError() <> ERROR_PIPE_BUSY) then
      begin
      bugreport('from_copyover', 'grendel.dpr', 'Could not restart from copyover',
              'The copyover could not be completed succesfully.');
			exit;
      end;

    // All pipe instances are busy, so wait a second

    if (not WaitNamedPipe(pipeName, 1000)) then
      begin
      bugreport('from_copyover', 'grendel.dpr', 'Could not restart from copyover',
              'The copyover could not be completed succesfully.');
			exit;
      end;
		end;

  sock := -1;

  repeat
    suc := ReadFile(pipe, prot, sizeof(prot), w, nil);

    if (suc) then
  		sock := WSASocket(prot.iAddressFamily, SOCK_STREAM, IPPROTO_IP, @prot, 0, 0);

    suc := ReadFile(pipe, len, 4, w, nil);
    suc := ReadFile(pipe, g, len, w, nil);

		if (suc) and (sock <> -1) then
      begin
  		g[len] := #0;

      cl := @client_addr;
      l := 128;
      getpeername(sock, cl^, l);

      GGameThread.Create(sock, client_addr, true, g);
			end;
  until (not suc);

  CloseHandle(pipe);
end;

begin
  old_exitproc := ExitProc;

{$IFDEF __DEBUG}
  MemChk;
{$ENDIF}

  boot_mud;

  if (CmdLine = 'copyover') then
    from_copyover;

  SetConsoleCtrlHandler(@ctrl_handler, true);
  write_console('Grendel ' + version_number + {$IFDEF __DEBUG} ' (__DEBUG compile)' + {$ENDIF} ' ready...');
  SetConsoleTitle(version_info + ', ' + version_number + '. ' + version_copyright + '.');

  game_loop;
end.