source: trunk/Packages/uos/uos_httpgetthread.pas

Last change on this file was 664, checked in by chronos, 3 days ago
  • Added: Ability to play music in background in start screen and in-game. Used uos as audio library.
File size: 8.9 KB
Line 
1{This unit is part of United Openlibraries of Sound (uos)}
2
3{ This is HTTP Thread Getter
4 created by Andrew Haines -> andrewd207@aol.com
5 License: modified LGPL.
6 Fred van Stappen / fiens@hotmail.com}
7
8unit uos_httpgetthread;
9
10{$mode objfpc}{$H+}
11
12interface
13
14uses
15 Classes, SysUtils, Pipes;
16
17type
18 { TThreadHttpGetter }
19 TThreadHttpGetter = class(TThread)
20 private
21 FOutStream: TOutputPipeStream;
22 FWantedURL: string;
23 FIcyMetaInt: int64; // ICY metadata interval (bytes)
24 FOnIcyMetaInt: TNotifyEvent;
25 procedure DoIcyMetaInt;
26 function GetRedirectURL(AResponseStrings: TStrings): string;
27 procedure Headers(Sender: TObject);
28 protected
29 procedure Execute; override;
30 public
31 FIsRunning: Boolean;
32 ICYenabled: Boolean;
33 FormatType: integer; // 0: mp3, 1: opus, 2: aac
34 ContentType: string;
35 ice_audio_info: string; // channels=2;samplerate=44100;bitrate=128
36 icy_description: string;
37 icy_genre: string;
38 icy_name: string;
39 icy_url: string;
40 property IcyMetaInt: int64 read FIcyMetaInt;
41 property IsRunning: Boolean read FIsRunning;
42 constructor Create(AWantedURL: string; AOutputStream: TOutputPipeStream);
43 end;
44
45{ Function to check URL status with detailed error codes }
46function CheckURLStatus(const URL: string): Integer;
47{ Returns:
48 0: URL is accessible (200, 204, etc.)
49 1: Invalid URL format
50 2: Connection timeout
51 3: DNS resolution failure
52 4: Redirect loop or failure
53 5: Other network error (e.g., SSL, protocol error)
54 301, 302, 303, 307, 308: HTTP redirect status
55 400+: HTTP server error (e.g., 404, 500, 403)
56}
57
58implementation
59
60uses
61 fphttpclient, openssl, opensslsockets;
62
63{ Check URL status with detailed error codes }
64function CheckURLStatus(const URL: string): Integer;
65var
66 Http: TFPHTTPClient;
67begin
68 // Check for invalid URL format
69 if (URL = '') or (Pos('http', LowerCase(URL)) <> 1) then
70 Exit(1); // Invalid URL format
71
72 Http := TFPHTTPClient.Create(nil);
73 try
74 Http.AllowRedirect := True;
75 Http.MaxRedirects := 5; // Prevent infinite redirect loops
76 Http.IOTimeout := 5000; // 5-second timeout
77 Http.ConnectTimeout := 5000;
78 Http.RequestHeaders.Clear;
79 try
80 Http.HTTPMethod('HEAD', URL, nil, [200, 204, 301, 302, 303, 307, 308]);
81 Result := Http.ResponseStatusCode; // Return exact success status (e.g., 200, 204)
82 //writeln('Http.ResponseStatusCode ', result);
83 case Http.ResponseStatusCode of 200, 204, 301, 302, 303, 307, 308, 400:
84 result := 0;
85 end;
86 except
87 on E: EHTTPClient do
88 begin
89 //writeln('error Http.ResponseStatusCode ', result);
90
91 case Http.ResponseStatusCode of 301, 302, 303, 307, 308:
92 Result := Http.ResponseStatusCode;
93 end;
94
95 if Http.ResponseStatusCode = 400 then
96 Result := 0
97 else if Http.ResponseStatusCode > 400 then
98 Result := Http.ResponseStatusCode // Return server error (e.g., 404, 500)
99 else if Pos('redirect', LowerCase(E.Message)) > 0 then
100 Result := 4 // Redirect loop or failure
101 else
102 Result := 5; // Other HTTP-related error
103 end;
104 on E: Exception do
105 begin
106 if Pos('timeout', LowerCase(E.Message)) > 0 then
107 Result := 2 // Connection timeout
108 else if (Pos('dns', LowerCase(E.Message)) > 0) or (Pos('host', LowerCase(E.Message)) > 0) then
109 Result := 3 // DNS resolution failure
110 else
111 Result := 5; // Other unexpected error (e.g., SSL, protocol)
112 end;
113 end;
114 finally
115 Http.Free;
116 end;
117end;
118
119{ TThreadHttpGetter }
120
121function TThreadHttpGetter.GetRedirectURL(AResponseStrings: TStrings): string;
122var
123 S: string;
124 F: integer;
125 Search: string = 'location:';
126begin
127 Result := '';
128 for S in AResponseStrings do
129 begin
130 F := Pos(Search, Lowercase(S));
131 if F > 0 then
132 begin
133 Inc(F, Length(Search));
134 Exit(Trim(Copy(S, F, Length(S) - F + 1)));
135 end;
136 end;
137end;
138
139procedure TThreadHttpGetter.DoIcyMetaInt;
140begin
141 if Assigned(FOnIcyMetaInt) then
142 FOnIcyMetaInt(Self);
143end;
144
145procedure TThreadHttpGetter.Headers(Sender: TObject);
146begin
147 FIcyMetaInt := StrToInt64Def(TFPHTTPClient(Sender).GetHeader(TFPHTTPClient(Sender).ResponseHeaders, 'icy-metaint'), 0);
148 if (FIcyMetaInt > 0) and (FOnIcyMetaInt <> nil) then
149 Synchronize(@DoIcyMetaInt);
150end;
151
152procedure TThreadHttpGetter.Execute;
153var
154 Http: TFPHTTPClient;
155 SL: TStringList;
156 URL: string;
157begin
158 URL := FWantedURL;
159 if (URL = '') or (Pos(' ', URL) > 0) then
160 begin
161 FIsRunning := False;
162 Exit;
163 end;
164
165 // Initialize SSL and HTTP client
166 InitSSLInterface;
167 Http := TFPHTTPClient.Create(nil);
168 SL := TStringList.Create;
169 ContentType := '';
170 ice_audio_info := '';
171 icy_description := '';
172 icy_genre := '';
173 icy_name := '';
174 icy_url := '';
175 FormatType := 0;
176
177 try
178 Http.AllowRedirect := True;
179 Http.IOTimeout := 5000;
180 Http.ConnectTimeout := 5000;
181
182 // HEAD request to check headers
183 try
184 Http.RequestHeaders.Clear;
185 Http.KeepConnection := False;
186 Http.HTTPMethod('HEAD', URL, nil, [200, 204, 301, 302, 303, 307, 308]);
187 SL.Assign(Http.ResponseHeaders);
188
189 if SL.Count = 0 then
190 begin
191 // Fallback format detection based on URL
192 if Pos('mpeg', URL) > 0 then FormatType := 1 else
193 if Pos('mp3', URL) > 0 then FormatType := 1 else
194 if Pos('opus', URL) > 0 then FormatType := 2 else
195 if Pos('ogg', URL) > 0 then FormatType := 2 else
196 if Pos('aac', URL) > 0 then FormatType := 3 else
197 FormatType := 2;
198 end
199 else
200 begin
201 ContentType := LowerCase(SL.Values['Content-Type']);
202 ice_audio_info := LowerCase(SL.Values['ice-audio-info']);
203 icy_description := LowerCase(SL.Values['icy-description']);
204 icy_genre := LowerCase(SL.Values['icy-genre']);
205 icy_name := LowerCase(SL.Values['icy-name']);
206 icy_url := LowerCase(SL.Values['icy-url']);
207 end;
208 except
209 on E: Exception do
210 begin
211 // Fallback format detection
212 if Pos('mpeg', URL) > 0 then FormatType := 1 else
213 if Pos('mp3', URL) > 0 then FormatType := 1 else
214 if Pos('opus', URL) > 0 then FormatType := 2 else
215 if Pos('ogg', URL) > 0 then FormatType := 2 else
216 if Pos('aac', URL) > 0 then FormatType := 3 else
217 FormatType := 2;
218 end;
219 end;
220
221 // Determine FormatType based on ContentType or fallback
222 if Length(ContentType) > 0 then
223 begin
224 if Pos('mpeg', ContentType) > 0 then FormatType := 1
225 else if Pos('aac', ContentType) > 0 then FormatType := 3
226 else if Pos('ogg', ContentType) > 0 then FormatType := 2
227 else if Pos('opus', ContentType) > 0 then FormatType := 2
228 else if Pos('opus', icy_name) > 0 then FormatType := 2
229 else if Pos('aac', icy_name) > 0 then FormatType := 3
230 else if Pos('mp3', icy_name) > 0 then FormatType := 1
231 else if Pos('mpeg', URL) > 0 then FormatType := 1
232 else if Pos('mp3', URL) > 0 then FormatType := 1
233 else if Pos('opus', URL) > 0 then FormatType := 2
234 else if Pos('ogg', URL) > 0 then FormatType := 2
235 else if Pos('aac', URL) > 0 then FormatType := 3
236 else FormatType := 2;
237 end;
238
239 if FormatType = 0 then
240 begin
241 FIsRunning := False;
242 Exit;
243 end;
244
245 // GET request to stream data
246 try
247 Http.RequestHeaders.Clear;
248
249 if (ICYenabled = True) and (FormatType = 1) then
250 begin
251 Http.RequestHeaders.Clear;
252 Http.AddHeader('icy-metadata', '1');
253 Http.OnHeaders := @Headers;
254 end;
255
256 // Ensure FOutStream is valid
257 if not Assigned(FOutStream) then
258 begin
259 FIsRunning := False;
260 Exit;
261 end;
262
263 Http.Get(URL, FOutStream);
264 except
265 on E: EHTTPClient do
266 begin
267 if (Http.ResponseStatusCode > 399) or (Http.ResponseStatusCode < 1) then
268 FIsRunning := False
269 else if Http.ResponseStatusCode = 302 then
270 begin
271 URL := GetRedirectURL(Http.ResponseHeaders);
272 if URL <> '' then
273 begin
274 Http.RequestHeaders.Clear;
275 if (ICYenabled = True) and (FormatType = 1) then
276 begin
277 Http.AddHeader('icy-metadata', '1');
278 Http.OnHeaders := @Headers;
279 end;
280 try
281 Http.Get(URL, FOutStream);
282 except
283 on E: Exception do
284 begin
285 FIsRunning := False;
286 end;
287 end;
288 end
289 else
290 FIsRunning := False;
291 end
292 else
293 FIsRunning := False;
294 end;
295 on E: Exception do
296 begin
297 FIsRunning := False;
298 end;
299 end;
300 finally
301 SL.Free;
302 Http.Free;
303 FIsRunning := False;
304 end;
305end;
306
307constructor TThreadHttpGetter.Create(AWantedURL: string; AOutputStream: TOutputPipeStream);
308begin
309 inherited Create(True);
310 ICYenabled := False;
311 FIsRunning := True;
312 FWantedURL := AWantedURL;
313 FOutStream := AOutputStream;
314end;
315
316end.
Note: See TracBrowser for help on using the repository browser.