1 (*
2 * Licensed to the Apache Software Foundation (ASF) under one
3 * or more contributor license agreements. See the NOTICE file
4 * distributed with this work for additional information
5 * regarding copyright ownership. The ASF licenses this file
6 * to you under the Apache License, Version 2.0 (the
7 * "License"); you may not use this file except in compliance
8 * with the License. You may obtain a copy of the License at
9 *
10 * http://www.apache.org/licenses/LICENSE-2.0
11 *
12 * Unless required by applicable law or agreed to in writing,
13 * software distributed under the License is distributed on an
14 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
15 * KIND, either express or implied. See the License for the
16 * specific language governing permissions and limitations
17 * under the License.
18 *)
19 unit Thrift.Transport.MsxmlHTTP;
20
21 {$I Thrift.Defines.inc}
22 {$SCOPEDENUMS ON}
23
24 interface
25
26 uses
27 Classes,
28 SysUtils,
29 Math,
30 Generics.Collections,
31 {$IFDEF OLD_UNIT_NAMES}
32 ActiveX, msxml,
33 {$ELSE}
34 Winapi.ActiveX, Winapi.msxml,
35 {$ENDIF}
36 Thrift.Collections,
37 Thrift.Configuration,
38 Thrift.Transport,
39 Thrift.Exception,
40 Thrift.Utils,
41 Thrift.Stream;
42
43 type
44 TMsxmlHTTPClientImpl = class( TEndpointTransportBase, IHTTPClient)
45 strict private
46 FUri : string;
47 FInputStream : IThriftStream;
48 FOutputStream : IThriftStream;
49 FDnsResolveTimeout : Integer;
50 FConnectionTimeout : Integer;
51 FSendTimeout : Integer;
52 FReadTimeout : Integer;
53 FCustomHeaders : IThriftDictionary<string,string>;
54
CreateRequestnull55 function CreateRequest: IXMLHTTPRequest;
56 strict protected
GetIsOpennull57 function GetIsOpen: Boolean; override;
58 procedure Open(); override;
59 procedure Close(); override;
Readnull60 function Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; override;
61 procedure Write( const pBuf : Pointer; off, len : Integer); override;
62 procedure Flush; override;
63
64 procedure SetDnsResolveTimeout(const Value: Integer);
GetDnsResolveTimeoutnull65 function GetDnsResolveTimeout: Integer;
66 procedure SetConnectionTimeout(const Value: Integer);
GetConnectionTimeoutnull67 function GetConnectionTimeout: Integer;
68 procedure SetSendTimeout(const Value: Integer);
GetSendTimeoutnull69 function GetSendTimeout: Integer;
70 procedure SetReadTimeout(const Value: Integer);
GetReadTimeoutnull71 function GetReadTimeout: Integer;
GetSecureProtocolsnull72 function GetSecureProtocols : TSecureProtocols;
73 procedure SetSecureProtocols( const value : TSecureProtocols);
74
GetCustomHeadersnull75 function GetCustomHeaders: IThriftDictionary<string,string>;
76 procedure SendRequest;
77
78 property DnsResolveTimeout: Integer read GetDnsResolveTimeout write SetDnsResolveTimeout;
79 property ConnectionTimeout: Integer read GetConnectionTimeout write SetConnectionTimeout;
80 property SendTimeout: Integer read GetSendTimeout write SetSendTimeout;
81 property ReadTimeout: Integer read GetReadTimeout write SetReadTimeout;
82 property CustomHeaders: IThriftDictionary<string,string> read GetCustomHeaders;
83 public
84 constructor Create( const aUri: string; const aConfig : IThriftConfiguration); reintroduce;
85 destructor Destroy; override;
86 end;
87
88
89 implementation
90
91 const
92 XMLHTTP_CONNECTION_TIMEOUT = 60 * 1000;
93 XMLHTTP_SENDRECV_TIMEOUT = 30 * 1000;
94
95 { TMsxmlHTTPClientImpl }
96
97 constructor TMsxmlHTTPClientImpl.Create( const aUri: string; const aConfig : IThriftConfiguration);
98 begin
99 inherited Create( aConfig);
100 FUri := aUri;
101
102 // defaults according to MSDN
103 FDnsResolveTimeout := 0; // no timeout
104 FConnectionTimeout := XMLHTTP_CONNECTION_TIMEOUT;
105 FSendTimeout := XMLHTTP_SENDRECV_TIMEOUT;
106 FReadTimeout := XMLHTTP_SENDRECV_TIMEOUT;
107
108 FCustomHeaders := TThriftDictionaryImpl<string,string>.Create;
109 FOutputStream := TThriftStreamAdapterDelphi.Create( TMemoryStream.Create, True);
110 end;
111
CreateRequestnull112 function TMsxmlHTTPClientImpl.CreateRequest: IXMLHTTPRequest;
113 var
114 pair : TPair<string,string>;
115 srvHttp : IServerXMLHTTPRequest;
116 begin
117 {$IF CompilerVersion >= 21.0}
118 Result := CoServerXMLHTTP.Create;
119 {$ELSE}
120 Result := CoXMLHTTPRequest.Create;
121 {$IFEND}
122
123 // setting a timeout value to 0 (zero) means "no timeout" for that setting
124 if Supports( result, IServerXMLHTTPRequest, srvHttp)
125 then srvHttp.setTimeouts( DnsResolveTimeout, ConnectionTimeout, SendTimeout, ReadTimeout);
126
127 Result.open('POST', FUri, False, '', '');
128 Result.setRequestHeader( 'Content-Type', THRIFT_MIMETYPE);
129 Result.setRequestHeader( 'Accept', THRIFT_MIMETYPE);
130 Result.setRequestHeader( 'User-Agent', 'Delphi/IHTTPClient');
131
132 for pair in FCustomHeaders do begin
133 Result.setRequestHeader( pair.Key, pair.Value );
134 end;
135 end;
136
137 destructor TMsxmlHTTPClientImpl.Destroy;
138 begin
139 Close;
140 inherited;
141 end;
142
GetDnsResolveTimeoutnull143 function TMsxmlHTTPClientImpl.GetDnsResolveTimeout: Integer;
144 begin
145 Result := FDnsResolveTimeout;
146 end;
147
148 procedure TMsxmlHTTPClientImpl.SetDnsResolveTimeout(const Value: Integer);
149 begin
150 FDnsResolveTimeout := Value;
151 end;
152
TMsxmlHTTPClientImpl.GetConnectionTimeoutnull153 function TMsxmlHTTPClientImpl.GetConnectionTimeout: Integer;
154 begin
155 Result := FConnectionTimeout;
156 end;
157
158 procedure TMsxmlHTTPClientImpl.SetConnectionTimeout(const Value: Integer);
159 begin
160 FConnectionTimeout := Value;
161 end;
162
TMsxmlHTTPClientImpl.GetSendTimeoutnull163 function TMsxmlHTTPClientImpl.GetSendTimeout: Integer;
164 begin
165 Result := FSendTimeout;
166 end;
167
168 procedure TMsxmlHTTPClientImpl.SetSendTimeout(const Value: Integer);
169 begin
170 FSendTimeout := Value;
171 end;
172
TMsxmlHTTPClientImpl.GetReadTimeoutnull173 function TMsxmlHTTPClientImpl.GetReadTimeout: Integer;
174 begin
175 Result := FReadTimeout;
176 end;
177
178 procedure TMsxmlHTTPClientImpl.SetReadTimeout(const Value: Integer);
179 begin
180 FReadTimeout := Value;
181 end;
182
GetSecureProtocolsnull183 function TMsxmlHTTPClientImpl.GetSecureProtocols : TSecureProtocols;
184 begin
185 Result := [];
186 end;
187
188 procedure TMsxmlHTTPClientImpl.SetSecureProtocols( const value : TSecureProtocols);
189 begin
190 raise TTransportExceptionBadArgs.Create('SetSecureProtocols: Not supported with '+ClassName);
191 end;
192
GetCustomHeadersnull193 function TMsxmlHTTPClientImpl.GetCustomHeaders: IThriftDictionary<string,string>;
194 begin
195 Result := FCustomHeaders;
196 end;
197
GetIsOpennull198 function TMsxmlHTTPClientImpl.GetIsOpen: Boolean;
199 begin
200 Result := True;
201 end;
202
203 procedure TMsxmlHTTPClientImpl.Open;
204 begin
205 FOutputStream := TThriftStreamAdapterDelphi.Create( TMemoryStream.Create, True);
206 end;
207
208 procedure TMsxmlHTTPClientImpl.Close;
209 begin
210 FInputStream := nil;
211 FOutputStream := nil;
212 end;
213
214 procedure TMsxmlHTTPClientImpl.Flush;
215 begin
216 try
217 SendRequest;
218 finally
219 FOutputStream := nil;
220 FOutputStream := TThriftStreamAdapterDelphi.Create( TMemoryStream.Create, True);
221 ASSERT( FOutputStream <> nil);
222 end;
223 end;
224
Readnull225 function TMsxmlHTTPClientImpl.Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer;
226 begin
227 if FInputStream = nil then begin
228 raise TTransportExceptionNotOpen.Create('No request has been sent');
229 end;
230
231 try
232 Result := FInputStream.Read( pBuf, buflen, off, len);
233 except
234 on E: Exception
235 do raise TTransportExceptionUnknown.Create(E.Message);
236 end;
237 end;
238
239 procedure TMsxmlHTTPClientImpl.SendRequest;
240 var
241 xmlhttp : IXMLHTTPRequest;
242 ms : TMemoryStream;
243 a : TBytes;
244 len : Integer;
245 begin
246 xmlhttp := CreateRequest;
247
248 ms := TMemoryStream.Create;
249 try
250 a := FOutputStream.ToArray;
251 len := Length(a);
252 if len > 0 then begin
253 ms.WriteBuffer( Pointer(@a[0])^, len);
254 end;
255 ms.Position := 0;
256 xmlhttp.send( IUnknown( TStreamAdapter.Create( ms, soReference )));
257 FInputStream := nil;
258 FInputStream := TThriftStreamAdapterCOM.Create( IUnknown( xmlhttp.responseStream) as IStream);
259 UpdateKnownMessageSize( FInputStream.Size);
260 finally
261 ms.Free;
262 end;
263 end;
264
265 procedure TMsxmlHTTPClientImpl.Write( const pBuf : Pointer; off, len : Integer);
266 begin
267 FOutputStream.Write( pBuf, off, len);
268 end;
269
270
271
272 end.
273
274