API tools faq
paste
Guest User

Untitled

a guest
Jan 22nd, 2019
162
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 56.76 KB | None | 0 0
raw download clone embed print report
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 2011 by the Free Pascal development team
  4.  
  5. HTTP client component.
  6.  
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  9.  
  10. This program is distributed in the hope that it will be useful,
  11. but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  
  14. **********************************************************************}
  15. unit fphttpclient_test;
  16.  
  17. { ---------------------------------------------------------------------
  18. Todo:
  19. * Proxy support ?
  20. ---------------------------------------------------------------------}
  21.  
  22. {$mode objfpc}{$H+}
  23.  
  24. interface
  25.  
  26. uses
  27. Classes, SysUtils, ssockets, httpdefs, uriparser, base64;
  28.  
  29. Const
  30. // Socket Read buffer size
  31. ReadBufLen = 4096;
  32. // Default for MaxRedirects Request redirection is aborted after this number of redirects.
  33. DefMaxRedirects = 16;
  34.  
  35. Type
  36. TRedirectEvent = Procedure (Sender : TObject; Const ASrc : String; Var ADest: String) of object;
  37. TPasswordEvent = Procedure (Sender : TObject; Var RepeatRequest : Boolean) of object;
  38. // During read of headers, ContentLength equals 0.
  39. // During read of content, of Server did not specify contentlength, -1 is passed.
  40. // CurrentPos is reset to 0 when the actual content is read, i.e. it is the position in the data, discarding header size.
  41. TDataEvent = Procedure (Sender : TObject; Const ContentLength, CurrentPos : Int64) of object;
  42. // Use this to set up a socket handler. UseSSL is true if protocol was https
  43. TGetSocketHandlerEvent = Procedure (Sender : TObject; Const UseSSL : Boolean; Out AHandler : TSocketHandler) of object;
  44.  
  45. TFPCustomHTTPClient = Class;
  46.  
  47. { TProxyData }
  48.  
  49. TProxyData = Class (TPersistent)
  50. private
  51. FHost: string;
  52. FPassword: String;
  53. FPort: Word;
  54. FUserName: String;
  55. FHTTPClient : TFPCustomHTTPClient;
  56. Protected
  57. Function GetProxyHeaders : String; virtual;
  58. Property HTTPClient : TFPCustomHTTPClient Read FHTTPClient;
  59. Public
  60. Procedure Assign(Source: TPersistent); override;
  61. Property Host: string Read FHost Write FHost;
  62. Property Port: Word Read FPort Write FPort;
  63. Property UserName : String Read FUserName Write FUserName;
  64. Property Password : String Read FPassword Write FPassword;
  65. end;
  66.  
  67. { TFPCustomHTTPClient }
  68. TFPCustomHTTPClient = Class(TComponent)
  69. private
  70. FDataRead : Int64;
  71. FContentLength : Int64;
  72. FAllowRedirect: Boolean;
  73. FKeepConnection: Boolean;
  74. FMaxRedirects: Byte;
  75. FOnDataReceived: TDataEvent;
  76. FOnHeaders: TNotifyEvent;
  77. FOnPassword: TPasswordEvent;
  78. FOnRedirect: TRedirectEvent;
  79. FPassword: String;
  80. FIOTimeout: Integer;
  81. FSentCookies,
  82. FCookies: TStrings;
  83. FHTTPVersion: String;
  84. FRequestBody: TStream;
  85. FRequestHeaders: TStrings;
  86. FResponseHeaders: TStrings;
  87. FResponseStatusCode: Integer;
  88. FResponseStatusText: String;
  89. FServerHTTPVersion: String;
  90. FSocket : TInetSocket;
  91. FBuffer : Ansistring;
  92. FTerminated: Boolean;
  93. FUserName: String;
  94. FOnGetSocketHandler : TGetSocketHandlerEvent;
  95. FProxy : TProxyData;
  96. function CheckContentLength: Int64;
  97. function CheckTransferEncoding: string;
  98. function GetCookies: TStrings;
  99. function GetProxy: TProxyData;
  100. Procedure ResetResponse;
  101. Procedure SetCookies(const AValue: TStrings);
  102. procedure SetHTTPVersion(const AValue: String);
  103. procedure SetKeepConnection(AValue: Boolean);
  104. procedure SetProxy(AValue: TProxyData);
  105. Procedure SetRequestHeaders(const AValue: TStrings);
  106. procedure SetIOTimeout(AValue: Integer);
  107. Procedure ExtractHostPort(AURI: TURI; Out AHost: String; Out APort: Word);
  108. Procedure CheckConnectionCloseHeader;
  109. protected
  110.  
  111. Function NoContentAllowed(ACode : Integer) : Boolean;
  112. // Peform a request, close connection.
  113. Procedure DoNormalRequest(const AURI: TURI; const AMethod: string;
  114. AStream: TStream; const AAllowedResponseCodes: array of Integer;
  115. AHeadersOnly, AIsHttps: Boolean); virtual;
  116. // Peform a request, try to keep connection.
  117. Procedure DoKeepConnectionRequest(const AURI: TURI; const AMethod: string;
  118. AStream: TStream; const AAllowedResponseCodes: array of Integer;
  119. AHeadersOnly, AIsHttps: Boolean); virtual;
  120. // Return True if FSocket is assigned
  121. Function IsConnected: Boolean; virtual;
  122. // True if we need to use a proxy: ProxyData Assigned and Hostname Set
  123. Function ProxyActive : Boolean;
  124. // Override this if you want to create a custom instance of proxy.
  125. Function CreateProxyData : TProxyData;
  126. // Called whenever data is read.
  127. Procedure DoDataRead; virtual;
  128. // Parse response status line. Saves status text and protocol, returns numerical code. Exception if invalid line.
  129. Function ParseStatusLine(AStatusLine : String) : Integer;
  130. // Construct server URL for use in request line.
  131. function GetServerURL(URI: TURI): String;
  132. // Read 1 line of response. Fills FBuffer
  133. function ReadString(out S: String): Boolean;
  134. // Check if response code is in AllowedResponseCodes. if not, an exception is raised.
  135. // If AllowRedirect is true, and the result is a Redirect status code, the result is also true
  136. // If the OnPassword event is set, then a 401 will also result in True.
  137. function CheckResponseCode(ACode: Integer; const AllowedResponseCodes: array of Integer): Boolean; virtual;
  138. // Read response from server, and write any document to Stream.
  139. Function ReadResponse(Stream: TStream; const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean = False): Boolean; virtual;
  140. // Read server response line and headers. Returns status code.
  141. Function ReadResponseHeaders : integer; virtual;
  142. // Allow header in request ? (currently checks only if non-empty and contains : token)
  143. function AllowHeader(var AHeader: String): Boolean; virtual;
  144. // Return True if the "connection: close" header is present
  145. Function HasConnectionClose: Boolean; virtual;
  146. // Connect to the server. Must initialize FSocket.
  147. Procedure ConnectToServer(const AHost: String; APort: Integer; UseSSL : Boolean=False); virtual;
  148. // Re-connect to the server. Must reinitialize FSocket.
  149. Procedure ReconnectToServer(const AHost: String; APort: Integer; UseSSL : Boolean=False); virtual;
  150. // Disconnect from server. Must free FSocket.
  151. Procedure DisconnectFromServer; virtual;
  152. // Run method AMethod, using request URL AURL. Write Response to Stream, and headers in ResponseHeaders.
  153. // If non-empty, AllowedResponseCodes contains an array of response codes considered valid responses.
  154. // If HandleRedirect is True, then Redirect status is accepted as a correct status, but request is not repeated.
  155. // No authorization callback.
  156. Procedure DoMethod(Const AMethod,AURL : String; Stream : TStream; Const AllowedResponseCodes : Array of Integer); virtual;
  157. // Send request to server: construct request line and send headers and request body.
  158. Procedure SendRequest(const AMethod: String; URI: TURI); virtual;
  159. // Create socket handler for protocol AProtocol. Calls OnGetSocketHandler.
  160. Function GetSocketHandler(Const UseSSL : Boolean) : TSocketHandler; virtual;
  161. Public
  162. Constructor Create(AOwner: TComponent); override;
  163. Destructor Destroy; override;
  164. // Add header Aheader with value AValue to HTTPHeaders, replacing exiting values
  165. Class Procedure AddHeader(HTTPHeaders : TStrings; Const AHeader,AValue : String);
  166. // Index of header AHeader in httpheaders.
  167. Class Function IndexOfHeader(HTTPHeaders : TStrings; Const AHeader : String) : Integer;
  168. // Return value of header AHeader from httpheaders. Returns empty if it doesn't exist yet.
  169. Class Function GetHeader(HTTPHeaders : TStrings; Const AHeader : String) : String;
  170. { Terminate the current request.
  171. It will stop the client from trying to send and/or receive data after the current chunk is sent/received. }
  172. Procedure Terminate;
  173. // Request Header management
  174. // Return index of header, -1 if not present.
  175. Function IndexOfHeader(Const AHeader : String) : Integer;
  176. // Add header, replacing an existing one if it exists.
  177. Procedure AddHeader(Const AHeader,AValue : String);
  178. // Return header value, empty if not present.
  179. Function GetHeader(Const AHeader : String) : String;
  180. // General-purpose call. Handles redirect and authorization retry (OnPassword).
  181. Procedure HTTPMethod(Const AMethod,AURL : String; Stream : TStream; Const AllowedResponseCodes : Array of Integer); virtual;
  182. // Execute GET on server, store result in Stream, File, StringList or string
  183. Procedure Get(Const AURL : String; Stream : TStream);
  184. Procedure Get(Const AURL : String; const LocalFileName : String);
  185. Procedure Get(Const AURL : String; Response : TStrings);
  186. Function Get(Const AURL : String) : String;
  187. // Check if responsecode is a redirect code that this class handles (301,302,303,307,308)
  188. Class Function IsRedirect(ACode : Integer) : Boolean; virtual;
  189. // If the code is a redirect, then this method must return TRUE if the next request should happen with a GET (307/308)
  190. Class Function RedirectForcesGET(ACode : Integer) : Boolean; virtual;
  191. // Simple class methods
  192. Class Procedure SimpleGet(Const AURL : String; Stream : TStream);
  193. Class Procedure SimpleGet(Const AURL : String; const LocalFileName : String);
  194. Class Procedure SimpleGet(Const AURL : String; Response : TStrings);
  195. Class Function SimpleGet(Const AURL : String) : String;
  196. // Simple post
  197. // Post URL, and Requestbody. Return response in Stream, File, TstringList or String;
  198. Procedure Post(const URL: string; const Response: TStream);
  199. Procedure Post(const URL: string; Response : TStrings);
  200. Procedure Post(const URL: string; const LocalFileName: String);
  201. function Post(const URL: string) : String;
  202. // Simple class methods.
  203. Class Procedure SimplePost(const URL: string; const Response: TStream);
  204. Class Procedure SimplePost(const URL: string; Response : TStrings);
  205. Class Procedure SimplePost(const URL: string; const LocalFileName: String);
  206. Class function SimplePost(const URL: string) : String;
  207. // Simple Put
  208. // Put URL, and Requestbody. Return response in Stream, File, TstringList or String;
  209. Procedure Put(const URL: string; const Response: TStream);
  210. Procedure Put(const URL: string; Response : TStrings);
  211. Procedure Put(const URL: string; const LocalFileName: String);
  212. function Put(const URL: string) : String;
  213. // Simple class methods.
  214. Class Procedure SimplePut(const URL: string; const Response: TStream);
  215. Class Procedure SimplePut(const URL: string; Response : TStrings);
  216. Class Procedure SimplePut(const URL: string; const LocalFileName: String);
  217. Class function SimplePut(const URL: string) : String;
  218. // Simple Delete
  219. // Delete URL, and Requestbody. Return response in Stream, File, TstringList or String;
  220. Procedure Delete(const URL: string; const Response: TStream);
  221. Procedure Delete(const URL: string; Response : TStrings);
  222. Procedure Delete(const URL: string; const LocalFileName: String);
  223. function Delete(const URL: string) : String;
  224. // Simple class methods.
  225. Class Procedure SimpleDelete(const URL: string; const Response: TStream);
  226. Class Procedure SimpleDelete(const URL: string; Response : TStrings);
  227. Class Procedure SimpleDelete(const URL: string; const LocalFileName: String);
  228. Class function SimpleDelete(const URL: string) : String;
  229. // Simple Options
  230. // Options from URL, and Requestbody. Return response in Stream, File, TstringList or String;
  231. Procedure Options(const URL: string; const Response: TStream);
  232. Procedure Options(const URL: string; Response : TStrings);
  233. Procedure Options(const URL: string; const LocalFileName: String);
  234. function Options(const URL: string) : String;
  235. // Simple class methods.
  236. Class Procedure SimpleOptions(const URL: string; const Response: TStream);
  237. Class Procedure SimpleOptions(const URL: string; Response : TStrings);
  238. Class Procedure SimpleOptions(const URL: string; const LocalFileName: String);
  239. Class function SimpleOptions(const URL: string) : String;
  240. // Get HEAD
  241. Class Procedure Head(AURL : String; Headers: TStrings);
  242. // Post Form data (www-urlencoded).
  243. // Formdata in string (urlencoded) or TStrings (plain text) format.
  244. // Form data will be inserted in the requestbody.
  245. // Return response in Stream, File, TStringList or String;
  246. Procedure FormPost(const URL, FormData: string; const Response: TStream);
  247. Procedure FormPost(const URL : string; FormData: TStrings; const Response: TStream);
  248. Procedure FormPost(const URL, FormData: string; const Response: TStrings);
  249. Procedure FormPost(const URL : string; FormData: TStrings; const Response: TStrings);
  250. function FormPost(const URL, FormData: string): String;
  251. function FormPost(const URL: string; FormData : TStrings): String;
  252. // Simple form
  253. Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStream);
  254. Class Procedure SimpleFormPost(const URL : string; FormData: TStrings; const Response: TStream);
  255. Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStrings);
  256. Class Procedure SimpleFormPost(const URL : string; FormData: TStrings; const Response: TStrings);
  257. Class function SimpleFormPost(const URL, FormData: string): String;
  258. Class function SimpleFormPost(const URL: string; FormData : TStrings): String;
  259. // Post a file
  260. Procedure FileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);
  261. // Post form with a file
  262. Procedure FileFormPost(const AURL: string; FormData: TStrings; AFieldName, AFileName: string; const Response: TStream);
  263. // Post a stream
  264. Procedure StreamFormPost(const AURL, AFieldName, AFileName: string; const AStream: TStream; const Response: TStream);
  265. // Post form with a stream
  266. Procedure StreamFormPost(const AURL: string; FormData: TStrings; const AFieldName, AFileName: string; const AStream: TStream; const Response: TStream);
  267. // Simple form of Posting a file
  268. Class Procedure SimpleFileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);
  269. // Has Terminate been called ?
  270. Property Terminated : Boolean Read FTerminated;
  271. Protected
  272. // Timeouts
  273. Property IOTimeout : Integer read FIOTimeout write SetIOTimeout;
  274. // Before request properties.
  275. // Additional headers for request. Host; and Authentication are automatically added.
  276. Property RequestHeaders : TStrings Read FRequestHeaders Write SetRequestHeaders;
  277. // Cookies. Set before request to send cookies to server.
  278. // After request the property is filled with the cookies sent by the server.
  279. Property Cookies : TStrings Read GetCookies Write SetCookies;
  280. // Optional body to send (mainly in POST request)
  281. Property RequestBody : TStream read FRequestBody Write FRequestBody;
  282. // used HTTP version when constructing the request.
  283. // Setting this to any other value than 1.1 will set KeepConnection to False.
  284. Property HTTPversion : String Read FHTTPVersion Write SetHTTPVersion;
  285. // After request properties.
  286. // After request, this contains the headers sent by server.
  287. Property ResponseHeaders : TStrings Read FResponseHeaders;
  288. // After request, HTTP version of server reply.
  289. Property ServerHTTPVersion : String Read FServerHTTPVersion;
  290. // After request, HTTP response status of the server.
  291. Property ResponseStatusCode : Integer Read FResponseStatusCode;
  292. // After request, HTTP response status text of the server.
  293. Property ResponseStatusText : String Read FResponseStatusText;
  294. // Allow redirect in HTTPMethod ?
  295. Property AllowRedirect : Boolean Read FAllowRedirect Write FAllowRedirect;
  296. // Maximum number of redirects. When this number is reached, an exception is raised.
  297. Property MaxRedirects : Byte Read FMaxRedirects Write FMaxRedirects default DefMaxRedirects;
  298. // Called On redirect. Dest URL can be edited.
  299. // If The DEST url is empty on return, the method is aborted (with redirect status).
  300. Property OnRedirect : TRedirectEvent Read FOnRedirect Write FOnRedirect;
  301. // Proxy support
  302. Property Proxy : TProxyData Read GetProxy Write SetProxy;
  303. // Authentication.
  304. // When set, they override the credentials found in the URI.
  305. // They also override any Authenticate: header in Requestheaders.
  306. Property UserName : String Read FUserName Write FUserName;
  307. Property Password : String Read FPassword Write FPassword;
  308. // Is client connected?
  309. Property Connected: Boolean read IsConnected;
  310. // Keep-Alive support. Setting to true will set HTTPVersion to 1.1
  311. Property KeepConnection: Boolean Read FKeepConnection Write SetKeepConnection;
  312. // If a request returns a 401, then the OnPassword event is fired.
  313. // It can modify the username/password and set RepeatRequest to true;
  314. Property OnPassword : TPasswordEvent Read FOnPassword Write FOnPassword;
  315. // Called whenever data is read from the connection.
  316. Property OnDataReceived : TDataEvent Read FOnDataReceived Write FOnDataReceived;
  317. // Called when headers have been processed.
  318. Property OnHeaders : TNotifyEvent Read FOnHeaders Write FOnHeaders;
  319. // Called to create socket handler. If not set, or Nil is returned, a standard socket handler is created.
  320. Property OnGetSocketHandler : TGetSocketHandlerEvent Read FOnGetSocketHandler Write FOnGetSocketHandler;
  321.  
  322. end;
  323.  
  324.  
  325. TFPHTTPClient = Class(TFPCustomHTTPClient)
  326. Published
  327. Property KeepConnection;
  328. Property Connected;
  329. Property IOTimeout;
  330. Property RequestHeaders;
  331. Property RequestBody;
  332. Property ResponseHeaders;
  333. Property HTTPversion;
  334. Property ServerHTTPVersion;
  335. Property ResponseStatusCode;
  336. Property ResponseStatusText;
  337. Property Cookies;
  338. Property AllowRedirect;
  339. Property MaxRedirects;
  340. Property OnRedirect;
  341. Property UserName;
  342. Property Password;
  343. Property OnPassword;
  344. Property OnDataReceived;
  345. Property OnHeaders;
  346. Property OnGetSocketHandler;
  347. Property Proxy;
  348. end;
  349.  
  350. EHTTPClient = Class(EHTTP);
  351.  
  352. Function EncodeURLElement(S : String) : String;
  353. Function DecodeURLElement(Const S : String) : String;
  354.  
  355. implementation
  356. {$if not defined(hasamiga)}
  357. uses sslsockets;
  358. {$endif}
  359.  
  360. resourcestring
  361. SErrInvalidProtocol = 'Invalid protocol : "%s"';
  362. SErrReadingSocket = 'Error reading data from socket';
  363. SErrInvalidProtocolVersion = 'Invalid protocol version in response: "%s"';
  364. SErrInvalidStatusCode = 'Invalid response status code: %s';
  365. SErrUnexpectedResponse = 'Unexpected response status code: %d';
  366. SErrChunkTooBig = 'Chunk too big';
  367. SErrChunkLineEndMissing = 'Chunk line end missing';
  368. SErrMaxRedirectsReached = 'Maximum allowed redirects reached : %d';
  369. //SErrRedirectAborted = 'Redirect aborted.';
  370.  
  371. Const
  372. CRLF = #13#10;
  373.  
  374. function EncodeURLElement(S: String): String;
  375.  
  376. Const
  377. NotAllowed = [ ';', '/', '?', ':', '@', '=', '&', '#', '+', '_', '<', '>',
  378. '"', '%', '{', '}', '|', '\', '^', '~', '[', ']', '`' ];
  379.  
  380. var
  381. i, o, l : Integer;
  382. h: string[2];
  383. P : PChar;
  384. c: AnsiChar;
  385. begin
  386. l:=Length(S);
  387. If (l=0) then Exit;
  388. SetLength(Result,l*3);
  389. P:=Pchar(Result);
  390. for I:=1 to L do
  391. begin
  392. C:=S[i];
  393. O:=Ord(c);
  394. if (O<=$20) or (O>=$7F) or (c in NotAllowed) then
  395. begin
  396. P^ := '%';
  397. Inc(P);
  398. h := IntToHex(Ord(c), 2);
  399. p^ := h[1];
  400. Inc(P);
  401. p^ := h[2];
  402. Inc(P);
  403. end
  404. else
  405. begin
  406. P^ := c;
  407. Inc(p);
  408. end;
  409. end;
  410. SetLength(Result,P-PChar(Result));
  411. end;
  412.  
  413. function DecodeURLElement(Const S: AnsiString): AnsiString;
  414.  
  415. var
  416. i,l,o : Integer;
  417. c: AnsiChar;
  418. p : pchar;
  419. h : string;
  420.  
  421. begin
  422. l := Length(S);
  423. if l=0 then exit;
  424. SetLength(Result, l);
  425. P:=PChar(Result);
  426. i:=1;
  427. While (I<=L) do
  428. begin
  429. c := S[i];
  430. if (c<>'%') then
  431. begin
  432. P^:=c;
  433. Inc(P);
  434. end
  435. else if (I<L-1) then
  436. begin
  437. H:='$'+Copy(S,I+1,2);
  438. o:=StrToIntDef(H,-1);
  439. If (O>=0) and (O<=255) then
  440. begin
  441. P^:=char(O);
  442. Inc(P);
  443. Inc(I,2);
  444. end;
  445. end;
  446. Inc(i);
  447. end;
  448. SetLength(Result, P-Pchar(Result));
  449. end;
  450.  
  451. { TProxyData }
  452.  
  453. function TProxyData.GetProxyHeaders: String;
  454. begin
  455. Result:='';
  456. if (UserName<>'') then
  457. Result:='Proxy-Authorization: Basic ' + EncodeStringBase64(UserName+':'+UserName);
  458. end;
  459.  
  460. procedure TProxyData.Assign(Source: TPersistent);
  461.  
  462. Var
  463. D : TProxyData;
  464.  
  465. begin
  466. if Source is TProxyData then
  467. begin
  468. D:=Source as TProxyData;
  469. Host:=D.Host;
  470. Port:=D.Port;
  471. UserName:=D.UserName;
  472. Password:=D.Password;
  473. end
  474. else
  475. inherited Assign(Source);
  476. end;
  477.  
  478. { TFPCustomHTTPClient }
  479.  
  480. procedure TFPCustomHTTPClient.SetRequestHeaders(const AValue: TStrings);
  481. begin
  482. if FRequestHeaders=AValue then exit;
  483. FRequestHeaders.Assign(AValue);
  484. end;
  485.  
  486. procedure TFPCustomHTTPClient.SetIOTimeout(AValue: Integer);
  487. begin
  488. if AValue=FIOTimeout then exit;
  489. FIOTimeout:=AValue;
  490. if Assigned(FSocket) then
  491. FSocket.IOTimeout:=AValue;
  492. end;
  493.  
  494. function TFPCustomHTTPClient.IsConnected: Boolean;
  495. begin
  496. Result := Assigned(FSocket);
  497. end;
  498.  
  499. function TFPCustomHTTPClient.NoContentAllowed(ACode: Integer): Boolean;
  500. begin
  501. Result:=((ACode div 100)=1) or ((ACode=204) or (ACode=304))
  502. end;
  503.  
  504. function TFPCustomHTTPClient.ProxyActive: Boolean;
  505. begin
  506. Result:=Assigned(FProxy) and (FProxy.Host<>'') and (FProxy.Port>0);
  507. end;
  508.  
  509. function TFPCustomHTTPClient.CreateProxyData: TProxyData;
  510. begin
  511. Result:=TProxyData.Create;
  512. end;
  513.  
  514. procedure TFPCustomHTTPClient.DoDataRead;
  515. begin
  516. If Assigned(FOnDataReceived) Then
  517. FOnDataReceived(Self,FContentLength,FDataRead);
  518. end;
  519.  
  520. function TFPCustomHTTPClient.IndexOfHeader(const AHeader: String): Integer;
  521. begin
  522. Result:=IndexOfHeader(RequestHeaders,AHeader);
  523. end;
  524.  
  525. procedure TFPCustomHTTPClient.AddHeader(const AHeader, AValue: String);
  526.  
  527. begin
  528. AddHeader(RequestHeaders,AHeader,AValue);
  529. end;
  530.  
  531. function TFPCustomHTTPClient.GetHeader(const AHeader: String): String;
  532.  
  533.  
  534. begin
  535. Result:=GetHeader(RequestHeaders,AHeader);
  536. end;
  537.  
  538. function TFPCustomHTTPClient.GetServerURL(URI: TURI): String;
  539.  
  540. Var
  541. D : String;
  542.  
  543. begin
  544. D:=URI.Path;
  545. If Length(D) = 0 then
  546. D := '/'
  547. else If (D[1]<>'/') then
  548. D:='/'+D;
  549. If (D[Length(D)]<>'/') then
  550. D:=D+'/';
  551. Result:=D+URI.Document;
  552. if (URI.Params<>'') then
  553. Result:=Result+'?'+URI.Params;
  554. if ProxyActive then
  555. begin
  556. if URI.Port>0 then
  557. Result:=':'+IntToStr(URI.Port)+Result;
  558. Result:=URI.Protocol+'://'+URI.Host+Result;
  559. end;
  560. end;
  561.  
  562. function TFPCustomHTTPClient.GetSocketHandler(const UseSSL: Boolean): TSocketHandler;
  563.  
  564. begin
  565. Result:=Nil;
  566. if Assigned(FonGetSocketHandler) then
  567. FOnGetSocketHandler(Self,UseSSL,Result);
  568. if (Result=Nil) then
  569. {$if not defined(HASAMIGA)}
  570. If UseSSL then
  571. Result:=TSSLSocketHandler.Create
  572. else
  573. {$endif}
  574. Result:=TSocketHandler.Create;
  575. end;
  576.  
  577. procedure TFPCustomHTTPClient.ConnectToServer(const AHost: String;
  578. APort: Integer; UseSSL : Boolean = False);
  579.  
  580. Var
  581. G : TSocketHandler;
  582.  
  583.  
  584. begin
  585. If IsConnected Then
  586. DisconnectFromServer; // avoid memory leaks
  587. if (Aport=0) then
  588. if UseSSL then
  589. Aport:=443
  590. else
  591. Aport:=80;
  592. G:=GetSocketHandler(UseSSL);
  593. FSocket:=TInetSocket.Create(AHost,APort,G);
  594. try
  595. if FIOTimeout<>0 then
  596. FSocket.IOTimeout:=FIOTimeout;
  597. FSocket.Connect;
  598. except
  599. FreeAndNil(FSocket);
  600. Raise;
  601. end;
  602. end;
  603.  
  604. Procedure TFPCustomHTTPClient.ReconnectToServer(const AHost: String;
  605. APort: Integer; UseSSL: Boolean);
  606. begin
  607. DisconnectFromServer;
  608. ConnectToServer(AHost, APort, UseSSL);
  609. end;
  610.  
  611. procedure TFPCustomHTTPClient.DisconnectFromServer;
  612.  
  613. begin
  614. FreeAndNil(FSocket);
  615. end;
  616.  
  617. function TFPCustomHTTPClient.AllowHeader(var AHeader: String): Boolean;
  618.  
  619. begin
  620. Result:=(AHeader<>'') and (Pos(':',AHeader)<>0);
  621. end;
  622.  
  623. Function TFPCustomHTTPClient.HasConnectionClose: Boolean;
  624. begin
  625. Result := CompareText(GetHeader('Connection'), 'close') = 0;
  626. end;
  627.  
  628. procedure TFPCustomHTTPClient.SendRequest(const AMethod: String; URI: TURI);
  629.  
  630. Var
  631. PH,UN,PW,S,L : String;
  632. I : Integer;
  633.  
  634. begin
  635. S:=Uppercase(AMethod)+' '+GetServerURL(URI)+' '+'HTTP/'+FHTTPVersion+CRLF;
  636. UN:=URI.Username;
  637. PW:=URI.Password;
  638. if (UserName<>'') then
  639. begin
  640. UN:=UserName;
  641. PW:=Password;
  642. end;
  643. If (UN<>'') then
  644. begin
  645. S:=S+'Authorization: Basic ' + EncodeStringBase64(UN+':'+PW)+CRLF;
  646. I:=IndexOfHeader('Authorization');
  647. If I<>-1 then
  648. RequestHeaders.Delete(i);
  649. end;
  650. if Assigned(FProxy) and (FProxy.Host<>'') then
  651. begin
  652. PH:=FProxy.GetProxyHeaders;
  653. if (PH<>'') then
  654. S:=S+PH+CRLF;
  655. end;
  656. S:=S+'Host: '+URI.Host;
  657. If (URI.Port<>0) then
  658. S:=S+':'+IntToStr(URI.Port);
  659. S:=S+CRLF;
  660. If Assigned(RequestBody) and (IndexOfHeader('Content-Length')=-1) then
  661. AddHeader('Content-Length',IntToStr(RequestBody.Size));
  662. CheckConnectionCloseHeader;
  663. For I:=0 to FRequestHeaders.Count-1 do
  664. begin
  665. l:=FRequestHeaders[i];
  666. If AllowHeader(L) then
  667. S:=S+L+CRLF;
  668. end;
  669. if Assigned(FCookies) then
  670. begin
  671. L:='Cookie:';
  672. For I:=0 to FCookies.Count-1 do
  673. begin
  674. If (I>0) then
  675. L:=L+'; ';
  676. L:=L+FCookies[i];
  677. end;
  678. if AllowHeader(L) then
  679. S:=S+L+CRLF;
  680. end;
  681. FreeAndNil(FSentCookies);
  682. FSentCookies:=FCookies;
  683. FCookies:=Nil;
  684. S:=S+CRLF;
  685. if not Terminated then
  686. FSocket.WriteBuffer(S[1],Length(S));
  687. If Assigned(FRequestBody) and not Terminated then
  688. FSocket.CopyFrom(FRequestBody,FRequestBody.Size);
  689. end;
  690.  
  691. function TFPCustomHTTPClient.ReadString(out S: String): Boolean;
  692.  
  693. Function FillBuffer: Boolean;
  694.  
  695. Var
  696. R : Integer;
  697.  
  698. begin
  699. if Terminated then
  700. Exit(False);
  701. SetLength(FBuffer,ReadBufLen);
  702. r:=FSocket.Read(FBuffer[1],ReadBufLen);
  703. If (r=0) or Terminated Then
  704. Exit(False);
  705. If (r<0) then
  706. Raise EHTTPClient.Create(SErrReadingSocket);
  707. if (r<ReadBuflen) then
  708. SetLength(FBuffer,r);
  709. FDataRead:=FDataRead+R;
  710. DoDataRead;
  711. Result:=r>0;
  712. end;
  713.  
  714. Var
  715. CheckLF: Boolean;
  716. P,L : integer;
  717.  
  718. begin
  719. S:='';
  720. Result:=False;
  721. CheckLF:=False;
  722. Repeat
  723. if Length(FBuffer)=0 then
  724. if not FillBuffer then
  725. Break;
  726. if Length(FBuffer)=0 then
  727. Result:=True
  728. else if CheckLF then
  729. begin
  730. If (FBuffer[1]<>#10) then
  731. S:=S+#13
  732. else
  733. begin
  734. System.Delete(FBuffer,1,1);
  735. Result:=True;
  736. end;
  737. end;
  738. if not Result then
  739. begin
  740. P:=Pos(#13#10,FBuffer);
  741. If P=0 then
  742. begin
  743. L:=Length(FBuffer);
  744. CheckLF:=FBuffer[L]=#13;
  745. if CheckLF then
  746. S:=S+Copy(FBuffer,1,L-1)
  747. else
  748. S:=S+FBuffer;
  749. FBuffer:='';
  750. end
  751. else
  752. begin
  753. S:=S+Copy(FBuffer,1,P-1);
  754. System.Delete(FBuffer,1,P+1);
  755. Result:=True;
  756. end;
  757. end;
  758. until Result or Terminated;
  759. end;
  760.  
  761. Function GetNextWord(Var S : String) : string;
  762.  
  763. Const
  764. WhiteSpace = [' ',#9];
  765.  
  766. Var
  767. P : Integer;
  768.  
  769. begin
  770. While (Length(S)>0) and (S[1] in WhiteSpace) do
  771. Delete(S,1,1);
  772. P:=Pos(' ',S);
  773. If (P=0) then
  774. P:=Pos(#9,S);
  775. If (P=0) then
  776. P:=Length(S)+1;
  777. Result:=Copy(S,1,P-1);
  778. Delete(S,1,P);
  779. end;
  780.  
  781. function TFPCustomHTTPClient.ParseStatusLine(AStatusLine: String): Integer;
  782.  
  783. Var
  784. S : String;
  785.  
  786. begin
  787. S:=Uppercase(GetNextWord(AStatusLine));
  788. If (Copy(S,1,5)<>'HTTP/') then
  789. Raise EHTTPClient.CreateFmt(SErrInvalidProtocolVersion,[S]);
  790. System.Delete(S,1,5);
  791. FServerHTTPVersion:=S;
  792. S:=GetNextWord(AStatusLine);
  793. Result:=StrToIntDef(S,-1);
  794. if Result=-1 then
  795. Raise EHTTPClient.CreateFmt(SErrInvalidStatusCode,[S]);
  796. FResponseStatusText:=AStatusLine;
  797. end;
  798.  
  799. function TFPCustomHTTPClient.ReadResponseHeaders: integer;
  800.  
  801. Procedure DoCookies(S : String);
  802.  
  803. Var
  804. P : Integer;
  805. C : String;
  806.  
  807. begin
  808. If Assigned(FCookies) then
  809. FCookies.Clear;
  810. P:=Pos(':',S);
  811. System.Delete(S,1,P);
  812. Repeat
  813. P:=Pos(';',S);
  814. If (P=0) then
  815. P:=Length(S)+1;
  816. C:=Trim(Copy(S,1,P-1));
  817. Cookies.Add(C);
  818. System.Delete(S,1,P);
  819. Until (S='') or Terminated;
  820. end;
  821.  
  822. Const
  823. SetCookie = 'set-cookie';
  824.  
  825. Var
  826. StatusLine,S : String;
  827.  
  828. begin
  829. if not ReadString(StatusLine) then
  830. Exit(0);
  831. Result:=ParseStatusLine(StatusLine);
  832. Repeat
  833. if ReadString(S) and (S<>'') then
  834. begin
  835. ResponseHeaders.Add(S);
  836. If (LowerCase(Copy(S,1,Length(SetCookie)))=SetCookie) then
  837. DoCookies(S);
  838. end
  839. Until (S='') or Terminated;
  840. If Assigned(FOnHeaders) and not Terminated then
  841. FOnHeaders(Self);
  842. end;
  843.  
  844. function TFPCustomHTTPClient.CheckResponseCode(ACode: Integer;
  845. const AllowedResponseCodes: array of Integer): Boolean;
  846.  
  847. Var
  848. I : Integer;
  849.  
  850. begin
  851. Result:=(High(AllowedResponseCodes)=-1);
  852. if not Result then
  853. begin
  854. I:=Low(AllowedResponseCodes);
  855. While (Not Result) and (I<=High(AllowedResponseCodes)) do
  856. begin
  857. Result:=(AllowedResponseCodes[i]=ACode);
  858. Inc(I);
  859. end
  860. end;
  861. If (Not Result) then
  862. begin
  863. if AllowRedirect then
  864. Result:=IsRedirect(ACode);
  865. If (ACode=401) then
  866. Result:=Assigned(FOnPassword);
  867. end;
  868. end;
  869.  
  870. function TFPCustomHTTPClient.CheckContentLength: Int64;
  871.  
  872. Const CL ='content-length:';
  873.  
  874. Var
  875. S : String;
  876. I : integer;
  877.  
  878. begin
  879. Result:=-1;
  880. I:=0;
  881. While (Result=-1) and (I<FResponseHeaders.Count) do
  882. begin
  883. S:=Trim(LowerCase(FResponseHeaders[i]));
  884. If (Copy(S,1,Length(Cl))=Cl) then
  885. begin
  886. System.Delete(S,1,Length(CL));
  887. Result:=StrToInt64Def(Trim(S),-1);
  888. end;
  889. Inc(I);
  890. end;
  891. FContentLength:=Result;
  892. end;
  893.  
  894. function TFPCustomHTTPClient.CheckTransferEncoding: string;
  895.  
  896. Const CL ='transfer-encoding:';
  897.  
  898. Var
  899. S : String;
  900. I : integer;
  901.  
  902. begin
  903. Result:='';
  904. I:=0;
  905. While (I<FResponseHeaders.Count) do
  906. begin
  907. S:=Trim(LowerCase(FResponseHeaders[i]));
  908. If (Copy(S,1,Length(Cl))=Cl) then
  909. begin
  910. System.Delete(S,1,Length(CL));
  911. Result:=Trim(S);
  912. exit;
  913. end;
  914. Inc(I);
  915. end;
  916. end;
  917.  
  918. function TFPCustomHTTPClient.GetCookies: TStrings;
  919. begin
  920. If (FCookies=Nil) then
  921. FCookies:=TStringList.Create;
  922. Result:=FCookies;
  923. end;
  924.  
  925. function TFPCustomHTTPClient.GetProxy: TProxyData;
  926. begin
  927. If not Assigned(FProxy) then
  928. begin
  929. FProxy:=CreateProxyData;
  930. FProxy.FHTTPClient:=Self;
  931. end;
  932. Result:=FProxy;
  933. end;
  934.  
  935. procedure TFPCustomHTTPClient.SetCookies(const AValue: TStrings);
  936. begin
  937. if GetCookies=AValue then exit;
  938. GetCookies.Assign(AValue);
  939. end;
  940.  
  941. procedure TFPCustomHTTPClient.SetHTTPVersion(const AValue: String);
  942. begin
  943. if FHTTPVersion = AValue then Exit;
  944. FHTTPVersion := AValue;
  945. if (AValue<>'1.1') then
  946. KeepConnection:=False;
  947. end;
  948.  
  949. procedure TFPCustomHTTPClient.SetKeepConnection(AValue: Boolean);
  950. begin
  951. if FKeepConnection=AValue then Exit;
  952. FKeepConnection:=AValue;
  953. if AValue then
  954. HTTPVersion:='1.1'
  955. else if IsConnected then
  956. DisconnectFromServer;
  957. CheckConnectionCloseHeader;
  958. end;
  959.  
  960. procedure TFPCustomHTTPClient.SetProxy(AValue: TProxyData);
  961. begin
  962. if (AValue=FProxy) then exit;
  963. Proxy.Assign(AValue);
  964. end;
  965.  
  966. Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
  967. const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean): Boolean;
  968.  
  969. Function Transfer(LB : Integer) : Integer;
  970.  
  971. begin
  972. Result:=FSocket.Read(FBuffer[1],LB);
  973. If Result<0 then
  974. Raise EHTTPClient.Create(SErrReadingSocket);
  975. if (Result>0) then
  976. begin
  977. FDataRead:=FDataRead+Result;
  978. DoDataRead;
  979. Stream.Write(FBuffer[1],Result);
  980. end;
  981. end;
  982.  
  983. Procedure ReadChunkedResponse;
  984. { HTTP 1.1 chunked response:
  985. There is no content-length. The response consists of several chunks of
  986. data, each
  987. - beginning with a line
  988. - starting with a hex number DataSize,
  989. - an optional parameter,
  990. - ending with #13#10,
  991. - followed by the data,
  992. - ending with #13#10 (not in DataSize),
  993. It ends when the DataSize is 0.
  994. After the last chunk there can be a some optional entity header fields.
  995. This trailer is not yet implemented. }
  996. var
  997. BufPos: Integer;
  998.  
  999. function FetchData(out Cnt: integer): boolean;
  1000.  
  1001. begin
  1002. Result:=False;
  1003. If Terminated then
  1004. exit;
  1005. SetLength(FBuffer,ReadBuflen);
  1006. Cnt:=FSocket.Read(FBuffer[1],length(FBuffer));
  1007. If Cnt<0 then
  1008. Raise EHTTPClient.Create(SErrReadingSocket);
  1009. SetLength(FBuffer,Cnt);
  1010. BufPos:=1;
  1011. Result:=Cnt>0;
  1012. FDataRead:=FDataRead+Cnt;
  1013. DoDataRead;
  1014. end;
  1015.  
  1016. Function ReadData(Data: PByte; Cnt: integer): integer;
  1017.  
  1018. var
  1019. l: Integer;
  1020. begin
  1021. Result:=0;
  1022. while Cnt>0 do
  1023. begin
  1024. l:=length(FBuffer)-BufPos+1;
  1025. if l=0 then
  1026. if not FetchData(l) then
  1027. exit; // end of stream
  1028. if l>Cnt then
  1029. l:=Cnt;
  1030. System.Move(FBuffer[BufPos],Data^,l);
  1031. inc(BufPos,l);
  1032. inc(Data,l);
  1033. inc(Result,l);
  1034. dec(Cnt,l);
  1035. end;
  1036. end;
  1037.  
  1038. var
  1039. c: char;
  1040. ChunkSize: Integer;
  1041. l: Integer;
  1042. begin
  1043. BufPos:=1;
  1044. repeat
  1045. // read ChunkSize
  1046. ChunkSize:=0;
  1047. repeat
  1048. if ReadData(@c,1)<1 then exit;
  1049. case c of
  1050. '0'..'9': ChunkSize:=ChunkSize*16+ord(c)-ord('0');
  1051. 'a'..'f': ChunkSize:=ChunkSize*16+ord(c)-ord('a')+10;
  1052. 'A'..'F': ChunkSize:=ChunkSize*16+ord(c)-ord('A')+10;
  1053. else
  1054. break;
  1055. end;
  1056. if ChunkSize>1000000 then
  1057. Raise EHTTPClient.Create(SErrChunkTooBig);
  1058. until Terminated;
  1059. // read till line end
  1060. while (c<>#10) and not Terminated do
  1061. if ReadData(@c,1)<1 then exit;
  1062. if ChunkSize=0 then exit;
  1063. // read data
  1064. repeat
  1065. if Terminated then
  1066. exit;
  1067. l:=length(FBuffer)-BufPos+1;
  1068. if l=0 then
  1069. if not FetchData(l) then
  1070. exit; // end of stream
  1071. if l>ChunkSize then
  1072. l:=ChunkSize;
  1073. if l>0 then
  1074. begin
  1075. // copy chunk data to output
  1076. Stream.Write(FBuffer[BufPos],l);
  1077. inc(BufPos,l);
  1078. dec(ChunkSize,l);
  1079. end;
  1080. until ChunkSize=0;
  1081. // read #13#10
  1082. if ReadData(@c,1)<1 then
  1083. exit;
  1084. if Not Terminated then
  1085. begin
  1086. if c<>#13 then
  1087. Raise EHTTPClient.Create(SErrChunkLineEndMissing);
  1088. if ReadData(@c,1)<1 then exit;
  1089. if c<>#10 then
  1090. Raise EHTTPClient.Create(SErrChunkLineEndMissing);
  1091. // next chunk
  1092. end;
  1093. until Terminated;
  1094. end;
  1095.  
  1096. Var
  1097. L : Int64;
  1098. LB,R : Integer;
  1099.  
  1100. begin
  1101. FDataRead:=0;
  1102. FContentLength:=0;
  1103. SetLength(FBuffer,0);
  1104. FResponseStatusCode:=ReadResponseHeaders;
  1105. Result := FResponseStatusCode > 0;
  1106. if not Result then
  1107. Exit;
  1108. if not CheckResponseCode(FResponseStatusCode,AllowedResponseCodes) then
  1109. Raise EHTTPClient.CreateFmt(SErrUnexpectedResponse,[ResponseStatusCode]);
  1110. if HeadersOnly Or (AllowRedirect and IsRedirect(FResponseStatusCode)) then
  1111. exit;
  1112. if CompareText(CheckTransferEncoding,'chunked')=0 then
  1113. ReadChunkedResponse
  1114. else
  1115. begin
  1116. // Write remains of buffer to output.
  1117. LB:=Length(FBuffer);
  1118. FDataRead:=LB;
  1119. If (LB>0) then
  1120. Stream.WriteBuffer(FBuffer[1],LB);
  1121. // Now read the rest, if any.
  1122. SetLength(FBuffer,ReadBuflen);
  1123. L:=CheckContentLength;
  1124. If (L>LB) then
  1125. begin
  1126. // We cannot use copyfrom, it uses ReadBuffer, and this is dangerous with sockets
  1127. L:=L-LB;
  1128. Repeat
  1129. LB:=ReadBufLen;
  1130. If (LB>L) then
  1131. LB:=L;
  1132. R:=Transfer(LB);
  1133. L:=L-R;
  1134. until (L=0) or (R=0) or Terminated;
  1135. end
  1136. else if (L<0) and (Not NoContentAllowed(ResponseStatusCode)) then
  1137. begin
  1138. // No content-length, so we read till no more data available.
  1139. Repeat
  1140. R:=Transfer(ReadBufLen);
  1141. until (R=0) or Terminated;
  1142. end;
  1143. end;
  1144. end;
  1145.  
  1146. Procedure TFPCustomHTTPClient.ExtractHostPort(AURI: TURI; Out AHost: String;
  1147. Out APort: Word);
  1148. Begin
  1149. if ProxyActive then
  1150. begin
  1151. AHost:=Proxy.Host;
  1152. APort:=Proxy.Port;
  1153. end
  1154. else
  1155. begin
  1156. AHost:=AURI.Host;
  1157. APort:=AURI.Port;
  1158. end;
  1159. End;
  1160.  
  1161. procedure TFPCustomHTTPClient.CheckConnectionCloseHeader;
  1162.  
  1163. Var
  1164. I : integer;
  1165. N,V : String;
  1166.  
  1167. begin
  1168. V:=GetHeader('Connection');
  1169. If FKeepConnection Then
  1170. begin
  1171. I:=IndexOfHeader(FRequestHeaders,'Connection');
  1172. If i>-1 Then
  1173. begin
  1174. // It can be keep-alive, check value
  1175. FRequestHeaders.GetNameValue(I,N,V);
  1176. If CompareText(V,'close')=0 then
  1177. FRequestHeaders.Delete(i);
  1178. end
  1179. end
  1180. Else
  1181. AddHeader('Connection', 'close');
  1182. end;
  1183.  
  1184. Procedure TFPCustomHTTPClient.DoNormalRequest(const AURI: TURI;
  1185. const AMethod: string; AStream: TStream;
  1186. const AAllowedResponseCodes: array of Integer;
  1187. AHeadersOnly, AIsHttps: Boolean);
  1188.  
  1189. Var
  1190. CHost: string;
  1191. CPort: Word;
  1192.  
  1193. begin
  1194. ExtractHostPort(AURI, CHost, CPort);
  1195. ConnectToServer(CHost,CPort,AIsHttps);
  1196. Try
  1197. SendRequest(AMethod,AURI);
  1198. if not Terminated then
  1199. ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
  1200. Finally
  1201. DisconnectFromServer;
  1202. End;
  1203. end;
  1204.  
  1205. Procedure TFPCustomHTTPClient.DoKeepConnectionRequest(const AURI: TURI;
  1206. const AMethod: string; AStream: TStream;
  1207. const AAllowedResponseCodes: array of Integer;
  1208. AHeadersOnly, AIsHttps: Boolean);
  1209.  
  1210. Var
  1211. T: Boolean;
  1212. CHost: string;
  1213. CPort: Word;
  1214.  
  1215. begin
  1216. ExtractHostPort(AURI, CHost, CPort);
  1217. T := False;
  1218. Repeat
  1219. If Not IsConnected Then
  1220. ConnectToServer(CHost,CPort,AIsHttps);
  1221. Try
  1222. if not Terminated then
  1223. SendRequest(AMethod,AURI);
  1224. if not Terminated then
  1225. begin
  1226. T := ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
  1227. If Not T Then
  1228. ReconnectToServer(CHost,CPort,AIsHttps);
  1229. end;
  1230. Finally
  1231. // On terminate, we close the request
  1232. If HasConnectionClose or Terminated Then
  1233. DisconnectFromServer;
  1234. End;
  1235. Until T or Terminated;
  1236. end;
  1237.  
  1238. Procedure TFPCustomHTTPClient.DoMethod(Const AMethod, AURL: String;
  1239. Stream: TStream; Const AllowedResponseCodes: Array of Integer);
  1240.  
  1241. Var
  1242. URI: TURI;
  1243. P: String;
  1244. IsHttps, HeadersOnly: Boolean;
  1245.  
  1246. begin
  1247. ResetResponse;
  1248. URI:=ParseURI(AURL,False);
  1249. p:=LowerCase(URI.Protocol);
  1250. If Not ((P='http') or (P='https')) then
  1251. Raise EHTTPClient.CreateFmt(SErrInvalidProtocol,[URI.Protocol]);
  1252. IsHttps:=P='https';
  1253. HeadersOnly:=CompareText(AMethod,'HEAD')=0;
  1254. if FKeepConnection then
  1255. DoKeepConnectionRequest(URI,AMethod,Stream,AllowedResponseCodes,HeadersOnly,IsHttps)
  1256. else
  1257. DoNormalRequest(URI,AMethod,Stream,AllowedResponseCodes,HeadersOnly,IsHttps);
  1258. end;
  1259.  
  1260. constructor TFPCustomHTTPClient.Create(AOwner: TComponent);
  1261. begin
  1262. inherited Create(AOwner);
  1263. // Infinite timeout on most platforms
  1264. FIOTimeout:=0;
  1265. FRequestHeaders:=TStringList.Create;
  1266. FRequestHeaders.NameValueSeparator:=':';
  1267. FResponseHeaders:=TStringList.Create;
  1268. FResponseHeaders.NameValueSeparator:=':';
  1269. HTTPVersion:='1.1';
  1270. FMaxRedirects:=DefMaxRedirects;
  1271. end;
  1272.  
  1273. destructor TFPCustomHTTPClient.Destroy;
  1274. begin
  1275. if IsConnected then
  1276. DisconnectFromServer;
  1277. FreeAndNil(FProxy);
  1278. FreeAndNil(FCookies);
  1279. FreeAndNil(FSentCookies);
  1280. FreeAndNil(FRequestHeaders);
  1281. FreeAndNil(FResponseHeaders);
  1282. inherited Destroy;
  1283. end;
  1284.  
  1285. class procedure TFPCustomHTTPClient.AddHeader(HTTPHeaders: TStrings;
  1286. const AHeader, AValue: String);
  1287. Var
  1288. J: Integer;
  1289. begin
  1290. j:=IndexOfHeader(HTTPHeaders,Aheader);
  1291. if (J<>-1) then
  1292. HTTPHeaders.Delete(j);
  1293. HTTPHeaders.Add(AHeader+': '+Avalue);
  1294. end;
  1295.  
  1296.  
  1297. class function TFPCustomHTTPClient.IndexOfHeader(HTTPHeaders: TStrings;
  1298. const AHeader: String): Integer;
  1299.  
  1300. Var
  1301. L : Integer;
  1302. H : String;
  1303. begin
  1304. H:=LowerCase(Aheader);
  1305. l:=Length(AHeader);
  1306. Result:=HTTPHeaders.Count-1;
  1307. While (Result>=0) and ((LowerCase(Copy(HTTPHeaders[Result],1,l)))<>h) do
  1308. Dec(Result);
  1309. end;
  1310.  
  1311. class function TFPCustomHTTPClient.GetHeader(HTTPHeaders: TStrings;
  1312. const AHeader: String): String;
  1313. Var
  1314. I : Integer;
  1315. begin
  1316. I:=IndexOfHeader(HTTPHeaders,AHeader);
  1317. if (I=-1) then
  1318. Result:=''
  1319. else
  1320. begin
  1321. Result:=HTTPHeaders[i];
  1322. I:=Pos(':',Result);
  1323. if (I=0) then
  1324. I:=Length(Result);
  1325. System.Delete(Result,1,I);
  1326. Result:=TrimLeft(Result);
  1327. end;
  1328. end;
  1329.  
  1330. procedure TFPCustomHTTPClient.Terminate;
  1331. begin
  1332. FTerminated:=True;
  1333. end;
  1334.  
  1335. procedure TFPCustomHTTPClient.ResetResponse;
  1336.  
  1337. begin
  1338. FResponseStatusCode:=0;
  1339. FResponseStatusText:='';
  1340. FResponseHeaders.Clear;
  1341. FServerHTTPVersion:='';
  1342. FBuffer:='';
  1343. end;
  1344.  
  1345.  
  1346. procedure TFPCustomHTTPClient.HTTPMethod(const AMethod, AURL: String;
  1347. Stream: TStream; const AllowedResponseCodes: array of Integer);
  1348.  
  1349. Var
  1350. M,L,NL : String;
  1351. RC : Integer;
  1352. RR : Boolean; // Repeat request ?
  1353.  
  1354. begin
  1355. // Reset Terminated
  1356. FTerminated:=False;
  1357. L:=AURL;
  1358. RC:=0;
  1359. RR:=False;
  1360. M:=AMethod;
  1361. Repeat
  1362. if Not AllowRedirect then
  1363. DoMethod(M,L,Stream,AllowedResponseCodes)
  1364. else
  1365. begin
  1366. DoMethod(M,L,Stream,AllowedResponseCodes);
  1367. if IsRedirect(FResponseStatusCode) and not Terminated then
  1368. begin
  1369. Inc(RC);
  1370. if (RC>MaxRedirects) then
  1371. Raise EHTTPClient.CreateFmt(SErrMaxRedirectsReached,[RC]);
  1372. NL:=GetHeader(FResponseHeaders,'Location');
  1373. if Not Assigned(FOnRedirect) then
  1374. L:=NL
  1375. else
  1376. FOnRedirect(Self,L,NL);
  1377. if (RedirectForcesGET(FResponseStatusCode)) then
  1378. M:='GET';
  1379. L:=NL;
  1380. // Request has saved cookies in sentcookies.
  1381. FreeAndNil(FCookies);
  1382. FCookies:=FSentCookies;
  1383. FSentCookies:=Nil;
  1384. end;
  1385. end;
  1386. if (FResponseStatusCode=401) then
  1387. begin
  1388. RR:=False;
  1389. if Assigned(FOnPassword) then
  1390. FOnPassword(Self,RR);
  1391. end
  1392. else
  1393. RR:=AllowRedirect and IsRedirect(FResponseStatusCode) and (L<>'');
  1394. until Terminated or not RR ;
  1395. end;
  1396.  
  1397. procedure TFPCustomHTTPClient.Get(const AURL: String; Stream: TStream);
  1398. begin
  1399. HTTPMethod('GET',AURL,Stream,[200]);
  1400. end;
  1401.  
  1402. procedure TFPCustomHTTPClient.Get(const AURL: String;
  1403. const LocalFileName: String);
  1404.  
  1405. Var
  1406. F : TFileStream;
  1407.  
  1408. begin
  1409. F:=TFileStream.Create(LocalFileName,fmCreate);
  1410. try
  1411. Get(AURL,F);
  1412. finally
  1413. F.Free;
  1414. end;
  1415. end;
  1416.  
  1417. procedure TFPCustomHTTPClient.Get(const AURL: String; Response: TStrings);
  1418. begin
  1419. Response.Text:=Get(AURL);
  1420. end;
  1421.  
  1422. function TFPCustomHTTPClient.Get(const AURL: String): String;
  1423.  
  1424. Var
  1425. SS : TStringStream;
  1426.  
  1427. begin
  1428. SS:=TStringStream.Create('');
  1429. try
  1430. Get(AURL,SS);
  1431. Result:=SS.Datastring;
  1432. finally
  1433. SS.Free;
  1434. end;
  1435. end;
  1436.  
  1437. class function TFPCustomHTTPClient.IsRedirect(ACode: Integer): Boolean;
  1438. begin
  1439. Case ACode of
  1440. 301,
  1441. 302,
  1442. 303,
  1443. 307,808 : Result:=True;
  1444. else
  1445. Result:=False;
  1446. end;
  1447. end;
  1448.  
  1449. class function TFPCustomHTTPClient.RedirectForcesGET(ACode: Integer): Boolean;
  1450. begin
  1451. Result:=(ACode=303)
  1452. end;
  1453.  
  1454.  
  1455. class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String;
  1456. Stream: TStream);
  1457.  
  1458. begin
  1459. With Self.Create(nil) do
  1460. try
  1461. KeepConnection := False;
  1462. Get(AURL,Stream);
  1463. finally
  1464. Free;
  1465. end;
  1466. end;
  1467.  
  1468.  
  1469. class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String;
  1470. const LocalFileName: String);
  1471.  
  1472. begin
  1473. With Self.Create(nil) do
  1474. try
  1475. KeepConnection := False;
  1476. Get(AURL,LocalFileName);
  1477. finally
  1478. Free;
  1479. end;
  1480. end;
  1481.  
  1482.  
  1483. class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String;
  1484. Response: TStrings);
  1485.  
  1486. begin
  1487. With Self.Create(nil) do
  1488. try
  1489. KeepConnection := False;
  1490. Get(AURL,Response);
  1491. finally
  1492. Free;
  1493. end;
  1494. end;
  1495.  
  1496.  
  1497. class function TFPCustomHTTPClient.SimpleGet(const AURL: String): String;
  1498.  
  1499. begin
  1500. With Self.Create(nil) do
  1501. try
  1502. Result:=Get(AURL);
  1503. finally
  1504. Free;
  1505. end;
  1506. end;
  1507.  
  1508.  
  1509. procedure TFPCustomHTTPClient.Post(const URL: string; const Response: TStream);
  1510. begin
  1511. HTTPMethod('POST',URL,Response,[]);
  1512. end;
  1513.  
  1514.  
  1515. procedure TFPCustomHTTPClient.Post(const URL: string; Response: TStrings);
  1516. begin
  1517. Response.Text:=Post(URL);
  1518. end;
  1519.  
  1520.  
  1521. procedure TFPCustomHTTPClient.Post(const URL: string;
  1522. const LocalFileName: String);
  1523.  
  1524. Var
  1525. F : TFileStream;
  1526.  
  1527. begin
  1528. F:=TFileStream.Create(LocalFileName,fmCreate);
  1529. try
  1530. Post(URL,F);
  1531. finally
  1532. F.Free;
  1533. end;
  1534. end;
  1535.  
  1536.  
  1537. function TFPCustomHTTPClient.Post(const URL: string): String;
  1538. Var
  1539. SS : TStringStream;
  1540. begin
  1541. SS:=TStringStream.Create('');
  1542. try
  1543. Post(URL,SS);
  1544. Result:=SS.Datastring;
  1545. finally
  1546. SS.Free;
  1547. end;
  1548. end;
  1549.  
  1550.  
  1551. class procedure TFPCustomHTTPClient.SimplePost(const URL: string;
  1552. const Response: TStream);
  1553.  
  1554. begin
  1555. With Self.Create(nil) do
  1556. try
  1557. KeepConnection := False;
  1558. Post(URL,Response);
  1559. finally
  1560. Free;
  1561. end;
  1562. end;
  1563.  
  1564.  
  1565. class procedure TFPCustomHTTPClient.SimplePost(const URL: string;
  1566. Response: TStrings);
  1567.  
  1568. begin
  1569. With Self.Create(nil) do
  1570. try
  1571. KeepConnection := False;
  1572. Post(URL,Response);
  1573. finally
  1574. Free;
  1575. end;
  1576. end;
  1577.  
  1578.  
  1579. class procedure TFPCustomHTTPClient.SimplePost(const URL: string;
  1580. const LocalFileName: String);
  1581.  
  1582. begin
  1583. With Self.Create(nil) do
  1584. try
  1585. KeepConnection := False;
  1586. Post(URL,LocalFileName);
  1587. finally
  1588. Free;
  1589. end;
  1590. end;
  1591.  
  1592.  
  1593. class function TFPCustomHTTPClient.SimplePost(const URL: string): String;
  1594.  
  1595. begin
  1596. With Self.Create(nil) do
  1597. try
  1598. KeepConnection := False;
  1599. Result:=Post(URL);
  1600. finally
  1601. Free;
  1602. end;
  1603. end;
  1604.  
  1605. procedure TFPCustomHTTPClient.Put(const URL: string; const Response: TStream);
  1606. begin
  1607. HTTPMethod('PUT',URL,Response,[]);
  1608. end;
  1609.  
  1610. procedure TFPCustomHTTPClient.Put(const URL: string; Response: TStrings);
  1611. begin
  1612. Response.Text:=Put(URL);
  1613. end;
  1614.  
  1615. procedure TFPCustomHTTPClient.Put(const URL: string; const LocalFileName: String
  1616. );
  1617.  
  1618. Var
  1619. F : TFileStream;
  1620.  
  1621. begin
  1622. F:=TFileStream.Create(LocalFileName,fmCreate);
  1623. try
  1624. Put(URL,F);
  1625. finally
  1626. F.Free;
  1627. end;
  1628. end;
  1629.  
  1630. function TFPCustomHTTPClient.Put(const URL: string): String;
  1631. Var
  1632. SS : TStringStream;
  1633. begin
  1634. SS:=TStringStream.Create('');
  1635. try
  1636. Put(URL,SS);
  1637. Result:=SS.Datastring;
  1638. finally
  1639. SS.Free;
  1640. end;
  1641. end;
  1642.  
  1643. class procedure TFPCustomHTTPClient.SimplePut(const URL: string;
  1644. const Response: TStream);
  1645.  
  1646. begin
  1647. With Self.Create(nil) do
  1648. try
  1649. KeepConnection := False;
  1650. Put(URL,Response);
  1651. finally
  1652. Free;
  1653. end;
  1654. end;
  1655.  
  1656. class procedure TFPCustomHTTPClient.SimplePut(const URL: string;
  1657. Response: TStrings);
  1658.  
  1659. begin
  1660. With Self.Create(nil) do
  1661. try
  1662. KeepConnection := False;
  1663. Put(URL,Response);
  1664. finally
  1665. Free;
  1666. end;
  1667. end;
  1668.  
  1669. class procedure TFPCustomHTTPClient.SimplePut(const URL: string;
  1670. const LocalFileName: String);
  1671.  
  1672. begin
  1673. With Self.Create(nil) do
  1674. try
  1675. KeepConnection := False;
  1676. Put(URL,LocalFileName);
  1677. finally
  1678. Free;
  1679. end;
  1680. end;
  1681.  
  1682. class function TFPCustomHTTPClient.SimplePut(const URL: string): String;
  1683.  
  1684. begin
  1685. With Self.Create(nil) do
  1686. try
  1687. KeepConnection := False;
  1688. Result:=Put(URL);
  1689. finally
  1690. Free;
  1691. end;
  1692. end;
  1693.  
  1694. procedure TFPCustomHTTPClient.Delete(const URL: string; const Response: TStream
  1695. );
  1696. begin
  1697. HTTPMethod('DELETE',URL,Response,[]);
  1698. end;
  1699.  
  1700. procedure TFPCustomHTTPClient.Delete(const URL: string; Response: TStrings);
  1701. begin
  1702. Response.Text:=Delete(URL);
  1703. end;
  1704.  
  1705. procedure TFPCustomHTTPClient.Delete(const URL: string;
  1706. const LocalFileName: String);
  1707.  
  1708. Var
  1709. F : TFileStream;
  1710.  
  1711. begin
  1712. F:=TFileStream.Create(LocalFileName,fmCreate);
  1713. try
  1714. Delete(URL,F);
  1715. finally
  1716. F.Free;
  1717. end;
  1718. end;
  1719.  
  1720. function TFPCustomHTTPClient.Delete(const URL: string): String;
  1721. Var
  1722. SS : TStringStream;
  1723. begin
  1724. SS:=TStringStream.Create('');
  1725. try
  1726. Delete(URL,SS);
  1727. Result:=SS.Datastring;
  1728. finally
  1729. SS.Free;
  1730. end;
  1731. end;
  1732.  
  1733. class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string;
  1734. const Response: TStream);
  1735.  
  1736. begin
  1737. With Self.Create(nil) do
  1738. try
  1739. KeepConnection := False;
  1740. Delete(URL,Response);
  1741. finally
  1742. Free;
  1743. end;
  1744. end;
  1745.  
  1746. class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string;
  1747. Response: TStrings);
  1748.  
  1749. begin
  1750. With Self.Create(nil) do
  1751. try
  1752. KeepConnection := False;
  1753. Delete(URL,Response);
  1754. finally
  1755. Free;
  1756. end;
  1757. end;
  1758.  
  1759. class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string;
  1760. const LocalFileName: String);
  1761.  
  1762. begin
  1763. With Self.Create(nil) do
  1764. try
  1765. KeepConnection := False;
  1766. Delete(URL,LocalFileName);
  1767. finally
  1768. Free;
  1769. end;
  1770. end;
  1771.  
  1772. class function TFPCustomHTTPClient.SimpleDelete(const URL: string): String;
  1773.  
  1774. begin
  1775. With Self.Create(nil) do
  1776. try
  1777. KeepConnection := False;
  1778. Result:=Delete(URL);
  1779. finally
  1780. Free;
  1781. end;
  1782. end;
  1783.  
  1784. procedure TFPCustomHTTPClient.Options(const URL: string; const Response: TStream
  1785. );
  1786. begin
  1787. HTTPMethod('OPTIONS',URL,Response,[]);
  1788. end;
  1789.  
  1790. procedure TFPCustomHTTPClient.Options(const URL: string; Response: TStrings);
  1791. begin
  1792. Response.Text:=Options(URL);
  1793. end;
  1794.  
  1795. procedure TFPCustomHTTPClient.Options(const URL: string;
  1796. const LocalFileName: String);
  1797.  
  1798. Var
  1799. F : TFileStream;
  1800.  
  1801. begin
  1802. F:=TFileStream.Create(LocalFileName,fmCreate);
  1803. try
  1804. Options(URL,F);
  1805. finally
  1806. F.Free;
  1807. end;
  1808. end;
  1809.  
  1810. function TFPCustomHTTPClient.Options(const URL: string): String;
  1811. Var
  1812. SS : TStringStream;
  1813. begin
  1814. SS:=TStringStream.Create('');
  1815. try
  1816. Options(URL,SS);
  1817. Result:=SS.Datastring;
  1818. finally
  1819. SS.Free;
  1820. end;
  1821. end;
  1822.  
  1823. class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string;
  1824. const Response: TStream);
  1825.  
  1826. begin
  1827. With Self.Create(nil) do
  1828. try
  1829. KeepConnection := False;
  1830. Options(URL,Response);
  1831. finally
  1832. Free;
  1833. end;
  1834. end;
  1835.  
  1836. class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string;
  1837. Response: TStrings);
  1838.  
  1839. begin
  1840. With Self.Create(nil) do
  1841. try
  1842. KeepConnection := False;
  1843. Options(URL,Response);
  1844. finally
  1845. Free;
  1846. end;
  1847. end;
  1848.  
  1849. class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string;
  1850. const LocalFileName: String);
  1851.  
  1852. begin
  1853. With Self.Create(nil) do
  1854. try
  1855. KeepConnection := False;
  1856. Options(URL,LocalFileName);
  1857. finally
  1858. Free;
  1859. end;
  1860. end;
  1861.  
  1862. class function TFPCustomHTTPClient.SimpleOptions(const URL: string): String;
  1863.  
  1864. begin
  1865. With Self.Create(nil) do
  1866. try
  1867. KeepConnection := False;
  1868. Result:=Options(URL);
  1869. finally
  1870. Free;
  1871. end;
  1872. end;
  1873.  
  1874. class procedure TFPCustomHTTPClient.Head(AURL: String; Headers: TStrings);
  1875. begin
  1876. With Self.Create(nil) do
  1877. try
  1878. KeepConnection := False;
  1879. HTTPMethod('HEAD', AURL, Nil, [200]);
  1880. Headers.Assign(ResponseHeaders);
  1881. Finally
  1882. Free;
  1883. end;
  1884. end;
  1885.  
  1886. procedure TFPCustomHTTPClient.FormPost(const URL, FormData: string;
  1887. const Response: TStream);
  1888.  
  1889. begin
  1890. RequestBody:=TStringStream.Create(FormData);
  1891. try
  1892. AddHeader('Content-Type','application/x-www-form-urlencoded');
  1893. Post(URL,Response);
  1894. finally
  1895. RequestBody.Free;
  1896. RequestBody:=Nil;
  1897. end;
  1898. end;
  1899.  
  1900. procedure TFPCustomHTTPClient.FormPost(const URL: string; FormData: TStrings;
  1901. const Response: TStream);
  1902.  
  1903. Var
  1904. I : Integer;
  1905. S,N,V : String;
  1906.  
  1907. begin
  1908. S:='';
  1909. For I:=0 to FormData.Count-1 do
  1910. begin
  1911. If (S<>'') then
  1912. S:=S+'&';
  1913. FormData.GetNameValue(i,n,v);
  1914. S:=S+EncodeURLElement(N)+'='+EncodeURLElement(V);
  1915. end;
  1916. FormPost(URL,S,Response);
  1917. end;
  1918.  
  1919. procedure TFPCustomHTTPClient.FormPost(const URL, FormData: string;
  1920. const Response: TStrings);
  1921. begin
  1922. Response.Text:=FormPost(URL,FormData);
  1923. end;
  1924.  
  1925. procedure TFPCustomHTTPClient.FormPost(const URL: string; FormData: TStrings;
  1926. const Response: TStrings);
  1927. begin
  1928. Response.Text:=FormPost(URL,FormData);
  1929. end;
  1930.  
  1931. function TFPCustomHTTPClient.FormPost(const URL, FormData: string): String;
  1932. Var
  1933. SS : TStringStream;
  1934. begin
  1935. SS:=TStringStream.Create('');
  1936. try
  1937. FormPost(URL,FormData,SS);
  1938. Result:=SS.Datastring;
  1939. finally
  1940. SS.Free;
  1941. end;
  1942. end;
  1943.  
  1944. function TFPCustomHTTPClient.FormPost(const URL: string; FormData: TStrings): String;
  1945. Var
  1946. SS : TStringStream;
  1947. begin
  1948. SS:=TStringStream.Create('');
  1949. try
  1950. FormPost(URL,FormData,SS);
  1951. Result:=SS.Datastring;
  1952. finally
  1953. SS.Free;
  1954. end;
  1955. end;
  1956.  
  1957. class procedure TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string;
  1958. const Response: TStream);
  1959.  
  1960. begin
  1961. With Self.Create(nil) do
  1962. try
  1963. KeepConnection := False;
  1964. FormPost(URL,FormData,Response);
  1965. Finally
  1966. Free;
  1967. end;
  1968. end;
  1969.  
  1970.  
  1971. class procedure TFPCustomHTTPClient.SimpleFormPost(const URL: string;
  1972. FormData: TStrings; const Response: TStream);
  1973.  
  1974. begin
  1975. With Self.Create(nil) do
  1976. try
  1977. KeepConnection := False;
  1978. FormPost(URL,FormData,Response);
  1979. Finally
  1980. Free;
  1981. end;
  1982. end;
  1983.  
  1984.  
  1985. class procedure TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string;
  1986. const Response: TStrings);
  1987.  
  1988. begin
  1989. With Self.Create(nil) do
  1990. try
  1991. KeepConnection := False;
  1992. FormPost(URL,FormData,Response);
  1993. Finally
  1994. Free;
  1995. end;
  1996. end;
  1997.  
  1998. class procedure TFPCustomHTTPClient.SimpleFormPost(const URL: string;
  1999. FormData: TStrings; const Response: TStrings);
  2000.  
  2001. begin
  2002. With Self.Create(nil) do
  2003. try
  2004. KeepConnection := False;
  2005. FormPost(URL,FormData,Response);
  2006. Finally
  2007. Free;
  2008. end;
  2009. end;
  2010.  
  2011. class function TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string
  2012. ): String;
  2013.  
  2014. begin
  2015. With Self.Create(nil) do
  2016. try
  2017. KeepConnection := False;
  2018. Result:=FormPost(URL,FormData);
  2019. Finally
  2020. Free;
  2021. end;
  2022. end;
  2023.  
  2024. class function TFPCustomHTTPClient.SimpleFormPost(const URL: string;
  2025. FormData: TStrings): String;
  2026.  
  2027. begin
  2028. With Self.Create(nil) do
  2029. try
  2030. KeepConnection := False;
  2031. Result:=FormPost(URL,FormData);
  2032. Finally
  2033. Free;
  2034. end;
  2035. end;
  2036.  
  2037.  
  2038. procedure TFPCustomHTTPClient.FileFormPost(const AURL, AFieldName,
  2039. AFileName: string; const Response: TStream);
  2040. begin
  2041. FileFormPost(AURL, nil, AFieldName, AFileName, Response);
  2042. end;
  2043.  
  2044. procedure TFPCustomHTTPClient.FileFormPost(const AURL: string;
  2045. FormData: TStrings; AFieldName, AFileName: string; const Response: TStream);
  2046. var
  2047. F: TFileStream;
  2048. begin
  2049. F:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite);
  2050. try
  2051. StreamFormPost(AURL, FormData, AFieldName, ExtractFileName(AFileName), F, Response);
  2052. finally
  2053. F.Free;
  2054. end;
  2055. end;
  2056.  
  2057. procedure TFPCustomHTTPClient.StreamFormPost(const AURL, AFieldName,
  2058. AFileName: string; const AStream: TStream; const Response: TStream);
  2059. begin
  2060. StreamFormPost(AURL, nil, AFieldName, AFileName, AStream, Response);
  2061. end;
  2062.  
  2063. procedure TFPCustomHTTPClient.StreamFormPost(const AURL: string;
  2064. FormData: TStrings; const AFieldName, AFileName: string;
  2065. const AStream: TStream; const Response: TStream);
  2066. Var
  2067. S, Sep : string;
  2068. SS : TStringStream;
  2069. I: Integer;
  2070. N,V: String;
  2071. begin
  2072. Sep:=Format('%.8x_multipart_boundary',[Random($ffffff)]);
  2073. AddHeader('Content-Type','multipart/form-data; boundary='+Sep);
  2074. SS:=TStringStream.Create('');
  2075. try
  2076. if (FormData<>Nil) then
  2077. for I:=0 to FormData.Count -1 do
  2078. begin
  2079. // not url encoded
  2080. FormData.GetNameValue(I,N,V);
  2081. S :='--'+Sep+CRLF;
  2082. S:=S+Format('Content-Disposition: form-data; name="%s"'+CRLF+CRLF+'%s'+CRLF,[N, V]);
  2083. SS.WriteBuffer(S[1],Length(S));
  2084. end;
  2085. S:='--'+Sep+CRLF;
  2086. s:=s+Format('Content-Disposition: form-data; name="%s"; filename="%s"'+CRLF,[AFieldName,ExtractFileName(AFileName)]);
  2087. s:=s+'Content-Type: application/octet-string'+CRLF+CRLF;
  2088. SS.WriteBuffer(S[1],Length(S));
  2089. AStream.Seek(0, soFromBeginning);
  2090. SS.CopyFrom(AStream,AStream.Size);
  2091. S:=CRLF+'--'+Sep+'--'+CRLF;
  2092. SS.WriteBuffer(S[1],Length(S));
  2093. SS.Position:=0;
  2094. RequestBody:=SS;
  2095. Post(AURL,Response);
  2096. finally
  2097. RequestBody:=Nil;
  2098. SS.Free;
  2099. end;
  2100. end;
  2101.  
  2102.  
  2103. class procedure TFPCustomHTTPClient.SimpleFileFormPost(const AURL, AFieldName,
  2104. AFileName: string; const Response: TStream);
  2105.  
  2106. begin
  2107. With Self.Create(nil) do
  2108. try
  2109. KeepConnection := False;
  2110. FileFormPost(AURL,AFieldName,AFileName,Response);
  2111. Finally
  2112. Free;
  2113. end;
  2114. end;
  2115.  
  2116. end.
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!