I have a worker-thread which is sending XML-requests to a web-application.
In case I need to stop this worker-thread, how to abort the HTTP-execution?
I know that there are timeouts for connect/send/receive, but I'm not aware of any procedure to abort an ongoing HTTP-request...
Here's just a plain example of the HTTP-execution:
var
HTTPReqResp: THTTPReqResp;
Request, Response: TStringStream;
begin
HTTPReqResp := nil;
Request := nil;
Response := nil;
try
HTTPReqResp := THTTPReqResp.Create(nil);
HTTPReqResp.URL := 'some_url';
HTTPReqResp.WebNodeOptions := [wnoSOAP12];
HTTPReqResp.SendTimeout := 60000;
HTTPReqResp.ConnectTimeout := 60000;
HTTPReqResp.ReceiveTimeout := 60000;
Request := TStringStream.Create('<Request_XML>test</Request_XML>', TEncoding.UTF8);
Response := TStringStream.Create('', TEncoding.UTF8);
HTTPReqResp.Execute(Request, Response);
finally
Response.Free;
Request.Free;
HTTPReqResp.Free;
end;
end;
I'm wondering about this quite a while... Hopefully, someone can give me a hint...
Thanks!
Related
My FireMonkey app has a save button that does this:
procedure TFormProductionRuns.buSaveFinishProductClick(Sender: TObject);
begin
ShowActivity;
ITask(TTask.Create(
procedure
begin
try
TThread.Synchronize(nil,
procedure
begin
PostFinishProduct;
end);
finally
TThread.Synchronize(nil,
procedure
begin
HideActivity;
end);
end;
end)).Start;
end;
The activity methods are defined as:
procedure TFormProductionRuns.ShowActivity;
begin
frProgress1.ShowActivity;
end;
procedure TFormProductionRuns.HideActivity;
begin
frProgress1.HideActivity;
end;
procedure TfrProgress.ShowActivity;
begin
Self.Visible := True;
ProgFloatAnimation.Enabled := True;
end;
procedure TfrProgress.HideActivity;
begin
ProgFloatAnimation.Enabled := False;
Self.Visible := False;
end;
The frame is set to align content, so fills up the entire app screen when visible, and contains a "busy" animation. The bulk of the work is a REST request to a post web method.
procedure TFormProductionRuns.PostFinishProduct;
var
AList: TObjectList<TFinishedProduct>;
sReqBody, sResponse: String;
begin
...
sReqBody := TJSONUtils.ObjectsToJSONArray<TFinishedProduct>(AList).ToString;
RESTReqPostTransaction.Params.ParameterByName('ReqBody').Value := sReqBody;
RESTClient1.Params.ParameterByName('host_port').Value := FLoginInfo.Server + ':' + FLoginInfo.Port;
HTTPBasicAuthenticator1.Username := FLoginInfo.LoginId;
HTTPBasicAuthenticator1.Password := FLoginInfo.LoginPw;
try
RESTReqPostTransaction.Execute;
except on E:Exception do
begin
ShowMessage('Post Finish Product failed. Exception: ' + E.Message);
Exit;
end;
end;
sResponse := RESTResponseFromPost.Content;
...
end;
What I'm finding is that the animation stops while this request is being processed, but my understanding was that the main thread would continue while the worker thread was waiting for the response.
The app does have a similar method that uses a Get REST request rather than Post, and that has no problems animating the "busy" graphic while the worker thread is waiting for the response.
TThread.Synchronize is a method which request execution by the main thread of the method passed in synchronize argument. This actually completely defeat multi-threading.
You have to design you thread so that synchronize is only use for very short actions such as updating the user interface or pass data between the worker thread and main thread because when synchronize is called, the thread is waiting (It is stopped) for the method passed in argument to be executed by the main thread. And while the main thread execute that method, it doesn't do anything else (And you animation stop).
I have a important problem with building Indy Server/Clients realtime monitoring system...
I am using DELPHI 2010, and Indy version is 10.5.5.........
My purpose is that many client side PCs send screenshots continuosely(4~10fps) to Server, and Server have to send these screenshots frames to some monitoring PCs.
In other words....
Many clients -----send streams--------> to Server
Some monitors <---receive streams----- from Server
Of course, In the case of one client and one monitor with server works well...
But if connecting another clients or monitors, then server have been raising exceptions "Access violation at address 000000000.....", or "Invalid pointer operations" and disconnects client's connection or monitor's one.
At the result, client or monitor will be disconnected from server....
I have used idTCPClient component, described client and monitor code using thread for sending and receiving stream.
I am sure there is no problem with client and monitor side's Code...
But I think that there will be absolutely problem with server side.
For server side, I have used two TidTCPServer controls...
One is to receive streams from client PCs.And another is to send streams to monitor PCs.
server code is like below...
{one side----idTCPServerRecv is to receive screenshot streams from clients}
procedure TIndyServerForm.IdTCPServer_RecvExecute(AContext: TIdContext);
var
Hb: TIdIOHandler;
TempStr: TStrings;
begin
Hb := AContext.Connection.IOHandler;
if Not Hb.InputBufferIsEmpty then
Begin
Hb.CheckForDisconnect(True, True);
AContext.Connection.IOHandler.CheckForDisconnect(True, True);
recv_Stream := TMemoryStream.Create;
recv_Stream.Clear;
if (ReceiveStream(AContext, TStream(recv_Stream)) = False) then
begin
ROutMsg :=AContext.Binding.PeerIP+' -> receiving failed: ' + IntToStr(recv_Stream.Size)+'byte';
recv_Stream.Free;
Exit;
end;
if recv_Stream.Size < 1024 then
begin
recv_Stream.Seek(0, soFromBeginning);
ROutMsg :=AContext.Binding.PeerIP+' -> captionString received('+
IntToStr(recv_Stream.Size)+' byte) : "'+StringFromStream(TStream(recv_Stream))+'"';
recv_Stream.Free;
end
else
begin
ROutMsg :=AContext.Binding.PeerIP+' -> screenshot received: ' + KBStr(recv_Stream.Size)+' KB';
if G_Sendable = False then
begin
send_Stream:=TMemoryStream.Create;
send_Stream.Clear;
recv_Stream.Seek(0, soFromBeginning);
send_Stream.Seek(0, soFromBeginning);
send_Stream.CopyFrom(recv_Stream, recv_Stream.Size);
G_Sendable :=True;
end;
recv_Stream.Free;
end;
end;
Application.ProcessMessages;
WaitForSingleObject(Handle, 1);
end;
{another side----idTCPServerSend is to send screenshot streams to monitors}
procedure TIndyServerForm.IdTCPServer_SendExecute(AContext: TIdContext);
begin
if G_Sendable then
begin
send_Stream.Seek(0,soFromBeginning);
if (SendStream(AContext, TStream(send_Stream)) = False) then
begin
SOutMsg :=AContext.Binding.PeerIP+' -> sending failed -> ' + KBStr(send_Stream.Size)+' KB';
send_Stream.Free;
G_Sendable :=False;
Exit;
end;
SOutMsg :=AContext.Binding.PeerIP+' -> sending successful-> ' + KBStr(send_Stream.Size)+' KB';
send_Stream.Free;
G_Sendable :=False;
end;
Application.ProcessMessages;
WaitForSingleObject(Handle, 1);
end;
What should I do for multi-clients connections with realtime exchange of streams...
Every client PC send screenshot stream 4~10 times per second...
And these streams must be sent to monitors corresponding
Please give me advice....
Your code is not even close to being thread-safe, which is why you are having errors. Every client thread in IdTCPServer_Recv is receiving their respective screeshots to a single shared recv_Stream variable, and then copying that data to a single shared send_Stream variable. All clients connected to IdTCPServer_Send are then reading and sending the same send_Stream at the same time. You are trampling memory all over the place.
You need to use a local variable instead of a shared variable to receive each screenshot, and you need to use a separate TStream object for each monitor client. Don't use a shared TStream for sending, and certainly don't use a global boolean variable to let each monitor client go at it. Have IdTCPServer_RecvExecute() actively create and pass along a new TMemoryStream object to each monitor client that needs to send the current screenshot.
Try something more like this:
uses
..., IdThreadSafe;
type
TMonitorContext = class(TIdServerContext)
public
Screenshots: TIdThreadSafeObjectList;
ScreenshotEvent: THandle;
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil); override;
destructor Destroy; override;
end;
TScreenshotInfo = class
public
ClientIP: string;
ClientPort: TIdPort;
Data: TMemoryStream;
constructor Create;
destructor Destroy; override;
end;
constructor TMonitorContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList);
begin
inherited;
Screenshots := TIdThreadSafeObjectList.Create;
Screenshots.OwnsObjects := True;
ScreenshotEvent := CreateEvent(null, True, False, nil);
end;
destructor TMonitorContext.Destroy;
begin
Screenshots.Free;
CloseHandle(ScreenshotEvent);
inherited;
end;
constructor TScreenshotInfo.Create;
begin
inherited;
Data := TMemoryStream.Create;
end;
destructor TScreenshotInfo.Destroy;
begin
Data.Free;
inherited;
end;
{one side----idTCPServerRecv is to receive screenshot streams from clients}
procedure TIndyServerForm.IdTCPServer_RecvExecute(AContext: TIdContext);
var
recv_stream: TMemoryStream;
monitors, queue: TList;
i: Integer;
screenshot: TScreenshotInfo;
monitor: TMonitorContext;
begin
recv_stream := TMemoryStream.Create;
try
if not ReceiveStream(AContext, recv_stream) then
begin
ROutMsg := AContext.Binding.PeerIP + ' -> receiving failed: ' + IntToStr(recv_Stream.Size) + ' byte';
Exit;
end;
if recv_Stream.Size < 1024 then
begin
recv_Stream.Position := 0;
ROutMsg := AContext.Binding.PeerIP + ' -> captionString received(' +
IntToStr(recv_Stream.Size) + ' byte) : "' + StringFromStream(recv_Stream) + '"';
end
else
begin
ROutMsg := AContext.Binding.PeerIP + ' -> screenshot received: ' + KBStr(recv_Stream.Size) + ' KB';
monitors := IdTCPServer_Send.Contexts.LockList;
try
// alternatively, only queue the screenshot to particular monitors
// that are actually interested in this client...
for i := 0 to monitors.Count-1 do
begin
monitor := TMonitorContext(monitors[i]);
screenshot := TScreenshotInfo.Create;
try
recv_Stream.Position := 0;
screenshot.Data.CopyFrom(recv_stream, 0);
screenshot.Data.Position := 0;
queue := monitor.Screenshots.LockList;
try
queue.Add(screenshot);
SetEvent(monitor.ScreenshotEvent);
finally
monitor.Screenshots.UnlockList;
end;
except
screenshot.Free;
end;
end;
finally
IdTCPServer_Send.Contexts.UnlockList;
end;
end;
finally
recv_stream.Free;
end;
end;
{another side----idTCPServerSend is to send screenshot streams to monitors}
procedure TIndyServerForm.FormCreate(Sender: TObject);
begin
IdTCPServer_Send.ContextClass := TMonitorContext;
end;
procedure TIndyServerForm.IdTCPServer_SendExecute(AContext: TIdContext);
var
monitor: TMonitorContext;
queue: TList;
i: Integer;
screenshot: TScreenshotInfo;
begin
monitor := TMonitorContext(AContext);
if WaitForSingleObject(monitor.ScreenshotEvent, 1000) <> WAIT_OBJECT_0 then Exit;
screenshot := nil;
try
queue := monitor.Screenshots.LockList;
try
if queue.Count > 0 then
begin
screenshot := TScreenshotInfo(queue[0]);
queue.Delete(0);
end;
if queue.Count = 0 then
ResetEvent(monitor.ScreenshotEvent);
finally
monitor.Screenshots.UnlockList;
end;
if screenshot = nil then Exit;
// you should send screenshot.ClientIP and screenshot.ClientPort to
// this monitor so it knows which client the screenshot came from...
if not SendStream(AContext, screenshot.Data) then
begin
SOutMsg := AContext.Binding.PeerIP + ' -> sending failed -> ' + KBStr(screenshot.Data.Size) + ' KB';
Exit;
end;
SOutMsg := AContext.Binding.PeerIP + ' -> sending successful-> ' + KBStr(screenshot.Data.Size) + ' KB';
finally
screenshot.Free;
end;
end;
On the 'monitor' side, a TIdTCPClient in a thread can listen for incoming screenshot data from the server. I have posted a blog article about server-side push messaging technique with Indy (source code) here:
Indy 10 TIdTCPServer: Server-side message push example
Additional server-side code is required to direct the incoming data to the monitoring clients. Actually you only need to add 'tags' (which could be boolean flags) to the context, indicating wether this connection is sending or monitoring screenshot data. How to assign custom properties to connection context and iterating over them is already answered in other questions here on SO.
I've got a problem when people who tries to install my file has connection problems. It appears a message and you cannot retry nor wait until you solve the problem. It just has an accept button and the setup closes. So I would like to have a message saying "No connection, check it." or something similar and allow you to fix the problem and continue. The error is given by this line: WinHttpRequest.Send;
Thanks in advanced.
function DownloadFile(const AURL: string; var AResponse: string): Boolean;
var
WinHttpRequest: Variant;
begin
Result := True;
try
WinHttpRequest := CreateOleObject('WinHttp.WinHttpRequest.5.1');
WinHttpRequest.Open('GET', AURL, False);
WinHttpRequest.Send;
AResponse := WinHttpRequest.ResponseText;
except
Result := False;
AResponse := GetExceptionMessage;
end;
end;
I've been trying to figure this error our for about 4 days now. I'm using Delphi XE and have created a little tool for translators to use. I got the idea of using the Microsoft Translation API to help make things easier and a bit less tedious.
I created a class that accesses the Microsoft translator API, but I wanted to make it Thread Safe so the requests could be made in the background. I have no problem sending a request to get an Access Token, however, I run that request in a separate thread. When the user clicks a button, I spawn a new thread and run the http request to translate the term from in there. However, it times out every single time. If I run it from the same thread there's no problem.
Here is the method I use for sending the http requests (the THttpCli object that is passed is shared among threads)
function sendHTTPRequest(APost: Boolean; AURI: UTF8string;
AContentType: UTF8string; APostData: UTF8String; AHttpCli: TSSLHttpCli): UTF8string;
var
DataOut: TMemoryStream;
DataIn: TMemoryStream;
lHTMLStream: TStringStream;
lencoding: TUTF8Encoding;
lownClient: boolean;
begin
lownClient := false;
if AHttpCli = nil then
begin
AHttpCli := TSSLHttpCli.Create(nil);
AHttpCli.SslContext := TSSLContext.Create(nil);
with AHttpCli.SslContext do
begin
SSLCipherList := 'ALL:!ADH:RC4+RSA:+SSLv2:#STRENGTH';
SSLVersionMethod := sslV23_CLIENT;
SSLVerifyPeerModes := [SslVerifyMode_PEER]
end;
AHttpCli.MultiThreaded := true;
lownClient := true;
end;
AHttpCli.Accept := 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8';
if APost then
begin
DataOut := TMemoryStream.Create;
DataOut.Write(APostData[1], Length(APostData));
DataOut.Seek(0, soFromBeginning);
end;
AHttpCli.URL := AURI;
AHttpCli.ContentTypePost := AContentType;
DataIn := TMemoryStream.Create;
if APost then AHttpCli.SendStream := DataOut;
AHttpCli.RcvdStream := DataIn;
try
if apost then
AHttpCli.Post
else
AHttpCli.Get;
lHTMLStream := TStringStream.Create('', TEncoding.UTF8);
lHtmlStream.LoadFromStream(AHttpCli.RcvdStream);
result := lHtmlStream.DataString;
lHtmlStream.Free;
finally
AHttpCli.Close;
AHttpCli.RcvdStream := nil;
AHttpCli.SendStream := nil;
DataIn.Free;
if APost then
DataOut.Free;
if lownClient then
AHttpCli.free;
end;
end;
I suppose the obvious solution is to just have one thread that waits for a signal to execute, but I was hoping to get an explanation as to why the timeout happens. I have no way to explain why the second thread times out and the first does not.
The HTTP component seems to get stuck on the dnslookup. OverbyteICS uses the Windows function WSAAsyncGetHostByName to lookup the name.
Any help is much appreciated
UPDATE May 13, 2013:
So, as it turns out, sharing the THttpCli object among threads seems to be what causes the timeout. The Solution is simply to pass nil into the AHttpCli parameter in my function above.
I'll still accept an answer as to WHY this causes a timeout. As far as I could tell the WSAAsyncGetHostByName method doesn't use any synchronous objects and the other thread was not running at the same time so there shouldn't be anything blocking the threads.
On Windows, OverbyteICS uses WSAAsyncSelect (here) and MsgWaitForMultipleObjects (here) to allow asynchronous notification of the socket events (FD_READ, FD_WRITE, FD_CLOSE and FD_CONNECT). Part of the design of WSAAsyncSelect requires a window that will receive the event messages, and to that end, a control class is registered using RegisterClass here, and an instance created using CreateWindowEx here, both in the call to THttpCli.Create.
This is where the issue arises; as alluded to in the documentation for GetMessage, PeekMessage and PostMessage, the message queue itself is per thread.
I've tested various permutations of each discrete step of the process (listed below) shared between 2 threads, and the only combinations that fail are when the call to CreateWindowEx and MsgWaitForMultipleObjects are performed on different threads, which reinforces the idea that a given message queue can only be accessed on the same thread.
Seemingly, without a rewrite of the OverbyteICS library itself, the only way to use it in a threaded environment is to create the THttpCli instance in the same thread as the subsequent request calls (THttpCli.Get, THttpCli.Post etc).
Appendix
Call to RegisterClass
procedure Up0(S: PState);
var
WndClass: TWndClass;
begin
FillChar(WndClass, SizeOf(TWndClass), 0);
WndClass.lpfnWndProc := #DefWindowProc;
WndClass.hInstance := hInstance;
WndClass.lpszClassName := 'test';
if RegisterClass(WndClass) = 0 then
ExitProcess(GetLastError);
end;
Call to CreateWindowEx
procedure Up1(S: PState);
begin
S.Window := CreateWindowEx(WS_EX_TOOLWINDOW, 'test', '', WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
if S.Window = 0 then
ExitProcess(GetLastError);
end;
Call to Ics_socket
procedure Up2(S: PState);
begin
S.Socket := Ics_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
if S.Socket = INVALID_SOCKET then
ExitProcess(Ics_WSAGetLastError);
end;
Call to Ics_WSAAsyncSelect
procedure Up3(S: PState);
begin
if Ics_WSAAsyncSelect(S.Socket, S.Window, WM_USER, FD_CONNECT) = SOCKET_ERROR then
ExitProcess(Ics_WSAGetLastError);
end;
Call to Ics_connect
procedure Up4(S: PState);
var
Error: Integer;
Sin: TSockAddrIn;
begin
FillChar(Sin, SizeOf(TSockAddrIn), 0);
Sin.sin_family := AF_INET;
Sin.sin_port := Ics_htons(42);
if Ics_connect(S.Socket, PSockAddr(#Sin)^, SizeOf(TSockAddrIn)) = SOCKET_ERROR then
begin
Error := Ics_WSAGetLastError;
if Error <> WSAEWOULDBLOCK then
ExitProcess(Error);
end;
end;
Call to MsgWaitForMultipleObjects
procedure Up5(S: PState);
var
Msg: TMsg;
WaitResult: Cardinal;
begin
WaitResult := MsgWaitForMultipleObjects(0, Pointer(nil)^, False, 1000, QS_ALLINPUT);
if WaitResult = WAIT_TIMEOUT then
begin
S.Result := 0;
Exit;
end;
while PeekMessage(Msg, S.Window, WM_USER, WM_USER, PM_REMOVE) do
if LOWORD(Msg.lParam) = FD_CONNECT then
begin
S.Result := 1;
Exit;
end;
end;
I´m having a few problems trying to download a file with 14mb using a TThread.
When I put the download code into the TDataModule, the download is ok, but after a refactoring and move the code to TThread.Execute, on DownloadUrl.ExecuteTarget I receive the error message on the Title.
The code in the TThread:
procedure TThreadDownload.Execute;
var
DownloadFile: TDownloadUrl;
begin
try
DownloadFile := TDownLoadURL.Create(nil);
DownloadFile.URL := 'http://.....';
DownloadFile.Filename := 'c:\';
DownloadFile.OnDownloadProgress := URL_OnDownloadProgress; //Procedure created to update the progressbar.
DownloadFile.ExecuteTarget(nil);
DownloadFile.Free;
except
on E: Exception do
begin
MessageDlg('Error'+#13+#10+E.Message,
mtInformation, [mbOK], 0);
end;
end;
end;
Any idea about what is wrong?
Thanks.
I solved the problem:
after read the code of DownloadUrl, I made little changes in the code, and now it´s working fine.
Code OK:
procedure TThreadDownload.AtualizarTela;
begin
with _Form do
begin
TcxProgressBar(_Form.FindComponent(_ProgressBar.Name)).Properties.Max := _TotalDownload;
TcxProgressBar(_Form.FindComponent(_ProgressBar.Name)).Position := _StatusDownload;
end;
end;
constructor TThreadDownload.Create(CreateSuspended: Boolean; AForm: TFrmMyFormWithProgress; AProgress: TcxProgressBar; PathUrl, PathLocal: String);
begin
inherited Create(CreateSuspended);
_Form := AForm;
_ProgressBar := AProgress;
_PathUrl := PathUrl;
_PathLocal := PathLocal;
FreeOnTerminate := True;
end;
procedure TThreadDownload.Execute;
var
DownloadFile: TDownloadUrl;
begin
try
DownloadFile := TDownloadUrl.Create(nil);
DownloadFile.URL := _PathUrl;
DownloadFile.Filename := _PathLocal;
DownloadFile.OnDownloadProgress := URL_OnDownloadProgress;
DownloadFile.ExecuteTarget(_Form);
DownloadFile.Free;
except
on E: Exception do
begin
MessageDlg('Error Message'+#13+#10+E.Message, mtInformation, [mbOK], 0);
end;
end;
end;
procedure TThreadDownload.URL_OnDownloadProgress(Sender: TDownLoadURL; Progress,
ProgressMax: Cardinal; StatusCode: TURLDownloadStatus; StatusText: String;
var Cancel: Boolean);
begin
_TotalDownload := ProgressMax;
_StatusDownload := Progress;
Synchronize(AtualizarTela);
end;
Do not do it, because TDownloadUrl would not work properly. If you would create 2 or more objects base on TDownloadUrl class and make them download simultaneously they would not return results, each thread will remain frozen. Even if you will free the objects after this collision has happened (I freed them from main thread), it would take exactly 5 minutes for the system to resolve it, but even after all the objects will be freed all other will be created "harmed" (meaning they will freeze straight away).
Here is my unit for Delphi-7 that may be used to reproduce this situation, if someone would like to check my statement.