Project Structure

• ServerDbThread.dpr
• ServerForm.pas
• ServerForm.dfm

program ServerDbThread;

uses
  Forms,
  ServerForm in 'ServerForm.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit ServerForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ScktComp, StdCtrls, Grids, DBGrids, Db, DBTables, ComCtrls;

type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    Label1: TLabel;
    lbClients: TListBox;
    lbLog: TListBox;
    ServerSocket1: TServerSocket;
    Table1: TTable;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    Table1Company: TStringField;
    Table1CompID: TFloatField;
    Table1Address: TStringField;
    Table1State: TStringField;
    Table1Country: TStringField;
    Table1Email: TStringField;
    Table1Contact: TStringField;
    Table1LoggedBy: TStringField;
    Table1LoggetOn: TDateField;
    procedure ServerSocket1ClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure FormCreate(Sender: TObject);
    procedure ServerSocket1GetThread(Sender: TObject;
      ClientSocket: TServerClientWinSocket;
      var SocketThread: TServerClientThread);
    procedure ServerSocket1Accept(Sender: TObject;
      Socket: TCustomWinSocket);
  private
    { Private declarations }
  end;

var
  Form1: TForm1;

implementation

type
  TDbServerThread = class(TServerClientThread)
  private
    strCommand: string;
    strFeedback: string;
  public
    procedure ClientExecute; override;
    procedure Log;
    procedure LogFeedback;
    procedure AddRecord;
  end;

var
  ID: Integer;

{$R *.DFM}

procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  lbLog.Items.Add ('Connected: ' +
    Socket.RemoteHost + ' (' + Socket.RemoteAddress + ')' );
end;

procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  lbLog.Items.Add ('Disconnected: ' +
    Socket.RemoteHost + ' (' + Socket.RemoteAddress + ')' );
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // use a table in the current directory
  Table1.DatabaseName :=
    ExtractFilePath (Application.ExeName);
  // create the table, if it doens't exist
  if not Table1.Exists then
    Table1.CreateTable;
  Table1.Active := True;
  // setup first ID
end;

{ TDbServerThread }

procedure TDbServerThread.Log;
begin
  Form1.lbLog.Items.Add ('Request: ' + strCommand);
end;

procedure TDbServerThread.LogFeedback;
begin
  Form1.lbLog.Items.Add ('Response: ' + strFeedback);
end;

procedure TDbServerThread.AddRecord;
var
  Data: TStringList;
  I: Integer;
begin
  Data := TStringList.Create;
  try
    Data.Text := strCommand;
    // new record
    Form1.Table1.Insert;
    // set the fields using the strings
    for I := 0 to Form1.Table1.FieldCount - 1 do
      Form1.Table1.Fields [I].AsString :=
        Data.Values [Form1.Table1.Fields[I].FieldName];
    // complete with random ID, sender, and date

    Form1.Table1CompID.AsInteger := ID;
    Inc(ID);
    Form1.Table1LoggedBy.AsString := ClientSocket.RemoteAddress;
    Form1.Table1LoggetOn.AsDateTime := Date;
    Form1.Table1.Post;
    // get the value to return
    strFeedback := Form1.Table1CompID.AsString;
  finally
    Data.Free;
  end;
end;

procedure TDbServerThread.ClientExecute;
var
  Stream: TWinSocketStream;
  Buffer, strIn: string;
  nRead: Integer;
begin
  // keep going
  Stream := TWinSocketStream.Create(ClientSocket, 5000);
  try
    while not Terminated and ClientSocket.Connected do
    begin
      // initialize (thread might be reused)
      Buffer := '';
      strIn := '';
      SetLength(Buffer, 64);
      repeat
        nRead := Stream.Read(Buffer[1], 64);
        if nRead = 0 then
        begin
          ClientSocket.Close;
          Break;
        end;
        SetLength (Buffer, nRead);
        StrIn := StrIn + Buffer;
      until (Pos(#10#13'.'#10#13, Buffer) > 0);

      if strIn = '' then
        Continue // keep going
      else
      begin
        // handle the request, if anything arrived
        StrCommand := Copy (strIn, 1, Pos (#10#13'.'#10#13, strIn) -1);
        Synchronize(Log);
        Synchronize(AddRecord);
        // send results back
        Synchronize(LogFeedback);
        Stream.Write(strFeedback[1], Length (strFeedback));
      end;
    end;
  finally
    Stream.Free;
  end;
end;

procedure TForm1.ServerSocket1GetThread(Sender: TObject;
  ClientSocket: TServerClientWinSocket;
  var SocketThread: TServerClientThread);
begin
  lbLog.Items.Add ('GetThread: ' +
    ClientSocket.RemoteHost + ' (' + ClientSocket.RemoteAddress + ')' );
  SocketThread := TDbServerThread.Create(False, ClientSocket);
end;

procedure TForm1.ServerSocket1Accept(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  lbLog.Items.Add ('Accepted: ' +
    Socket.RemoteHost + ' (' + Socket.RemoteAddress + ')' );
end;


initialization
  // Setup first ID for this session
  ID := GetTickCount;

end.

object Form1: TForm1
  Left = 369
  Top = 113
  Width = 536
  Height = 396
  Caption = 'Server'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object PageControl1: TPageControl
    Left = 0
    Top = 0
    Width = 528
    Height = 369
    ActivePage = TabSheet1
    Align = alClient
    TabIndex = 0
    TabOrder = 0
    object TabSheet1: TTabSheet
      Caption = 'Connections'
      DesignSize = (
        520
        341)
      object Label1: TLabel
        Left = 16
        Top = 8
        Width = 31
        Height = 13
        Caption = 'Clients'
      end
      object lbClients: TListBox
        Left = 16
        Top = 24
        Width = 161
        Height = 297
        Anchors = [akLeft, akTop, akBottom]
        ItemHeight = 13
        TabOrder = 0
      end
      object lbLog: TListBox
        Left = 184
        Top = 24
        Width = 313
        Height = 298
        Anchors = [akLeft, akTop, akRight, akBottom]
        ItemHeight = 13
        TabOrder = 1
      end
    end
    object TabSheet2: TTabSheet
      Caption = 'Database'
      object DBGrid1: TDBGrid
        Left = 0
        Top = 0
        Width = 520
        Height = 341
        Align = alClient
        DataSource = DataSource1
        TabOrder = 0
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'MS Sans Serif'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'Company'
            Width = 175
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'CompID'
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'Address'
            Width = 130
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'State'
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'Country'
            Width = 89
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'Email'
            Width = 116
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'Contact'
            Width = 88
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'LoggedBy'
            Width = 83
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'LoggetOn'
            Visible = True
          end>
      end
    end
  end
  object ServerSocket1: TServerSocket
    Active = True
    Port = 51
    ServerType = stThreadBlocking
    OnAccept = ServerSocket1Accept
    OnGetThread = ServerSocket1GetThread
    OnClientConnect = ServerSocket1ClientConnect
    OnClientDisconnect = ServerSocket1ClientDisconnect
    Left = 40
    Top = 48
  end
  object Table1: TTable
    FieldDefs = <
      item
        Name = 'Company'
        DataType = ftString
        Size = 50
      end
      item
        Name = 'CompID'
        DataType = ftFloat
      end
      item
        Name = 'Address'
        DataType = ftString
        Size = 100
      end
      item
        Name = 'State'
        DataType = ftString
        Size = 2
      end
      item
        Name = 'Country'
        DataType = ftString
        Size = 20
      end
      item
        Name = 'Email'
        DataType = ftString
        Size = 40
      end
      item
        Name = 'Contact'
        DataType = ftString
        Size = 40
      end
      item
        Name = 'LoggedBy'
        DataType = ftString
        Size = 40
      end
      item
        Name = 'LoggetOn'
        DataType = ftDate
      end>
    StoreDefs = True
    TableName = 'ServDb.db'
    Left = 36
    Top = 104
    object Table1Company: TStringField
      FieldName = 'Company'
      Size = 50
    end
    object Table1CompID: TFloatField
      FieldName = 'CompID'
    end
    object Table1Address: TStringField
      FieldName = 'Address'
      Size = 100
    end
    object Table1State: TStringField
      FieldName = 'State'
      Size = 2
    end
    object Table1Country: TStringField
      FieldName = 'Country'
    end
    object Table1Email: TStringField
      FieldName = 'Email'
      Size = 40
    end
    object Table1Contact: TStringField
      FieldName = 'Contact'
      Size = 40
    end
    object Table1LoggedBy: TStringField
      FieldName = 'LoggedBy'
      Size = 40
    end
    object Table1LoggetOn: TDateField
      FieldName = 'LoggetOn'
    end
  end
  object DataSource1: TDataSource
    DataSet = Table1
    Left = 36
    Top = 160
  end
end