I am new with indy servers and so I'm struggling for this simple task. I have to create a server and upload a little file; its size is always 128 bytes. Then when someone opens the homepage of the server the file is sent automatically. So:
Upload a file (the one that is 128 bytes) on the disk
Open a browser like Firefox
Type the url (below you can see that I've set 127.0.0.1:798) and when you press enter there is a white page but a dialog appears asking you to download the file.
I have written this code so far:
procedure TForm1.Button1Click(Sender: TObject);
begin
// IP = 127.0.0.1:798 (port is 798)
IdTCPServer1.Active := true;
Memo1.Lines.Add('Server started at: ' + TimeToStr(Now) + slinebreak);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
IdTCPServer1.Active := false;
Memo1.Lines.Add('Server stopped at: ' + TimeToStr(Now));
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var a: TFileStream;
begin
a := TFileStream.Create('C:\Users\defaulr.user\Desktop\datfile.pkm', fmOpenWrite);
AContext.Connection.IOHandler.Write(a);
end;
This is the form:
Start is Button1 and End is Button2. As you can see I am loading in a stream the file and then I try to send it as output when I open the page. Is this the proper way to do it?
Since you are accessing the file via a web browser, you should be using TIdHTTPServer instead of TIdTCPServer:
procedure TForm1.Button1Click(Sender: TObject);
begin
// IP = 127.0.0.1:798 (port is 798)
IdHTTPServer1.Active := true;
Memo1.Lines.Add('Server started at: ' + TimeToStr(Now));
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
IdHTTPServer1.Active := false;
Memo1.Lines.Add('Server stopped at: ' + TimeToStr(Now));
end;
// TIdHTTPServer.OnCommandGet event handler...
procedure TForm1.IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
if ARequestInfo.Document = '/' then
begin
AResponseInfo.ResponseNo := 200;
AResponseInfo.ServeFile(AContext, 'C:\Users\defaulr.user\Desktop\datfile.pkm');
// alternatively:
// AResponseInfo.SmartServeFile(AContext, ARequestInfo, 'C:\Users\defaulr.user\Desktop\datfile.pkm');
end else
AResponseInfo.ResponseNo := 404;
end;
Related
I make an application where the client and the server are in the same program. I use Delphi XE7 and components TIpTCPServer / ... Client. But when I try to close the server with the client connected (in the same window), the program stops responding. Perhaps this is something related to multithreading. How to implement a program with a client and server in one application and is this the right approach?
procedure TfrmMain.startClick(Sender: TObject);
begin
if (server.active) then stopServer()
else startServer();
end;
procedure TfrmMain.startServer();
var
binding: TIdSocketHandle;
begin
server.bindings.clear();
try
server.defaultPort := strToInt(port.text);
binding := server.bindings.add();
binding.ip := ip;
binding.port := strToInt(port.text);
server.active := true;
if (server.active) then begin
addToLog('Server started');
start.caption := 'Stop';
end;
except on e: exception do
addToLog('Error: ' + e.message + '.');
end;
end;
procedure TfrmMain.stopServer();
begin
server.active := false;
server.bindings.clear();
if (not(server.active)) then begin
addToLog('Server stopped');
start.caption := 'Start';
end
else addToLog('Server shutdown error.');
end;
procedure TfrmMain.serverConnect(AContext: TIdContext);
var
i: integer;
begin
addToLog('New client: ' + aContext.connection.socket.binding.peerIP + '.');
clients.clear();
for i := 0 to server.contexts.lockList.count - 1 do begin
with TIdContext(server.contexts.lockList[i]) do
clients.items.add(connection.socket.binding.peerIP);
end;
server.contexts.unlockList();
end;
procedure TfrmMain.serverDisconnect(AContext: TIdContext);
begin
addToLog('Client ' + aContext.connection.socket.binding.peerIP + ' disconnected from the server.');
end;
procedure TfrmMain.clientConnected(Sender: TObject);
begin
addToConsole('You connected to server successfully.');
end;
procedure TfrmMain.clientDisconnected(Sender: TObject);
begin
addToConsole('The connection to the server was interrupted.');
end;
and connection code:
client.host := ip;
try
client.connect();
except on e: exception do
addToConsole('Error: ' + e.message);
end;
I see a number of issues with this code.
How are addToLog() and addToConsole() implemented? Are they thread-safe? Remember that TIdTCPServer is a multi-threaded component, its events are fired in the context of worker threads, not the main UI thread, so any access to the UI, shared variables, etc must be synchronized.
What is clients? Is it is a UI control? You need to sync access to it so you don't corrupt its content when multiple threads try to access it at the same time.
Your use of the TIdTCPServer.Contexts property is not adequately protected from exceptions. You need a try..finally block so you can call Contexts.UnlockList() safely.
More importantly, you are calling Contexts.LockList() too many times in your serverConnect() loop (this is the root cause of your problem). LockList() returns a TIdContextList object. Inside your loop, you should be accessing that list's Items[] property instead of calling LockList() again. Because you do not have a matching UnlockList() for each LockList(), once a client connects to your server, the Contexts list becomes deadlocked, and can no longer be accessed once serverConnect() exits, which includes when clients connect/disconnect, and during TIdTCPServer shutdown (such as in your case).
serverDisconnect() is not removing any items from clients. serverConnect() should not be resetting clients at all. It should add only the calling TIdContext to clients, and then serverDisconnect() should remove that same TIdContext from clients later.
With that said, try something more like this:
procedure TfrmMain.addToConsole(const AMsg: string);
begin
TThread.Queue(nil,
procedure
begin
// add AMsg to console ...
end
);
end;
procedure TfrmMain.addToLog(const AMsg: string);
begin
TThread.Queue(nil,
procedure
begin
// add AMsg to log ...
end
);
end;
procedure TfrmMain.startClick(Sender: TObject);
begin
if server.Active then
stopServer()
else
startServer();
end;
procedure TfrmMain.startServer();
var
binding: TIdSocketHandle;
begin
server.Bindings.Clear();
try
server.DefaultPort := StrToInt(port.Text);
binding := server.Bindings.Add();
binding.IP := ip;
binding.Port := StrToInt(port.Text);
server.Active := True;
addToLog('Server started');
start.Caption := 'Stop';
except
on e: Exception do
addToLog('Error: ' + e.message + '.');
end;
end;
procedure TfrmMain.stopServer();
begin
try
server.Active := False;
server.Bindings.Clear();
addToLog('Server stopped');
start.Caption := 'Start';
except
on e: Exception do
addToLog('Server shutdown error.');
end;
end;
procedure TfrmMain.serverConnect(AContext: TIdContext);
var
PeerIP: string;
begin
PeerIP := AContext.Binding.PeerIP;
addToLog('New client: ' + PeerIP + '.');
TThread.Queue(nil,
procedure
{
var
i: integer;
list: TIdContextList;
}
begin
{
clients.clear();
list := server.Contexts.LockList;
try
for i := 0 to list.count - 1 do begin
clients.Items.Add(TIdContext(list[i]).Binding.PeerIP);
end;
finally
list.UnlockList();
end;
}
// I'm assuming clients is a UI control whose Items property
// is a TStrings object. If not, adjust this code as needed...
clients.Items.AddObject(PeerIP, AContext);
end;
);
end;
procedure TfrmMain.serverDisconnect(AContext: TIdContext);
begin
addToLog('Client ' + AContext.Binding.PeerIP + ' disconnected from the server.');
TThread.Queue(nil,
procedure
var
i: Integer;
begin
// I'm assuming clients is a UI control whose Items property
// is a TStrings object. If not, adjust this code as needed...
i := clients.Items.IndexOfObject(AContext);
if i <> -1 then
clients.Items.Delete(i);
end
);
end;
procedure TfrmMain.clientConnected(Sender: TObject);
begin
addToConsole('You connected to server successfully.');
end;
procedure TfrmMain.clientDisconnected(Sender: TObject);
begin
addToConsole('The connection to the server was interrupted.');
end;
I want load a html file into Chromium (CEF4Delphi) but nothing is showed, only a white page.
Is possible load a local html file using the following approach?
Here is html file.
Also have other trouble that is everytime that Chromium is executed, also is executed other instance of my application. How solve this?
Code used:
var
Form1: TForm1;
FStarted: Boolean;
implementation
{$R *.dfm}
function CEFApplication: TCefApplication;
var
sPath: String;
begin
sPath := ExtractFilePath(ParamStr(0));
if not assigned(GlobalCEFApp) then
begin
GlobalCEFApp := TCefApplication.Create;
GlobalCEFApp.FlashEnabled := False;
GlobalCEFApp.FastUnload := True;
GlobalCEFApp.FrameworkDirPath := sPath + 'cef';
GlobalCEFApp.ResourcesDirPath := sPath + 'cef';
GlobalCEFApp.LocalesDirPath := sPath + 'cef\locales';
GlobalCEFApp.Cache := sPath + 'cef\cache';
GlobalCEFApp.Cookies := sPath + 'cef\cookies';
GlobalCEFApp.UserDataPath := sPath + 'cef\User Data';
GlobalCEFApp.EnableGPU := False;
end;
if not FStarted then
FStarted := GlobalCEFApp.StartMainProcess;
result := GlobalCEFApp;
end;
initialization
CEFApplication;
end.
Form2:
procedure TForm2.FormShow(Sender: TObject);
begin
while not(Chromium1.CreateBrowser(CEFWindowParent1, '')) and
(Chromium1.Initialized) do
begin
Sleep(100);
Application.processMessages;
end;
Chromium1.LoadURL(ExtractFilePath(ExtractFilePath(Application.ExeName)) + 'gmaps.html');
end;
EDITION:
Relative to my doubt about multiple instance of my application being executed, this is normal and right based on this
article.
This is how I do it in my code:
CBrowser.Load('file:///' + ReplaceStr(fpath, '\', '/'));
CEF4Delphi has a TChromium.LoadString for that.
I do it in a protected
procedure BrowserCreatedMsg(var aMessage : TMessage); message CEF_AFTERCREATED;
like this:
procedure TDialoogDeclaratieGoogleMaps.BrowserCreatedMsg(var aMessage : TMessage);
begin
PanelBrowser.UpdateSize; // The TCEFWindowParent
ChromiumBrowser.LoadString(FGoogleHTML); // String read from file earlier
end;
and that message gets posted in the afterCreated method:
procedure TDialoogDeclaratieGoogleMaps.ChromiumBrowserAfterCreated(Sender: TObject; const browser: ICefBrowser);
begin
PostMessage(Handle, CEF_AFTERCREATED, 0, 0);
end;
I have created a VCL application and I need to create an HTTP server that runs in my network. I have created the code that you can see below:
procedure TForm1.IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
a: TStringList;
count, logN: integer;
begin
if ARequestInfo.Document = '/' then
begin
AResponseInfo.ResponseNo := 200;
AResponseInfo.ContentText := IndexMemo.Lines.Text;
Memo1.Lines.Add(' Client: ' + ARequestInfo.RemoteIP);
end
else
begin
AResponseInfo.ResponseNo := 200;
AResponseInfo.ContentText := '<html><body><b>404 NOT FOUND</b></body></html>';
end;
end;
Now I have only a test case if ARequestInfo.Document = '/' then but later I'll need a lot of them. I have found this solution:
Drop a memo in the form
Add the html inside the memo
Load the text of the memo in the ContextText
I don't think that this is very efficient because I'd have to drop like 20 TMemo in my form and the HTML will be difficult to maintain. I thought that I could load the html pages with the Deployment manager.
In the same folder of the Delphi project I have created a folder called pages and it will contain the html files. I am not sure on how to load html pages with an indy HTTP server, so my questions are:
Do I have to store the html pages somewhere in a folder and then load them using indy?
Can I load html pages with indy that are included in the Deployment page?
Note: I would like to have a single exe (which is the http server) and not a folder with exe + html files. The solution that I have found works pretty well because I use a lot of TMemo to store the code, but this is not easy to maintain.
First, the code you have shown is not thread-safe. TIdHTTPServer is a multi-threaded component, the OnCommand... events are triggered in the context of worker threads. You must synchronize with the main UI thread in order to access UI controls safely, eg:
procedure TForm1.IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
s: string;
begin
if ARequestInfo.Document = '/' then
begin
TThread.Synchronize(nil,
procedure
begin
s := IndexMemo.Lines.Text;
Memo1.Lines.Add(' Client: ' + ARequestInfo.RemoteIP);
end
);
AResponseInfo.ResponseNo := 200;
AResponseInfo.ContentText := s;
AResponseInfo.ContentType := 'text/plain';
end
else
begin
AResponseInfo.ResponseNo := 404;
AResponseInfo.ContentText := '<html><body><b>404 NOT FOUND</b></body></html>';
AResponseInfo.ContentType := 'text/html';
end;
end;
Do I have to store the html pages somewhere in a folder and then load them using indy?
Can I load html pages with indy that are included in the Deployment page?
If you want to serve files from the local filesystem, you have to translate the ARequestInfo.Document property value to a local file path, and then you can either:
load the requested file into a TFileStream and assign it to the AResponseInfo.ContentStream property:
procedure TForm1.IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
str, filename: string;
begin
str := ' Client: ' + ARequestInfo.RemoteIP + ' requesting: ' + ARequestInfo.Document;
TThread.Queue(nil,
procedure
begin
Memo1.Lines.Add(str);
end
);
if TextStartsWith(ARequestInfo.Document, '/') then
begin
filename := Copy(ARequestInfo.Document, 2, MaxInt);
if filename = '' then
filename := 'index.txt';
// determine local path to requested file
// (ProcessPath() is declared in the IdGlobalProtocols unit)...
filename := ProcessPath(YourDeploymentFolder, filename);
if FileExists(filename) then
begin
AResponseInfo.ResponseNo := 200;
AResponseInfo.ContentStream := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);
AResponseInfo.ContentType := IdHTTPServer1.MIMETable.GetFileMIMEType(filename);
Exit;
end;
end;
AResponseInfo.ResponseNo := 404;
AResponseInfo.ContentText := '<html><body><b>404 NOT FOUND</b></body></html>';
AResponseInfo.ContentType := 'text/html';
end;
pass the file path to the TIdHTTPResponseInfo.(Smart)ServeFile() method and let it handle the file for you:
procedure TForm1.IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
str, filename: string;
begin
str := ' Client: ' + ARequestInfo.RemoteIP + ' requesting: ' + ARequestInfo.Document;
TThread.Queue(nil,
procedure
begin
Memo1.Lines.Add(str);
end
);
if TextStartsWith(ARequestInfo.Document, '/') then
begin
filename := Copy(ARequestInfo.Document, 2, MaxInt);
if filename = '' then
filename := 'index.txt';
// determine local path to requested file...
filename := ProcessPath(YourDeploymentFolder, filename);
AResponseInfo.SmartServeFile(AContext, ARequestInfo, filename);
Exit;
end;
AResponseInfo.ResponseNo := 404;
AResponseInfo.ContentText := '<html><body><b>404 NOT FOUND</b></body></html>';
AResponseInfo.ContentType := 'text/html';
end;
I would like to have a single exe (which is the http server) and not a folder with exe + html files.
In that case, save the HTML files into the EXE's resources at compile-time (using an .rc file, or the IDE's Resources and Images dialog. See Resource Files Support for more details) and then translate the ARequestInfo.Document into a resource ID/Name that you can load with TResourceStream for use as the AResponseInfo.ContentStream object:
procedure TForm1.IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
str, resID: string;
strm: TResourceStream;
begin
str := ' Client: ' + ARequestInfo.RemoteIP + ' requesting: ' + ARequestInfo.Document;
TThread.Queue(nil,
procedure
begin
Memo1.Lines.Add(str);
end
);
if TextStartsWith(ARequestInfo.Document, '/') then
begin
// determine resource ID for requested file
// (you have to write this yourself)...
resID := TranslateIntoResourceID(Copy(ARequestInfo.Document, 2, MaxInt));
try
strm := TResourceStream.Create(HInstance, resID, RT_RCDATA);
except
on E: EResNotFound do
strm := nil;
end;
if strm <> nil then
begin
AResponseInfo.ResponseNo := 200;
AResponseInfo.ContentStream := strm;
AResponseInfo.ContentType := 'text/html';
Exit;
end;
end;
AResponseInfo.ResponseNo := 404;
AResponseInfo.ContentText := '<html><body><b>404 NOT FOUND</b></body></html>';
AResponseInfo.ContentType := 'text/html';
end;
You can read the Content from a file
procedure TForm2.IdHTTPServer1CommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var Page : TStringStream;
begin
Page := TStringStream.Create;
Page.LoadFromFile('put the file path here');
AResponseInfo.ResponseNo := 200;
AResponseInfo.ContentStream := page;
end;
You can read the Content from a Resource, go to Project Menu, Resources and Imagens, add the resources that you need.
procedure TForm2.IdHTTPServer1CommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var page : TResourceStream;
begin
//home is the resource name
page := TResourceStream.Create(HInstance, 'home', RT_RCDATA);
AResponseInfo.ResponseNo := 200;
AResponseInfo.ContentStream := page;
end;
I have an application with TIdHTTPServer and TIdHTTP in delphi and I have this code :
// This is for activating the HTTPServer - works as expected
HTTPServer1.Bindings.Add.IP := '127.0.0.1';
HTTPServer1.Bindings.Add.Port := 50001;
HTTPServer1.Active := True;
This is the OnCommandGet procedure of my HTTPServer :
procedure TDataForm.HttpServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
AResponseInfo.ContentText := 'Hello, user';
end;
And I just don't know why this procedure isn't working :
procedure TDataForm.btnHTTPSendGetClick(Sender: TObject);
var
HTTPClient : TIdHTTP;
responseStream : TMemoryStream;
begin
HTTPClient := TIdHTTP.Create;
responseStream := TMemoryStream.Create;
try
try
HTTPClient.Get('http://127.0.0.1:50001', responseStream);
except on e : Exception do begin
showmessage('Could not send get request to localhost, port 50001');
end;
end;
finally
FreeAndNil(HTTPClient);
FreeAndNil(responseStream);
end;
end;
If I connect via browser I can see in the browser 'Hello, user', but if I try btnHTTPSendGetClick my program crashes with no exception or anything. Can anyone help me fix my code ?
HTTPServer1.Bindings.Add.IP := '127.0.0.1';
HTTPServer1.Bindings.Add.Port := 50001;
This is a common newbie mistake. You are creating two bindings, one bound to 127.0.0.1:DefaultPort, and one bound to 0.0.0.0:50001. You need one binding instead, that is bound to 127.0.0.1:50001 instead.
with HTTPServer1.Bindings.Add do begin
IP := '127.0.0.1';
Port := 50001;
end;
Or:
HTTPServer1.Bindings.Add.SetBinding('127.0.0.1', 50001, Id_IPv4);
Or:
HTTPServer1.DefaultPort := 50001;
HTTPServer1.Bindings.Add.IP := '127.0.0.1';
With that said, your server response is incomplete. Try this instead:
procedure TDataForm.HttpServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
AResponseInfo.ResponseNo := 200;
AResponseInfo.ContentType := 'text/plain';
AResponseInfo.ContentText := 'Hello, user';
end;
Hi I am sending a file via tsocket, I'm editing the first code to not use opendilalog but I want to use a string with the path of the file to send, the problem is that the second code that eh OpenDialog edited for not using shoot me an error saying the file to send is being used by another process.
The first source
procedure TForm1.Button2Click(Sender: TObject);
begin
if ClientSocket1.Active = True then
begin
OpenDialog1.Filter := 'All Files (*.*)'; // you can add more choices by adding | and followed by description and (*.extension)
OpenDialog1.FilterIndex := 1; // Here you follow which index number from above you want
if OpenDialog1.Execute then
begin
Edit1.Text := ExtractFileName(OpenDialog1.FileName); // To send as filename after
ClientSocket1.Socket.SendText('FILE!'+Edit1.Text);
sleep(2000); // Need to sleep so the other end has time to process the commands
Streamsize := TFileStream.Create(OpenDialog1.FileName, fmopenread); // Stream created just to Calculate size
Edit2.Text := inttostr(Streamsize.Size);
Sleep(2000);
ClientSocket1.Socket.SendText('SIZE!'+Edit2.Text); // Sends filesize through primary socket
Streamsize.Position := 0;
Streamsize.Free;
sleep(2000);
ClientSocket2.Address := Edit3.Text;
ClientSocket2.Open; // ready to send file on second socket
if ClientSocket2.Socket.SendStream(TFileStream.Create(OpenDialog1.FileName, fmopenRead)) then memo1.Lines.Add('File Sent');
// above creates a stream and sends as a stream its in a if line because this is the only way it will automatically check the byte order and send the whole stream
end;
end
else
MessageDlg('Error: You are not connected', mtError, [MbOK],0); // Error Check above code won't work until the socket is connected
end;
The second source
procedure TForm1.Button2Click(Sender: TObject);
var
archivo: string;
begin
archivo := 'c:/clap.jpg';
if ClientSocket1.Active = True then
begin
Edit1.Text := ExtractFileName(archivo);
// To send as filename after
ClientSocket1.Socket.SendText('FILE!' + Edit1.Text);
sleep(2000); // Need to sleep so the other end has time to process the commands
Streamsize := TFileStream.Create(archivo, fmopenread);
// Stream created just to Calculate size
Edit2.Text := inttostr(Streamsize.Size);
sleep(2000);
ClientSocket1.Socket.SendText('SIZE!' + Edit2.Text);
// Sends filesize through primary socket
Streamsize.Position := 0;
Streamsize.Free;
sleep(2000);
ClientSocket2.Address := '127.0.0.1';
ClientSocket2.Open; // ready to send file on second socket
if ClientSocket2.Socket.SendStream(TFileStream.Create(archivo, fmopenread))
then
Memo1.Lines.Add('File Sent');
// above creates a stream and sends as a stream its in a if line because this is the only way it will automatically check the byte order and send the whole stream
end
else
MessageDlg('Error: You are not connected', mtError, [MbOK], 0); // Error Check above code won't work until the socket is connected
end;
The server.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ScktComp, ComCtrls, idglobal, ExtCtrls, ShellAPI;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Label1: TLabel;
ServerSocket1: TServerSocket;
ServerSocket2: TServerSocket;
GroupBox1: TGroupBox;
Edit1: TEdit;
Edit2: TEdit;
Label2: TLabel;
Label3: TLabel;
ProgressBar1: TProgressBar;
Timer1: TTimer;
StatusBar1: TStatusBar;
procedure Button1Click(Sender: TObject);
procedure ServerSocket1Accept(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket2Accept(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket2ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
IncommingStream: TFileStream;
TimeTaken: integer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
// Written by me ColdFuzion
// All i ask is i be given some credit for coding this my e-mail is ColdFuzion#hushmail.com
// Program Usage: To recieve Files sent by the client
procedure TForm1.Button1Click(Sender: TObject);
begin
ServerSocket1.Open;
Memo1.Lines.Add('Server Listening on '+inttostr(ServerSocket1.Port) );
end;
procedure TForm1.ServerSocket1Accept(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo1.Lines.Add('Client connected From '+Socket.RemoteHost)
// Adds the clients host as it connects
end;
procedure TForm1.ServerSocket2Accept(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo1.Lines.Add('Incoming File Transfer');
end;
procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var IncommingText, StrippedData, CommandName: string;
begin
IncommingText := socket.ReceiveText;
StrippedData := copy(IncommingText,6,length(IncommingText) );
CommandName := copy(IncommingText,0,5);
if CommandName = 'FILE!' then
begin
IncommingStream := TFileStream.Create(StrippedData, fmCREATE or fmOPENWRITE and fmsharedenywrite); // Once File name is recieved the stream to recieve
Edit1.Text := StrippedData; // The file is created
ServerSocket2.Open;
end
else
if CommandName = 'SIZE!' then
begin
Edit2.Text := StrippedData;
ProgressBar1.Max := StrToInt(StrippedData);
ProgressBar1.Min := 0;
Memo1.lines.Add('Recieving File '+Edit1.Text +' of size '+Edit2.Text);
end;
end;
procedure TForm1.ServerSocket2ClientRead(Sender: TObject;
// This is the secondary socket it is the most important part of the program
Socket: TCustomWinSocket);
// It processes the incomming file stream
var Buffer: array [0..9999] of Char;
IncommingLen, RecievedLen: integer;
Filepath: string;
begin
Timer1.Enabled := True;
IncommingLen := socket.ReceiveLength;
// If the size of any incomming data is the size of 0 then the process begins
Filepath := ExtractFilePath(Edit1.Text)+Edit1.Text;
// Sets a String Filepath for the actual directory with the filename so that the shellexecute can run this after
while IncommingLen > 0 do
// Must make sure the process ends
begin
RecievedLen := socket.ReceiveBuf(Buffer, Sizeof(Buffer));
// Changes the size of RecievedLen by the amount of incoming data recieved
if RecievedLen <= 0 then
// Small part of the code where once the buffer reaches 0 the code will exit
Break
else
IncommingStream.Write(Buffer, RecievedLen);
// Writes the Incoming data into a new stream by the filename and size which is recieved
ProgressBar1.StepBy(RecievedLen);
// through the primary socket Also this line increases the progess indicator bar
if IncommingStream.Size >= strtoint(Edit2.Text) then
// Onces the stream size begins to reach the size which was sent before sending the file then this
begin
// procedure will start
IncommingStream.Free;
// Free's the stream
memo1.Lines.Add('File '+Edit1.Text +' Recieved Successfuly');
memo1.Lines.Add('Time Taken to Recieve File ' +IntToStr(TimeTaken)+' seconds');
ServerSocket1.Socket.Connections[0].SendText('DONE!');
Edit1.Text := '';
// From here it starts setting the variables back
Edit2.Text := '';
ProgressBar1.Position := 0;
Timer1.Enabled := False;
TimeTaken := 0;
if Messagedlg('Would you Like to open the recieved file?', mtConfirmation, [MbYes,MbNo],0) = MrYes then // Simply asks the user if he wants to open the file if yes will execute if no break
begin
ShellExecute(Form1.Handle, 'open', pchar(Filepath),nil, nil, SW_NORMAL); // A shellapi was added to uses to beable to execute this line
end;
Break; // This line basically executes any file using the extension from the windows ini files.
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Text := '';
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
inc(TimeTaken,1);
// Counts number of seconds starts once the filestream begins
end;
end.
// This entire Program could use alot more Error checking but it simply is a very basic
// Example of how to do certain things using the basic components that come with Delphi
// There are hardly any examples of sending files with delphi on the internet so most of
// the code here had to be improvised i hope this helps people where i had to struggle with
I can correct as the second code to pull no more errors?
If the OS is complaining that the file is already in use, then it really is already in use.
You are creating multiple streams to the same file (you are also using the wrong path delimiter). Create one stream and reuse it multiple times instead, eg:
procedure TForm1.Button2Click(Sender: TObject);
var
archivo: string;
Strm: TFileStream;
begin
archivo := 'c:\clap.jpg';
if ClientSocket1.Active then
begin
Strm := TFileStream.Create(archivo, fmOpenRead or fmShareDenyWrite);
try
Edit1.Text := ExtractFileName(archivo);
Edit2.Text := IntToStr(Strm.Size);
ClientSocket1.Socket.SendText('FILE!' + Edit1.Text);
// Need to sleep so the other end has time to process the commands
Sleep(2000);
ClientSocket1.Socket.SendText('SIZE!' + Edit2.Text);
Sleep(2000);
ClientSocket2.Address := '127.0.0.1';
ClientSocket2.Open; // ready to send file on second socket
if ClientSocket2.Socket.SendStream(Strm) then
begin
// SendStream() takes ownership of the Stream, so don't free it!
Strm := nil;
Memo1.Lines.Add('File Sent');
end;
finally
Strm.Free;
end;
end
else
MessageDlg('Error: You are not connected', mtError, [MbOK], 0);
end;
As noted, SendStream() takes ownership of the stream. If you are using the socket in non-blocking mode, it may take time to transfer the whole stream. You would not be able to re-open the file again until that transfer is finished. That could account for the error you are seeing.
Now, with that said, the fact that you have to introduce sleeps into your protocol in order to get commands processed correctly means you did not design your protocol very well to begin with. It would be much more reliable to put a delimiter between your commands instead, eg:
procedure TForm1.Button2Click(Sender: TObject);
var
archivo: string;
Strm: TFileStream;
begin
archivo := 'c:\clap.jpg';
if ClientSocket1.Active then
begin
Strm := TFileStream.Create(archivo, fmOpenRead or fmShareDenyWrite);
try
Edit1.Text := ExtractFileName(archivo);
Edit2.Text := IntToStr(Strm.Size);
ClientSocket1.Socket.SendText('FILE!' + Edit1.Text + #13#10);
ClientSocket1.Socket.SendText('SIZE!' + Edit2.Text + #13#10);
ClientSocket2.Address := '127.0.0.1';
ClientSocket2.Open; // ready to send file on second socket
if ClientSocket2.Socket.SendStream(Strm) then
begin
// SendStream() takes ownership of the Stream and will free it
// after it is done sending, so don't free it yourself!
Strm := nil;
Memo1.Lines.Add('File Sent');
end;
finally
Strm.Free;
end;
end
else
MessageDlg('Error: You are not connected', mtError, [MbOK], 0);
end;
Then the receiver can simply read inbound data and split it on the delimiters as needed, no sleeps needed.
BTW, you are essentially recreating the FTP protocol, jut with a different syntax, so why not use the actual FTP protocol instead? There are plenty of FTP components/libraries readily available.