The error lies in your Execute method, probably as a result of copy n'
paste from the demo:
...for n := 0 to Headers.Count - 1 do
Sock.SendString(Headers[n] + CRLF);
if the Socket is forcefully closed, your loop will hang.
Here is a modified unit which works fine no matter how many times you
press F5, in summary, you have to check the socket error after *all*
IO:
unit http;
interface
uses
Classes, blcksock, winsock, Synautil, SysUtils, SyncObjs;
type
TTCPHttpDaemon = class(TThread)
private
Sock: TTCPBlockSocket;
public
constructor Create;
destructor Destroy; override;
procedure Execute; override;
end;
TTCPHttpThrd = class(TThread)
private
Sock: TTCPBlockSocket;
public
Headers: TStringList;
InputData, OutputData: TMemoryStream;
constructor Create(hsock: tSocket);
destructor Destroy; override;
procedure Execute; override;
function ProcessHttpRequest(Request, URI: string): Integer;
end;
procedure CWrite(const S: string);
implementation
var
ConsoleLock: TCriticalSection;
const
ImagePath = 'C:\Temp\serv\info.bmp';
procedure CWrite(const S: string);
begin
ConsoleLock.Enter;
try
Writeln(S);
finally
ConsoleLock.Leave;
end;
end;
{ TTCPHttpDaemon }
constructor TTCPHttpDaemon.Create;
begin
Sock := TTCPBlockSocket.Create;
FreeOnTerminate := True;
Priority := tpNormal;
inherited Create(False);
end;
destructor TTCPHttpDaemon.Destroy;
begin
Sock.Free;
inherited Destroy;
end;
procedure TTCPHttpDaemon.Execute;
var
ClientSock: tSocket;
begin
with Sock do
begin
CreateSocket;
setLinger(True, 10000);
bind('0.0.0.0', '80');
listen;
repeat
if Terminated then Break;
if canread(1000) and (LastError = 0) then
begin
ClientSock := accept;
if LastError = 0 then TTCPHttpThrd.Create(ClientSock);
end;
until False;
end;
end;
{ TTCPHttpThrd }
constructor TTCPHttpThrd.Create(hsock: tSocket);
begin
Sock := TTCPBlockSocket.Create;
Headers := TStringList.Create;
InputData := TMemoryStream.Create;
OutputData := TMemoryStream.Create;
Sock.socket := hsock;
FreeOnTerminate := True;
Priority := tpNormal;
inherited Create(False);
end;
destructor TTCPHttpThrd.Destroy;
begin
Sock.Free;
Headers.Free;
InputData.Free;
OutputData.Free;
inherited Destroy;
end;
procedure TTCPHttpThrd.Execute;
var
b: Byte;
timeout: Integer;
S: Ansistring;
method, URI, protocol: string;
Size: Integer;
x, n: Integer;
resultcode: Integer;
begin
CWrite('Thread starting, TID: ' + IntToStr(ThreadID));
try
timeout := 120000;
//read request line
S := Sock.RecvString(timeout);
if Sock.LastError <> 0 then
Exit;
if S = '' then
Exit;
method := fetch(S, ' ');
if (S = '') or (method = '') then
Exit;
URI := fetch(S, ' ');
if URI = '' then
Exit;
protocol := fetch(S, ' ');
Headers.Clear;
Size := -1;
//read request headers
if protocol <> '' then
begin
if Pos('HTTP/', protocol) <> 1 then
Exit;
repeat
S := Sock.RecvString(timeout);
if Sock.LastError <> 0 then
Exit;
if S <> '' then
Headers.Add(S);
if Pos('CONTENT-LENGTH:', UpperCase(S)) = 1 then
Size := StrToIntDef(SeparateRight(S, ' '), -1);
until S = '';
end;
//recv document...
InputData.Clear;
if Size >= 0 then
begin
InputData.SetSize(Size);
x := Sock.RecvBufferEx(InputData.Memory, Size, timeout);
InputData.SetSize(x);
if Sock.LastError <> 0 then
Exit;
end;
OutputData.Clear;
resultcode := ProcessHttpRequest(method, URI);
Sock.SendString('HTTP/1.0 ' + IntToStr(resultcode) + CRLF);
if protocol <> '' then
begin
Headers.Add('Content-length: ' + IntToStr(OutputData.Size));
Headers.Add('Connection: close');
Headers.Add('Date: ' + Rfc822DateTime(now));
Headers.Add('Server: Synapse HTTP server demo');
Headers.Add('');
for n := 0 to Headers.Count - 1 do
begin
Sock.SendString(Headers[n] + CRLF);
if Sock.LastError <> 0 then
begin
CWrite('Error here by any chance?');
break;
end;
end;
end;
if Sock.LastError <> 0 then
Exit;
Sock.SendBuffer(OutputData.Memory, OutputData.Size);
finally
CWrite('Thread exiting, TID: ' + IntToStr(ThreadID) + ' Err: ' +
IntToStr(Sock.LastError) + ' ' + Sock.LastErrorDesc);
end;
end;
function TTCPHttpThrd.ProcessHttpRequest(Request, URI: string): Integer;
var
l: TStringList;
begin
//sample of precessing HTTP request:
// InputData is uploaded document, headers is stringlist with request headers.
// Request is type of request and URI is URI of request
// OutputData is document with reply, headers is stringlist with
reply headers.
// Result is result code
Result := 504;
if Request = 'GET' then
begin
Headers.Clear;
Headers.Add('Content-type: Text/Html');
if (ExtractFileExt(URI) = '.html') or (ExtractFileExt(URI) = '.htm') then
begin
l := TStringList.Create;
try
l.Add('<html>');
l.Add('<head></head>');
l.Add('<body>');
l.Add('Request Uri: ' + URI);
l.Add('<br>');
l.Add('This document is generated by Synapse HTTP server demo!<br>');
l.Add('<img src="info.bmp" alt="x" border="2"><br/>example-1<br/>');
l.Add('</body>');
l.Add('</html>');
l.SaveToStream(OutputData);
finally
l.Free;
end;
Result := 200;
end
else
begin
try
OutputData.LoadFromFile(ImagePath); //Add path were the image is saved
Result := 200;
finally
end;
end;
end;
end;
initialization
begin
ConsoleLock := TCriticalSection.Create;
end;
finalization
ConsoleLock.Free;
end.
On 07/02/07, Deborah <[EMAIL PROTECTED]> wrote:
> Does anybody know how to solve that problem? Wether immedeately nor
> after a timeout the thread is closed. It stays got stuck and does
> nothing anymore.
>
> CCRDude schrieb:
> >> As we said before, presing F5 in your web server abanond existing TCp
> >> connection and open new. So, depending on how good is abandoned
> >> connection closed, handling thread onserver may be closed immediately
> >> or will be cloded after some timeout.
> >>
> >>
> > If I may interrupt, how good the connection will be closed is a question
> > how good the official httpserv demo is, since her attached demo is
> > exactly that, only slightly modified to raise the likelyhood of this to
> > appear ;)
> >
> > -------------------------------------------------------------------------
> > Using Tomcat but need to do more? Need to support web services, security?
> > Get stuff done quickly with pre-integrated technology to make your job
> > easier.
> > Download IBM WebSphere Application Server v.1.0.1 based on Apache Geronimo
> > http://sel.as-us.falkag.net/sel?cmd=lnk&kid=120709&bid=263057&dat=121642
> > _______________________________________________
> > synalist-public mailing list
> > [email protected]
> > https://lists.sourceforge.net/lists/listinfo/synalist-public
> >
> >
>
>
> -------------------------------------------------------------------------
> Using Tomcat but need to do more? Need to support web services, security?
> Get stuff done quickly with pre-integrated technology to make your job easier.
> Download IBM WebSphere Application Server v.1.0.1 based on Apache Geronimo
> http://sel.as-us.falkag.net/sel?cmd=lnk&kid=120709&bid=263057&dat=121642
> _______________________________________________
> synalist-public mailing list
> [email protected]
> https://lists.sourceforge.net/lists/listinfo/synalist-public
>
-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys-and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV
_______________________________________________
synalist-public mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/synalist-public
