labradwsaserverthread.pas

As science advances, novel experiments are becoming more and more complex, requiring a zoo of contro

{ Copyright (C) 2007 Markus Ansmann
 
  This program is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 2 of the License, or
  (at your option) any later version.
 
  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.
 
  You should have received a copy of the GNU General Public License
  along with this program.  If not, see <http://www.gnu.org/licenses/>.  }

unit LabRADWSAServerThread;

{
This unit provides a TCP/IP server base class.
The server runs in a single thread for all connections.
This dramatically increases execution speed,
especially for packet-shuffling applications where data
needs to be routed from one connection to another.

All calls to the Do<Something> methods that are meant to be
overridden to implement the functionality of the server
are enclosed in try...except blocks, catching all exceptions
and reporting them via DoError.
DoError calls are enclosed in try...except blocks and all
exceptions generated are swallowed. This prevents deadlocks
from repeated DoError calls.
}

interface

 uses
  Classes, SyncObjs, LabRADWinSock2;

 type
  PWSASendBuffer = ^TWSASendBuffer;
  TWSASendBuffer = record
    Data:   array of Byte;
    Pos:    Integer;
    Next:   PWSASendBuffer;
  end;

  TWSAAddress = packed array[0..3] of Byte;

  TWSAClientInfo = record
    Address: TWSAAddress;
    Port:    Word;
  end;

  TWSAServerSocketInfo = record
    Socket:    TSocket;
    Data:      TObject;
    Fresh:     Boolean;
    Client:    TWSAClientInfo;
    Writable:  Boolean;
    SBFirst:   PWSASendBuffer;
    SBLast:    PWSASendBuffer;
    KillMe:    (kmNone, kmNow, kmSent);
  end;

  TCustomWSAServerThread = class(TThread)
   private
    fEvents:     packed record
                   Socket:     WSAEvent;
                   Notify:     WSAEvent;
                 end;
    fSockets:    array of TWSAServerSocketInfo;
    fPort:       Word;
    fNoDelay:    Boolean;
    fProtector:  TEvent;

    fRunning:    Boolean;
    fCITMethod:  TThreadMethod;
    fCITWait:    TEvent;
    fCITProtect: TEvent;

    procedure   KillSocket(SocketID: Integer);

   protected
    // Message notification functions - override to implement handlers
    procedure   DoError     (Error: String);                                                           virtual;
    procedure   DoListen;                                                                              virtual;
    procedure   DoAccept    (SocketID: Integer; var SocketData: TObject; ClientInfo: TWSAClientInfo);  virtual;
    procedure   DoRead      (SocketID: Integer; var SocketData: TObject; const Buffer; Size: Integer); virtual; abstract;
    procedure   DoWrite     (SocketID: Integer; var SocketData: TObject; Size: Integer);               virtual;
    procedure   DoDisconnect(SocketID: Integer; var SocketData: TObject);                              virtual;
    procedure   DoFinish;                                                                              virtual;

   public
    constructor Create(CreateSuspended: Boolean; Port: Word; TCP_NODELAY: Boolean = True);             virtual;
    destructor  Destroy;   override;
    procedure   Execute;   override;
    procedure   Terminate; reintroduce;
    function    Write(SocketID: Integer; const Buffer; Size: Integer): Boolean; overload;
    function    Write(SocketID: Integer; const Buffer: String): Boolean;        overload;
    procedure   Disconnect(SocketID: Integer; FinishSending: Boolean = True);
    procedure   CallInThread(Method: TThreadMethod);

    property    Running: Boolean read fRunning;
  end;

  function WSALookupHost(Host: string): TWSAAddress; overload;
  function WSALookupHost(Addr: TWSAAddress): string; overload;
  function WSAAddressToStr(IP: TWSAAddress): string;
  function WSAStrToAddress(IP: string): TWSAAddress;
  function WSAAddressToInt(IP: TWSAAddress): integer;
  function WSAIntToAddress(IP: integer): TWSAAddress;

implementation

uses SysUtils;

const BufSize          = 16384;      // Receive 16K of data at a time
      WaitEventTimeout = $FFFFFFFF;  // WaitEvent does not time out

var WinsockReady: Boolean;

{
constructor Create(CreateSuspended, Port, TCP_NODELAY)
This function calls TThread's Create method and initializes local variables.
Parameters:
  CreateSuspended: the usual (check help for TThread.Create)
  Port:            port to listen on
  TCP_NODELAY:     set TCP_NODELAY flag for new connections;
                   reduces outgoing packet latency by not pooling packets
}
constructor TCustomWSAServerThread.Create(CreateSuspended: Boolean; Port: Word; TCP_NODELAY: Boolean = True);
begin
  inherited Create(CreateSuspended);
  fRunning:=False;
  fEvents.Socket:=WSA_INVALID_EVENT;
  fEvents.Notify:=WSA_INVALID_EVENT;
  setlength(fSockets, 0);
  fPort:=Port;
  fNoDelay:=TCP_NODELAY;
  fProtector:= TEvent.Create(nil, False, True, '');
  fCITWait:=   TEvent.Create(nil, True, False, '');
  fCITProtect:=TEvent.Create(nil, False, True, '');
  fCITMethod:=nil;
end;

{
destructor Destroy
Cleans up the events and kills the thread object
}
destructor TCustomWSAServerThread.Destroy;
begin
  Terminate;
  WaitFor;
  fProtector.Free;
  fCITProtect.Free;
  fCITWait.Free;
  inherited;
end;

{
procedure DoError(Message)
This method gets called every time an error is detected.
Override it to implement error handling.
}
procedure TCustomWSAServerThread.DoError(Error: String);
begin
end;

{
procedure DoListen
This method gets called when the socket is listening
Override it to implement message handling.
}
procedure TCustomWSAServerThread.DoListen;
begin
end;

{
procedure DoAccept(SocketID, SocketData, ClientInfo)
This method gets called when a connection has been accepted
Override it to implement message handling.
}
procedure TCustomWSAServerThread.DoAccept(SocketID: Integer; var SocketData: TObject; ClientInfo: TWSAClientInfo);
begin
end;

{
procedure DoWrite(SocketID, SocketData, Size)
This method gets called when data was successfully written to the socket
Override it to implement message handling.
}
procedure TCustomWSAServerThread.DoWrite(SocketID: Integer; var SocketData: TObject; Size: Integer);
begin
end;

{
procedure DoDisconnect(SocketID, SocketData)
This method gets called when a connection is lost
Override it to implement message handling.
}
procedure TCustomWSAServerThread.DoDisconnect(SocketID: Integer; var SocketData: TObject);
begin
end;

{
procedure DoFinish
This method gets called when the server thread finishes
Override it to implement message handling.
}
procedure TCustomWSAServerThread.DoFinish;
begin
end;


{
procedure Execute
This method runs the server thread
}
procedure TCustomWSAServerThread.Execute;
var Socket:     TSocket;
    Addr:       TSockAddr_In;
    AddrLen:    Integer;
    NetEvents:  TWSANetworkEvents;
    ReadBuf:    packed array[0..BufSize-1] of Byte;
    Len:        Integer;
    SocketDead: Boolean;
    a:          Integer;
    b:          Boolean;
    NextSB:     PWSASendBuffer;
begin
  // Check if the Winsock library initialized correctly
  if not WinsockReady then begin
    try DoError('Winsock 2.0 not found') except end;
    exit;
  end;

  // Create events for asynchronous socket operation
  fEvents.Socket:=WSACreateEvent;
  fEvents.Notify:=WSACreateEvent;
  if (fEvents.Socket=WSA_INVALID_EVENT) or (fEvents.Notify=WSA_INVALID_EVENT) then begin
    try DoError('Could not create event objects') except end;
    exit;
  end;

  // Create the server socket
  Socket:=WSASocket(AF_INET, SOCK_STREAM, IPPROTO_TCP, nil, 0, 0);
  if Socket=INVALID_SOCKET then begin
    WSACloseEvent(fEvents.Socket);
    WSACloseEvent(fEvents.Notify);
    try DoError('Could not create server socket') except end;
    exit;
  end;

  // Select which port to listen on, using TCP/IP on all interfaces
  Addr.sin_family:=AF_INET;
  Addr.sin_addr.s_addr:=ADDR_ANY;
  Addr.sin_port:=swap(fPort);
  if bind(Socket, @Addr, sizeof(Addr))<>0 then begin
    WSACloseEvent(fEvents.Socket);
    WSACloseEvent(fEvents.Notify);
    closesocket(Socket);
    try DoError('Bind failed with error code '+inttostr(WSAGetLastError)) except end;
    exit;
  end;

  // Select aynchronous mode using event notification
  if WSAEventSelect(Socket, fEvents.Socket, FD_READ or FD_WRITE or FD_ACCEPT or FD_CLOSE)<>0 then begin
    try DoError('Event selection failed with error code '+inttostr(WSAGetLastError)) except end;
    exit;
  end;

  // Listen on socket
  if listen(Socket, SOMAXCONN)<>0 then begin
    WSACloseEvent(fEvents.Socket);
    WSACloseEvent(fEvents.Notify);
    closesocket(Socket);
    try DoError('Listen failed with error code '+inttostr(WSAGetLastError)) except end;
    exit;
  end;

  // Socket is now listening, call the notification procedure
  try
    DoListen;
   except
    on E: Exception do try DoError('DoListen exception: ' + E.Message) except end;
  end;

  // For TCP_NODELAY...
  B:=True;

  // Now comes the handler loop which runs until we kill it
  fRunning:=True;
  try
    while not Terminated do begin

      // Wait for either a socket event or a notification from us (for terminate or write)
      case WSAWaitForMultipleEvents(2, @fEvents.Socket, false, WaitEventTimeout, false) of

       // Handle socket event:
       WSA_WAIT_EVENT_0:
        begin
          // Get list of events caused by server socket
          if WSAEnumNetworkEvents(Socket, fEvents.Socket, @NetEvents)=0 then begin
            // Did we receive FD_ACCEPT?
            if (NetEvents.lNetworkEvents and FD_ACCEPT)>0 then begin
              // Find unused spot in socket list
              a:=0;
              while (a<length(fSockets)) and (fSockets[a].Socket<>INVALID_SOCKET) do inc(a);
              if a=length(fSockets) then setlength(fSockets, a+1);
              // Accept connection
              AddrLen:=sizeof(Addr);
              fSockets[a].Socket:=accept(Socket, @Addr, AddrLen);
              if fSockets[a].Socket<>INVALID_SOCKET then begin
                // Set TCP_NODELAY, if requested
                if fNoDelay then begin
                  if setsockopt(fSockets[a].Socket, IPPROTO_TCP, TCP_NODELAY, @B, sizeof(B))<>0 then begin
                    try DoError('TCP_nodelay failed with error code '+inttostr(WSAGetLastError)) except end;
                  end;
                end;
                // Mark connection as new (report as soon as writable)
                fSockets[a].Fresh:=True;
                fSockets[a].Data:=nil;
                fSockets[a].Writable:=False;
                fSockets[a].SBFirst:=nil;
                fSockets[a].SBLast:=nil;
                fSockets[a].KillMe:=kmNone;
                // Record information about client
                fSockets[a].Client.Address[0]:=ord(Addr.sin_addr.S_un_b.s_b1);
                fSockets[a].Client.Address[1]:=ord(Addr.sin_addr.S_un_b.s_b2);
                fSockets[a].Client.Address[2]:=ord(Addr.sin_addr.S_un_b.s_b3);
                fSockets[a].Client.Address[3]:=ord(Addr.sin_addr.S_un_b.s_b4);
                fSockets[a].Client.Port:=swap(Addr.sin_port);
               end else begin
                try DoError('Accept failed with error code '+inttostr(WSAGetLastError)) except end;
              end;
            end;
          end;

          // Run through current connections to look for more events
          for a:=1 to length(fSockets) do begin
            if fSockets[a-1].Socket<>INVALID_SOCKET then begin
              // Assume the connection socket is OK
              SocketDead:=False;
              // Get list of events caused by client socket
              if WSAEnumNetworkEvents(fSockets[a-1].Socket, 0, @NetEvents)=0 then begin
                // Are there any?
                if NetEvents.lNetworkEvents>0 then begin
                  // Was it FD_WRITE?
                  if (NetEvents.lNetworkEvents and FD_WRITE)>0 then begin
                    // If socket was just accepted, report as new connection
                    if fSockets[a-1].Fresh then begin
                      fSockets[a-1].Fresh:=False;
                      try
                        DoAccept(a-1, fSockets[a-1].Data, fSockets[a-1].Client);
                       except
                        on E: Exception do begin
                          try DoError('DoAccept exception: ' + E.Message) except end;
                          SocketDead:=True;
                        end;
                      end;
                    end;
                    // Socket is ready for more data
                    fSockets[a-1].Writable:=True;
                  end;

                  // Was it FD_READ?
                  if (NetEvents.lNetworkEvents and FD_READ)>0 then begin
                    // If socket was just accepted, report as new connection
                    if fSockets[a-1].Fresh then begin
                      fSockets[a-1].Fresh:=False;
                      try
                        DoAccept(a-1, fSockets[a-1].Data, fSockets[a-1].Client);
                       except
                        on E: Exception do begin
                          try DoError('DoAccept exception: ' + E.Message) except end;
                          SocketDead:=True;
                        end;
                      end;
                    end;
                    // Read data from connection
                    Len:=recv(fSockets[a-1].Socket, ReadBuf[0], BufSize, 0);
                    if Len>0 then begin
                      // If we got something, pass it on to application
                      try
                        DoRead(a-1, fSockets[a-1].Data, ReadBuf[0], Len);
                       except
                        on E: Exception do begin