On 11/12/2012 00:59, Tomas Hajny wrote:
On 10 Dec 12, at 17:52, Tomas Hajny wrote:
On Mon, December 10, 2012 14:24, Ludo Brands wrote:
There should be no C runtime involved when accessing the standard OS/2
API
(which includes both the native BSD sockets and the Winsock
compatibility
layer). Whatever is done when using EMX libc, it must still go through
this OS/2 API in the end. However, I understand that there may be some
socket initialization involved on the EMX libc side (this indeed seems
to
be the case as suggested by peeking into
http://svn.netlabs.org/repos/libc/branches/libc-0.6/src/emx/src/os2/tcpip.c
- really bad, all this ugly world of mixing file and socket handles
together on a platform having these concepts completely separated :-( ).
I'll see what I could do (probably start by extending the previous test
to
import the "send" call from EMX libc). It would be the best to just
allocate the fake "file" handle expected by EMX libc to the existing
socket number if necessary (i.e. if OpenSSL is involved), but I'm afraid
that the respective EMX libc function (tcpip_new_handle) may not be
exported / accessible externally. Too bad. :-(
It seems that there is a call published by the EMX runtime for
importing an externally opened socket handle, so this might be the
best solution. I'll play with it once I find the needed time and let
you know the results.
tcpip_impsockhandle?
Attached is a modified httpsend and ssl_openssl that uses openssl BIO to
make the connection. It only works with https since I didn't change
TBlockSocket. TBlockSocket uses SSL_write and SSL_read for ssl
connections and send recv for non ssl.
Test program:
program project1;
{$mode objfpc}{$H+}
uses
Classes,ssl_openssl_openssl,httpsend_openssl;
var
HTTP: THTTPSend;
s:string;
begin
HTTP := THTTPSend.Create;
try
if HTTP.HTTPMethod('GET', 'https://www.google.com') then
begin
setlength(s,HTTP.Document.Size);
HTTP.Document.Read(s[1],length(s));
writeln(s);
end;
finally
HTTP.Free;
end;
end.
Tested on windows. You'll need to check the library names in both files.
This is a quick and dirty implementation using static linking.
If this works, the code can be rather easily adapted to not depend on
openssl:
- move the statically linked functions to ssl_openssl_lib and load
dynamically.
- use BIO in THTTPSend.InternalDoConnect when needssl=true, standard
sockets when false, eventually test for SSLImplementation = TSSLOpenSSL
and ifdef the lot for OS/2.
- add error checking to set FSock.LastError
BTW, when writing this patch, I lost count of the number of times
sslconnect returned -1 and no error ;)
Ludo
{==============================================================================|
| Project : Ararat Synapse | 001.002.000 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
| Copyright (c)1999-2012, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005-2012. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//requires OpenSSL libraries!
{:@abstract(SSL plugin for OpenSSL)
You need OpenSSL libraries version 0.9.7. It can work with 0.9.6 too, but
application mysteriously crashing when you are using freePascal on Linux.
Use Kylix on Linux is OK! If you have version 0.9.7 on Linux, then I not see
any problems with FreePascal.
OpenSSL libraries are loaded dynamicly - you not need OpenSSl librares even you
compile your application with this unit. SSL just not working when you not have
OpenSSL libraries.
This plugin have limited support for .NET too! Because is not possible to use
callbacks with CDECL calling convention under .NET, is not supported
key/certificate passwords and multithread locking. :-(
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br
@link(TCustomSSL.Certificate) for ASN1 DER format only. @br
@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br
@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br
@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br
@link(TCustomSSL.PFXFile) for PFX format. @br
@link(TCustomSSL.PFX) for PFX format from binary string. @br
This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
server without explicitly assigned key and certificate, then this plugin create
Ad-Hoc key and certificate for each incomming connection by self. It slowdown
accepting of new connections!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ssl_openssl_openssl;
interface
uses
SysUtils, Classes,
blcksock, synsock, synautil,
{$IFDEF CIL}
System.Text,
{$ENDIF}
ssl_openssl_lib;
type
{:@abstract(class implementing OpenSSL SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse
itself!}
TSSLOpenSSL = class(TCustomSSL)
protected
FBIO:PBIO;
FSsl: PSSL;
Fctx: PSSL_CTX;
function SSLCheck: Boolean;
function SetSslKeys: boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
function LoadPFX(pfxdata: ansistring): Boolean;
function CreateSelfSignedCert(Host: string): Boolean; override;
public
{:See @inherited}
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
property BIO:PBIO read FBIO write FBIO;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerSerialNo: integer; override; {pf}
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerNameHash: cardinal; override; {pf}
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
{:See @inherited}
function GetCipherName: string; override;
{:See @inherited}
function GetCipherBits: integer; override;
{:See @inherited}
function GetCipherAlgBits: integer; override;
{:See @inherited}
function GetVerifyCert: integer; override;
end;
implementation
procedure SSL_set_bio(ssl:PSSL; rbio,wbio:PBIO);cdecl;external 'ssleay32.dll';
{==============================================================================}
{$IFNDEF CIL}
function PasswordCallback(buf:PAnsiChar; size:Integer; rwflag:Integer;
userdata: Pointer):Integer; cdecl;
var
Password: AnsiString;
begin
Password := '';
if TCustomSSL(userdata) is TCustomSSL then
Password := TCustomSSL(userdata).KeyPassword;
if Length(Password) > (Size - 1) then
SetLength(Password, Size - 1);
Result := Length(Password);
StrLCopy(buf, PAnsiChar(Password + #0), Result + 1);
end;
{$ENDIF}
{==============================================================================}
constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FCiphers := 'DEFAULT';
FSsl := nil;
Fctx := nil;
end;
destructor TSSLOpenSSL.Destroy;
begin
DeInit;
inherited Destroy;
end;
function TSSLOpenSSL.LibVersion: String;
begin
Result := SSLeayversion(0);
end;
function TSSLOpenSSL.LibName: String;
begin
Result := 'ssl_openssl';
end;
function TSSLOpenSSL.SSLCheck: Boolean;
var
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
s : AnsiString;
begin
Result := true;
FLastErrorDesc := '';
FLastError := ErrGetError;
ErrClearError;
if FLastError <> 0 then
begin
Result := False;
{$IFDEF CIL}
sb := StringBuilder.Create(256);
ErrErrorString(FLastError, sb, 256);
FLastErrorDesc := Trim(sb.ToString);
{$ELSE}
s := StringOfChar(#0, 256);
ErrErrorString(FLastError, s, Length(s));
FLastErrorDesc := s;
{$ENDIF}
end;
end;
function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean;
var
pk: EVP_PKEY;
x: PX509;
rsa: PRSA;
t: PASN1_UTCTIME;
name: PX509_NAME;
b: PBIO;
xn, y: integer;
s: AnsiString;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
Result := True;
pk := EvpPkeynew;
x := X509New;
try
rsa := RsaGenerateKey(1024, $10001, nil, nil);
EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa);
X509SetVersion(x, 2);
Asn1IntegerSet(X509getSerialNumber(x), 0);
t := Asn1UtctimeNew;
try
X509GmtimeAdj(t, -60 * 60 *24);
X509SetNotBefore(x, t);
X509GmtimeAdj(t, 60 * 60 * 60 *24);
X509SetNotAfter(x, t);
finally
Asn1UtctimeFree(t);
end;
X509SetPubkey(x, pk);
Name := X509GetSubjectName(x);
X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0);
X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0);
x509SetIssuerName(x, Name);
x509Sign(x, pk, EvpGetDigestByName('SHA1'));
b := BioNew(BioSMem);
try
i2dX509Bio(b, x);
xn := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(xn);
y := bioread(b, sb, xn);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s, xn);
y := bioread(b, s, xn);
if y > 0 then
setlength(s, y);
{$ENDIF}
finally
BioFreeAll(b);
end;
FCertificate := s;
b := BioNew(BioSMem);
try
i2dPrivatekeyBio(b, pk);
xn := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(xn);
y := bioread(b, sb, xn);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s, xn);
y := bioread(b, s, xn);
if y > 0 then
setlength(s, y);
{$ENDIF}
finally
BioFreeAll(b);
end;
FPrivatekey := s;
finally
X509free(x);
EvpPkeyFree(pk);
end;
end;
function TSSLOpenSSL.LoadPFX(pfxdata: Ansistring): Boolean;
var
cert, pkey, ca: SslPtr;
b: PBIO;
p12: SslPtr;
begin
Result := False;
b := BioNew(BioSMem);
try
BioWrite(b, pfxdata, Length(PfxData));
p12 := d2iPKCS12bio(b, nil);
if not Assigned(p12) then
Exit;
try
cert := nil;
pkey := nil;
ca := nil;
try {pf}
if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then
if SSLCTXusecertificate(Fctx, cert) > 0 then
if SSLCTXusePrivateKey(Fctx, pkey) > 0 then
Result := True;
{pf}
finally
EvpPkeyFree(pkey);
X509free(cert);
SkX509PopFree(ca,_X509Free); // for ca=nil a new STACK was allocated...
end;
{/pf}
finally
PKCS12free(p12);
end;
finally
BioFreeAll(b);
end;
end;
function TSSLOpenSSL.SetSslKeys: boolean;
var
st: TFileStream;
s: string;
begin
Result := False;
if not assigned(FCtx) then
Exit;
try
if FCertificateFile <> '' then
if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then
if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM)
<> 1 then
if SslCtxUseCertificateFile(FCtx, FCertificateFile,
SSL_FILETYPE_ASN1) <> 1 then
Exit;
if FCertificate <> '' then
if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <>
1 then
Exit;
SSLCheck;
if FPrivateKeyFile <> '' then
if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1
then
if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <>
1 then
Exit;
if FPrivateKey <> '' then
if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey,
length(FPrivateKey)) <> 1 then
Exit;
SSLCheck;
if FCertCAFile <> '' then
if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then
Exit;
if FPFXfile <> '' then
begin
try
st := TFileStream.Create(FPFXfile, fmOpenRead or fmShareDenyNone);
try
s := ReadStrFromStream(st, st.Size);
finally
st.Free;
end;
if not LoadPFX(s) then
Exit;
except
on Exception do
Exit;
end;
end;
if FPFX <> '' then
if not LoadPFX(FPfx) then
Exit;
SSLCheck;
Result := True;
finally
SSLCheck;
end;
end;
function TSSLOpenSSL.Init(server:Boolean): Boolean;
var
s: AnsiString;
begin
Result := False;
FLastErrorDesc := '';
FLastError := 0;
Fctx := nil;
case FSSLType of
LT_SSLv2:
Fctx := SslCtxNew(SslMethodV2);
LT_SSLv3:
Fctx := SslCtxNew(SslMethodV3);
LT_TLSv1:
Fctx := SslCtxNew(SslMethodTLSV1);
LT_all:
Fctx := SslCtxNew(SslMethodV23);
else
Exit;
end;
if Fctx = nil then
begin
SSLCheck;
Exit;
end
else
begin
s := FCiphers;
SslCtxSetCipherList(Fctx, s);
if FVerifyCert then
SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil)
else
SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil);
{$IFNDEF CIL}
SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
{$ENDIF}
if server and (FCertificateFile = '') and (FCertificate = '')
and (FPFXfile = '') and (FPFX = '') then
begin
CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
end;
if not SetSSLKeys then
Exit
else
begin
Fssl := nil;
Fssl := SslNew(Fctx);
if Fssl = nil then
begin
SSLCheck;
exit;
end;
end;
end;
Result := true;
end;
function TSSLOpenSSL.DeInit: Boolean;
begin
Result := True;
if assigned (Fssl) then
sslfree(Fssl);
Fssl := nil;
if assigned (Fctx) then
begin
SslCtxFree(Fctx);
Fctx := nil;
ErrRemoveState(0);
end;
FSSLEnabled := False;
end;
function TSSLOpenSSL.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLOpenSSL.Connect: boolean;
var
x: integer;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(False) then
begin
{$IFDEF CIL}
if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
{$ELSE}
if sslsetfd(FSsl, FSocket.Socket) < 1 then
{$ENDIF}
begin
SSLCheck;
Exit;
end;
SSL_set_bio(FSsl, FBIO, FBIO);
if SNIHost<>'' then
SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name,
PAnsiChar(AnsiString(SNIHost)));
x := sslconnect(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
if FverifyCert then
if (GetVerifyCert <> 0) or (not DoVerifyCert) then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLOpenSSL.Accept: boolean;
var
x: integer;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(True) then
begin
{$IFDEF CIL}
if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
{$ELSE}
if sslsetfd(FSsl, FSocket.Socket) < 1 then
{$ENDIF}
begin
SSLCheck;
Exit;
end;
x := sslAccept(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLOpenSSL.Shutdown: boolean;
begin
if assigned(FSsl) then
sslshutdown(FSsl);
DeInit;
Result := True;
end;
function TSSLOpenSSL.BiShutdown: boolean;
var
x: integer;
begin
if assigned(FSsl) then
begin
x := sslshutdown(FSsl);
if x = 0 then
begin
Synsock.Shutdown(FSocket.Socket, 1);
sslshutdown(FSsl);
end;
end;
DeInit;
Result := True;
end;
function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
err: integer;
{$IFDEF CIL}
s: ansistring;
{$ENDIF}
begin
FLastError := 0;
FLastErrorDesc := '';
repeat
{$IFDEF CIL}
s := StringOf(Buffer);
Result := SslWrite(FSsl, s, Len);
{$ELSE}
Result := SslWrite(FSsl, Buffer , Len);
{$ENDIF}
err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then
Result := 0
else
if (err <> 0) then
FLastError := err;
end;
function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
err: integer;
{$IFDEF CIL}
sb: stringbuilder;
s: ansistring;
{$ENDIF}
begin
FLastError := 0;
FLastErrorDesc := '';
repeat
{$IFDEF CIL}
sb := StringBuilder.Create(Len);
Result := SslRead(FSsl, sb, Len);
if Result > 0 then
begin
sb.Length := Result;
s := sb.ToString;
System.Array.Copy(BytesOf(s), Buffer, length(s));
end;
{$ELSE}
Result := SslRead(FSsl, Buffer , Len);
{$ENDIF}
err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then
Result := 0
{pf}// Verze 1.1.0 byla s else tak jak to ted mam,
// ve verzi 1.1.1 bylo ELSE zruseno, ale pak je SSL_ERROR_ZERO_RETURN
// propagovano jako Chyba.
{pf} else {/pf} if (err <> 0) then
FLastError := err;
end;
function TSSLOpenSSL.WaitingData: Integer;
begin
Result := sslpending(Fssl);
end;
function TSSLOpenSSL.GetSSLVersion: string;
begin
if not assigned(FSsl) then
Result := ''
else
Result := SSlGetVersion(FSsl);
end;
function TSSLOpenSSL.GetPeerSubject: string;
var
cert: PX509;
s: ansistring;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
{$IFDEF CIL}
sb := StringBuilder.Create(4096);
Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096);
{$ELSE}
setlength(s, 4096);
Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s));
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetPeerSerialNo: integer; {pf}
var
cert: PX509;
SN: PASN1_INTEGER;
begin
if not assigned(FSsl) then
begin
Result := -1;
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
try
if not assigned(cert) then
begin
Result := -1;
Exit;
end;
SN := X509GetSerialNumber(cert);
Result := Asn1IntegerGet(SN);
finally
X509Free(cert);
end;
end;
function TSSLOpenSSL.GetPeerName: string;
var
s: ansistring;
begin
s := GetPeerSubject;
s := SeparateRight(s, '/CN=');
Result := Trim(SeparateLeft(s, '/'));
end;
function TSSLOpenSSL.GetPeerNameHash: cardinal; {pf}
var
cert: PX509;
begin
if not assigned(FSsl) then
begin
Result := 0;
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
try
if not assigned(cert) then
begin
Result := 0;
Exit;
end;
Result := X509NameHash(X509GetSubjectName(cert));
finally
X509Free(cert);
end;
end;
function TSSLOpenSSL.GetPeerIssuer: string;
var
cert: PX509;
s: ansistring;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
{$IFDEF CIL}
sb := StringBuilder.Create(4096);
Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096);
{$ELSE}
setlength(s, 4096);
Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s));
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetPeerFingerprint: string;
var
cert: PX509;
x: integer;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
{$IFDEF CIL}
sb := StringBuilder.Create(EVP_MAX_MD_SIZE);
X509Digest(cert, EvpGetDigestByName('MD5'), sb, x);
sb.Length := x;
Result := sb.ToString;
{$ELSE}
setlength(Result, EVP_MAX_MD_SIZE);
X509Digest(cert, EvpGetDigestByName('MD5'), Result, x);
SetLength(Result, x);
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetCertInfo: string;
var
cert: PX509;
x, y: integer;
b: PBIO;
s: AnsiString;
{$IFDEF CIL}
sb: stringbuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
try {pf}
b := BioNew(BioSMem);
try
X509Print(b, cert);
x := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(x);
y := bioread(b, sb, x);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s,x);
y := bioread(b,s,x);
if y > 0 then
setlength(s, y);
{$ENDIF}
Result := ReplaceString(s, LF, CRLF);
finally
BioFreeAll(b);
end;
{pf}
finally
X509Free(cert);
end;
{/pf}
end;
function TSSLOpenSSL.GetCipherName: string;
begin
if not assigned(FSsl) then
Result := ''
else
Result := SslCipherGetName(SslGetCurrentCipher(FSsl));
end;
function TSSLOpenSSL.GetCipherBits: integer;
var
x: integer;
begin
if not assigned(FSsl) then
Result := 0
else
Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x);
end;
function TSSLOpenSSL.GetCipherAlgBits: integer;
begin
if not assigned(FSsl) then
Result := 0
else
SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result);
end;
function TSSLOpenSSL.GetVerifyCert: integer;
begin
if not assigned(FSsl) then
Result := 1
else
Result := SslGetVerifyResult(FSsl);
end;
{==============================================================================}
initialization
if InitSSLInterface then
SSLImplementation := TSSLOpenSSL;
end.
{==============================================================================|
| Project : Ararat Synapse | 003.012.006 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
| Copyright (c)1999-2011, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2011. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(HTTP protocol client)
Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit httpsend_openssl;
interface
uses
SysUtils, Classes,
synautil, synaip, synacode, blcksock, ssl_openssl_lib,ssl_openssl_openssl;
const
cHttpProtocol = '80';
type
{:These encoding types are used internally by the THTTPSend object to identify
the transfer data types.}
TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
{:abstract(Implementation of HTTP protocol.)}
THTTPSend = class(TSynaClient)
protected
FSock: TTCPBlockSocket;
FTransferEncoding: TTransferEncoding;
FAliveHost: string;
FAlivePort: string;
FHeaders: TStringList;
FDocument: TMemoryStream;
FMimeType: string;
FProtocol: string;
FKeepAlive: Boolean;
FKeepAliveTimeout: integer;
FStatus100: Boolean;
FProxyHost: string;
FProxyPort: string;
FProxyUser: string;
FProxyPass: string;
FResultCode: Integer;
FResultString: string;
FUserAgent: string;
FCookies: TStringList;
FDownloadSize: integer;
FUploadSize: integer;
FRangeStart: integer;
FRangeEnd: integer;
FAddPortNumberToHost: Boolean;
function ReadUnknown: Boolean; virtual;
function ReadIdentity(Size: Integer): Boolean;
function ReadChunked: Boolean;
procedure ParseCookies;
function PrepareHeaders: AnsiString;
function InternalDoConnect(needssl: Boolean): Boolean;
function InternalConnect(needssl: Boolean): Boolean;
public
constructor Create;
destructor Destroy; override;
{:Reset headers, document and Mimetype.}
procedure Clear;
{:Decode ResultCode and ResultString from Value.}
procedure DecodeStatus(const Value: string);
{:Connects to host defined in URL and accesses resource defined in URL by
method. If Document is not empty, send it to the server as part of the HTTP
request. Server response is in Document and headers. Connection may be
authorised by username and password in URL. If you define proxy properties,
connection is made by this proxy.
If all OK, result is @true, else result is @false.
If you use 'https:' instead of 'http:' in the URL, your request is made
by SSL/TLS connection (if you do not specify port, then port 443 is used
instead of standard port 80). If you use SSL/TLS request and you have
defined HTTP proxy, then HTTP-tunnel mode is automatically used .}
function HTTPMethod(const Method, URL: string): Boolean;
{:You can call this method from OnStatus event to break current data
transfer. (or from another thread.)}
procedure Abort;
published
{:Before HTTP operation you may define any non-standard headers for HTTP
request, except: 'Expect: 100-continue', 'Content-Length', 'Content-Type',
'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers.
After HTTP operation, it contains full headers of the returned document.}
property Headers: TStringList read FHeaders;
{:Stringlist with name-value stringlist pairs. Each pair is one cookie.
After the HTTP request is returned, cookies are parsed to this stringlist.
You can leave these cookies untouched for next HTTP requests. You can also
save this stringlist for later use.}
property Cookies: TStringList read FCookies;
{:Stream with document to send (before request), or with document received
from HTTP server (after request).}
property Document: TMemoryStream read FDocument;
{:If you need to download only part of a requested document, specify here
the position of subpart begin. If 0, the full document is requested.}
property RangeStart: integer read FRangeStart Write FRangeStart;
{:If you need to download only part of a requested document, specify here
the position of subpart end. If 0, the document from rangeStart to end of
document is requested.
(Useful for resuming broken downloads, for example.)}
property RangeEnd: integer read FRangeEnd Write FRangeEnd;
{:Mime type of sending data. Default is: 'text/html'.}
property MimeType: string read FMimeType Write FMimeType;
{:Define protocol version. Possible values are: '1.1', '1.0' (default)
and '0.9'.}
property Protocol: string read FProtocol Write FProtocol;
{:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.}
property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
{:Define timeout for keepalives in seconds!}
property KeepAliveTimeout: integer read FKeepAliveTimeout Write
FKeepAliveTimeout;
{:if @true, then the server is requested for 100status capability when
uploading data. Default is @false (off).}
property Status100: Boolean read FStatus100 Write FStatus100;
{:Address of proxy server (IP address or domain name) where you want to
connect in @link(HTTPMethod) method.}
property ProxyHost: string read FProxyHost Write FProxyHost;
{:Port number for proxy connection. Default value is 8080.}
property ProxyPort: string read FProxyPort Write FProxyPort;
{:Username for connection to proxy server used in HTTPMethod method.}
property ProxyUser: string read FProxyUser Write FProxyUser;
{:Password for connection to proxy server used in HTTPMethod method.}
property ProxyPass: string read FProxyPass Write FProxyPass;
{:Here you can specify custom User-Agent identification.
Default: 'Mozilla/4.0 (compatible; Synapse)'}
property UserAgent: string read FUserAgent Write FUserAgent;
{:Operation result code after successful @link(HTTPMethod) method.}
property ResultCode: Integer read FResultCode;
{:Operation result string after successful @link(HTTPMethod) method.}
property ResultString: string read FResultString;
{:if this value is not 0, then data download is pending. In this case you
have here the total size of downloaded data. Useful for drawing download
progressbar from OnStatus event.}
property DownloadSize: integer read FDownloadSize;
{:if this value is not 0, then data upload is pending. In this case you have
here the total size of uploaded data. Useful for drawing upload progressbar
from OnStatus event.}
property UploadSize: integer read FUploadSize;
{:Socket object used for TCP/IP operation.
Good for setting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{:Allows to switch off port number in 'Host:' HTTP header. By default @TRUE.
Some buggy servers do not like port informations in this header.}
property AddPortNumberToHost: Boolean read FAddPortNumberToHost write
FAddPortNumberToHost;
end;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the GET method of the HTTP protocol. This function sends
the GET method for URL document to an HTTP server. Returned document is in the
"Response" stringlist (without any headers). Returns boolean TRUE if all went
well.}
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the GET method of the HTTP protocol. This function sends
the GET method for URL document to an HTTP server. Returned document is in the
"Response" stream. Returns boolean TRUE if all went well.}
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function sends
the SEND method for a URL document to an HTTP server. The document to be sent
is located in the "Data" stream. The returned document is in the "Data" stream.
Returns boolean TRUE if all went well.}
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function is
good for POSTing form data. It sends the POST method for a URL document to
an HTTP server. You must prepare the form data in the same manner as you would
the URL data, and pass this prepared data to "URLdata". The following is
a sample of how the data would appear: 'name=Lukas&field1=some%20data'.
The information in the field must be encoded by the EncodeURLElement function.
The returned document is in the "Data" stream. Returns boolean TRUE if all
went well.}
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function sends
the POST method for a URL document to an HTTP server. This function simulates
posting of file by HTML form using the 'multipart/form-data' method. The posted
file is in the DATA stream. Its name is Filename string. Fieldname is for the
name of the form field with the file. (simulates HTML INPUT FILE) The returned
document is in the ResultData Stringlist. Returns boolean TRUE if all
went well.}
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStrings): Boolean;
implementation
const
BIO_C_DO_STATE_MACHINE=101;
BIO_C_GET_FD=105;
function BIO_new_connect(name:pchar):PBIO; cdecl;external 'libeay32.dll';
function BIO_ctrl(b:PBIO; cmd:integer;larg:longint;parg:pointer):longint
;cdecl;external 'libeay32.dll';
constructor THTTPSend.Create;
begin
inherited Create;
FHeaders := TStringList.Create;
FCookies := TStringList.Create;
FDocument := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := True;
FSock.SizeRecvBuffer := c64k;
FSock.SizeSendBuffer := c64k;
FTimeout := 90000;
FTargetPort := cHttpProtocol;
FProxyHost := '';
FProxyPort := '8080';
FProxyUser := '';
FProxyPass := '';
FAliveHost := '';
FAlivePort := '';
FProtocol := '1.0';
FKeepAlive := True;
FStatus100 := False;
FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
FDownloadSize := 0;
FUploadSize := 0;
FAddPortNumberToHost := true;
FKeepAliveTimeout := 300;
Clear;
end;
destructor THTTPSend.Destroy;
begin
FSock.Free;
FDocument.Free;
FCookies.Free;
FHeaders.Free;
inherited Destroy;
end;
procedure THTTPSend.Clear;
begin
FRangeStart := 0;
FRangeEnd := 0;
FDocument.Clear;
FHeaders.Clear;
FMimeType := 'text/html';
end;
procedure THTTPSend.DecodeStatus(const Value: string);
var
s, su: string;
begin
s := Trim(SeparateRight(Value, ' '));
su := Trim(SeparateLeft(s, ' '));
FResultCode := StrToIntDef(su, 0);
FResultString := Trim(SeparateRight(s, ' '));
if FResultString = s then
FResultString := '';
end;
function THTTPSend.PrepareHeaders: AnsiString;
begin
if FProtocol = '0.9' then
Result := FHeaders[0] + CRLF
else
{$IFNDEF MSWINDOWS}
Result := {$IFDEF
UNICODE}AnsiString{$ENDIF}(AdjustLineBreaks(FHeaders.Text, tlbsCRLF));
{$ELSE}
Result := FHeaders.Text;
{$ENDIF}
end;
function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean;
var
p:integer;
begin
Result := False;
TSSLOpenSSL(FSock.SSL).BIO:=BIO_new_connect(pchar(FTargetHost+':'+FTargetPort));
if TSSLOpenSSL(FSock.SSL).BIO=nil then
Exit;
if BIO_ctrl(TSSLOpenSSL(FSock.SSL).BIO,BIO_C_DO_STATE_MACHINE,0,nil)=0 then
//BIO_do_connect
Exit;
FSock.Socket:=BIO_ctrl(TSSLOpenSSL(FSock.SSL).BIO,BIO_C_GET_FD,0,nil);
//BIO_get_fd
if needssl then
begin
if (FSock.SSL.SNIHost='') then
FSock.SSL.SNIHost:=FTargetHost;
FSock.SSLDoConnect;
FSock.SSL.SNIHost:=''; //don't need it anymore and don't wan't to reuse it
in next connection
if FSock.LastError <> 0 then
Exit;
end;
FAliveHost := FTargetHost;
FAlivePort := FTargetPort;
Result := True;
end;
function THTTPSend.InternalConnect(needssl: Boolean): Boolean;
begin
if TSSLOpenSSL(FSock.SSL).BIO = nil then
Result := InternalDoConnect(needssl)
else
if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort)
then
Result := InternalDoConnect(needssl)
else
Result := True;
end;
function THTTPSend.HTTPMethod(const Method, URL: string): Boolean;
var
Sending, Receiving: Boolean;
status100: Boolean;
status100error: string;
ToClose: Boolean;
Size: Integer;
Prot, User, Pass, Host, Port, Path, Para, URI: string;
s, su: AnsiString;
HttpTunnel: Boolean;
n,i: integer;
pp: string;
UsingProxy: boolean;
l: TStringList;
x: integer;
begin
{initial values}
Result := False;
FResultCode := 500;
FResultString := '';
FDownloadSize := 0;
FUploadSize := 0;
URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
User := DecodeURL(user);
Pass := DecodeURL(pass);
if User = '' then
begin
User := FUsername;
Pass := FPassword;
end;
if UpperCase(Prot) = 'HTTPS' then
begin
HttpTunnel := FProxyHost <> '';
FSock.HTTPTunnelIP := FProxyHost;
FSock.HTTPTunnelPort := FProxyPort;
FSock.HTTPTunnelUser := FProxyUser;
FSock.HTTPTunnelPass := FProxyPass;
end
else
begin
HttpTunnel := False;
FSock.HTTPTunnelIP := '';
FSock.HTTPTunnelPort := '';
FSock.HTTPTunnelUser := '';
FSock.HTTPTunnelPass := '';
end;
UsingProxy := (FProxyHost <> '') and not(HttpTunnel);
Sending := FDocument.Size > 0;
{Headers for Sending data}
status100 := FStatus100 and Sending and (FProtocol = '1.1');
if status100 then
FHeaders.Insert(0, 'Expect: 100-continue');
if Sending then
begin
FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
if FMimeType <> '' then
FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
end;
{ setting User-agent }
if FUserAgent <> '' then
FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
{ setting Ranges }
if (FRangeStart > 0) or (FRangeEnd > 0) then
begin
if FRangeEnd >= FRangeStart then
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' +
IntToStr(FRangeEnd))
else
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-');
end;
{ setting Cookies }
s := '';
for n := 0 to FCookies.Count - 1 do
begin
if s <> '' then
s := s + '; ';
s := s + FCookies[n];
end;
if s <> '' then
FHeaders.Insert(0, 'Cookie: ' + s);
{ setting KeepAlives }
pp := '';
if UsingProxy then
pp := 'Proxy-';
if FKeepAlive then
begin
FHeaders.Insert(0, pp + 'Connection: keep-alive');
FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout));
end
else
FHeaders.Insert(0, pp + 'Connection: close');
{ set target servers/proxy, authorizations, etc... }
if User <> '' then
FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' +
Pass));
if UsingProxy and (FProxyUser <> '') then
FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
EncodeBase64(FProxyUser + ':' + FProxyPass));
if isIP6(Host) then
s := '[' + Host + ']'
else
s := Host;
if FAddPortNumberToHost and (Port <> '80') then
FHeaders.Insert(0, 'Host: ' + s + ':' + Port)
else
FHeaders.Insert(0, 'Host: ' + s);
if UsingProxy then
URI := Prot + '://' + s + ':' + Port + URI;
if URI = '/*' then
URI := '*';
if FProtocol = '0.9' then
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
else
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
if UsingProxy then
begin
FTargetHost := FProxyHost;
FTargetPort := FProxyPort;
end
else
begin
FTargetHost := Host;
FTargetPort := Port;
end;
if FHeaders[FHeaders.Count - 1] <> '' then
FHeaders.Add('');
{ connect }
if not InternalConnect(UpperCase(Prot) = 'HTTPS') then
begin
FAliveHost := '';
FAlivePort := '';
Exit;
end;
{ reading Status }
FDocument.Position := 0;
Status100Error := '';
if status100 then
begin
{ send Headers }
FSock.SendString(PrepareHeaders);
repeat
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
DecodeStatus(s);
Status100Error := s;
repeat
s := FSock.recvstring(FTimeout);
if s = '' then
Break;
until FSock.LastError <> 0;
if (FResultCode >= 100) and (FResultCode < 200) then
begin
{ we can upload content }
Status100Error := '';
FUploadSize := FDocument.Size;
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
end;
end
else
{ upload content }
if sending then
begin
if FDocument.Size >= c64k then
begin
FSock.SendString(PrepareHeaders);
FUploadSize := FDocument.Size;
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
end
else
begin
s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size);
FUploadSize := Length(s);
FSock.SendString(s);
end;
end
else
begin
{ we not need to upload document, send headers only }
FSock.SendString(PrepareHeaders);
end;
if FSock.LastError <> 0 then
Exit;
Clear;
Size := -1;
FTransferEncoding := TE_UNKNOWN;
{ read status }
if Status100Error = '' then
begin
repeat
repeat
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
if Pos('HTTP/', UpperCase(s)) = 1 then
begin
FHeaders.Add(s);
DecodeStatus(s);
end
else
begin
{ old HTTP 0.9 and some buggy servers not send result }
s := s + CRLF;
WriteStrToStream(FDocument, s);
FResultCode := 0;
end;
until (FSock.LastError <> 0) or (FResultCode <> 100);
end
else
FHeaders.Add(Status100Error);
{ if need receive headers, receive and parse it }
ToClose := FProtocol <> '1.1';
if FHeaders.Count > 0 then
begin
l := TStringList.Create;
try
repeat
s := FSock.RecvString(FTimeout);
l.Add(s);
if s = '' then
Break;
until FSock.LastError <> 0;
x := 0;
while l.Count > x do
begin
s := NormalizeHeader(l, x);
FHeaders.Add(s);
su := UpperCase(s);
if Pos('CONTENT-LENGTH:', su) = 1 then
begin
Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1);
if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
FTransferEncoding := TE_IDENTITY;
end;
if Pos('CONTENT-TYPE:', su) = 1 then
FMimeType := Trim(SeparateRight(s, ' '));
if Pos('TRANSFER-ENCODING:', su) = 1 then
begin
s := Trim(SeparateRight(su, ' '));
if Pos('CHUNKED', s) > 0 then
FTransferEncoding := TE_CHUNKED;
end;
if UsingProxy then
begin
if Pos('PROXY-CONNECTION:', su) = 1 then
if Pos('CLOSE', su) > 0 then
ToClose := True;
end
else
begin
if Pos('CONNECTION:', su) = 1 then
if Pos('CLOSE', su) > 0 then
ToClose := True;
end;
end;
finally
l.free;
end;
end;
Result := FSock.LastError = 0;
if not Result then
Exit;
{if need receive response body, read it}
Receiving := Method <> 'HEAD';
Receiving := Receiving and (FResultCode <> 204);
Receiving := Receiving and (FResultCode <> 304);
if Receiving then
case FTransferEncoding of
TE_UNKNOWN:
Result := ReadUnknown;
TE_IDENTITY:
Result := ReadIdentity(Size);
TE_CHUNKED:
Result := ReadChunked;
end;
FDocument.Seek(0, soFromBeginning);
if ToClose then
begin
FSock.CloseSocket;
FAliveHost := '';
FAlivePort := '';
end;
ParseCookies;
end;
function THTTPSend.ReadUnknown: Boolean;
var
s: ansistring;
begin
Result := false;
repeat
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
WriteStrToStream(FDocument, s);
until FSock.LastError <> 0;
//if FSock.LastError = WSAECONNRESET then
//begin
// Result := true;
// FSock.ResetLastError;
//end;
end;
function THTTPSend.ReadIdentity(Size: Integer): Boolean;
begin
if Size > 0 then
begin
FDownloadSize := Size;
FSock.RecvStreamSize(FDocument, FTimeout, Size);
FDocument.Position := FDocument.Size;
Result := FSock.LastError = 0;
end
else
Result := true;
end;
function THTTPSend.ReadChunked: Boolean;
var
s: ansistring;
Size: Integer;
begin
repeat
repeat
s := FSock.RecvString(FTimeout);
until (s <> '') or (FSock.LastError <> 0);
if FSock.LastError <> 0 then
Break;
s := Trim(SeparateLeft(s, ' '));
s := Trim(SeparateLeft(s, ';'));
Size := StrToIntDef('$' + s, 0);
if Size = 0 then
Break;
if not ReadIdentity(Size) then
break;
until False;
Result := FSock.LastError = 0;
end;
procedure THTTPSend.ParseCookies;
var
n: integer;
s: string;
sn, sv: string;
begin
for n := 0 to FHeaders.Count - 1 do
if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then
begin
s := SeparateRight(FHeaders[n], ':');
s := trim(SeparateLeft(s, ';'));
sn := trim(SeparateLeft(s, '='));
sv := trim(SeparateRight(s, '='));
FCookies.Values[sn] := sv;
end;
end;
procedure THTTPSend.Abort;
begin
FSock.StopFlag := True;
end;
{==============================================================================}
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
Result := HTTP.HTTPMethod('GET', URL);
if Result then
Response.LoadFromStream(HTTP.Document);
finally
HTTP.Free;
end;
end;
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
Result := HTTP.HTTPMethod('GET', URL);
if Result then
begin
Response.Seek(0, soFromBeginning);
Response.CopyFrom(HTTP.Document, 0);
end;
finally
HTTP.Free;
end;
end;
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
HTTP.Document.CopyFrom(Data, 0);
HTTP.MimeType := 'Application/octet-stream';
Result := HTTP.HTTPMethod('POST', URL);
Data.Size := 0;
if Result then
begin
Data.Seek(0, soFromBeginning);
Data.CopyFrom(HTTP.Document, 0);
end;
finally
HTTP.Free;
end;
end;
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
WriteStrToStream(HTTP.Document, URLData);
HTTP.MimeType := 'application/x-www-form-urlencoded';
Result := HTTP.HTTPMethod('POST', URL);
if Result then
Data.CopyFrom(HTTP.Document, 0);
finally
HTTP.Free;
end;
end;
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStrings): Boolean;
var
HTTP: THTTPSend;
Bound, s: string;
begin
Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
HTTP := THTTPSend.Create;
try
s := '--' + Bound + CRLF;
s := s + 'content-disposition: form-data; name="' + FieldName + '";';
s := s + ' filename="' + FileName +'"' + CRLF;
s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
WriteStrToStream(HTTP.Document, s);
HTTP.Document.CopyFrom(Data, 0);
s := CRLF + '--' + Bound + '--' + CRLF;
WriteStrToStream(HTTP.Document, s);
HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
Result := HTTP.HTTPMethod('POST', URL);
if Result then
ResultData.LoadFromStream(HTTP.Document);
finally
HTTP.Free;
end;
end;
end.
------------------------------------------------------------------------------
LogMeIn Rescue: Anywhere, Anytime Remote support for IT. Free Trial
Remotely access PCs and mobile devices and provide instant support
Improve your efficiency, and focus on delivering more value-add services
Discover what IT Professionals Know. Rescue delivers
http://p.sf.net/sfu/logmein_12329d2d
_______________________________________________
synalist-public mailing list
synalist-public@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/synalist-public
