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 |
|
---|
8 | unit uos_httpgetthread;
|
---|
9 |
|
---|
10 | {$mode objfpc}{$H+}
|
---|
11 |
|
---|
12 | interface
|
---|
13 |
|
---|
14 | uses
|
---|
15 | Classes, SysUtils, Pipes;
|
---|
16 |
|
---|
17 | type
|
---|
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 }
|
---|
46 | function 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 |
|
---|
58 | implementation
|
---|
59 |
|
---|
60 | uses
|
---|
61 | fphttpclient, openssl, opensslsockets;
|
---|
62 |
|
---|
63 | { Check URL status with detailed error codes }
|
---|
64 | function CheckURLStatus(const URL: string): Integer;
|
---|
65 | var
|
---|
66 | Http: TFPHTTPClient;
|
---|
67 | begin
|
---|
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;
|
---|
117 | end;
|
---|
118 |
|
---|
119 | { TThreadHttpGetter }
|
---|
120 |
|
---|
121 | function TThreadHttpGetter.GetRedirectURL(AResponseStrings: TStrings): string;
|
---|
122 | var
|
---|
123 | S: string;
|
---|
124 | F: integer;
|
---|
125 | Search: string = 'location:';
|
---|
126 | begin
|
---|
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;
|
---|
137 | end;
|
---|
138 |
|
---|
139 | procedure TThreadHttpGetter.DoIcyMetaInt;
|
---|
140 | begin
|
---|
141 | if Assigned(FOnIcyMetaInt) then
|
---|
142 | FOnIcyMetaInt(Self);
|
---|
143 | end;
|
---|
144 |
|
---|
145 | procedure TThreadHttpGetter.Headers(Sender: TObject);
|
---|
146 | begin
|
---|
147 | FIcyMetaInt := StrToInt64Def(TFPHTTPClient(Sender).GetHeader(TFPHTTPClient(Sender).ResponseHeaders, 'icy-metaint'), 0);
|
---|
148 | if (FIcyMetaInt > 0) and (FOnIcyMetaInt <> nil) then
|
---|
149 | Synchronize(@DoIcyMetaInt);
|
---|
150 | end;
|
---|
151 |
|
---|
152 | procedure TThreadHttpGetter.Execute;
|
---|
153 | var
|
---|
154 | Http: TFPHTTPClient;
|
---|
155 | SL: TStringList;
|
---|
156 | URL: string;
|
---|
157 | begin
|
---|
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;
|
---|
305 | end;
|
---|
306 |
|
---|
307 | constructor TThreadHttpGetter.Create(AWantedURL: string; AOutputStream: TOutputPipeStream);
|
---|
308 | begin
|
---|
309 | inherited Create(True);
|
---|
310 | ICYenabled := False;
|
---|
311 | FIsRunning := True;
|
---|
312 | FWantedURL := AWantedURL;
|
---|
313 | FOutStream := AOutputStream;
|
---|
314 | end;
|
---|
315 |
|
---|
316 | end.
|
---|