pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

LazMapViewer: Add downloadengine based on WinInet (Windows only). Update fulldemo_with_addons. Remove Synapse openssl units from package.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8703 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2023-02-12 23:02:11 +00:00
parent e343a8232f
commit 55c9a60bbb
10 changed files with 213 additions and 3183 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
components/lazmapviewer/examples/fulldemo_with_addons/MapViewer_Demo.lpi
View File

@ -25,19 +25,22 @@
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<RequiredPackages Count="4">
<RequiredPackages Count="5">
<Item1>
<PackageName Value="lazmapviewer_bgra"/>
<PackageName Value="lazMapViewer_Synapse"/>
</Item1>
<Item2>
<PackageName Value="lazmapviewer_rgbgraphics"/>
<PackageName Value="lazmapviewer_bgra"/>
</Item2>
<Item3>
<PackageName Value="lazMapViewerPkg"/>
<PackageName Value="lazmapviewer_rgbgraphics"/>
</Item3>
<Item4>
<PackageName Value="LCL"/>
<PackageName Value="lazMapViewerPkg"/>
</Item4>
<Item5>
<PackageName Value="LCL"/>
</Item5>
</RequiredPackages>
<Units Count="4">
<Unit0>
@ -76,6 +79,9 @@
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf3"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>

84
components/lazmapviewer/examples/fulldemo_with_addons/main.lfm
View File

@ -36,9 +36,9 @@ object MainForm: TMainForm
Height = 640
Top = 0
Width = 275
ActivePage = PgData
ActivePage = PgConfig
Align = alRight
TabIndex = 0
TabIndex = 1
TabOrder = 1
object PgData: TTabSheet
Caption = 'Data'
@ -560,11 +560,11 @@ object MainForm: TMainForm
end
object LblProviders: TLabel
AnchorSideLeft.Control = CbProviders
AnchorSideTop.Control = CbDrawingEngine
AnchorSideTop.Control = CbDownloadEngine
AnchorSideTop.Side = asrBottom
Left = 6
Height = 15
Top = 54
Top = 102
Width = 52
BorderSpacing.Top = 8
Caption = 'Providers:'
@ -577,7 +577,7 @@ object MainForm: TMainForm
AnchorSideRight.Control = BtnLoadMapProviders
Left = 6
Height = 23
Top = 71
Top = 119
Width = 199
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Left = 6
@ -596,7 +596,7 @@ object MainForm: TMainForm
AnchorSideRight.Control = BtnSaveMapProviders
Left = 209
Height = 22
Top = 71
Top = 119
Width = 23
Anchors = [akTop, akRight]
BorderSpacing.Right = 4
@ -647,7 +647,7 @@ object MainForm: TMainForm
AnchorSideRight.Side = asrBottom
Left = 236
Height = 22
Top = 71
Top = 119
Width = 23
Anchors = [akTop, akRight]
BorderSpacing.Right = 8
@ -695,8 +695,8 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrBottom
Left = 6
Height = 19
Top = 127
Width = 81
Top = 175
Width = 79
BorderSpacing.Left = 6
BorderSpacing.Top = 6
Caption = 'Use threads'
@ -711,8 +711,8 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrBottom
Left = 6
Height = 19
Top = 152
Width = 87
Top = 200
Width = 85
BorderSpacing.Top = 6
BorderSpacing.Right = 9
Caption = 'DblBuffering'
@ -727,8 +727,8 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrBottom
Left = 6
Height = 19
Top = 177
Width = 79
Top = 225
Width = 77
BorderSpacing.Top = 6
Caption = 'Debug tiles'
OnChange = CbDebugTilesChange
@ -740,8 +740,8 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrBottom
Left = 6
Height = 19
Top = 214
Width = 107
Top = 262
Width = 105
BorderSpacing.Top = 6
Caption = 'Show POI image'
OnChange = CbShowPOIImageChange
@ -752,7 +752,7 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrBottom
Left = 6
Height = 25
Top = 241
Top = 289
Width = 93
AutoSize = True
BorderSpacing.Top = 8
@ -769,7 +769,7 @@ object MainForm: TMainForm
AnchorSideRight.Side = asrBottom
Left = 154
Height = 22
Top = 242
Top = 290
Width = 107
NoneColorColor = clWhite
Style = [cbStandardColors, cbExtendedColors, cbIncludeNone, cbCustomColor, cbPrettyNames, cbCustomColors]
@ -786,7 +786,7 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrCenter
Left = 107
Height = 15
Top = 246
Top = 294
Width = 39
BorderSpacing.Left = 8
Caption = 'Backgr.'
@ -799,7 +799,7 @@ object MainForm: TMainForm
AnchorSideRight.Side = asrBottom
Left = 6
Height = 4
Top = 204
Top = 252
Width = 255
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Top = 8
@ -811,8 +811,8 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrBottom
Left = 6
Height = 19
Top = 102
Width = 102
Top = 150
Width = 100
BorderSpacing.Left = 6
BorderSpacing.Top = 8
Caption = 'Zoom to cursor'
@ -821,6 +821,44 @@ object MainForm: TMainForm
State = cbChecked
TabOrder = 8
end
object Label2: TLabel
AnchorSideLeft.Control = CbDownloadEngine
AnchorSideTop.Control = CbDrawingEngine
AnchorSideTop.Side = asrBottom
Left = 6
Height = 15
Top = 54
Width = 96
BorderSpacing.Top = 8
Caption = 'Download engine:'
end
object CbDownloadEngine: TComboBox
AnchorSideLeft.Control = PgConfig
AnchorSideTop.Control = Label2
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = PgConfig
AnchorSideRight.Side = asrBottom
Left = 6
Height = 23
Top = 71
Width = 255
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Left = 6
BorderSpacing.Top = 2
BorderSpacing.Right = 6
ItemHeight = 15
ItemIndex = 0
Items.Strings = (
'default'
'Synapse'
'FpHTTPClient'
'WinInet'
)
OnChange = CbDownloadEngineChange
Style = csDropDownList
TabOrder = 9
Text = 'default'
end
end
end
object GeoNames: TMVGeoNames
@ -837,7 +875,7 @@ object MainForm: TMainForm
object FontDialog: TFontDialog
MinFontSize = 0
MaxFontSize = 0
Left = 816
Top = 152
Left = 808
Top = 216
end
end

47
components/lazmapviewer/examples/fulldemo_with_addons/main.pas
View File

@ -8,7 +8,7 @@ uses
Classes, SysUtils, Types, Forms, Controls, Graphics, Dialogs,
ExtCtrls, StdCtrls, ComCtrls, Buttons, IntfGraphics, ColorBox,
mvGeoNames, mvMapViewer, mvTypes, mvGpsObj, mvDrawingEngine,
mvDE_RGBGraphics, mvDE_BGRA;
mvDE_RGBGraphics, mvDE_BGRA, mvDLEFPC, mvDLEWin, mvDLESynapse;
type
@ -23,6 +23,7 @@ type
BtnLoadGPXFile: TButton;
BtnPOITextFont: TButton;
CbDoubleBuffer: TCheckBox;
CbDownloadEngine: TComboBox;
CbFoundLocations: TComboBox;
CbLocations: TComboBox;
CbProviders: TComboBox;
@ -46,6 +47,7 @@ type
GPSPointInfo: TLabel;
InfoViewportWidth: TLabel;
Label1: TLabel;
Label2: TLabel;
LblPOITextBgColor: TLabel;
LblSelectLocation: TLabel;
LblCenterLatitude: TLabel;
@ -74,6 +76,7 @@ type
procedure BtnSaveToFileClick(Sender: TObject);
procedure BtnPOITextFontClick(Sender: TObject);
procedure CbDebugTilesChange(Sender: TObject);
procedure CbDownloadEngineChange(Sender: TObject);
procedure CbDrawingEngineChange(Sender: TObject);
procedure CbDoubleBufferChange(Sender: TObject);
procedure CbFoundLocationsDrawItem(Control: TWinControl; Index: Integer;
@ -104,6 +107,11 @@ type
private
FRGBGraphicsDrawingEngine: TMvRGBGraphicsDrawingEngine;
FBGRADrawingEngine: TMvBGRADrawingEngine;
FSynapseDownloadEngine: TMvDESynapse;
FFpHttpClientDownloadEngine: TMvDEFPC;
{$IFDEF MSWINDOWS}
FWinDownloadEngine: TMvDEWin;
{$ENDIF}
POIImage: TCustomBitmap;
procedure ClearFoundLocations;
procedure UpdateCoords(X, Y: Integer);
@ -254,6 +262,32 @@ begin
MapView.DebugTiles := CbDebugTiles.Checked;
end;
procedure TMainForm.CbDownloadEngineChange(Sender: TObject);
begin
case CbDownloadEngine.ItemIndex of
0: MapView.DownloadEngine := nil;
1: begin
if FSynapseDownloadEngine = nil then
FSynapseDownloadEngine := TMvDESynapse.Create(self);
MapView.DownloadEngine := FSynapseDownloadEngine;
end;
2: begin
if FFpHttpClientDownloadEngine = nil then
FFpHttpClientDownloadEngine := TMvDEFPC.Create(self);
MapView.DownloadEngine := FFpHttpClientDownloadEngine;
end;
3: begin
{$IFDEF MSWINDOWS}
if FWinDownloadEngine = nil then
FWinDownloadEngine := TMvDEWin.Create(Self);
MapView.DownloadEngine := FWinDownloadEngine;
{$ELSE}
ShowMessage('WinInet download engine can only be used in Windows.');
{$ENDIF}
end;
end;
end;
procedure TMainForm.CbDrawingEngineChange(Sender: TObject);
begin
case CbDrawingEngine.ItemIndex of
@ -356,7 +390,7 @@ begin
// FMapMarker := CreateMapMarker(32, clRed, clBlack);
POIImage := TPortableNetworkGraphic.Create;
POIImage.PixelFormat := pf32bit;
POIImage.LoadFromFile('../../mapmarker.png');
POIImage.LoadFromFile('mapmarker.png');
ForceDirectories(HOMEDIR + 'cache/');
MapView.CachePath := HOMEDIR + 'cache/';
@ -384,7 +418,14 @@ procedure TMainForm.FormDestroy(Sender: TObject);
begin
WriteToIni;
ClearFoundLocations;
FreeAndNil(POIImage)
FreeAndNil(POIImage);
FreeAndNil(FRGBGraphicsDrawingEngine);
FreeAndNil(FBGRADrawingEngine);
FreeAndNil(FSynapseDownloadEngine);
FreeAndNil(FFpHttpClientDownloadEngine);
{$IFDEF MSWINDOWS}
FreeAndNil(FWinDownloadEngine);
{$ENDIF}
end;
procedure TMainForm.FormShow(Sender: TObject);

6
components/lazmapviewer/lazmapviewerpkg.lpk
View File

@ -15,7 +15,7 @@
This is a fork of MapViewer by ti_dic (https://sourceforge.net/p/roadbook/code/ci/master/tree/mapviewer/) which itself is based on the MapViewer by Maciej Kaczkowski (https://github.com/maciejkaczkowski/mapviewer)."/>
<License Value="modified LGPL with linking exception, like FreePascal RTL/FCL and Lazarus LCL"/>
<Version Minor="2" Release="5"/>
<Files Count="18">
<Files Count="19">
<Item1>
<Filename Value="source/mvcache.pas"/>
<UnitName Value="mvCache"/>
@ -89,6 +89,10 @@ This is a fork of MapViewer by ti_dic (https://sourceforge.net/p/roadbook/code/c
<Filename Value="source/mvde_lcl.pas"/>
<UnitName Value="mvDE_LCL"/>
</Item18>
<Item19>
<Filename Value="source/mvdlewin.pas"/>
<UnitName Value="mvdlewin"/>
</Item19>
</Files>
<CompatibilityMode Value="True"/>
<RequiredPkgs Count="1">

3
components/lazmapviewer/lazmapviewerpkg.pas
View File

@ -4,13 +4,14 @@
unit lazMapViewerPkg;
{$warn 5023 off : no warning about unused units}
interface
uses
mvCache, mvDownloadEngine, mvDragObj, mvEngine, mvGeoNames, mvGpsObj,
mvJobQueue, mvJobs, mvMapProvider, mvTypes, mvMapViewer, mvExtraData,
mvDLEFpc, mvMapViewerReg, mvGPX, mvDrawingEngine, mvDE_IntfGraphics,
mvDE_LCL, LazarusPackageIntf;
mvDE_LCL, mvDLEWin, LazarusPackageIntf;
implementation

3
components/lazmapviewer/source/addons/synapse_downloadengine/readme.txt
View File

@ -1,5 +1,2 @@
This folder contains the sources of the download engine based on the Synapse
library.
Since the Synapse package (laz_synapse.lpk) does not contain the files needed
for ssl they were copied into this folder to be found for compilation.

932
components/lazmapviewer/source/addons/synapse_downloadengine/ssl_openssl.pas
View File

@ -1,932 +0,0 @@
{==============================================================================|
| Project : Ararat Synapse | 001.003.000 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
| Copyright (c)1999-2017, 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-2017. |
| 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)
Compatibility with OpenSSL versions:
0.9.6 should work, known mysterious crashing on FreePascal and Linux platform.
0.9.7 - 1.0.0 working fine.
1.1.0 should work, under testing.
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;
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
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;
{: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
{==============================================================================}
{$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_TLSv1_1:
Fctx := SslCtxNew(SslMethodTLSV11);
LT_TLSv1_2:
Fctx := SslCtxNew(SslMethodTLSV12);
LT_all:
begin
//try new call for OpenSSL 1.1.0 first
Fctx := SslCtxNew(SslMethodTLS);
if Fctx=nil then
//callback to previous versions
Fctx := SslCtxNew(SslMethodV23);
end;
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;
b: boolean;
err: 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;
if SNIHost<>'' then
SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, PAnsiChar(AnsiString(SNIHost)));
if FSocket.ConnectionTimeout <= 0 then //do blocking call of SSL_Connect
begin
x := sslconnect(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
end
else //do non-blocking call of SSL_Connect
begin
b := Fsocket.NonBlockMode;
Fsocket.NonBlockMode := true;
repeat
x := sslconnect(FSsl);
err := SslGetError(FSsl, x);
if err = SSL_ERROR_WANT_READ then
if not FSocket.CanRead(FSocket.ConnectionTimeout) then
break;
if err = SSL_ERROR_WANT_WRITE then
if not FSocket.CanWrite(FSocket.ConnectionTimeout) then
break;
until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
Fsocket.NonBlockMode := b;
if err <> SSL_ERROR_NONE then
begin
SSLcheck;
Exit;
end;
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.

2214
components/lazmapviewer/source/addons/synapse_downloadengine/ssl_openssl_lib.pas
View File

File diff suppressed because it is too large Load Diff

81
components/lazmapviewer/source/mvdlewin.pas Normal file
View File

@ -0,0 +1,81 @@
{ Map Viewer Download Engine Free Pascal HTTP Client
License: modified LGPL with linking exception (like RTL, FCL and LCL)
See the file COPYING.modifiedLGPL.txt, included in the Lazarus distribution,
for details about the license.
See also: https://wiki.lazarus.freepascal.org/FPC_modified_LGPL
}
unit mvDLEWin;
{$mode objfpc}{$H+}
interface
{$IFDEF MSWindows}
uses
Classes, SysUtils,
mvDownloadEngine;
type
TMVDEWin = class(TMvCustomDownloadEngine)
protected
procedure InternalDownloadFile(const Url: string; AStream: TStream); override;
end;
{$ENDIF}
implementation
{$IFDEF MSWindows}
uses
windows, wininet;
procedure TMVDEWin.InternalDownloadFile(const Url: string; AStream: TStream);
const
KB = 1024;
var
netHandle: HInternet;
urlHandle: HInternet;
buffer: array[0..4*KB-1] of Char;
bytesRead: dWord = 0;
errCode: Integer = 0;
header: String;
begin
NetHandle := InternetOpen('Mozilla/5.0(compatible; WinInet)', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
// NetHandle valid?
if netHandle = nil then
exit;
try
header := '';
urlHandle := InternetOpenUrl(netHandle, PChar(URL), PChar(header), Length(header), INTERNET_FLAG_RELOAD, 0);
// UrlHandle valid?
if urlHandle = nil then
exit;
try
repeat
InternetReadFile(urlHandle, @buffer, SizeOf(buffer), bytesRead);
if bytesRead > 0 then
AStream.Write(buffer, bytesRead);
until bytesRead = 0;
AStream.Position := 0;
finally
InternetCloseHandle(urlHandle);
end
finally
InternetCloseHandle(netHandle);
end;
end;
{$ENDIF}
end.

10
components/lazmapviewer/source/mvmapviewer.pas
View File

@ -174,7 +174,11 @@ implementation
uses
GraphType, Types,
mvJobQueue, mvExtraData, mvDLEFpc, mvDE_IntfGraphics;
mvJobQueue, mvExtraData, mvDLEFpc,
{$IFDEF MSWINDOWS}
mvDLEWin,
{$ENDIF}
mvDE_IntfGraphics;
{ Converts a length given in millimeters to screen pixels }
function mmToPx(AValue: Double): Integer;
@ -865,7 +869,11 @@ begin
FGPSItems := TGPSObjectList.Create;
FGPSItems.OnModified := @OnGPSItemsModified;
{$IFDEF MSWindows}
FBuiltinDownloadEngine := TMvDEWin.Create(self);
{$ELSE}
FBuiltinDownloadEngine := TMvDEFpc.Create(self);
{$ENDIF}
FBuiltinDownloadEngine.Name := 'BuiltInDLE';
FEngine := TMapViewerEngine.Create(self);