Программа для прослушивания журнала АРК Томск http://blindage.org/?p=6627
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

httpsend.pas 27KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845
  1. {==============================================================================|
  2. | Project : Ararat Synapse | 003.012.006 |
  3. |==============================================================================|
  4. | Content: HTTP client |
  5. |==============================================================================|
  6. | Copyright (c)1999-2011, Lukas Gebauer |
  7. | All rights reserved. |
  8. | |
  9. | Redistribution and use in source and binary forms, with or without |
  10. | modification, are permitted provided that the following conditions are met: |
  11. | |
  12. | Redistributions of source code must retain the above copyright notice, this |
  13. | list of conditions and the following disclaimer. |
  14. | |
  15. | Redistributions in binary form must reproduce the above copyright notice, |
  16. | this list of conditions and the following disclaimer in the documentation |
  17. | and/or other materials provided with the distribution. |
  18. | |
  19. | Neither the name of Lukas Gebauer nor the names of its contributors may |
  20. | be used to endorse or promote products derived from this software without |
  21. | specific prior written permission. |
  22. | |
  23. | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
  24. | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
  25. | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
  26. | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
  27. | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
  28. | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
  29. | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
  30. | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
  31. | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
  32. | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
  33. | DAMAGE. |
  34. |==============================================================================|
  35. | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  36. | Portions created by Lukas Gebauer are Copyright (c) 1999-2011. |
  37. | All Rights Reserved. |
  38. |==============================================================================|
  39. | Contributor(s): |
  40. |==============================================================================|
  41. | History: see HISTORY.HTM from distribution package |
  42. | (Found at URL: http://www.ararat.cz/synapse/) |
  43. |==============================================================================}
  44. {:@abstract(HTTP protocol client)
  45. Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
  46. }
  47. {$IFDEF FPC}
  48. {$MODE DELPHI}
  49. {$ENDIF}
  50. {$H+}
  51. //old Delphi does not have MSWINDOWS define.
  52. {$IFDEF WIN32}
  53. {$IFNDEF MSWINDOWS}
  54. {$DEFINE MSWINDOWS}
  55. {$ENDIF}
  56. {$ENDIF}
  57. {$IFDEF UNICODE}
  58. {$WARN IMPLICIT_STRING_CAST OFF}
  59. {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
  60. {$ENDIF}
  61. unit httpsend;
  62. interface
  63. uses
  64. SysUtils, Classes,
  65. blcksock, synautil, synaip, synacode, synsock;
  66. const
  67. cHttpProtocol = '80';
  68. type
  69. {:These encoding types are used internally by the THTTPSend object to identify
  70. the transfer data types.}
  71. TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
  72. {:abstract(Implementation of HTTP protocol.)}
  73. THTTPSend = class(TSynaClient)
  74. protected
  75. FSock: TTCPBlockSocket;
  76. FTransferEncoding: TTransferEncoding;
  77. FAliveHost: string;
  78. FAlivePort: string;
  79. FHeaders: TStringList;
  80. FDocument: TMemoryStream;
  81. FMimeType: string;
  82. FProtocol: string;
  83. FKeepAlive: Boolean;
  84. FKeepAliveTimeout: integer;
  85. FStatus100: Boolean;
  86. FProxyHost: string;
  87. FProxyPort: string;
  88. FProxyUser: string;
  89. FProxyPass: string;
  90. FResultCode: Integer;
  91. FResultString: string;
  92. FUserAgent: string;
  93. FCookies: TStringList;
  94. FDownloadSize: integer;
  95. FUploadSize: integer;
  96. FRangeStart: integer;
  97. FRangeEnd: integer;
  98. FAddPortNumberToHost: Boolean;
  99. function ReadUnknown: Boolean;
  100. function ReadIdentity(Size: Integer): Boolean;
  101. function ReadChunked: Boolean;
  102. procedure ParseCookies;
  103. function PrepareHeaders: AnsiString;
  104. function InternalDoConnect(needssl: Boolean): Boolean;
  105. function InternalConnect(needssl: Boolean): Boolean;
  106. public
  107. constructor Create;
  108. destructor Destroy; override;
  109. {:Reset headers and document and Mimetype.}
  110. procedure Clear;
  111. {:Decode ResultCode and ResultString from Value.}
  112. procedure DecodeStatus(const Value: string);
  113. {:Connects to host define in URL and access to resource defined in URL by
  114. method. If Document is not empty, send it to server as part of HTTP request.
  115. Server response is in Document and headers. Connection may be authorised
  116. by username and password in URL. If you define proxy properties, connection
  117. is made by this proxy. If all OK, result is @true, else result is @false.
  118. If you use in URL 'https:' instead only 'http:', then your request is made
  119. by SSL/TLS connection (if you not specify port, then port 443 is used
  120. instead standard port 80). If you use SSL/TLS request and you have defined
  121. HTTP proxy, then HTTP-tunnel mode is automaticly used .}
  122. function HTTPMethod(const Method, URL: string): Boolean;
  123. {:You can call this method from OnStatus event for break current data
  124. transfer. (or from another thread.)}
  125. procedure Abort;
  126. published
  127. {:Before HTTP operation you may define any non-standard headers for HTTP
  128. request, except of: 'Expect: 100-continue', 'Content-Length', 'Content-Type',
  129. 'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers.
  130. After HTTP operation contains full headers of returned document.}
  131. property Headers: TStringList read FHeaders;
  132. {:This is stringlist with name-value stringlist pairs. Each this pair is one
  133. cookie. After HTTP request is returned cookies parsed to this stringlist.
  134. You can leave this cookies untouched for next HTTP request. You can also
  135. save this stringlist for later use.}
  136. property Cookies: TStringList read FCookies;
  137. {:Stream with document to send (before request, or with document received
  138. from HTTP server (after request).}
  139. property Document: TMemoryStream read FDocument;
  140. {:If you need download only part of requested document, here specify
  141. possition of subpart begin. If here 0, then is requested full document.}
  142. property RangeStart: integer read FRangeStart Write FRangeStart;
  143. {:If you need download only part of requested document, here specify
  144. possition of subpart end. If here 0, then is requested document from
  145. rangeStart to end of document. (for broken download restoration,
  146. for example.)}
  147. property RangeEnd: integer read FRangeEnd Write FRangeEnd;
  148. {:Mime type of sending data. Default is: 'text/html'.}
  149. property MimeType: string read FMimeType Write FMimeType;
  150. {:Define protocol version. Possible values are: '1.1', '1.0' (default)
  151. and '0.9'.}
  152. property Protocol: string read FProtocol Write FProtocol;
  153. {:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.}
  154. property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
  155. {:Define timeout for keepalives in seconds!}
  156. property KeepAliveTimeout: integer read FKeepAliveTimeout Write FKeepAliveTimeout;
  157. {:if @true, then server is requested for 100status capability when uploading
  158. data. Default is @false (off).}
  159. property Status100: Boolean read FStatus100 Write FStatus100;
  160. {:Address of proxy server (IP address or domain name) where you want to
  161. connect in @link(HTTPMethod) method.}
  162. property ProxyHost: string read FProxyHost Write FProxyHost;
  163. {:Port number for proxy connection. Default value is 8080.}
  164. property ProxyPort: string read FProxyPort Write FProxyPort;
  165. {:Username for connect to proxy server where you want to connect in
  166. HTTPMethod method.}
  167. property ProxyUser: string read FProxyUser Write FProxyUser;
  168. {:Password for connect to proxy server where you want to connect in
  169. HTTPMethod method.}
  170. property ProxyPass: string read FProxyPass Write FProxyPass;
  171. {:Here you can specify custom User-Agent indentification. By default is
  172. used: 'Mozilla/4.0 (compatible; Synapse)'}
  173. property UserAgent: string read FUserAgent Write FUserAgent;
  174. {:After successful @link(HTTPMethod) method contains result code of
  175. operation.}
  176. property ResultCode: Integer read FResultCode;
  177. {:After successful @link(HTTPMethod) method contains string after result code.}
  178. property ResultString: string read FResultString;
  179. {:if this value is not 0, then data download pending. In this case you have
  180. here total sice of downloaded data. It is good for draw download
  181. progressbar from OnStatus event.}
  182. property DownloadSize: integer read FDownloadSize;
  183. {:if this value is not 0, then data upload pending. In this case you have
  184. here total sice of uploaded data. It is good for draw upload progressbar
  185. from OnStatus event.}
  186. property UploadSize: integer read FUploadSize;
  187. {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
  188. property Sock: TTCPBlockSocket read FSock;
  189. {:To have possibility to switch off port number in 'Host:' HTTP header, by
  190. default @TRUE. Some buggy servers not like port informations in this header.}
  191. property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost;
  192. end;
  193. {:A very usefull function, and example of use can be found in the THTTPSend
  194. object. It implements the GET method of the HTTP protocol. This function sends
  195. the GET method for URL document to an HTTP server. Returned document is in the
  196. "Response" stringlist (without any headers). Returns boolean TRUE if all went
  197. well.}
  198. function HttpGetText(const URL: string; const Response: TStrings): Boolean;
  199. {:A very usefull function, and example of use can be found in the THTTPSend
  200. object. It implements the GET method of the HTTP protocol. This function sends
  201. the GET method for URL document to an HTTP server. Returned document is in the
  202. "Response" stream. Returns boolean TRUE if all went well.}
  203. function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
  204. {:A very useful function, and example of use can be found in the THTTPSend
  205. object. It implements the POST method of the HTTP protocol. This function sends
  206. the SEND method for a URL document to an HTTP server. The document to be sent
  207. is located in "Data" stream. The returned document is in the "Data" stream.
  208. Returns boolean TRUE if all went well.}
  209. function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
  210. {:A very useful function, and example of use can be found in the THTTPSend
  211. object. It implements the POST method of the HTTP protocol. This function is
  212. good for POSTing form data. It sends the POST method for a URL document to
  213. an HTTP server. You must prepare the form data in the same manner as you would
  214. the URL data, and pass this prepared data to "URLdata". The following is
  215. a sample of how the data would appear: 'name=Lukas&field1=some%20data'.
  216. The information in the field must be encoded by EncodeURLElement function.
  217. The returned document is in the "Data" stream. Returns boolean TRUE if all
  218. went well.}
  219. function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
  220. {:A very useful function, and example of use can be found in the THTTPSend
  221. object. It implements the POST method of the HTTP protocol. This function sends
  222. the POST method for a URL document to an HTTP server. This function simulate
  223. posting of file by HTML form used method 'multipart/form-data'. Posting file
  224. is in DATA stream. Its name is Filename string. Fieldname is for name of
  225. formular field with file. (simulate HTML INPUT FILE) The returned document is
  226. in the ResultData Stringlist. Returns boolean TRUE if all went well.}
  227. function HttpPostFile(const URL, FieldName, FileName: string;
  228. const Data: TStream; const ResultData: TStrings): Boolean;
  229. implementation
  230. constructor THTTPSend.Create;
  231. begin
  232. inherited Create;
  233. FHeaders := TStringList.Create;
  234. FCookies := TStringList.Create;
  235. FDocument := TMemoryStream.Create;
  236. FSock := TTCPBlockSocket.Create;
  237. FSock.Owner := self;
  238. FSock.ConvertLineEnd := True;
  239. FSock.SizeRecvBuffer := c64k;
  240. FSock.SizeSendBuffer := c64k;
  241. FTimeout := 90000;
  242. FTargetPort := cHttpProtocol;
  243. FProxyHost := '';
  244. FProxyPort := '8080';
  245. FProxyUser := '';
  246. FProxyPass := '';
  247. FAliveHost := '';
  248. FAlivePort := '';
  249. FProtocol := '1.0';
  250. FKeepAlive := True;
  251. FStatus100 := False;
  252. FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
  253. FDownloadSize := 0;
  254. FUploadSize := 0;
  255. FAddPortNumberToHost := true;
  256. FKeepAliveTimeout := 300;
  257. Clear;
  258. end;
  259. destructor THTTPSend.Destroy;
  260. begin
  261. FSock.Free;
  262. FDocument.Free;
  263. FCookies.Free;
  264. FHeaders.Free;
  265. inherited Destroy;
  266. end;
  267. procedure THTTPSend.Clear;
  268. begin
  269. FRangeStart := 0;
  270. FRangeEnd := 0;
  271. FDocument.Clear;
  272. FHeaders.Clear;
  273. FMimeType := 'text/html';
  274. end;
  275. procedure THTTPSend.DecodeStatus(const Value: string);
  276. var
  277. s, su: string;
  278. begin
  279. s := Trim(SeparateRight(Value, ' '));
  280. su := Trim(SeparateLeft(s, ' '));
  281. FResultCode := StrToIntDef(su, 0);
  282. FResultString := Trim(SeparateRight(s, ' '));
  283. if FResultString = s then
  284. FResultString := '';
  285. end;
  286. function THTTPSend.PrepareHeaders: AnsiString;
  287. begin
  288. if FProtocol = '0.9' then
  289. Result := FHeaders[0] + CRLF
  290. else
  291. {$IFNDEF MSWINDOWS}
  292. Result := {$IFDEF UNICODE}AnsiString{$ENDIF}(AdjustLineBreaks(FHeaders.Text, tlbsCRLF));
  293. {$ELSE}
  294. Result := FHeaders.Text;
  295. {$ENDIF}
  296. end;
  297. function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean;
  298. begin
  299. Result := False;
  300. FSock.CloseSocket;
  301. FSock.Bind(FIPInterface, cAnyPort);
  302. if FSock.LastError <> 0 then
  303. Exit;
  304. FSock.Connect(FTargetHost, FTargetPort);
  305. if FSock.LastError <> 0 then
  306. Exit;
  307. if needssl then
  308. begin
  309. if (FSock.SSL.SNIHost='') then
  310. FSock.SSL.SNIHost:=FTargetHost;
  311. FSock.SSLDoConnect;
  312. FSock.SSL.SNIHost:=''; //don't need it anymore and don't wan't to reuse it in next connection
  313. if FSock.LastError <> 0 then
  314. Exit;
  315. end;
  316. FAliveHost := FTargetHost;
  317. FAlivePort := FTargetPort;
  318. Result := True;
  319. end;
  320. function THTTPSend.InternalConnect(needssl: Boolean): Boolean;
  321. begin
  322. if FSock.Socket = INVALID_SOCKET then
  323. Result := InternalDoConnect(needssl)
  324. else
  325. if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort)
  326. or FSock.CanRead(0) then
  327. Result := InternalDoConnect(needssl)
  328. else
  329. Result := True;
  330. end;
  331. function THTTPSend.HTTPMethod(const Method, URL: string): Boolean;
  332. var
  333. Sending, Receiving: Boolean;
  334. status100: Boolean;
  335. status100error: string;
  336. ToClose: Boolean;
  337. Size: Integer;
  338. Prot, User, Pass, Host, Port, Path, Para, URI: string;
  339. s, su: AnsiString;
  340. HttpTunnel: Boolean;
  341. n: integer;
  342. pp: string;
  343. UsingProxy: boolean;
  344. l: TStringList;
  345. x: integer;
  346. begin
  347. {initial values}
  348. Result := False;
  349. FResultCode := 500;
  350. FResultString := '';
  351. FDownloadSize := 0;
  352. FUploadSize := 0;
  353. URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
  354. User := DecodeURL(user);
  355. Pass := DecodeURL(pass);
  356. if User = '' then
  357. begin
  358. User := FUsername;
  359. Pass := FPassword;
  360. end;
  361. if UpperCase(Prot) = 'HTTPS' then
  362. begin
  363. HttpTunnel := FProxyHost <> '';
  364. FSock.HTTPTunnelIP := FProxyHost;
  365. FSock.HTTPTunnelPort := FProxyPort;
  366. FSock.HTTPTunnelUser := FProxyUser;
  367. FSock.HTTPTunnelPass := FProxyPass;
  368. end
  369. else
  370. begin
  371. HttpTunnel := False;
  372. FSock.HTTPTunnelIP := '';
  373. FSock.HTTPTunnelPort := '';
  374. FSock.HTTPTunnelUser := '';
  375. FSock.HTTPTunnelPass := '';
  376. end;
  377. UsingProxy := (FProxyHost <> '') and not(HttpTunnel);
  378. Sending := FDocument.Size > 0;
  379. {Headers for Sending data}
  380. status100 := FStatus100 and Sending and (FProtocol = '1.1');
  381. if status100 then
  382. FHeaders.Insert(0, 'Expect: 100-continue');
  383. if Sending then
  384. begin
  385. FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
  386. if FMimeType <> '' then
  387. FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
  388. end;
  389. { setting User-agent }
  390. if FUserAgent <> '' then
  391. FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
  392. { setting Ranges }
  393. if (FRangeStart > 0) or (FRangeEnd > 0) then
  394. begin
  395. if FRangeEnd >= FRangeStart then
  396. FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd))
  397. else
  398. FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-');
  399. end;
  400. { setting Cookies }
  401. s := '';
  402. for n := 0 to FCookies.Count - 1 do
  403. begin
  404. if s <> '' then
  405. s := s + '; ';
  406. s := s + FCookies[n];
  407. end;
  408. if s <> '' then
  409. FHeaders.Insert(0, 'Cookie: ' + s);
  410. { setting KeepAlives }
  411. pp := '';
  412. if UsingProxy then
  413. pp := 'Proxy-';
  414. if FKeepAlive then
  415. begin
  416. FHeaders.Insert(0, pp + 'Connection: keep-alive');
  417. FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout));
  418. end
  419. else
  420. FHeaders.Insert(0, pp + 'Connection: close');
  421. { set target servers/proxy, authorizations, etc... }
  422. if User <> '' then
  423. FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass));
  424. if UsingProxy and (FProxyUser <> '') then
  425. FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
  426. EncodeBase64(FProxyUser + ':' + FProxyPass));
  427. if isIP6(Host) then
  428. s := '[' + Host + ']'
  429. else
  430. s := Host;
  431. if FAddPortNumberToHost and (Port <> '80') then
  432. FHeaders.Insert(0, 'Host: ' + s + ':' + Port)
  433. else
  434. FHeaders.Insert(0, 'Host: ' + s);
  435. if UsingProxy then
  436. URI := Prot + '://' + s + ':' + Port + URI;
  437. if URI = '/*' then
  438. URI := '*';
  439. if FProtocol = '0.9' then
  440. FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
  441. else
  442. FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
  443. if UsingProxy then
  444. begin
  445. FTargetHost := FProxyHost;
  446. FTargetPort := FProxyPort;
  447. end
  448. else
  449. begin
  450. FTargetHost := Host;
  451. FTargetPort := Port;
  452. end;
  453. if FHeaders[FHeaders.Count - 1] <> '' then
  454. FHeaders.Add('');
  455. { connect }
  456. if not InternalConnect(UpperCase(Prot) = 'HTTPS') then
  457. begin
  458. FAliveHost := '';
  459. FAlivePort := '';
  460. Exit;
  461. end;
  462. { reading Status }
  463. FDocument.Position := 0;
  464. Status100Error := '';
  465. if status100 then
  466. begin
  467. { send Headers }
  468. FSock.SendString(PrepareHeaders);
  469. if FSock.LastError <> 0 then
  470. Exit;
  471. repeat
  472. s := FSock.RecvString(FTimeout);
  473. if s <> '' then
  474. Break;
  475. until FSock.LastError <> 0;
  476. DecodeStatus(s);
  477. Status100Error := s;
  478. repeat
  479. s := FSock.recvstring(FTimeout);
  480. if s = '' then
  481. Break;
  482. until FSock.LastError <> 0;
  483. if (FResultCode >= 100) and (FResultCode < 200) then
  484. begin
  485. { we can upload content }
  486. Status100Error := '';
  487. FUploadSize := FDocument.Size;
  488. FSock.SendBuffer(FDocument.Memory, FDocument.Size);
  489. end;
  490. end
  491. else
  492. { upload content }
  493. if sending then
  494. begin
  495. if FDocument.Size >= c64k then
  496. begin
  497. FSock.SendString(PrepareHeaders);
  498. FUploadSize := FDocument.Size;
  499. FSock.SendBuffer(FDocument.Memory, FDocument.Size);
  500. end
  501. else
  502. begin
  503. s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size);
  504. FUploadSize := Length(s);
  505. FSock.SendString(s);
  506. end;
  507. end
  508. else
  509. begin
  510. { we not need to upload document, send headers only }
  511. FSock.SendString(PrepareHeaders);
  512. end;
  513. if FSock.LastError <> 0 then
  514. Exit;
  515. Clear;
  516. Size := -1;
  517. FTransferEncoding := TE_UNKNOWN;
  518. { read status }
  519. if Status100Error = '' then
  520. begin
  521. repeat
  522. repeat
  523. s := FSock.RecvString(FTimeout);
  524. if s <> '' then
  525. Break;
  526. until FSock.LastError <> 0;
  527. if Pos('HTTP/', UpperCase(s)) = 1 then
  528. begin
  529. FHeaders.Add(s);
  530. DecodeStatus(s);
  531. end
  532. else
  533. begin
  534. { old HTTP 0.9 and some buggy servers not send result }
  535. s := s + CRLF;
  536. WriteStrToStream(FDocument, s);
  537. FResultCode := 0;
  538. end;
  539. until (FSock.LastError <> 0) or (FResultCode <> 100);
  540. end
  541. else
  542. FHeaders.Add(Status100Error);
  543. { if need receive headers, receive and parse it }
  544. ToClose := FProtocol <> '1.1';
  545. if FHeaders.Count > 0 then
  546. begin
  547. l := TStringList.Create;
  548. try
  549. repeat
  550. s := FSock.RecvString(FTimeout);
  551. l.Add(s);
  552. if s = '' then
  553. Break;
  554. until FSock.LastError <> 0;
  555. x := 0;
  556. while l.Count > x do
  557. begin
  558. s := NormalizeHeader(l, x);
  559. FHeaders.Add(s);
  560. su := UpperCase(s);
  561. if Pos('CONTENT-LENGTH:', su) = 1 then
  562. begin
  563. Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1);
  564. if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
  565. FTransferEncoding := TE_IDENTITY;
  566. end;
  567. if Pos('CONTENT-TYPE:', su) = 1 then
  568. FMimeType := Trim(SeparateRight(s, ' '));
  569. if Pos('TRANSFER-ENCODING:', su) = 1 then
  570. begin
  571. s := Trim(SeparateRight(su, ' '));
  572. if Pos('CHUNKED', s) > 0 then
  573. FTransferEncoding := TE_CHUNKED;
  574. end;
  575. if UsingProxy then
  576. begin
  577. if Pos('PROXY-CONNECTION:', su) = 1 then
  578. if Pos('CLOSE', su) > 0 then
  579. ToClose := True;
  580. end
  581. else
  582. begin
  583. if Pos('CONNECTION:', su) = 1 then
  584. if Pos('CLOSE', su) > 0 then
  585. ToClose := True;
  586. end;
  587. end;
  588. finally
  589. l.free;
  590. end;
  591. end;
  592. Result := FSock.LastError = 0;
  593. if not Result then
  594. Exit;
  595. {if need receive response body, read it}
  596. Receiving := Method <> 'HEAD';
  597. Receiving := Receiving and (FResultCode <> 204);
  598. Receiving := Receiving and (FResultCode <> 304);
  599. if Receiving then
  600. case FTransferEncoding of
  601. TE_UNKNOWN:
  602. Result := ReadUnknown;
  603. TE_IDENTITY:
  604. Result := ReadIdentity(Size);
  605. TE_CHUNKED:
  606. Result := ReadChunked;
  607. end;
  608. FDocument.Seek(0, soFromBeginning);
  609. if ToClose then
  610. begin
  611. FSock.CloseSocket;
  612. FAliveHost := '';
  613. FAlivePort := '';
  614. end;
  615. ParseCookies;
  616. end;
  617. function THTTPSend.ReadUnknown: Boolean;
  618. var
  619. s: ansistring;
  620. begin
  621. Result := false;
  622. repeat
  623. s := FSock.RecvPacket(FTimeout);
  624. if FSock.LastError = 0 then
  625. WriteStrToStream(FDocument, s);
  626. until FSock.LastError <> 0;
  627. if FSock.LastError = WSAECONNRESET then
  628. begin
  629. Result := true;
  630. FSock.ResetLastError;
  631. end;
  632. end;
  633. function THTTPSend.ReadIdentity(Size: Integer): Boolean;
  634. begin
  635. if Size > 0 then
  636. begin
  637. FDownloadSize := Size;
  638. FSock.RecvStreamSize(FDocument, FTimeout, Size);
  639. FDocument.Position := FDocument.Size;
  640. Result := FSock.LastError = 0;
  641. end
  642. else
  643. Result := true;
  644. end;
  645. function THTTPSend.ReadChunked: Boolean;
  646. var
  647. s: ansistring;
  648. Size: Integer;
  649. begin
  650. repeat
  651. repeat
  652. s := FSock.RecvString(FTimeout);
  653. until (s <> '') or (FSock.LastError <> 0);
  654. if FSock.LastError <> 0 then
  655. Break;
  656. s := Trim(SeparateLeft(s, ' '));
  657. s := Trim(SeparateLeft(s, ';'));
  658. Size := StrToIntDef('$' + s, 0);
  659. if Size = 0 then
  660. Break;
  661. if not ReadIdentity(Size) then
  662. break;
  663. until False;
  664. Result := FSock.LastError = 0;
  665. end;
  666. procedure THTTPSend.ParseCookies;
  667. var
  668. n: integer;
  669. s: string;
  670. sn, sv: string;
  671. begin
  672. for n := 0 to FHeaders.Count - 1 do
  673. if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then
  674. begin
  675. s := SeparateRight(FHeaders[n], ':');
  676. s := trim(SeparateLeft(s, ';'));
  677. sn := trim(SeparateLeft(s, '='));
  678. sv := trim(SeparateRight(s, '='));
  679. FCookies.Values[sn] := sv;
  680. end;
  681. end;
  682. procedure THTTPSend.Abort;
  683. begin
  684. FSock.StopFlag := True;
  685. end;
  686. {==============================================================================}
  687. function HttpGetText(const URL: string; const Response: TStrings): Boolean;
  688. var
  689. HTTP: THTTPSend;
  690. begin
  691. HTTP := THTTPSend.Create;
  692. try
  693. Result := HTTP.HTTPMethod('GET', URL);
  694. if Result then
  695. Response.LoadFromStream(HTTP.Document);
  696. finally
  697. HTTP.Free;
  698. end;
  699. end;
  700. function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
  701. var
  702. HTTP: THTTPSend;
  703. begin
  704. HTTP := THTTPSend.Create;
  705. try
  706. Result := HTTP.HTTPMethod('GET', URL);
  707. if Result then
  708. begin
  709. Response.Seek(0, soFromBeginning);
  710. Response.CopyFrom(HTTP.Document, 0);
  711. end;
  712. finally
  713. HTTP.Free;
  714. end;
  715. end;
  716. function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
  717. var
  718. HTTP: THTTPSend;
  719. begin
  720. HTTP := THTTPSend.Create;
  721. try
  722. HTTP.Document.CopyFrom(Data, 0);
  723. HTTP.MimeType := 'Application/octet-stream';
  724. Result := HTTP.HTTPMethod('POST', URL);
  725. Data.Size := 0;
  726. if Result then
  727. begin
  728. Data.Seek(0, soFromBeginning);
  729. Data.CopyFrom(HTTP.Document, 0);
  730. end;
  731. finally
  732. HTTP.Free;
  733. end;
  734. end;
  735. function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
  736. var
  737. HTTP: THTTPSend;
  738. begin
  739. HTTP := THTTPSend.Create;
  740. try
  741. WriteStrToStream(HTTP.Document, URLData);
  742. HTTP.MimeType := 'application/x-www-form-urlencoded';
  743. Result := HTTP.HTTPMethod('POST', URL);
  744. if Result then
  745. Data.CopyFrom(HTTP.Document, 0);
  746. finally
  747. HTTP.Free;
  748. end;
  749. end;
  750. function HttpPostFile(const URL, FieldName, FileName: string;
  751. const Data: TStream; const ResultData: TStrings): Boolean;
  752. var
  753. HTTP: THTTPSend;
  754. Bound, s: string;
  755. begin
  756. Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
  757. HTTP := THTTPSend.Create;
  758. try
  759. s := '--' + Bound + CRLF;
  760. s := s + 'content-disposition: form-data; name="' + FieldName + '";';
  761. s := s + ' filename="' + FileName +'"' + CRLF;
  762. s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
  763. WriteStrToStream(HTTP.Document, s);
  764. HTTP.Document.CopyFrom(Data, 0);
  765. s := CRLF + '--' + Bound + '--' + CRLF;
  766. WriteStrToStream(HTTP.Document, s);
  767. HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
  768. Result := HTTP.HTTPMethod('POST', URL);
  769. if Result then
  770. ResultData.LoadFromStream(HTTP.Document);
  771. finally
  772. HTTP.Free;
  773. end;
  774. end;
  775. end.