Pastebin

{(
 )) MEOW.dpr - Mini EO? WOW!
((
 )) Created by Sordie Solomon-Smith out of bordem
((  http://sordie.com/
 )}

program MEOW;

{$APPTYPE CONSOLE}

uses
  Windows, WinSock;

type
  procedureref = reference to procedure;

  CriticalSectionHelper = record helper for TRTLCriticalSection
    procedure Create; inline;
    procedure Free;   inline;

    procedure Enter; inline;
    procedure Leave; inline;

    procedure Section(Code: procedureref); inline;
  end;{CriticalSectionHelper}

  Server = class abstract
    class var CriticalSection: TRTLCriticalSection;

    type TSession = class
      var Socket: TSocket;
      var IPStr:  AnsiString;
      var IPInt:  Integer;

      var Thread: THandle;

      var ID: Cardinal;

      constructor Create(ASocket: TSocket);
      destructor  Destroy; override;

      function Execute: Boolean;
    end;{Session}

    type TArray<T: class> = class
      var Items: array of T;

      constructor Create;
      destructor  Destroy; override;

      function Find  (Item: T): Integer;
      function Add   (Item: T): Integer;
      function Remove(Item: T): Integer;

      procedure Clear;
    end;{TArray<T>}

    class var Sessions: TArray<TSession>;
    class var Socket:   TSocket;

    class constructor Create;
    class destructor  Destroy;

    class procedure Reference;
    class procedure Main;

    class function GetSessionByID(ID: Cardinal): TSession;

    class procedure Log  (Params: array of const);
    class procedure Error(Params: array of const);
  end;{Server}

procedure CriticalSectionHelper.Create;
begin
  InitializeCriticalSection(Self);
end;{CriticalSectionHelper.Create}

procedure CriticalSectionHelper.Free;
begin
  DeleteCriticalSection(Self);
end;{CriticalSectionHelper.Free}

procedure CriticalSectionHelper.Enter;
begin
  EnterCriticalSection(Self);
end;{CriticalSectionHelper.Enter}

procedure CriticalSectionHelper.Leave;
begin
  LeaveCriticalSection(Self);
end;{CriticalSectionHelper.Leave}

procedure CriticalSectionHelper.Section(Code: procedureref);
begin
  Enter;
  try
    Code;
  finally
    Leave;
  end;{try...finally}
end;{CriticalSectionHelper.Secion}

class constructor Server.Create;
var
  WSAData: TWSAData;
  AddrIn:  TSockAddrIn;
begin
  CriticalSection.Create;
  Log(['Server.Create']);

  Sessions := TArray<TSession>.Create;

  WSAStartup(MakeLong(2, 2), WSAData);

  Socket := WinSock.socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
  if Socket = 0 then
    Error(['Failed to create socket']);

  FillChar(AddrIn, sizeof(AddrIn), 0);
  with AddrIn do
  begin
    sin_family      := AF_INET;
    sin_addr.S_addr := inet_addr('0.0.0.0');
    sin_port        := htons(8078);
  end;{with AddrIn}
  if bind(Socket, AddrIn, sizeof(AddrIn)) <> 0 then
    Error(['Failed to bind socket']);

  if listen(Socket, 0) <> 0 then
    Error(['Cannot listen on socket']);

  try
    Main;
  except
    Log(['Server Exception']);
  end;{try...except}
end;{class)Server.Create}

class destructor Server.Destroy;
begin
  if Socket <> 0 then
  begin
    closesocket(Socket);
    Socket := 0;
  end;{if Socket <> 0}

  Sessions.Free;

  Log(['Server.Destroy']);

  CriticalSection.Free;
  Readln;
end;{class)Server.Destroy}

class procedure Server.Reference;
begin
  ClassName
end;{class)Server.Reference}

class procedure Server.Main;
var
  FDSet:    TFDSet;
  SockSize: Integer;
  SockAddr: TSockAddr;
begin
  repeat
    Sleep(1);

    FDSet.fd_count    := 1;
    FDSet.fd_array[0] := Socket;

    if select(0, @FDSet, nil, nil, nil) = 1 then
    begin
      SockSize := sizeof(SockAddr);
      TSession.Create(accept(Socket, @SockAddr, @SockSize));
    end;{if select}
  until Socket = 0;
end;{class)Server.Main}

class function Server.GetSessionByID(ID: Cardinal): TSession;
var
  Session: TSession;
begin
  CriticalSection.Enter;
  try
    for Session in Sessions.Items do
      if Session.ID = ID then exit(Session);

    Result := nil;
  finally
    CriticalSection.Leave;
  end;{try...finally}
end;{class)Server.GetSessionByID}

class procedure Server.Log(Params: array of const);
var
  i: Integer;
begin
  CriticalSection.Enter;
  try
    for i := 0 to high(Params) do
      with TVarRec(Params[i]) do
        case VType of
          vtInteger:       Write(VInteger);
          vtBoolean:       Write(VBoolean);
          vtChar:          Write(VChar);
          vtWideChar:      Write(VWideChar);
          vtExtended:      Write(VExtended^);
          vtString:        Write(AnsiString(VString));
          vtPointer:       Write(Cardinal(VPointer));
          vtPChar:         Write(AnsiString(VPChar));
          vtObject:        Write(VObject.ClassName);
          vtClass:         Write(VClass.ClassName);
          vtPWideChar:     Write(WideString(VPWideChar));
          vtWideString:    Write(WideString(VWideString));
          vtInt64:         Write(VInt64^);
          vtUnicodeString: Write(String(VUnicodeString));
        else
          Write('?(', VType, ')');
        end;{case VType}
  finally
    Writeln;
    CriticalSection.Leave;
  end;{try...finally}
end;{class)Server.Log}

class procedure Server.Error(Params: array of const);
begin
  Log(Params);
  halt(1);
end;{class)Server.Error}

constructor Server.TArray<T>.Create;
begin
  inherited Create;

  Clear;
end;{Server.TArray<T>.Create}

destructor Server.TArray<T>.Destroy;
begin
  Clear;

  inherited;
end;{Server.TArray<T>.Destroy}

function Server.TArray<T>.Find(Item: T): Integer;
var
  i: Integer;
begin
  for i := 0 to high(Items) do
    if Items[i] = Item then exit(i);

  Result := -1;
end;{Server.TArray<T>.Add}

function Server.TArray<T>.Add(Item: T): Integer;
begin
  Result := Find(Item);

  if Result = -1 then
  begin
    SetLength(Items, length(Items) + 1);
    Result := high(Items);
    Items[Result] := Item;
  end;{if Result = -1}
end;{Server.TArray<T>.Add}

function Server.TArray<T>.Remove(Item: T): Integer;
begin
  Result := Find(Item);
  if Result = -1 then exit;

  if Result < high(Items) then
    move(Items[Result + 1], Items[Result], sizeof(T) * (length(Items) - 1));

  SetLength(Items, length(Items) - 1);
end;{Server.Tarray<T>.Remove}

procedure Server.TArray<T>.Clear;
begin
  SetLength(Items, 0);
end;{Server.TArray<T>.Clear}

function SessionThread(Session: Server.TSession): Integer;
begin
  Result := 0;

  try
    try
      while Session.Execute do
        Sleep(1);
    except
      Server.Log(['Session Exception']);
    end;{try...except}
  finally
    try
      Session.Free;
    except
      {}
    end;{try...except}

    EndThread(Result);
  end;{try...finally}
end;{SessionThread}

constructor Server.TSession.Create(ASocket: TSocket);
var
  i:    Integer;
  Addr: TSockAddr;
begin
  inherited Create;

  Socket := ASocket;

  if Socket <> 0 then
  begin
    FillChar(Addr, sizeof(Addr), 0);
    i := sizeof(Addr);
    getpeername(Socket, Addr, i);
    IPStr := AnsiString(inet_ntoa(Addr.sin_addr));
    IPInt := Addr.sin_addr.S_addr;

    i := 1;
    ioctlsocket(Socket, FIONBIO, i);
  end;{if Socket}

  Server.CriticalSection.Section(procedure
  begin
    ID := 100;
    while Server.GetSessionByID(ID) <> nil do inc(ID);

    Server.Sessions.Add(Self);
  end);{Server.CriticalSection.Section}

  BeginThread(nil, 0, @SessionThread, Pointer(Self), 0, Thread);

  Server.Log(['Session[', ID, '] ', IPStr, ' created']);
end;{Server.TSession.Create}

destructor Server.TSession.Destroy;
begin
  if Socket <> 0 then
  begin
    closesocket(Socket);
    Socket := 0;
  end;{if Socket <> 0}

  Server.CriticalSection.Section(procedure
  begin
    Server.Sessions.Remove(Self);
  end);{Server.CriticalSection.Section}

  Server.Log(['Session[', ID, '] ', IPStr, ' destroyed']);

  inherited;
end;{Server.TSession.Destroy}

function Server.TSession.Execute: Boolean;
begin
  if (Socket = 0) or (recv(Socket, nil^, 0, MSG_OOB) = 0) then exit(False);

  Result := True;
end;{Server.TSession.Execute}

begin
  Server.Reference;
end.