• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 392
  • Last Modified:

client / server file download

good evining gentilmen
this my first quistion here i hope u will help me

i am coding  a client server application with delphi
i made file manger
but the problem when i download 2 or more files at same time it return errors
so pls any idia about that and about to susbend and resum downloading

thnxxxx
0
the_gladiator
Asked:
the_gladiator
  • 3
  • 2
1 Solution
 
TheRealLokiSenior DeveloperCommented:
We will need some more information before we can offer you any useful help.
What components are you using? Indy, ICS, Native Sockets?
Are you creating a specific existing protocol. e.g. FTP, or is this a custom one?
I've got some demos up on http://sourceforge.net/projects/internetdemos if you are using indy or native sockets
0
 
the_gladiatorAuthor Commented:
thnx for reply
i am using tclientsocket and tserversocket
i am using normal connection
0
 
TheRealLokiSenior DeveloperCommented:
I have a Serversocket demo on that site, it shows file xfer
0
 
the_gladiatorAuthor Commented:
thnx for reply my friend
just past link for it or for any source

thnx
0
 
TheRealLokiSenior DeveloperCommented:
well here's the code from my demo
you should only need the "CMD_FILE" routine
you can test teh code with any of the "clients" from my demo page
or just do
telnet localhost 2000

unit servermain;
 
(*
      The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at
      http://www.mozilla.org/MPL/
 
      Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
      ANY KIND, either express or implied. See the License for the specific language governing rights and
      limitations under the License.
 
      The Initial Developer of the Original Code is David Hooper }=-Loki=-{. Portions created by
       David Hooper are Copyright (C) 2006 David Hooper. All Rights
      Reserved.
 
*)
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, FileCtrl, ScktComp, WinSock, ExtCtrls;
 
const
  WM_DisplayConnections = WM_user + 101;
  WM_ClientFileProgress = WM_user + 102;
 
// Client Sub stages
  css_NONE = 0;
// File
  css_File_WaitingForFilename = 0;
  css_File_WaitingForFilesize = 1;
  css_File_ReceivingStream    = 2;
 
  DefaultBufferLength = 8192;
 
  ClientsRepaintTime = 100; // miliseconds - how often to repaint progress bars.
 
// Process
  PingInterval = 10; // ping every "x" seconds
  PingTimeout  = 10; // if no response to "ping" in "x" seconds, then fail
 
{
// used in the lParam for threads sending log messages
  tlmtinformation = 1;
  tlmtWarning = 2;
  tlmtError = 4;
// used in the lParam for threads sending log messages
  tldNone = 8;
  tldIn = 16;
  tldOut = 32;
}
 
// used for logging only
type TImportanceLevel = (ilBoring, ilLow, ilNormal, ilHigh, ilImportant);
type TLogMessageType = (lmtInformation, lmtWarning, lmtError);
type TLogDirection = (ldNone, ldConnect, ldDisconnect, ldIn, ldOut);
// flag so we know what stage the client connection is in. i.e. has it sent a valid password and logged in
type TClientStage = (csNone, csCommand, csFile, csTimer, csCountdown, csProcess);
 
// the data object for each client. We store any extra info we want about the client here.
// we also have the events for file transfer here
 
// make our own socket to hold specific information about each connection.
type
  TSpecificClientConnection = class(TServerClientWinSocket)
  private
    function GetCurrentProgressPercent: integer;
    function GetDisplayName: string;
    procedure ClientTimer_Timer(Sender: TObject);
  public
    ClientStage: TClientStage;
    SubStage: integer; // uses constants for various commands eg. "waiting for filename" css_File_WaitingForFilename
    ID:          string; // just the unique id we create for each connection
    Username:    string;
    ReceivedString: string; //buffer of string data sent to us (we break this up by #13#10)
    // used for csFile progress
    Filename_: string;
    FS: TFileStream;
    ExpectedFileSize, CurrentProgress: int64;
    ClientBuffer: array[0..defaultbufferlength] of Byte;
    ShowProgress: boolean;
    // used for certain tasks (csTimer, csCountdown, csProcess)
    ClientTimer: TTimer;
    CounterValue: integer;
    // used for csProcess
    Process: record
      WaitResult: integer;
      StartupInfo: TStartupInfo;
      ProcessInfo: TProcessInformation;
      iResult: integer;
      Filename: string;
      ClientResponding: boolean;
      Counter: integer;
      S: string;
      BeforePing, AfterPing: int64;
    end;
 
    property CurrentProgressPercent: integer Read GetCurrentProgressPercent;
    property DisplayName: string read GetDisplayName;
    function CanProcessNewCommands: boolean;
    // used when we are receiving data while in a 1-way conversational place, like "csCountdown" or "csTimer"
    // New commands are simply queued up to be processed when the 1-way stage is complete (stage complete calls "HandleCommand" manually)
 
    constructor Create(Socket: TSocket; ServerWinSocket: TServerWinSocket);
    destructor Destroy; override;
  end;
 
 
type
  TfServerMain = class(TForm)
    lbLogging: TListBox;
    gbSettings:    TGroupBox;
    Label1:        TLabel;
    ePort:         TEdit;
    bListen:       TButton;
    bOffline:      TButton;
    lConnectionCount: TLabel;
    lbConnections: TListBox;
    Splitter1:     TSplitter;
    ServerSocket1: TServerSocket;
    tClientsRepaint: TTimer;
    procedure bListenClick(Sender: TObject);
    procedure bOfflineClick(Sender: TObject);
    procedure lbConnectionsDrawItem(Control: TWinControl; Index: integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure FormCreate(Sender: TObject);
    procedure ServerSocket1Listen(Sender: TObject; Socket: TCustomWinSocket);
    procedure ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure ServerSocket1ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure ServerSocket1GetSocket(Sender: TObject; Socket: Integer; var ClientSocket: TServerClientWinSocket);
    procedure tClientsRepaintTimer(Sender: TObject);
  private
    { Private declarations }
    fLoggingLevel: TImportanceLevel;
    // the following procedures are run in the context of a client thread
    procedure SendStringWithLogging(Socket: TCustomWinSocket; S: string);
 
    procedure HandleCommand(Socket: TCustomWinSocket);
    procedure CMD_LOGIN(Socket: TCustomWinSocket; InCmd: string);
    procedure CMD_TIMER(Socket: TCustomWinSocket; InCmd: string);
    procedure CMD_COUNTDOWN(Socket: TCustomWinSocket; InCmd: string);
    procedure CMD_FILE(Socket: TCustomWinSocket; InCmd: string);
    procedure CMD_PROCESS(Socket: TCustomWinSocket; InCmd: string);
      procedure CMD_PROCESS_Heartbeat(Socket: TCustomWinSocket; InCmd: string); // usually just the Ping-Pong "PONG" response
  public
    { Public declarations }
    property LoggingLevel: TImportanceLevel Read fLoggingLevel Write fLoggingLevel;
    procedure LogMessage(Socket: TCustomWinSocket;
      ImportanceLevel: TImportanceLevel; LogMessageType: TLogMessageType;
      LogDirection: TLogDirection; S: string); overload;
    procedure LogMessage(ImportanceLevel: TImportanceLevel;
      LogMessageType: TLogMessageType; LogDirection: TLogDirection; S: string); overload;
    procedure DisplayConnectionCount(Socket: TCustomWinSocket);
    // Messages
    // the following procedures are for catching the windows messages the client thread sends us
    procedure DisplayConnections(var Msg: TMessage); message WM_DisplayConnections;
  end;
 
var
  fServerMain: TfServerMain;
 
implementation
 
{$R *.DFM}
 
procedure TfServerMain.FormCreate(Sender: TObject);
begin
  LoggingLevel := ilBoring; //ilNormal;
  // get rid of the flicker during file transfer
  lbConnections.DoubleBuffered := True;
  tClientsRepaint.Interval := ClientsRepaintTime;
end;
 
procedure TfServerMain.LogMessage(Socket: TCustomWinSocket;
  ImportanceLevel: TImportanceLevel; LogMessageType: TLogMessageType;
  LogDirection: TLogDirection; S: string);
begin
  LogMessage(ImportanceLevel, LogMessageType, LogDirection,
    Socket.RemoteAddress + ':' + IntToStr(Socket.RemotePort) + ' ' + s);
end;
 
// display our message in a readable format, by using the flags we set (in, out, info, error etc)
procedure TfServerMain.LogMessage(ImportanceLevel: TImportanceLevel;
  LogMessageType: TLogMessageType; LogDirection: TLogDirection; S: string);
var
  FullMsg: string;
begin
  if ImportanceLevel >= LoggingLevel then
  begin
    FullMSg := '';
    case LogMessageType of
      lmtInformation: FullMsg := '  ';
      lmtWarning: FullMsg := '? ';
      lmtError: FullMsg := '!  ';
    end;
 
    case LogDirection of
      ldNone: FullMsg    := FullMsg + '   ';
      ldConnect: FullMsg := FullMsg + ' + ';
      ldDisconnect: FullMsg := FullMsg + ' - ';
      ldIn: FullMsg      := FullMsg + '<- ';
      ldOut: FullMsg     := FullMsg + '-> ';
    end;
    FullMsg := FullMsg + FormatDateTime('hh":"nn":"ss', Now) + ' ' + S;
    lbLogging.Items.Add(FullMsg);
    while lbLogging.Items.Count > 1000 do
      lbLogging.Items.Delete(0);
    lbLogging.ItemIndex := pred(lbLogging.Items.Count);
  end;
end;
 
procedure TfServerMain.SendStringWithLogging(Socket: TCustomWinSocket; S: string);
begin
  Socket.SendText(S + #13#10);
  LogMessage(Socket, ilBoring, lmtInformation, ldOut, S);
end;
 
procedure TfServerMain.bListenClick(Sender: TObject);
begin
  ServerSocket1.Port   := StrToIntDef(ePort.Text, 2000);
  ServerSocket1.Active := True;
end;
 
procedure TfServerMain.bOfflineClick(Sender: TObject);
begin
  ServerSocket1.Active := False;
  LogMessage(ilHigh, lmtInformation, ldNone, 'OFFLINE');
  PostMessage(fServerMain.Handle, WM_DisplayConnections, 0, 0);
end;
 
procedure TfServerMain.ServerSocket1Listen(Sender: TObject; Socket: TCustomWinSocket);
begin
  LogMessage(ilHigh, lmtInformation, ldNone, 'BOUND TO PORT ' +
    IntToStr(ServerSocket1.Port));
  LogMessage(ilHigh, lmtInformation, ldNone, 'LISTENING');
end;
 
procedure TfServerMain.DisplayConnections(var Msg: TMessage);
var
  i: integer;
begin
  i  := Msg.WParam;
  if i = 0 then
    DisplayConnectionCount(nil)
  else
    DisplayConnectionCount(TCustomWinSocket(i));
end;
 
procedure TfServerMain.tClientsRepaintTimer(Sender: TObject);
begin
  tClientsRepaint.Enabled := False;
  lbConnections.Refresh;
end;
 
procedure TfServerMain.ServerSocket1GetSocket(Sender: TObject;
  Socket: Integer; var ClientSocket: TServerClientWinSocket);
begin
// create our own socket (with extra information) for this connection.
  ClientSocket := (TSpecificClientConnection.Create( Socket, (sender as tserverwinsocket)));
end;
 
procedure TfServerMain.ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  (Socket as TSpecificClientConnection).ID := Socket.RemoteAddress + ':' + IntToStr(Socket.RemotePort);
  LogMessage(Socket, ilNormal, lmtInformation, ldConnect, 'connected');
  PostMessage(fServerMain.Handle, WM_DisplayConnections, 0, 0);
end;
 
procedure TfServerMain.ServerSocket1ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  LogMessage(Socket, ilNormal, lmtInformation, ldDisconnect, 'disconnected');
  PostMessage(fServerMain.Handle, WM_DisplayConnections, integer(Socket), 0);
end;
 
procedure TfServerMain.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
begin
{ if we are in "command" mode, then call another method
which splits the receivedstring at #13#10 and does a
while stage = command do...
- this way we can call that procedure from our clienttimerOntimer() event
and have it process any pending commands.
also, when the stage switches to "file" it can know to carry on with the file commands
 - haven't worked this out exactly yet
 }
  case (Socket as TSpecificClientConnection).ClientStage of
    csNone, csCommand: HandleCommand(Socket);
    csFile:
      begin
        case (Socket as TSpecificClientConnection).SubStage of
          css_File_WaitingForFilename: HandleCommand(Socket);
          css_File_WaitingForFilesize: HandleCommand(Socket);
          css_File_ReceivingStream: CMD_File(Socket, '');
        end;
      end;
    csCountdown, csTimer:
      begin
        HandleCommand(Socket);
        // although we have told this to read the command from teh socket, it will not get processed
        // because the stage denies processing (by "CanProcessNewCommands" being false)
        // once the timer or countdown has completed, it will manually
        // call the HandleCommand() routine to process the commands later
      end;
      csProcess: HandleCommand(Socket);
  else
    SendStringWithLogging(Socket, 'Unknown Stage');
  end;
end;
 
procedure TfServerMain.HandleCommand(Socket: TCustomWinSocket);
var
  S: string;
  InCmd: string;
begin
  S := Socket.ReceiveText;
  (Socket as TSpecificClientConnection).ReceivedString :=
    (Socket as TSpecificClientConnection).ReceivedString + S;
  while (
          (Socket as TSpecificClientConnection).CanProcessNewCommands and
          (pos(#13#10, (Socket as TSpecificClientConnection).ReceivedString) > 0)
        ) do
  begin
    InCmd := copy((Socket as TSpecificClientConnection).ReceivedString, 1, pos(#13#10, (Socket as TSpecificClientConnection).ReceivedString)-1);
    delete((Socket as TSpecificClientConnection).ReceivedString, 1, length(InCmd) + 2);
    if (length(InCmd) > 1) and (copy(InCmd, length(InCmd)-1, 2) = #13#10) then
      delete(InCMd, length(InCmd)-1, 2); // remove CR/LF
    if InCmd <> '' then
    begin
      LogMessage((Socket as TSpecificClientConnection), ilBoring, lmtInformation, ldIn, InCmd);
 
      case (Socket as TSpecificClientConnection).ClientStage of
        csNone: CMD_LOGIN(Socket, InCmd);
        csCommand:
          begin
            if InCmd = 'PING' then
              SendStringWithLogging(Socket, 'PONG')
            //Note: we do not show logging for this, becaue we want it as fast as possible
            else if InCmd = 'JUMP' then
              SendStringWithLogging(Socket, 'Whee!')
            else if (pos('TIMER ', InCmd) = 1) then
              CMD_TIMER(SOCKET, copy(InCmd, pos(' ', InCmd) + 1, maxint))
            else if (pos('COUNTDOWN ', InCmd) = 1) then
              CMD_COUNTDOWN(Socket, copy(InCmd, pos(' ', InCmd) + 1, maxint))
            else if InCmd = 'FILE' then
            begin
              (Socket as TSpecificClientConnection).ClientStage := csFile;
              (Socket as TSpecificClientConnection).SubStage := css_File_WaitingForFilename;
            end
            else if (pos('PROCESS ', InCmd) = 1) then
              CMD_PROCESS(Socket, copy(InCmd, pos(' ', InCmd) + 1, maxint))
            else if InCmd = 'QUIT' then
              Socket.Close
            else if (pos('CHAT ', InCmd) = 1) then
            begin
            // already logged , so nothing to do atm
            end
            else
              SendStringWithLogging(Socket, 'ERROR Unknown command "' + InCmd + '"');
          end;
        csFile: CMD_FILE(Socket, InCmd);
        csProcess: CMD_PROCESS_Heartbeat(Socket, InCmd); // usually the PING-PONG response "PONG"
        else
          SendStringWithLogging(Socket, 'Unknown Stage');
      end;
    end;
  end;
end;
 
procedure TfServerMain.CMD_COUNTDOWN(Socket: TCustomWinSocket; InCmd: string);
begin
    (Socket as TSpecificClientConnection).ClientStage := csCountdown;
    (Socket as TSpecificClientConnection).CounterValue := StrToIntDef(InCmd, 1);
    SendStringWithLogging((Socket as TCustomWinSocket), 'COUNTDOWN: ' + IntToStr((Socket as TSpecificClientConnection).CounterValue));
    (Socket as TSpecificClientConnection).ClientTimer.Interval := 1000;
    (Socket as TSpecificClientConnection).ClientTimer.Enabled := True;
end;
 
procedure TfServerMain.CMD_TIMER(Socket: TCustomWinSocket; InCmd: string);
begin
    (Socket as TSpecificClientConnection).ClientStage := csTimer;
    (Socket as TSpecificClientConnection).CounterValue := StrToIntDef(InCmd, 1);
    (Socket as TSpecificClientConnection).ClientTimer.Interval := 1000;
    (Socket as TSpecificClientConnection).ClientTimer.Enabled := True;
end;
 
 
procedure TfServerMain.CMD_FILE(Socket: TCustomWinSocket; InCmd: string);
var
  s: string;
  sbufferlength: integer;
  howmuchdoweneed, howmuchdidweread: int64;
//  i, j: int64;
begin
  case (Socket as TSpecificClientConnection).SubStage of
    css_File_WaitingForFilename:
      begin
        (Socket as TSpecificClientConnection).Filename_ := InCmd;
        (Socket as TSpecificClientConnection).SubStage := css_File_WaitingForFilesize;
      end;
    css_File_WaitingForFilesize:
      begin
        (Socket as TSpecificClientConnection).ExpectedFileSize := StrToInt64Def(InCmd, 0);
// test the file info.
        s := ExtractFilePath(ParamStr(0)) + 'In\' + ExtractFilename((Socket as TSpecificClientConnection).Filename_);
        (Socket as TSpecificClientConnection).Filename_ := s;
(*
        if FileExists(S) then
        begin // would overwrite
          (Socket as TSpecificClientConnection).ClientStage := csCommand;
          (Socket as TSpecificClientConnection).SubStage := css_NONE;
          SendStringWithLogging(Socket, 'ERROR File would overwrite');
        end
        else *)if (Socket as TSpecificClientConnection).ExpectedFileSize = 0 then
        begin
          (Socket as TSpecificClientConnection).ClientStage := csCommand;
          (Socket as TSpecificClientConnection).SubStage := css_NONE;
          SendStringWithLogging(Socket, 'ERROR Filesize');
        end
        else
        try
// attempt to create the filestream, and then send "OK"
          ForceDirectories(ExtractFilePath(S));
          if assigned((Socket as TSpecificClientConnection).FS) then FreeAndNil((Socket as TSpecificClientConnection).FS);
{
          if (Socket as TSpecificClientConnection).ClientBufferLength <> DefaultBufferLength then
          begin
            (Socket as TSpecificClientConnection).ClientBufferLength := DefaultBufferLength;
            SetLength((Socket as TSpecificClientConnection).ClientBuffer, (Socket as TSpecificClientConnection).ClientBufferLength);
          end;
}
          (Socket as TSpecificClientConnection).FS := TFileStream.Create(S, fmCreate);
          (Socket as TSpecificClientConnection).CurrentProgress := 0;
          (Socket as TSpecificClientConnection).SubStage := css_File_ReceivingStream;
          SendStringWithLogging(Socket, 'OK Please send file now');
        except
          on e: exception do
          begin
            (Socket as TSpecificClientConnection).ClientStage := csCommand;
            (Socket as TSpecificClientConnection).SubStage := css_NONE;
            SendStringWithLogging(Socket, 'ERROR ' + E.Message);
          end;
        end;
      end;
      css_File_ReceivingStream:
      begin
        sbufferlength := Socket.ReceiveLength; // how much data is there to collect in this read?
{
        if sbufferlength > (Socket as TSpecificClientConnection).ClientBufferLength then
        begin // increase our buffer because we obviously cannot keep up.
          (Socket as TSpecificClientConnection).ClientBufferLength := sbufferlength;
          SetLength((Socket as TSpecificClientConnection).ClientBuffer, (Socket as TSpecificClientConnection).ClientBufferLength);
        end;
}
//Read as much as we can. either the remainder of the file, or the complete buffer, or our buffer size, whichever is less
        howmuchdoweneed := ((Socket as TSpecificClientConnection).ExpectedFileSize - (Socket as TSpecificClientConnection).CurrentProgress);
        if sbufferlength < howmuchdoweneed then howmuchdoweneed := sbufferlength;
        if DefaultBufferLength < sbufferlength then howmuchdoweneed := DefaultBufferLength;
// now read what we can
        howmuchdidweread := Socket.ReceiveBuf((Socket as TSpecificClientConnection).Clientbuffer, howmuchdoweneed);
// copy this to our stream
        (Socket as TSpecificClientConnection).FS.Write((Socket as TSpecificClientConnection).ClientBuffer, howmuchdidweread);
        (Socket as TSpecificClientConnection).CurrentProgress := (Socket as TSpecificClientConnection).CurrentProgress + howmuchdidweread;
        if ((Socket as TSpecificClientConnection).CurrentProgress >= (Socket as TSpecificClientConnection).ExpectedFileSize) then
        begin // finished receiving all expected data
            FreeAndNil((Socket as TSpecificClientConnection).FS);
            (Socket as TSpecificClientConnection).ClientStage := csCommand;
            (Socket as TSpecificClientConnection).SubStage := css_NONE;
            SendStringWithLogging(Socket, 'OK received file');
        end;
        fServerMain.tClientsRepaint.Enabled := True;
//        Postmessage(fServerMain.Handle, WM_ClientFileProgress, 0, 0);
      end;
  end;
//
end;
 
procedure TfServerMain.CMD_LOGIN(Socket: TCustomWinSocket; InCmd: string);
var
  s, s2: string;
  i: integer;
begin
  if (pos('LOGIN', uppercase(InCmd)) = 1) then
  begin
    Delete(InCmd, 1, length('LOGIN ')); // remove the LOGIN part
    i := pos(' ', InCmd);
    if i = 0 then
      SendStringWithLogging(Socket,
      'ERROR Not enough parameters for "LOGIN" command. expecting LOGIN <username> <password>')
    else
    begin
      S  := copy(InCmd, 1, i - 1);
      S2 := copy(InCmd, i + 1, maxint);
    // check login details here, e.g. database, ini file, whatever. for now we will just always accept
      (Socket as TSpecificClientConnection).Username := S;
      (Socket as TSpecificClientConnection).ClientStage := csCommand; // logged in. allows other commands
    // send the "ID" command, this means login was successful (could just send "OK" if you like
      SendStringWithLogging(Socket, 'ID ' + (Socket as TSpecificClientConnection).ID);
      fServerMain.tClientsRepaint.Enabled := True;
    end;
  end
  else
    SendStringWithLogging(Socket, 'ERROR Not logged in. Can not use "' + InCmd + '" command');
end;
 
procedure TfServerMain.CMD_PROCESS(Socket: TCustomWinSocket;  InCmd: string);
begin
    if (uppercase(InCmd) = 'TEST') then
    begin
      if FileExists('C:\Windows\Notepad.exe') then
        (Socket as TSpecificClientConnection).Process.Filename := 'C:\Windows\Notepad.exe'
      else if FileExists('C:\WinNT\Notepad.exe') then
        (Socket as TSpecificClientConnection).Process.Filename := 'C:\WinNT\Notepad.exe';
    end
    else
      (Socket as TSpecificClientConnection).Process.Filename := ''; // would normally determine the process from the passed parameter
    (Socket as TSpecificClientConnection).Process.ClientResponding := True; // default
    (Socket as TSpecificClientConnection).Process.Counter := 0;
    (Socket as TSpecificClientConnection).Process.BeforePing := 0;
    (Socket as TSpecificClientConnection).Process.AfterPing := 0;
    (Socket as TSpecificClientConnection).Process.ClientResponding := True;
 
    // for this example we will just run notepad
    if (Socket as TSpecificClientConnection).Process.Filename <> '' then
    begin
      FillChar((Socket as TSpecificClientConnection).Process.StartupInfo, SizeOf((Socket as TSpecificClientConnection).Process.StartupInfo), 0);
      with (Socket as TSpecificClientConnection).Process.StartupInfo do
      begin
        cb      := SizeOf((Socket as TSpecificClientConnection).Process.StartupInfo);
        dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
(* you could pass sw_show or sw_hide as parameter
sw_hide would make more sense if you do not wish to see anything on the screen
                    but not a good idea if the application doe not close itself*)
        wShowWindow := SW_SHOW; //visibility;
      end;
      if CreateProcess(nil, PChar((Socket as TSpecificClientConnection).Process.Filename), nil, nil, False,
        NORMAL_PRIORITY_CLASS, nil, nil, (Socket as TSpecificClientConnection).Process.StartupInfo, (Socket as TSpecificClientConnection).Process.ProcessInfo) then
      begin // successfully created the process, set the timer to check every second
          (Socket as TSpecificClientConnection).ClientStage := csProcess;
          (Socket as TSpecificClientConnection).ClientTimer.Interval := 1000;
          (Socket as TSpecificClientConnection).ClientTimer.Enabled := True;
      end
      else
      begin //Failed
        (Socket as TSpecificClientConnection).Process.iresult := GetLastError;
        LogMessage(Socket, ilHigh, lmtError, ldNone, 'Unable to create process: ' + IntToStr((Socket as TSpecificClientConnection).Process.iresult));
        SendStringWithLogging(Socket, 'ERROR: Unable to create process: ' + IntToStr((Socket as TSpecificClientConnection).Process.iresult));
        (Socket as TSpecificClientConnection).ClientStage := csCommand;
      end;
    end
    else
    begin
        SendStringWithLogging(Socket, 'ERROR: No process file');
        (Socket as TSpecificClientConnection).ClientStage := csCommand;
    end;
          // check ctrl1, ctrl2 and put code in the clienttimer
end;
 
procedure TfServerMain.CMD_PROCESS_Heartbeat(Socket: TCustomWinSocket; InCmd: string);
begin
  (Socket as TSpecificClientConnection).Process.AfterPing := GetTickCount;
  LogMessage(Socket, ilBoring, lmtInformation, ldNone,  InCmd + ' (' +
    IntToStr((Socket as TSpecificClientConnection).Process.AfterPing - (Socket as TSpecificClientConnection).Process.BeforePing) + 'ms)');
  if InCmd <> 'PONG' then
    LogMessage(Socket, ilNormal, lmtWarning, ldIn, 'Expected "PONG", received "' + InCmd + '"');
    (Socket as TSpecificClientConnection).Process.BeforePing := 0;
    (Socket as TSpecificClientConnection).Process.AfterPing := 0;
    (Socket as TSpecificClientConnection).Process.Counter := 0;
end;
 
procedure TfServerMain.lbConnectionsDrawItem(Control: TWinControl;
  Index: integer; Rect: TRect; State: TOwnerDrawState);
var
  progressbarrect: TRect;
  progressrect:    TRect;
 
  lastcolor: tcolor;
  currentx: integer;
  progresspercent: integer;
  currentconnection: TSpecificClientConnection;
begin
  with (Control as TListbox).Canvas do
  begin
    (* This ensures the correct highlight color is used *)
    FillRect(Rect);
    // outline of progress bar
    progressbarrect.Top    := Rect.Top;
    progressbarrect.Left   := Rect.Left;
    progressbarrect.Bottom := Rect.Bottom;
    progressbarrect.Right  := (progressbarrect.Left + 57);
 
    lastcolor := Brush.Color;
    InflateRect(progressbarrect, -2, -2);
    if odSelected in State then
      Brush.Color := clWhite
    else
      Brush.Color := clBlack;
    (Control as TListbox).Canvas.FrameRect(progressbarrect);
 
    progresspercent := 0; //default
 
    // actual progress
    if assigned((Control as TListbox).Items.Objects[Index]) then
    begin
      currentconnection := ((Control as TListbox).Items.Objects[Index] as TSpecificClientConnection);
      progresspercent := currentconnection.CurrentProgressPercent;
      if (Control as TListbox).Items[Index] <> currentconnection.DisplayName then
      (Control as TListbox).Items[Index] := currentconnection.DisplayName;
    end;
    if progresspercent > 0 then
    begin
      progressrect.Top := progressbarrect.Top + 1;
      progressrect.Left := progressbarrect.Left + 1;
      progressrect.Bottom := progressbarrect.Bottom - 1;
      progressrect.Right := progressrect.Left + 1 + (progresspercent div 2);
      // to get 1-100 to 1-50 pixels
      Brush.Color := clLime;
      (Control as TListbox).Canvas.FillRect(progressrect);
    end;
    Brush.Color := lastcolor;
    currentx    := Rect.Left + (progressbarrect.Right -
      progressbarrect.Left) + 4 + 2;
    TextOut(currentx, Rect.Top, lbConnections.items[Index]);
  end;
end;
 
{
//used to catch logging message from thread
procedure TfServerMain.WriteLog(var Msg: TMessage);
var
  PS: PString;
  S:  string;
  i:  integer;
  LogMessageType: TLogMessageType;
  LogDirection: TLogDirection;
begin
 
  PS := Pointer(Msg.WParam);
  S  := PS^;
 
  i := Msg.LParam;
  if (i and tlmtinformation) = tlmtinformation then
    LogMessageType := lmtInformation;
  if (i and tlmtwarning) = tlmtwarning then
    LogMessageType := lmtWarning;
  if (i and tlmterror) = tlmterror then
    LogMessageType := lmtError;
 
  if (i and tldNone) = tldNone then
    LogDirection := ldNone;
  if (i and tldIn) = tldIn then
    LogDirection := ldIn;
  if (i and tldOut) = tldOut then
    LogDirection := ldOut;
  LogMessage(LogMessageType, LogDirection, S);
 
  //        FS.WriteBuffer(S^[1],Length(S^));
  Dispose(PS);
end;
}
// used to catch connects and disconnects, and display the connection info at a suitable time (ie. after the connect or disconnect)
//start of file transfer
 
procedure TfServerMain.DisplayConnectionCount(Socket: TCustomWinSocket);
var
  i: integer;
  founddisconnectingsocket: boolean;
begin
    founddisconnectingsocket := false;
    ServerSocket1.Socket.Lock;
    try
      lbConnections.Items.BeginUpdate;
      lbConnections.Items.Clear;
      lConnectionCount.Caption := IntToStr(ServerSocket1.Socket.ActiveConnections) + ' connections';
 
      for i := 0 to ServerSocket1.Socket.ActiveConnections - 1 do
      begin
        if (Socket <> ServerSocket1.Socket.Connections[i]) then // Socket is the disconnecting socket
        begin
          lbConnections.Items.AddObject(
          (ServerSocket1.Socket.Connections[i] as TSpecificClientConnection).DisplayName,
            (ServerSocket1.Socket.Connections[i] as TSpecificClientConnection));
        end
        else
          founddisconnectingsocket := True;
      end;
    finally
      lbConnections.Items.EndUpdate;
      ServerSocket1.Socket.Unlock;
    end;
    if founddisconnectingsocket then
      PostMessage(fServerMain.Handle, WM_DisplayConnections, integer(Socket), 0);
end;
 
{ TSpecificClientConnection }
 
function TSpecificClientConnection.CanProcessNewCommands: boolean;
begin
  result := ClientStage in [csNone, csCommand, csFile, csProcess];
  if (ClientStage = csFile) and (SubStage = css_File_ReceivingStream) then
    result := False; // although it is inconceivable that it could get to the HandleCommand() routine, i am putting this here for completeness.
end;
 
procedure TSpecificClientConnection.ClientTimer_Timer(Sender: TObject);
  var
    rearm: boolean;
begin
  self.ClientTimer.Enabled := False;
  rearm := True;
  try
    case self.ClientStage of
      csTimer:
        begin
          dec(CounterValue);
          if CounterValue <= 0 then
          begin
            rearm := False;
            self.ClientStage := csCommand;
            fServerMain.SendStringWithLogging((self as TCustomWinSocket), 'TIMER_STOPPED');
            if (self as TCustomWinSocket).ReceivedString <> '' then fServerMain.HandleCommand((self as TCustomWinSocket)); // check for new commands
          end;
        end;
 
      csCountdown:
        begin
          dec(CounterValue);
          if CounterValue > 0 then
          begin
            fServerMain.SendStringWithLogging((self as TCustomWinSocket), 'COUNTDOWN: ' + IntToStr(CounterValue));
          end
          else
          begin
            rearm := False;
            self.ClientStage := csCommand;
            fServerMain.SendStringWithLogging((self as TCustomWinSocket), 'COUNTDOWN_END');
            if (self as TCustomWinSocket).ReceivedString <> '' then fServerMain.HandleCommand((self as TCustomWinSocket));
          end;
        end;
 
      csProcess:
        begin
          inc(self.Process.Counter);
          //Check if process finished first
          self.Process.WaitResult := WaitForSingleObject(self.Process.ProcessInfo.hProcess, 1);
          //Wait for 1/1000th seconds at a time.
          if (self.Process.WaitResult <> WAIT_TIMEOUT) then
          begin // Process finished
            if self.Process.ProcessInfo.hProcess <> 0 then
              CloseHandle(self.Process.ProcessInfo.hProcess);
            if self.Process.ProcessInfo.hThread <> 0 then
              CloseHandle(self.Process.ProcessInfo.hThread);
            Process.ProcessInfo.hProcess := 0;
            Process.ProcessInfo.hThread := 0;
            self.ClientStage := csCommand;
            rearm := False;
            fServerMain.SendStringWithLogging((self as TCustomWinSocket), 'PROCESS_DONE');
            if (self as TCustomWinSocket).ReceivedString <> '' then fServerMain.HandleCommand((self as TCustomWinSocket));
          end
          else if (self.Process.Counter > (PingInterval + PingTimeout) ) then
          begin // timed out after pinging
            self.Process.ClientResponding := False;
            fServerMain.LogMessage((self as TCustomWinSocket), ilHigh, lmtWarning, ldNone,'Timed out wating for Ping response');
            //Terminate the process
            self.Process.iresult := integer(TerminateProcess(self.Process.ProcessInfo.hProcess, 0));
 
            if self.Process.ProcessInfo.hProcess <> 0 then
              CloseHandle(self.Process.ProcessInfo.hProcess);
            if self.Process.ProcessInfo.hThread <> 0 then
              CloseHandle(self.Process.ProcessInfo.hThread);
            Process.ProcessInfo.hProcess := 0;
            Process.ProcessInfo.hThread := 0;
 
            self.ClientStage := csCommand;
            rearm := False;
            if (self as TCustomWinSocket).ReceivedString <> '' then fServerMain.HandleCommand((self as TCustomWinSocket));
          end
          else if ( (self.Process.BeforePing = 0) and (self.Process.Counter >= PingInterval) ) then
          begin // time to do a ping and check if we are still there
            self.Process.BeforePing := GetTickCount;
            fServerMain.SendStringWithLogging((self as TCustomWinSocket), 'PING');
          end;
        end;
      else
        rearm := False;
    end;
  finally
    if rearm then self.ClientTimer.Enabled := True;
  end;
 
end;
 
constructor TSpecificClientConnection.Create(Socket: TSocket;
  ServerWinSocket: TServerWinSocket);
begin
  ReceivedString := '';
  ID := '';
  Username := '';
  ClientTimer := TTimer.Create(nil);
  ClientTimer.Enabled := False;
  ClientTimer.OnTimer := self.ClientTimer_Timer;
  inherited Create(Socket, ServerWinSocket);
end;
 
destructor TSpecificClientConnection.Destroy;
begin
  ClientTimer.Enabled := False;
  ClientTimer.Free;
  if assigned(FS) then FreeAndNil(FS);
  if Process.ProcessInfo.hProcess <> 0 then
  try
    //Terminate the process
    self.Process.iresult := integer(TerminateProcess(self.Process.ProcessInfo.hProcess, 0));
    CloseHandle(Process.ProcessInfo.hProcess);
    if Process.ProcessInfo.hThread <> 0 then
      CloseHandle(Process.ProcessInfo.hThread);
    Process.ProcessInfo.hProcess := 0;
    Process.ProcessInfo.hThread := 0;
  except
  end;
 
  inherited;
end;
 
//convert the data sent / total into a nice %age
function TSpecificClientConnection.GetCurrentProgressPercent: integer;
begin
  if ExpectedFileSize = 0 then
    Result := 0
  else
    Result := Trunc( (CurrentProgress / ExpectedFileSize) * 100);
  if Result > 100 then
    Result := 100;
end;
 
function TSpecificClientConnection.GetDisplayName: string;
begin
  result := UserName;
  if result = '' then result := ID;
  if result = '' then result := '(not connected)';
end;
 
 
end.
 
 
*************************
**** FORM FOLLOWS
*************************
 
 
object fServerMain: TfServerMain
  Left = 274
  Top = 107
  Width = 569
  Height = 507
  Caption = 'Delphi 5 Sockets }-Loki=-{ lokiwashere@yahoo.co.nz'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Splitter1: TSplitter
    Left = 169
    Top = 49
    Width = 3
    Height = 431
    Cursor = crHSplit
  end
  object lbLogging: TListBox
    Left = 172
    Top = 49
    Width = 389
    Height = 431
    Align = alClient
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'Courier New'
    Font.Style = []
    ItemHeight = 14
    ParentFont = False
    TabOrder = 0
  end
  object gbSettings: TGroupBox
    Left = 0
    Top = 0
    Width = 561
    Height = 49
    Align = alTop
    Caption = 'Server'
    TabOrder = 1
    object Label1: TLabel
      Left = 16
      Top = 20
      Width = 19
      Height = 13
      Caption = 'Port'
    end
    object lConnectionCount: TLabel
      Left = 264
      Top = 20
      Width = 67
      Height = 13
      Caption = '0 connections'
    end
    object ePort: TEdit
      Left = 40
      Top = 16
      Width = 41
      Height = 21
      TabOrder = 0
      Text = '2000'
    end
    object bListen: TButton
      Left = 88
      Top = 16
      Width = 75
      Height = 25
      Caption = 'Listen'
      TabOrder = 1
      OnClick = bListenClick
    end
    object bOffline: TButton
      Left = 168
      Top = 16
      Width = 75
      Height = 25
      Caption = 'Offline'
      TabOrder = 2
      OnClick = bOfflineClick
    end
  end
  object lbConnections: TListBox
    Left = 0
    Top = 49
    Width = 169
    Height = 431
    Align = alLeft
    ItemHeight = 16
    Style = lbOwnerDrawFixed
    TabOrder = 2
    OnDrawItem = lbConnectionsDrawItem
  end
  object ServerSocket1: TServerSocket
    Active = False
    Port = 0
    ServerType = stNonBlocking
    OnListen = ServerSocket1Listen
    OnGetSocket = ServerSocket1GetSocket
    OnClientConnect = ServerSocket1ClientConnect
    OnClientDisconnect = ServerSocket1ClientDisconnect
    OnClientRead = ServerSocket1ClientRead
    Left = 200
    Top = 80
  end
  object tClientsRepaint: TTimer
    Enabled = False
    OnTimer = tClientsRepaintTimer
    Left = 204
    Top = 132
  end
end

Open in new window

0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now