http.pp 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682
  1. {
  2. $Id$
  3. HTTP: Classes for dealing with HTTP requests
  4. Copyright (C) 2000-2003 by Sebastian Guenther ([email protected])
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. }
  11. unit HTTP;
  12. interface
  13. uses Classes, SSockets, fpAsync;
  14. const
  15. fieldAccept = 'Accept';
  16. fieldAcceptCharset = 'Accept-Charset';
  17. fieldAcceptEncoding = 'Accept-Encoding';
  18. fieldAcceptLanguage = 'Accept-Language';
  19. fieldAuthorization = 'Authorization';
  20. fieldContentEncoding = 'Content-Encoding';
  21. fieldContentLanguage = 'Content-Language';
  22. fieldContentLength = 'Content-Length';
  23. fieldContentType = 'Content-Type';
  24. fieldCookie = 'Cookie';
  25. fieldDate = 'Date';
  26. fieldExpires = 'Expires';
  27. fieldFrom = 'From';
  28. fieldIfModifiedSince = 'If-Modified-Since';
  29. fieldLastModified = 'Last-Modified';
  30. fieldLocation = 'Location';
  31. fieldPragma = 'Pragma';
  32. fieldReferer = 'Referer';
  33. fieldRetryAfter = 'Retry-After';
  34. fieldServer = 'Server';
  35. fieldSetCookie = 'Set-Cookie';
  36. fieldUserAgent = 'User-Agent';
  37. fieldWWWAuthenticate = 'WWW-Authenticate';
  38. type
  39. PHttpField = ^THttpField;
  40. THttpField = record
  41. Name, Value: String;
  42. end;
  43. THttpHeader = class
  44. protected
  45. FReader: TAsyncStreamLineReader;
  46. FWriter: TAsyncWriteStream;
  47. FOnCompleted: TNotifyEvent;
  48. FFields: TList;
  49. CmdReceived: Boolean;
  50. procedure ParseFirstHeaderLine(const line: String); virtual; abstract;
  51. procedure LineReceived(const ALine: String);
  52. function GetFirstHeaderLine: String; virtual; abstract;
  53. procedure WriterCompleted(ASender: TObject);
  54. function GetFieldCount: Integer;
  55. function GetFields(AIndex: Integer): String;
  56. function GetFieldNames(AIndex: Integer): String;
  57. procedure SetFieldNames(AIndex: Integer; const AName: String);
  58. function GetFieldValues(AIndex: Integer): String;
  59. procedure SetFieldValues(AIndex: Integer; const AValue: String);
  60. function GetAccept: String;
  61. procedure SetAccept(const AValue: String);
  62. function GetAcceptCharset: String;
  63. procedure SetAcceptCharset(const AValue: String);
  64. function GetAcceptEncoding: String;
  65. procedure SetAcceptEncoding(const AValue: String);
  66. function GetAcceptLanguage: String;
  67. procedure SetAcceptLanguage(const AValue: String);
  68. function GetAuthorization: String;
  69. procedure SetAuthorization(const AValue: String);
  70. function GetContentEncoding: String;
  71. procedure SetContentEncoding(const AValue: String);
  72. function GetContentLanguage: String;
  73. procedure SetContentLanguage(const AValue: String);
  74. function GetContentLength: Integer;
  75. procedure SetContentLength(AValue: Integer);
  76. function GetContentType: String;
  77. procedure SetContentType(const AValue: String);
  78. function Get_Cookie: String;
  79. procedure Set_Cookie(const AValue: String);
  80. function GetDate: String;
  81. procedure SetDate(const AValue: String);
  82. function GetExpires: String;
  83. procedure SetExpires(const AValue: String);
  84. function GetFrom: String;
  85. procedure SetFrom(const AValue: String);
  86. function GetIfModifiedSince: String;
  87. procedure SetIfModifiedSince(const AValue: String);
  88. function GetLastModified: String;
  89. procedure SetLastModified(const AValue: String);
  90. function GetLocation: String;
  91. procedure SetLocation(const AValue: String);
  92. function GetPragma: String;
  93. procedure SetPragma(const AValue: String);
  94. function GetReferer: String;
  95. procedure SetReferer(const AValue: String);
  96. function GetRetryAfter: String;
  97. procedure SetRetryAfter(const AValue: String);
  98. function GetServer: String;
  99. procedure SetServer(const AValue: String);
  100. function Get_SetCookie: String;
  101. procedure Set_SetCookie(const AValue: String);
  102. function GetUserAgent: String;
  103. procedure SetUserAgent(const AValue: String);
  104. function GetWWWAuthenticate: String;
  105. procedure SetWWWAuthenticate(const AValue: String);
  106. public
  107. HttpVersion: String;
  108. constructor Create;
  109. destructor Destroy; override;
  110. procedure SetFieldByName(const AName, AValue: String);
  111. function GetFieldByName(const AName: String): String;
  112. procedure AsyncSend(AManager: TEventLoop; AStream: THandleStream);
  113. procedure AsyncReceive(AManager: TEventLoop; AStream: THandleStream);
  114. property Reader: TAsyncStreamLineReader read FReader;
  115. property Writer: TAsyncWriteStream read FWriter;
  116. property FieldCount: Integer read GetFieldCount;
  117. property Fields[AIndex: Integer]: String read GetFields;
  118. property FieldNames[AIndex: Integer]: String read GetFieldNames write SetFieldNames;
  119. property FieldValues[AIndex: Integer]: String read GetFieldValues write SetFieldValues;
  120. property OnCompleted: TNotifyEvent read FOnCompleted write FOnCompleted;
  121. property Accept: String read GetAccept write SetAccept;
  122. property AcceptCharset: String read GetAcceptCharset write SetAcceptCharset;
  123. property AcceptEncoding: String read GetAcceptEncoding write SetAcceptEncoding;
  124. property AcceptLanguage: String read GetAcceptLanguage write SetAcceptLanguage;
  125. property Authorization: String read GetAuthorization write SetAuthorization;
  126. property ContentEncoding: String read GetContentEncoding write SetContentEncoding;
  127. property ContentLanguage: String read GetContentLanguage write SetContentLanguage;
  128. property ContentLength: Integer read GetContentLength write SetContentLength;
  129. property ContentType: String read GetContentType write SetContentType;
  130. property Cookie: String read Get_Cookie write Set_Cookie;
  131. property Date: String read GetDate write SetDate;
  132. property Expires: String read GetExpires write SetExpires;
  133. property From: String read GetFrom write SetFrom;
  134. property IfModifiedSince: String read GetIfModifiedSince write SetIfModifiedSince;
  135. property LastModified: String read GetLastModified write SetLastModified;
  136. property Location: String read GetLocation write SetLocation;
  137. property Pragma: String read GetPragma write SetPragma;
  138. property Referer: String read GetReferer write SetReferer;
  139. property RetryAfter: String read GetRetryAfter write SetRetryAfter;
  140. property Server: String read GetServer write SetServer;
  141. property SetCookie: String read Get_SetCookie write Set_SetCookie;
  142. property UserAgent: String read GetUserAgent write SetUserAgent;
  143. property WWWAuthenticate: String read GetWWWAuthenticate write SetWWWAuthenticate;
  144. end;
  145. THttpRequestHeader = class(THttpHeader)
  146. protected
  147. procedure ParseFirstHeaderLine(const line: String); override;
  148. function GetFirstHeaderLine: String; override;
  149. public
  150. CommandLine: String;
  151. Command: String;
  152. URI: String; // Uniform Resource Identifier
  153. QueryString: String;
  154. end;
  155. THttpAnswerHeader = class(THttpHeader)
  156. protected
  157. procedure ParseFirstHeaderLine(const line: String); override;
  158. function GetFirstHeaderLine: String; override;
  159. public
  160. Code: Integer;
  161. CodeText: String;
  162. constructor Create;
  163. end;
  164. TCustomHttpConnection = class
  165. protected
  166. FManager: TEventLoop;
  167. FSocket: TInetSocket;
  168. SendBuffer: TAsyncWriteStream;
  169. FOnHeaderSent, FOnStreamSent, FOnHeaderReceived, FOnStreamReceived: TNotifyEvent;
  170. FOnDestroy: TNotifyEvent;
  171. RecvSize: Integer; // How many bytes are still to be read. -1 if unknown.
  172. DataAvailableNotifyHandle: Pointer;
  173. procedure HeaderToSendCompleted(Sender: TObject);
  174. procedure StreamToSendCompleted(Sender: TObject);
  175. procedure ReceivedHeaderCompleted(Sender: TObject);
  176. procedure DataAvailable(Sender: TObject);
  177. procedure ReceivedStreamCompleted(Sender: TObject);
  178. property OnHeaderSent: TNotifyEvent read FOnHeaderSent write FOnHeaderSent;
  179. property OnStreamSent: TNotifyEvent read FOnStreamSent write FOnStreamSent;
  180. property OnHeaderReceived: TNotifyEvent read FOnHeaderReceived write FOnHeaderReceived;
  181. property OnStreamReceived: TNotifyEvent read FOnStreamReceived write FOnStreamReceived;
  182. property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
  183. public
  184. HeaderToSend: THttpHeader;
  185. StreamToSend: TStream;
  186. ReceivedHeader: THttpHeader;
  187. ReceivedStream: TStream;
  188. DoDestroy: Boolean;
  189. constructor Create(AManager: TEventLoop; ASocket: TInetSocket);
  190. destructor Destroy; override;
  191. procedure Receive;
  192. procedure Send;
  193. end;
  194. THttpConnection = class(TCustomHttpConnection)
  195. public
  196. property OnHeaderSent;
  197. property OnStreamSent;
  198. property OnHeaderReceived;
  199. property OnStreamReceived;
  200. property OnDestroy;
  201. end;
  202. // ===================================================================
  203. // ===================================================================
  204. implementation
  205. uses SysUtils;
  206. // -------------------------------------------------------------------
  207. // THttpHeader
  208. // -------------------------------------------------------------------
  209. procedure THttpHeader.LineReceived(const ALine: String);
  210. var
  211. i: Integer;
  212. begin
  213. if Length(ALine) = 0 then
  214. begin
  215. FReader.OnLine := nil; // Stop receiving
  216. FReader.StopAndFree;
  217. if Assigned(FOnCompleted) then
  218. FOnCompleted(Self);
  219. FReader := nil;
  220. end else
  221. if not CmdReceived then
  222. begin
  223. CmdReceived := True;
  224. ParseFirstHeaderLine(ALine);
  225. end else
  226. begin
  227. i := Pos(':', ALine);
  228. SetFieldByName(Trim(Copy(ALine, 1, i - 1)),
  229. Trim(Copy(ALine, i + 1, Length(ALine))));
  230. end;
  231. end;
  232. procedure THttpHeader.WriterCompleted(ASender: TObject);
  233. begin
  234. if Assigned(FOnCompleted) then
  235. FOnCompleted(Self);
  236. FreeAndNil(FWriter);
  237. end;
  238. function THttpHeader.GetFieldCount: Integer;
  239. begin
  240. Result := FFields.Count;
  241. end;
  242. function THttpHeader.GetFields(AIndex: Integer): String;
  243. begin
  244. Result := FieldNames[AIndex] + ': ' + FieldValues[AIndex];
  245. end;
  246. function THttpHeader.GetFieldNames(AIndex: Integer): String;
  247. begin
  248. Result := PHttpField(FFields.Items[AIndex])^.Name;
  249. end;
  250. procedure THttpHeader.SetFieldNames(AIndex: Integer; const AName: String);
  251. begin
  252. PHttpField(FFields.Items[AIndex])^.Name := AName;
  253. end;
  254. function THttpHeader.GetFieldValues(AIndex: Integer): String;
  255. begin
  256. Result := PHttpField(FFields.Items[AIndex])^.Value;
  257. end;
  258. procedure THttpHeader.SetFieldValues(AIndex: Integer; const AValue: String);
  259. begin
  260. PHttpField(FFields.Items[AIndex])^.Name := AValue;
  261. end;
  262. function THttpHeader.GetAccept: String; begin Result := GetFieldByName(fieldAccept) end;
  263. procedure THttpHeader.SetAccept(const AValue: String); begin SetFieldByName(fieldAccept, AValue) end;
  264. function THttpHeader.GetAcceptCharset: String; begin Result := GetFieldByName(fieldAcceptCharset) end;
  265. procedure THttpHeader.SetAcceptCharset(const AValue: String); begin SetFieldByName(fieldAcceptCharset, AValue) end;
  266. function THttpHeader.GetAcceptEncoding: String; begin Result := GetFieldByName(fieldAcceptEncoding) end;
  267. procedure THttpHeader.SetAcceptEncoding(const AValue: String); begin SetFieldByName(fieldAcceptEncoding, AValue) end;
  268. function THttpHeader.GetAcceptLanguage: String; begin Result := GetFieldByName(fieldAcceptLanguage) end;
  269. procedure THttpHeader.SetAcceptLanguage(const AValue: String); begin SetFieldByName(fieldAcceptLanguage, AValue) end;
  270. function THttpHeader.GetAuthorization: String; begin Result := GetFieldByName(fieldAuthorization) end;
  271. procedure THttpHeader.SetAuthorization(const AValue: String); begin SetFieldByName(fieldAuthorization, AValue) end;
  272. function THttpHeader.GetContentEncoding: String; begin Result := GetFieldByName(fieldContentEncoding) end;
  273. procedure THttpHeader.SetContentEncoding(const AValue: String); begin SetFieldByName(fieldContentEncoding, AValue) end;
  274. function THttpHeader.GetContentLanguage: String; begin Result := GetFieldByName(fieldContentLanguage) end;
  275. procedure THttpHeader.SetContentLanguage(const AValue: String); begin SetFieldByName(fieldContentLanguage, AValue) end;
  276. function THttpHeader.GetContentLength: Integer; var s: String; begin s := GetFieldByName(fieldContentLength); if Length(s) = 0 then Result := -1 else Result := StrToInt(s) end;
  277. procedure THttpHeader.SetContentLength(AValue: Integer); begin SetFieldByName(fieldContentLength, IntToStr(AValue)) end;
  278. function THttpHeader.GetContentType: String; begin Result := GetFieldByName(fieldContentType) end;
  279. procedure THttpHeader.SetContentType(const AValue: String); begin SetFieldByName(fieldContentType, AValue) end;
  280. function THttpHeader.Get_Cookie: String; begin Result := GetFieldByName(fieldCookie) end;
  281. procedure THttpHeader.Set_Cookie(const AValue: String); begin SetFieldByName(fieldCookie, AValue) end;
  282. function THttpHeader.GetDate: String; begin Result := GetFieldByName(fieldDate) end;
  283. procedure THttpHeader.SetDate(const AValue: String); begin SetFieldByName(fieldDate, AValue) end;
  284. function THttpHeader.GetExpires: String; begin Result := GetFieldByName(fieldExpires) end;
  285. procedure THttpHeader.SetExpires(const AValue: String); begin SetFieldByName(fieldExpires, AValue) end;
  286. function THttpHeader.GetFrom: String; begin Result := GetFieldByName(fieldFrom) end;
  287. procedure THttpHeader.SetFrom(const AValue: String); begin SetFieldByName(fieldFrom, AValue) end;
  288. function THttpHeader.GetIfModifiedSince: String; begin Result := GetFieldByName(fieldIfModifiedSince) end;
  289. procedure THttpHeader.SetIfModifiedSince(const AValue: String); begin SetFieldByName(fieldIfModifiedSince, AValue) end;
  290. function THttpHeader.GetLastModified: String; begin Result := GetFieldByName(fieldLastModified) end;
  291. procedure THttpHeader.SetLastModified(const AValue: String); begin SetFieldByName(fieldLastModified, AValue) end;
  292. function THttpHeader.GetLocation: String; begin Result := GetFieldByName(fieldLocation) end;
  293. procedure THttpHeader.SetLocation(const AValue: String); begin SetFieldByName(fieldLocation, AValue) end;
  294. function THttpHeader.GetPragma: String; begin Result := GetFieldByName(fieldPragma) end;
  295. procedure THttpHeader.SetPragma(const AValue: String); begin SetFieldByName(fieldPragma, AValue) end;
  296. function THttpHeader.GetReferer: String; begin Result := GetFieldByName(fieldReferer) end;
  297. procedure THttpHeader.SetReferer(const AValue: String); begin SetFieldByName(fieldReferer, AValue) end;
  298. function THttpHeader.GetRetryAfter: String; begin Result := GetFieldByName(fieldRetryAfter) end;
  299. procedure THttpHeader.SetRetryAfter(const AValue: String); begin SetFieldByName(fieldRetryAfter, AValue) end;
  300. function THttpHeader.GetServer: String; begin Result := GetFieldByName(fieldServer) end;
  301. procedure THttpHeader.SetServer(const AValue: String); begin SetFieldByName(fieldServer, AValue) end;
  302. function THttpHeader.Get_SetCookie: String; begin Result := GetFieldByName(fieldSetCookie) end;
  303. procedure THttpHeader.Set_SetCookie(const AValue: String); begin SetFieldByName(fieldSetCookie, AValue) end;
  304. function THttpHeader.GetUserAgent: String; begin Result := GetFieldByName(fieldUserAgent) end;
  305. procedure THttpHeader.SetUserAgent(const AValue: String); begin SetFieldByName(fieldUserAgent, AValue) end;
  306. function THttpHeader.GetWWWAuthenticate: String; begin Result := GetFieldByName(fieldWWWAuthenticate) end;
  307. procedure THttpHeader.SetWWWAuthenticate(const AValue: String); begin SetFieldByName(fieldWWWAuthenticate, AValue) end;
  308. constructor THttpHeader.Create;
  309. begin
  310. inherited Create;
  311. FFields := TList.Create;
  312. HttpVersion := '1.0';
  313. end;
  314. destructor THttpHeader.Destroy;
  315. var
  316. i: Integer;
  317. Field: PHttpField;
  318. begin
  319. if Assigned(FReader) then
  320. FReader.StopAndFree;
  321. if Assigned(FWriter) then
  322. FWriter.StopAndFree;
  323. for i := 0 to FFields.Count - 1 do
  324. begin
  325. Field := PHttpField(FFields.Items[i]);
  326. { SetLength(Field^.Name, 0);
  327. SetLength(Field^.Value, 0);}
  328. Dispose(Field);
  329. end;
  330. FFields.Free;
  331. inherited Destroy;
  332. end;
  333. function THttpHeader.GetFieldByName(const AName: String): String;
  334. var
  335. i: Integer;
  336. Name: String;
  337. begin
  338. Name := UpperCase(AName);
  339. for i := 0 to FFields.Count - 1 do
  340. if UpperCase(FieldNames[i]) = Name then
  341. begin
  342. Result := FieldValues[i];
  343. exit;
  344. end;
  345. SetLength(Result, 0);
  346. end;
  347. procedure THttpHeader.SetFieldByName(const AName, AValue: String);
  348. var
  349. i: Integer;
  350. Name: String;
  351. Field: PHttpField;
  352. begin
  353. Name := UpperCase(AName);
  354. for i := 0 to FFields.Count - 1 do
  355. if UpperCase(FieldNames[i]) = Name then
  356. begin
  357. FieldNames[i] := AName; // preserve case
  358. FieldValues[i] := AValue;
  359. exit;
  360. end;
  361. New(Field);
  362. FillChar(Field^, SizeOf(Field^), 0);
  363. Field^.Name := AName;
  364. Field^.Value := AValue;
  365. FFields.Add(field);
  366. end;
  367. procedure THttpHeader.AsyncSend(AManager: TEventLoop; AStream: THandleStream);
  368. var
  369. i: Integer;
  370. begin
  371. if Assigned(FWriter) then
  372. FWriter.StopAndFree;
  373. FWriter := TAsyncWriteStream.Create(AManager, AStream);
  374. FWriter.OnBufferEmpty := @WriterCompleted;
  375. FWriter.EndOfLineMarker := #13#10;
  376. FWriter.WriteLine(GetFirstHeaderLine);
  377. for i := 0 to FFields.Count - 1 do
  378. FWriter.WriteLine(Fields[i]);
  379. FWriter.WriteLine('');
  380. end;
  381. procedure THttpHeader.AsyncReceive(AManager: TEventLoop; AStream: THandleStream);
  382. begin
  383. CmdReceived := False;
  384. FReader.Free;
  385. FReader := TAsyncStreamLineReader.Create(AManager, AStream);
  386. FReader.OnLine := @LineReceived;
  387. end;
  388. // -------------------------------------------------------------------
  389. // THttpRequestHeader
  390. // -------------------------------------------------------------------
  391. procedure THttpRequestHeader.ParseFirstHeaderLine(const line: String);
  392. var
  393. i: Integer;
  394. begin
  395. CommandLine := line;
  396. i := Pos(' ', line);
  397. Command := UpperCase(Copy(line, 1, i - 1));
  398. URI := Copy(line, i + 1, Length(line));
  399. // Extract HTTP version
  400. i := Pos(' ', URI);
  401. if i > 0 then
  402. begin
  403. HttpVersion := Copy(URI, i + 1, Length(URI));
  404. URI := Copy(URI, 1, i - 1);
  405. HttpVersion := Copy(HttpVersion, Pos('/', HttpVersion) + 1, Length(HttpVersion));
  406. end;
  407. // Extract query string
  408. i := Pos('?', URI);
  409. if i > 0 then
  410. begin
  411. QueryString := Copy(URI, i + 1, Length(URI));
  412. URI := Copy(URI, 1, i - 1);
  413. end;
  414. end;
  415. function THttpRequestHeader.GetFirstHeaderLine: String;
  416. begin
  417. Result := Command + ' ' + URI;
  418. if Length(HttpVersion) > 0 then
  419. Result := Result + ' HTTP/' + HttpVersion;
  420. end;
  421. // -------------------------------------------------------------------
  422. // THttpAnswerHeader
  423. // -------------------------------------------------------------------
  424. procedure THttpAnswerHeader.ParseFirstHeaderLine(const line: String);
  425. var
  426. i: Integer;
  427. s: String;
  428. begin
  429. i := Pos('/', line);
  430. s := Copy(line, i + 1, Length(line));
  431. i := Pos(' ', s);
  432. HttpVersion := Copy(s, 1, i - 1);
  433. s := Copy(s, i + 1, Length(s));
  434. i := Pos(' ', s);
  435. if i > 0 then begin
  436. CodeText := Copy(s, i + 1, Length(s));
  437. s := Copy(s, 1, i - 1);
  438. end;
  439. Code := StrToInt(s);
  440. end;
  441. function THttpAnswerHeader.GetFirstHeaderLine: String;
  442. begin
  443. Result := Format('HTTP/%s %d %s', [HttpVersion, Code, CodeText]);
  444. end;
  445. constructor THttpAnswerHeader.Create;
  446. begin
  447. inherited Create;
  448. Code := 200;
  449. CodeText := 'OK';
  450. end;
  451. // -------------------------------------------------------------------
  452. // TCustomHttpConnection
  453. // -------------------------------------------------------------------
  454. procedure TCustomHttpConnection.HeaderToSendCompleted(Sender: TObject);
  455. begin
  456. //WriteLn('TCustomHttpConnection.HeaderToSendCompleted');
  457. if Assigned(FOnHeaderSent) then
  458. FOnHeaderSent(Self);
  459. if Assigned(StreamToSend) then
  460. begin
  461. SendBuffer := TAsyncWriteStream.Create(FManager, FSocket);
  462. SendBuffer.CopyFrom(StreamToSend, StreamToSend.Size);
  463. SendBuffer.OnBufferEmpty := @StreamToSendCompleted;
  464. end else
  465. begin
  466. StreamToSendCompleted(nil);
  467. if DoDestroy then
  468. Self.Free;
  469. end;
  470. end;
  471. procedure TCustomHttpConnection.StreamToSendCompleted(Sender: TObject);
  472. begin
  473. if Assigned(FOnStreamSent) then
  474. FOnStreamSent(Self);
  475. //WriteLn('TCustomHttpConnection.StreamToSendCompleted');
  476. FreeAndNil(SendBuffer);
  477. if DoDestroy then
  478. Self.Free;
  479. end;
  480. procedure TCustomHttpConnection.ReceivedHeaderCompleted(Sender: TObject);
  481. var
  482. BytesInBuffer: Integer;
  483. begin
  484. //WriteLn('TCustomHttpConnection.ReceivedHeaderCompleted');
  485. BytesInBuffer := ReceivedHeader.Reader.BytesInBuffer;
  486. //WriteLn('BytesInBuffer: ', BytesInBuffer, ', Content length: ', ReceivedHeader.ContentLength);
  487. if Assigned(FOnHeaderReceived) then
  488. FOnHeaderReceived(Self);
  489. RecvSize := ReceivedHeader.ContentLength;
  490. if Assigned(ReceivedStream) then
  491. begin
  492. if BytesInBuffer > 0 then
  493. begin
  494. ReceivedStream.Write(ReceivedHeader.Reader.Buffer^, BytesInBuffer);
  495. if RecvSize > 0 then
  496. Dec(RecvSize, BytesInBuffer);
  497. if BytesInBuffer = ReceivedHeader.ContentLength then
  498. begin
  499. ReceivedStreamCompleted(nil);
  500. exit;
  501. end;
  502. end;
  503. DataAvailableNotifyHandle :=
  504. FManager.SetDataAvailableNotify(FSocket.Handle, @DataAvailable, FSocket);
  505. end else
  506. ReceivedStreamCompleted(nil);
  507. if DoDestroy then
  508. Self.Free;
  509. end;
  510. procedure TCustomHttpConnection.DataAvailable(Sender: TObject);
  511. var
  512. FirstRun: Boolean;
  513. ReadNow, BytesRead: Integer;
  514. buf: array[0..1023] of Byte;
  515. begin
  516. FirstRun := True;
  517. while True do
  518. begin
  519. if RecvSize >= 0 then
  520. begin
  521. ReadNow := RecvSize;
  522. if ReadNow > 1024 then
  523. ReadNow := 1024;
  524. end else
  525. ReadNow := 1024;
  526. BytesRead := FSocket.Read(buf, ReadNow);
  527. //WriteLn('TCustomHttpConnection.DataAvailable: Read ', BytesRead, ' bytes; RecvSize=', RecvSize);
  528. if BytesRead <= 0 then
  529. begin
  530. if FirstRun then
  531. ReceivedStreamCompleted(nil);
  532. break;
  533. end;
  534. FirstRun := False;
  535. ReceivedStream.Write(buf, BytesRead);
  536. if RecvSize > 0 then
  537. Dec(RecvSize, BytesRead);
  538. if RecvSize = 0 then
  539. begin
  540. ReceivedStreamCompleted(nil);
  541. break;
  542. end;
  543. end;
  544. if DoDestroy then
  545. Self.Free;
  546. end;
  547. procedure TCustomHttpConnection.ReceivedStreamCompleted(Sender: TObject);
  548. begin
  549. //WriteLn('TCustomHttpConnection.ReceivedStreamCompleted');
  550. if Assigned(DataAvailableNotifyHandle) then
  551. begin
  552. FManager.ClearDataAvailableNotify(DataAvailableNotifyHandle);
  553. DataAvailableNotifyHandle := nil;
  554. end;
  555. if Assigned(FOnStreamReceived) then
  556. FOnStreamReceived(Self);
  557. if DoDestroy then
  558. Self.Free;
  559. end;
  560. constructor TCustomHttpConnection.Create(AManager: TEventLoop; ASocket: TInetSocket);
  561. begin
  562. inherited Create;
  563. FManager := AManager;
  564. FSocket := ASocket;
  565. end;
  566. destructor TCustomHttpConnection.Destroy;
  567. begin
  568. if Assigned(DataAvailableNotifyHandle) then
  569. FManager.ClearDataAvailableNotify(DataAvailableNotifyHandle);
  570. if Assigned(OnDestroy) then
  571. OnDestroy(Self);
  572. FreeAndNil(SendBuffer);
  573. inherited Destroy;
  574. end;
  575. procedure TCustomHttpConnection.Receive;
  576. begin
  577. // Start receiver
  578. if Assigned(ReceivedHeader) then
  579. begin
  580. ReceivedHeader.OnCompleted := @ReceivedHeaderCompleted;
  581. ReceivedHeader.AsyncReceive(FManager, FSocket);
  582. end;
  583. end;
  584. procedure TCustomHttpConnection.Send;
  585. begin
  586. // Start sender
  587. if Assigned(HeaderToSend) then
  588. begin
  589. HeaderToSend.OnCompleted := @HeaderToSendCompleted;
  590. HeaderToSend.AsyncSend(FManager, FSocket);
  591. end;
  592. end;
  593. end.
  594. {
  595. $Log$
  596. Revision 1.1 2002-04-25 19:30:29 sg
  597. * First version (with exception of the HTTP unit: This is an improved version
  598. of the old asyncio HTTP unit, now adapted to fpAsync)
  599. }