1 unit LNetHTTPDataProvider;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Forms, Classes, SysUtils, IpHtml, IpMsg, IpUtils, lnetcomponents, Graphics, lhttp, lnet;
9
10 type
11
12 TIpHTTPDataProvider = class;
13
14 TGettingURLCB = procedure(AProvider: TIpHTTPDataProvider; AURL: String) of object;
15
16 { TIpHTTPDataProvider }
17
18 TIpHTTPDataProvider = class(TIpAbstractHtmlDataProvider)
19 private
20 fLastType: String;
21 fCachedStreams: TStringList;
22 fCachedEmbeddedObjects: TStringList;
23 procedure AddObjectToCache(ACache: TStringList; AURL: String; AStream: TStream);
24 procedure ClearCache;
25 procedure ClearCachedObjects;
GetCachedURLnull26 function GetCachedURL(AURL: String): TStream;
GetCachedObjectnull27 function GetCachedObject(AURL: String): TStream;
28 procedure HttpError(const msg: string; aSocket: TLSocket);
HttpInputnull29 function HttpInput(ASocket: TLHTTPClientSocket; ABuffer: pchar; ASize: LongInt): LongInt;
30 procedure HttpInputDone(ASocket: TLHTTPClientSocket);
31 procedure HttpProcessHeader(ASocket: TLHTTPClientSocket);
32 procedure HttpCanWrite(ASocket: TLHTTPClientSocket; var OutputEof: TWriteBlockStatus);
33 procedure HttpDisconnect(aSocket: TLSocket);
34
GetURLnull35 function GetURL(const AURL: String; JustHeader: Boolean = False): TStream;
GetHostAndURInull36 function GetHostAndURI(const fURL: String; var AHost: String; var AURI: String): Boolean;
37 protected
DoGetHtmlStreamnull38 function DoGetHtmlStream(const URL: string;
39 PostData: TIpFormDataEntity) : TStream; override;
DoCheckURLnull40 function DoCheckURL(const URL: string;
41 var ContentType: string): Boolean; override;
42 procedure DoLeave(Html: TIpHtml); override;
43 procedure DoReference(const URL: string); override;
44 procedure DoGetImage(Sender: TIpHtmlNode; const URL: string;
45 var Picture: TPicture); override;
DoGetStreamnull46 function DoGetStream(const URL: string): TStream; override;
CanHandlenull47 function CanHandle(const URL: string): Boolean; override;
BuildURLnull48 function BuildURL(const OldURL, NewURL: string): string; override;
49 public
50 constructor Create(AOwner: TComponent);
51 destructor Destroy; override;
52 end;
53
54 TLHttpClientEx = class(TLHTTPClientComponent)
55 //TLHttpClientEx = class(TLHTTPClient)
56 private
57 Stream: TStream;
58 Waiting: Boolean;
59 HeaderOnly: Boolean;
60 end;
61
62
63 implementation
64
65 uses
66 FPImage,
67 {$IF FPC_FULLVERSION>=20602} //fpreadgif exists since at least this version
68 FPReadgif,
69 {$ENDIF}
70 FPReadbmp,
71 FPReadxpm,
72 FPReadJPEG,
73 FPReadpng,
74 FPWritebmp,
75 IntFGraphics;
76
77 { TIpHTTPDataProvider }
78
79 procedure TIpHTTPDataProvider.AddObjectToCache ( ACache: TStringList;
80 AURL: String; AStream: TStream ) ;
81 var
82 TmpStream: TStream;
83 begin
84 TmpStream := TMemoryStream.Create;
85 AStream.Position := 0;
86 TmpStream.CopyFrom(AStream, AStream.Size);
87 ACache.AddObject(AURL, TmpStream);
88 AStream.Position := 0;
89 end;
90
91 procedure TIpHTTPDataProvider.ClearCache;
92 var
93 i: Integer;
94 begin
95 for i := 0 to fCachedStreams.Count-1 do
96 if fCachedStreams.Objects[i] <> nil then
97 fCachedStreams.Objects[i].Free;
98 fCachedStreams.Clear;
99
100 end;
101
102 procedure TIpHTTPDataProvider.ClearCachedObjects;
103 var
104 i: Integer;
105 begin
106 for i := 0 to fCachedStreams.Count-1 do
107 if fCachedEmbeddedObjects.Objects[i] <> nil then
108 fCachedEmbeddedObjects.Objects[i].Free;
109 fCachedEmbeddedObjects.Clear;
110
111
112 end;
113
GetCachedURLnull114 function TIpHTTPDataProvider.GetCachedURL ( AURL: String ) : TStream;
115 var
116 i: Integer;
117 begin
118 Result := nil;
119 if Trim(AURL) = '' then
120 Exit;
121 for i := 0 to fCachedStreams.Count-1 do
122 if fCachedStreams.Strings[i] = AURL then
123 begin
124 if fCachedStreams.Objects[i] = nil then break;
125 Result := TMemoryStream.Create;
126 TStream(fCachedStreams.Objects[i]).Position := 0;
127 Result.CopyFrom(TStream(fCachedStreams.Objects[i]), TStream(fCachedStreams.Objects[i]).Size);
128 Result.Position := 0;
129 break;
130 end;
131 //WriteLn(AURL,' in cache = ', Result <> nil);
132 if Result = nil then
133 Result := GetCachedObject(AURL);
134
135 end;
136
GetCachedObjectnull137 function TIpHTTPDataProvider.GetCachedObject ( AURL: String ) : TStream;
138 var
139 i: Integer;
140 begin
141 Result := nil;
142 if Trim(AURL) = '' then
143 Exit;
144 for i := 0 to fCachedEmbeddedObjects.Count-1 do
145 if fCachedEmbeddedObjects.Strings[i] = AURL then
146 begin
147 if fCachedEmbeddedObjects.Objects[i] = nil then break;
148 Result := TMemoryStream.Create;
149 TStream(fCachedEmbeddedObjects.Objects[i]).Position := 0;
150 Result.CopyFrom(TStream(fCachedEmbeddedObjects.Objects[i]), TStream(fCachedEmbeddedObjects.Objects[i]).Size);
151 Result.Position := 0;
152 break;
153 end;
154 //WriteLn(AURL,' in cached objects = ', Result <> nil);
155
156 end;
157
158 procedure TIpHTTPDataProvider.HttpError(const msg: string; aSocket: TLSocket);
159 begin
160 TLHttpClientEx(ASocket.Creator).Waiting := False;
161 //writeLn('Error occured: ', msg);
162
163 end;
164
HttpInputnull165 function TIpHTTPDataProvider.HttpInput(ASocket: TLHTTPClientSocket;
166 ABuffer: pchar; ASize: LongInt): LongInt;
167 begin
168 //WriteLN(ASocket.Creator.ClassName);
169 if TLHttpClientEx(ASocket.Creator).Stream = nil then
170 TLHttpClientEx(ASocket.Creator).Stream := TMemoryStream.Create;
171 Result := TLHttpClientEx(ASocket.Creator).Stream.Write(ABuffer^, ASize);
172
173
174 end;
175
176 procedure TIpHTTPDataProvider.HttpInputDone(ASocket: TLHTTPClientSocket);
177 begin
178 TLHttpClientEx(ASocket.Creator).Waiting := False;
179 aSocket.Disconnect;
180 //WriteLn('InputDone');
181 end;
182
183 procedure TIpHTTPDataProvider.HttpProcessHeader(ASocket: TLHTTPClientSocket);
184 var
185 i: TLHTTPParameter;
186 begin
187 //WriteLn('Process Header');
188 //for i := Low(TLHTTPParameterArray) to High(TLHTTPParameterArray) do
189 // if ASocket.Parameters[i] <> '' then
190 // WriteLn(ASocket.Parameters[i]);
191 //WriteLn(ASocket.Parameters[hpContentType]);
192 fLastType := ASocket.Parameters[hpContentType];
193 if TLHttpClientEx(ASocket.Creator).HeaderOnly then
194 TLHttpClientEx(ASocket.Creator).Waiting := False;
195 end;
196
197 procedure TIpHTTPDataProvider.HttpCanWrite(ASocket: TLHTTPClientSocket;
198 var OutputEof: TWriteBlockStatus);
199 begin
200 //WriteLn('OnCanWrite');
201 end;
202
203 procedure TIpHTTPDataProvider.HttpDisconnect(aSocket: TLSocket);
204 begin
205 TLHttpClientEx(ASocket.Creator).Waiting := False;
206 //WriteLn('Disconnected');
207 end;
208
209
TIpHTTPDataProvider.GetURLnull210 function TIpHTTPDataProvider.GetURL(const AURL: String; JustHeader: Boolean = False): TStream;
211 var
212 fHost, fURI: String;
213 fHttpClient: TLHttpClientEx;
214 begin
215 Result := nil;
216
217 if JustHeader = False then
218 Result := GetCachedURL(AURL);
219 //WriteLN('Getting: ', AURL);
220 if Result = nil then
221 begin
222 if not GetHostAndURI(AURL, fHost, fURI) then Exit(nil);
223 //WriteLn('Result := True');
224 fHttpClient := TLHttpClientEx.Create(Owner);
225 fHttpClient.OnInput := @HttpInput;
226 fHttpClient.OnError := @HttpError;
227 fHttpClient.OnDoneInput := @HttpInputDone;
228 fHttpClient.OnProcessHeaders := @HttpProcessHeader;
229 fHttpClient.OnCanWrite := @HttpCanWrite;
230 fHttpClient.OnDisconnect := @HttpDisconnect;
231
232 fHttpClient.Host := fHost;
233 fHttpClient.Port := 80;
234 fHttpClient.HeaderOnly := JustHeader;
235 if JustHeader then
236 fHttpClient.Method := hmHead
237 else
238 fHttpClient.Method := hmGet;
239 fHttpClient.URI := fURI;
240
241 fHttpClient.SendRequest;
242 //WriteLn('Sending Request');
243
244 fHttpClient.Waiting := True;
245 {while fHttpClient.Waiting = True do
246 begin
247 fHttpClient.CallAction;
248 Sleep(1);
249 end;}
250
251 while fHttpClient.Waiting do begin
252 //WriteLn('InFirstLoop');
253 Application.HandleMessage;
254 if csDestroying in ComponentState then Exit;
255 end;
256 //WriteLn('LeftLoop');
257
258 Result:= fHttpClient.Stream;
259 if Result <> nil then
260 Result.Position := 0;
261 //fDataStream.SaveToFile('temp.txt');
262 //Application.Terminate;
263 fHttpClient.Free;
264 end;
265 end;
266
GetHostAndURInull267 function TIpHTTPDataProvider.GetHostAndURI(const fURL: String; var AHost: String; var AURI: String): Boolean;
268 var
269 fPos: Integer;
270 begin
271 fPos := Pos('://', fUrl);
272 if fPos = 0 then Exit(False);
273 Result := True;
274 AHost := Copy(fURL, fPos+3, Length(fURL));
275
276
277 fPos := Pos('/', AHost);
278 if fPos = 0 then begin
279 AURI:='/';
280 Exit(True);
281 end;
282 AURI := Copy(AHost, fPos, Length(AHost));
283 AHost := Copy(AHost, 1, fPos-1);
284 //WriteLn('Got Host: ',AHost);
285 //WriteLn('Got URI : ',AURI);
286 end;
287
DoGetHtmlStreamnull288 function TIpHTTPDataProvider.DoGetHtmlStream(const URL: string;
289 PostData: TIpFormDataEntity): TStream;
290 begin
291 Result := GetCachedURL(URL);
292 if Result = nil then
293 begin
294 Result := GetURL(URL);
295 if Result <> nil then
296 AddObjectToCache(fCachedStreams, URL, Result);
297 end;
298 end;
299
TIpHTTPDataProvider.DoCheckURLnull300 function TIpHTTPDataProvider.DoCheckURL(const URL: string;
301 var ContentType: string): Boolean;
302 var
303 TmpStream: TStream;
304 begin
305 //WriteLn('Want content type: "', ContentType,'" for Url:',URL);
306 Result := True;
307 //TmpStream := GetCachedURL(URL);
308 //if TmpStream = nil then
309 //begin
310 TmpStream := GetURL(URL, True);
311 // if TmpStream <> nil then
312 // AddObjectToCache(fCachedStreams, URL, TmpStream);
313 //end;
314
315 if TmpStream <> nil then FreeAndNil(TmpStream);
316 ContentType := fLastType;//}'text/html';
317 end;
318
319 procedure TIpHTTPDataProvider.DoLeave(Html: TIpHtml);
320 begin
321 ClearCache;
322 end;
323
324 procedure TIpHTTPDataProvider.DoReference(const URL: string);
325 begin
326
327 end;
328
329 procedure TIpHTTPDataProvider.DoGetImage(Sender: TIpHtmlNode;
330 const URL: string; var Picture: TPicture);
331 var
332 Stream: TStream;
333 FileExt: String;
334 begin
335 //DebugLn('Getting Image ',(Url));
336 Picture := nil;
337
338 FileExt := ExtractFileExt(URL);
339
340 Picture := TPicture.Create;
341 try
342 Stream := GetCachedObject(URL);
343 if Stream = nil then
344 begin
345 Stream := GetURL(URL);
346 if Stream <> nil then
347 AddObjectToCache(fCachedEmbeddedObjects, URL, Stream);
348 end;
349
350 if Assigned(Stream) then
351 begin
352 Stream.Position := 0;
353 Picture.LoadFromStreamWithFileExt(Stream, FileExt);
354 end
355 else
356 Picture.Graphic := TBitmap.Create;
357 except
358 try
359 Picture.Free;
360 finally
361 Picture := TPicture.Create;
362 Picture.Graphic := TBitmap.Create;
363 end;
364 end;
365 Stream.Free;
366 end;
367
DoGetStreamnull368 function TIpHTTPDataProvider.DoGetStream ( const URL: string ) : TStream;
369 begin
370 Result := GetCachedObject(URL);
371 if Result = nil then
372 begin
373 Result := GetURL(URL);
374 if Result <> nil then
375 AddObjectToCache(fCachedEmbeddedObjects, URL, Result);
376 end;
377 end;
378
CanHandlenull379 function TIpHTTPDataProvider.CanHandle(const URL: string): Boolean;
380 begin
381 //WriteLn('Can Handle: ', URL);
382 Result := True;
383 end;
384
BuildURLnull385 function TIpHTTPDataProvider.BuildURL(const OldURL, NewURL: string): string;
386 begin
387 Result := Iputils.BuildURL(OldURL, NewURL);
388 end;
389
390 constructor TIpHTTPDataProvider.Create(AOwner: TComponent);
391 begin
392 inherited Create(AOwner);
393 fCachedEmbeddedObjects := TStringList.Create;
394 fCachedStreams := TStringList.Create;
395 end;
396
397 destructor TIpHTTPDataProvider.Destroy;
398 begin
399 ClearCache;
400 ClearCachedObjects;
401 fCachedStreams.Free;
402 fCachedEmbeddedObjects.Free;
403 inherited Destroy;
404 end;
405
406 end.
407
408