{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Author: François PIETTE Creation: Feb 15, 2003 Description: A simple HTTPS client. Make use of OpenSSL (http://www.openssl.org). Make use of freeware TSslHttpCli and TSslWSocket components from ICS (Internet Component Suite). Version: V9.8 - Compatible with V10, still has old defines EMail: francois.piette@overbyte.be http://www.overbyte.be Support: https://en.delphipraxis.net/forum/37-ics-internet-component-suite/ Legal issues: Copyright (C) 1997-2026 by François PIETTE Rue de Grady 24, 4053 Embourg, Belgium. SSL implementation includes code written by Arno Garrels, Berlin, Germany This software is provided 'as-is', without any express or implied warranty. In no event will the author be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented, you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. 4. You must register this software by sending a picture postcard to the author. Use a nice stamp and mention your name, street address, EMail address and any comment you like to say. History: Oct 22, 2005 V1.03 Arno Garrels implemented client-side SSL session caching, alternate verify methode, and support for dynamicaly provided client certificates. Nov 08, 2005 V1.04 Arno Garrels adjusted a few type casts in some event handlers. Put in OpenSSL version info. Dec 20, 2005 V1.05 Angus Robertson added new LogOptions and GZIP decompression and display more log lines Jul 18, 2008 V1.06 A. Garrels fixed an AV in SslHttpCli1SslCliCertRequest May 2012 - V8.00 - Arno converted demo for FireMonkey cross platform Mac OS X support, now XE2 and later only uising FMX components Dec 09, 2020 V8.65 Added DEFINE FMX. Renamed Ics.Posix.Messages.pas to Ics.Posix.PXMessages.pas. Dec 21, 2021 V8.68 Builds again, SSL issue. Added OpenSSL initialisations. Sep 10, 2022 V8.70 Default to OpenSSL 3.0. Display compiler version. Aug 08, 2023 V9.0 Updated version to major release 9. Feb 07, 2024 V9.1 Added OverbyteIcsSslBase which now includes TSslContext,TX509Base and TX509List. Aug 07, 2024 V9.3 Added OverbyteIcsTypes for consolidated types and constants, allowing other import units to be removed. Sep 01, 2026 V9.8 Commonise sample caption version and date, from Types. IcsLogger gone, USE_SSL gone, removed old MacOS Posix stuff. New logging tick boxes, SSL session cache gone. https://www.ftptest.org/ is default which is ICS OverbyteIcsDDWebService sample. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} unit IcsHttpsTst1; {$B-} { Enable partial boolean evaluation } {$T-} { Untyped pointers } {$X+} { Enable extended syntax } {$H+} { Use long strings } {$J+} { Allow typed constant to be modified } {$WARN SYMBOL_PLATFORM OFF} {$WARN SYMBOL_LIBRARY OFF} {$WARN SYMBOL_DEPRECATED OFF} {$I Include\OverbyteIcsDefs.inc} {$DEFINE FMX} interface {$IF CompilerVersion < 23} {$MESSAGE FATAL 'This project requires Delphi or RAD Studio XE2 or better'}; {$IFEND} uses {$IFDEF MSWINDOWS} Winapi.Windows, WinApi.Messages, {$ENDIF} System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, System.IOUtils, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Layouts, FMX.Memo, FMX.Edit, FMX.ListBox, FMX.TabControl, FMX.StdCtrls, FMX.Memo.Types, FMX.Controls.Presentation, FMX.ScrollBox, OverbyteIcsTypes, { V9.3 consolidated types and constants } Ics.Fmx.OverbyteIcsWndControl, Ics.Fmx.OverbyteIcsSslBase, Ics.Fmx.OverbyteIcsHttpProt, OverbyteIcsIniFiles, OverbyteIcsUtils, OverbyteIcsHttpCCodZLib, OverbyteIcsCookies; const HttpsTstVersion = IcsVerLitNum; { V9.8 } HttpsTstName = 'HttpsTst'; CopyRight : String = ' HttpsTst' + IcsVerLitCopyright; { V9.8 } type THttpsTstForm = class(TForm) DisplayMemo: TMemo; SslHttpCli1: TSslHttpCli; DocumentMemo: TMemo; Splitter1: TSplitter; ToolsPanel: TPanel; Label1: TLabel; Label8: TLabel; Label9: TLabel; Label2: TLabel; Label3: TLabel; Label7: TLabel; Label10: TLabel; Label6: TLabel; Label4: TLabel; Label5: TLabel; Label11: TLabel; Label15: TLabel; Label16: TLabel; UrlEdit: TEdit; SocksServerEdit: TEdit; SocksPortEdit: TEdit; DocEdit: TEdit; CertFileEdit: TEdit; CAFileEdit: TEdit; VerifyPeerCheckBox: TCheckBox; CAPathEdit: TEdit; PrivKeyFileEdit: TEdit; PassPhraseEdit: TEdit; SocksLevelComboBox: TComboBox; GetButton: TButton; ClearButton: TButton; CloseButton: TButton; ProxyHostEdit: TEdit; ProxyPortEdit: TEdit; SslContext1: TSslContext; Label17: TLabel; Label18: TLabel; DateTimeEdit: TEdit; HeadButton: TButton; AbortButton: TButton; ListBoxItem1: TListBoxItem; ListBoxItem2: TListBoxItem; ListBoxItem3: TListBoxItem; DebugLogHdr: TCheckBox; HttpVersionComboBox: TComboBox; ListBoxItem6: TListBoxItem; ListBoxItem7: TListBoxItem; IcsCookies: TIcsCookies; DebugLogProxy: TCheckBox; DebugLogSsl: TCheckBox; DebugLogCerts: TCheckBox; procedure FormShow(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormCreate(Sender: TObject); procedure GetButtonClick(Sender: TObject); procedure SslHttpCli1SslVerifyPeer(Sender: TObject; var Ok: Integer; Cert : TX509Base); procedure FormDestroy(Sender: TObject); procedure SslHttpCli1RequestDone(Sender: TObject; RqType: THttpRequest; ErrCode: Word); procedure ClearButtonClick(Sender: TObject); procedure CloseButtonClick(Sender: TObject); procedure SslHttpCli1Cookie(Sender: TObject; const Data: String; var Accept: Boolean); procedure SslHttpCli1DocBegin(Sender: TObject); procedure SslHttpCli1DocEnd(Sender: TObject); procedure SslHttpCli1LocationChange(Sender: TObject); procedure SslHttpCli1SslCliNewSession(Sender: TObject; SslSession: Pointer; WasReused: Boolean; var IncRefCount: Boolean); procedure SslHttpCli1SslCliGetSession(Sender: TObject; var SslSession: Pointer; var FreeSession: Boolean); procedure SslHttpCli1SslHandshakeDone(Sender: TObject; ErrCode: Word; PeerCert: TX509Base; var Disconnect: Boolean); procedure SslHttpCli1SslCliCertRequest(Sender: TObject; var Cert: TX509Base); procedure ButtonOSSLVersionClick(Sender: TObject); procedure IcsLogger1IcsLogEvent(Sender: TObject; DebugOption: TLogOption; const Msg: String); procedure HeadButtonClick(Sender: TObject); procedure AbortButtonClick(Sender: TObject); procedure SslHttpCli1DocData(Sender: TObject; Buffer: Pointer; Len: Integer); procedure IcsCookiesNewCookie(Sender: TObject; ACookie: TCookie; var Save: Boolean); procedure SslHttpCli1Display(Sender: TObject; const Msg: string); private FIniFileName : String; FInitialized : Boolean; FClientCerts : TX509List; FDocFileName : String; FByteCount : Integer; FStartTime : Integer; FCurrentRequest : THttpRequest; /// FNotifyWindow : HWND; procedure BackgroundException(Sender: TObject; E: Exception; var CanClose: Boolean); procedure PrepareConnection; procedure SetButtonState(State: Boolean); procedure TransfertStats; public procedure Display(Msg : String); property IniFileName : String read FIniFileName write FIniFileName; end; var HttpsTstForm: THttpsTstForm; implementation {$R *.FMX} uses DemoUtils, IcsCliCertDlg; const SectionWindow = 'HttpTstMainWindow'; KeyTop = 'Top'; KeyLeft = 'Left'; KeyWidth = 'Width'; KeyHeight = 'Height'; SectionData = 'Data'; KeyUrl = 'Url'; KeySocksServer = 'SocksServer'; KeySocksPort = 'SocksPort'; KeySocksLevel = 'SocksLevelIndex'; KeyProxyHost = 'ProxyHost'; KeyProxyPort = 'ProxyPort'; KeyDateTime = 'DateTime'; KeyDoc = 'Doc'; KeyCertFile = 'CertFile'; KeyPassPhrase = 'PassPhrase'; KeyPrivKeyFile = 'PrivKeyFile'; KeyCAFile = 'CAFile'; KeyCAPath = 'CAPath'; KeyLineMode = 'LineMode'; KeyVerifyPeer = 'VerifyPeer'; KeyAcceptableHosts = 'AcceptableHosts'; KeyHttpVer = 'HttpVer'; KeySessCache = 'SessCache'; KeyDebugLogHdr = 'DebugLogHdr'; KeyDebugLogProxy = 'DebugDebugLogProxy'; KeyDebugLogCerts = 'DebugLogCerts'; KeyDebugLogSsl = 'DebugLogSsl'; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.FormCreate(Sender: TObject); begin Caption := Caption + IcsVerLitSample; { V9.8 commonise sample caption version and date } {$IFDEF MSWINDOWS} ReportMemoryLeaksOnShutdown := (DebugHook <> 0); {$ENDIF} IcsNameThreadForDebugging('Main'); FIniFileName := GetIcsIniFileName; SslHttpCli1.CtrlSocket.OnBgException := BackgroundException; FormShow(Self); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.FormDestroy(Sender: TObject); begin FClientCerts.Free; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.FormShow(Sender: TObject); var IniFile : TIcsIniFile; begin if not FInitialized then begin DisplayMemo.Lines.Clear; FInitialized := TRUE; IniFile := TIcsIniFile.Create(FIniFileName); try Width := IniFile.ReadInteger(SectionWindow, KeyWidth, Width); Height := IniFile.ReadInteger(SectionWindow, KeyHeight, Height); Top := IniFile.ReadInteger(SectionWindow, KeyTop, (ScreenHeight - Height) div 2); Left := IniFile.ReadInteger(SectionWindow, KeyLeft,(ScreenWidth - Width) div 2); UrlEdit.Text := IniFile.ReadString(SectionData, KeyUrl, 'https://www.ftptest.org/'); // 'http://localhost'); { V9.8 } SocksServerEdit.Text := IniFile.ReadString(SectionData, KeySocksServer, ''); SocksPortEdit.Text := IniFile.ReadString(SectionData, KeySocksPort, '1080'); ProxyHostEdit.Text := IniFile.ReadString(SectionData, KeyProxyHost, ''); ProxyPortEdit.Text := IniFile.ReadString(SectionData, KeyProxyPort, '8080'); DateTimeEdit.Text := IniFile.ReadString(SectionData, KeyDateTime, ''); DocEdit.Text := IniFile.ReadString(SectionData, KeyDoc, '/index.html'); CertFileEdit.Text := IniFile.ReadString(SectionData, KeyCertFile, ''); PrivKeyFileEdit.Text := IniFile.ReadString(SectionData, KeyPrivKeyFile, ''); PassPhraseEdit.Text := IniFile.ReadString(SectionData, KeyPassPhrase, ''); CAFileEdit.Text := IniFile.ReadString(SectionData, KeyCAFile, ''); CAPathEdit.Text := IniFile.ReadString(SectionData, KeyCAPath, ''); SocksLevelComboBox.ItemIndex := IniFile.ReadInteger(SectionData, KeySocksLevel, 0); VerifyPeerCheckBox.IsChecked := Boolean(IniFile.ReadInteger(SectionData, KeyVerifyPeer, 0)); HttpVersionComboBox.ItemIndex := IniFile.ReadInteger(SectionData, KeyHttpVer, 1); DebugLogHdr.IsChecked := IniFile.ReadBool(SectionData, KeyDebugLogHdr, True); { V9.6 } DebugLogProxy.IsChecked := IniFile.ReadBool(SectionData, KeyDebugLogProxy, True); { V9.6 } DebugLogSsl.IsChecked := IniFile.ReadBool(SectionData, KeyDebugLogSsl, True); { V9.6 } DebugLogCerts.IsChecked := IniFile.ReadBool(SectionData, KeyDebugLogCerts, True); { V9.6 } DisplayMemo.Lines.Add('Read INI, URL=' + UrlEdit.Text); finally IniFile.Free; end; end; { V8.70 load OpenSSL, then display OpenSSL DLL name and version } GSSLEAY_DLL_IgnoreNew := True; // V10.0 force OpenSSL 3, not 4 IcsSslRootCAStore.Initialise; { loads OpenSSL and certificate bundle } DisplayMemo.Lines.Add(IcsReportOpenSSLVer); DisplayMemo.Lines.Add ('Compiler: ' + IcsBuiltWithEx + ' FMX ' + IntToStr(FMX.Types.FireMonkeyVersion)); { V8.70 } DisplayMemo.Lines.Add('INI File: ' + FIniFileName); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.FormClose(Sender: TObject; var Action: TCloseAction); var IniFile : TIcsIniFile; begin IniFile := TIcsIniFile.Create(FIniFileName); IniFile.WriteInteger(SectionWindow, KeyTop, Top); IniFile.WriteInteger(SectionWindow, KeyLeft, Left); IniFile.WriteInteger(SectionWindow, KeyWidth, Width); IniFile.WriteInteger(SectionWindow, KeyHeight, Height); IniFile.WriteString(SectionData, KeyUrl, UrlEdit.Text); IniFile.WriteString(SectionData, KeySocksServer, SocksServerEdit.Text); IniFile.WriteString(SectionData, KeySocksPort, SocksPortEdit.Text); IniFile.WriteString(SectionData, KeyProxyHost, ProxyHostEdit.Text); IniFile.WriteString(SectionData, KeyProxyPort, ProxyPortEdit.Text); IniFile.WriteString(SectionData, KeyDateTime, DateTimeEdit.Text); IniFile.WriteInteger(SectionData, KeyVerifyPeer, Ord(VerifyPeerCheckBox.IsChecked)); IniFile.WriteString(SectionData, KeyDoc, DocEdit.Text); IniFile.WriteString(SectionData, KeyCertFile, CertFileEdit.Text); IniFile.WriteString(SectionData, KeyPrivKeyFile, PrivKeyFileEdit.Text); IniFile.WriteString(SectionData, KeyPassPhrase, PassPhraseEdit.Text); IniFile.WriteString(SectionData, KeyCAFile, CAFileEdit.Text); IniFile.WriteString(SectionData, KeyCAPath, CAPathEdit.Text); IniFile.WriteInteger(SectionData, KeySocksLevel, SocksLevelComboBox.ItemIndex); IniFile.WriteInteger(SectionData, KeyHttpVer, HttpVersionComboBox.ItemIndex); IniFile.WriteBool(SectionData, KeyDebugLogHdr, DebugLogHdr.IsChecked); { V9.6 } IniFile.WriteBool(SectionData, KeyDebugLogProxy, DebugLogProxy.IsChecked); { V9.6 } IniFile.WriteBool(SectionData, KeyDebugLogSsl, DebugLogSsl.IsChecked); { V9.6 } IniFile.WriteBool(SectionData, KeyDebugLogCerts, DebugLogCerts.IsChecked); { V9.6 } IniFile.UpdateFile; IniFile.Free; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.Display(Msg : String); var I, J : Integer; begin DisplayMemo.Lines.BeginUpdate; try if DisplayMemo.Lines.Count > 1000 then begin while DisplayMemo.Lines.Count > 1000 do DisplayMemo.Lines.Delete(0); end; // Display Msg, breaking it into separate lines // Line end is either LF alone or CR/LF pair I := 1; while I <= Length(Msg) do begin J := I; while (I <= Length(Msg)) and (Msg[I] <> #10) do Inc(I); if (I > 1) and (I <= Length(Msg)) and (Msg[I] = #10) and (Msg[I-1] = #13) then DisplayMemo.Lines.Add(Copy(Msg, J, I -J - 1)) else DisplayMemo.Lines.Add(Copy(Msg, J, I - J)); Inc(I); end; finally DisplayMemo.Lines.EndUpdate; DisplayMemo.GoToTextEnd; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.PrepareConnection; const SocksLevelValues : array [0..2] of String = ('5', '4A', '4'); begin { V9.8 what we want to log using WSocket onDebugDisplay event, replaces lots of local logging } // SslHttpCli1.WSDebugOptions := DefWSDebugClient; // simple way SslHttpCli1.WSDebugOptions := [wsdlogConnWS, wsdlogInfo, wsdlogErrs, wsdlogDns]; if DebugLogHdr.IsChecked then SslHttpCli1.WSDebugOptions := SslHttpCli1.WSDebugOptions + [wsdlogHdr]; if DebugLogProxy.IsChecked then SslHttpCli1.WSDebugOptions := SslHttpCli1.WSDebugOptions + [wsdlogProxy]; if DebugLogSsl.IsChecked then SslHttpCli1.WSDebugOptions := SslHttpCli1.WSDebugOptions + [wsdlogSsl]; if DebugLogCerts.IsChecked then SslHttpCli1.WSDebugOptions := SslHttpCli1.WSDebugOptions + [wsdlogCerts]; // SslHttpCli1.WSDebugOptions := SslHttpCli1.WSDebugOptions + [wsdlogMsgs]; // !!! TEMP new messages if SocksServerEdit.Text > '' then begin SslHttpCli1.SocksServer := SocksServerEdit.Text; SslHttpCli1.SocksPort := SocksPortEdit.Text; SslHttpCli1.SocksLevel := SocksLevelValues[SocksLevelComboBox.ItemIndex]; end else begin SslHttpCli1.SocksServer := ''; SslHttpCli1.SocksPort := ''; SslHttpCli1.SocksLevel := '5'; end; if ProxyHostEdit.Text > '' then begin SslHttpCli1.Proxy := ProxyHostEdit.Text; SslHttpCli1.ProxyPort := ProxyPortEdit.Text; end else begin SslHttpCli1.Proxy := ProxyHostEdit.Text; SslHttpCli1.ProxyPort := ProxyPortEdit.Text; end; SslHttpCli1.URL := UrlEdit.Text; SslHttpCli1.AcceptLanguage := 'en, fr'; SslHttpCli1.Connection := 'Keep-Alive'; SslHttpCli1.RequestVer := '1.' + IntToStr(HttpVersionComboBox.ItemIndex); SslHttpCli1.ResponseNoException := True; { V9.8 } if DateTimeEdit.Text <> '' then SslHttpCli1.ModifiedSince := StrToDateTime(DateTimeEdit.Text) else SslHttpCli1.ModifiedSince := 0; SslHttpCli1.Cookie := IcsCookies.GetCookies(SslHttpCli1.URL); SslContext1.SslCertFile := CertFileEdit.Text; SslContext1.SslPassPhrase := PassPhraseEdit.Text; SslContext1.SslPrivKeyFile := PrivKeyFileEdit.Text; SslContext1.SslCAFile := CAFileEdit.Text; SslContext1.SslCAPath := CAPathEdit.Text; SslContext1.SslVerifyPeer := VerifyPeerCheckBox.IsChecked; SslContext1.SslVersionMethod := sslV23_CLIENT; SslContext1.UseSharedCAStore := True; { V9.1 } if SslContext1.SslVerifyPeer then { V9.6 report chain } SslHttpCli1.SslCertVerMethod := CertVerBundle else SslHttpCli1.SslCertVerMethod := CertVerNone; SslHttpCli1.SslAllowSelfSign := True; { V9.6 chain is allowed self signed testing certicates } try SslContext1.InitContext; { get any error now before making request } except on E:Exception do begin Display('Failed to initialize SSL Context: ' + E.Message); Exit; end; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.GetButtonClick(Sender: TObject); begin try PrepareConnection; Display('Connecting...'); GetButton.Enabled := FALSE; DocumentMemo.Lines.Clear; FCurrentRequest := httpGet; SslHttpCli1.GetAsync; except on E: Exception do begin Display('Connect error. ' + E.Classname + ': ' + E.Message); Exit; end; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.ClearButtonClick(Sender: TObject); begin DocumentMemo.Lines.Clear; DisplayMemo.Lines.Clear; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.CloseButtonClick(Sender: TObject); begin SslHttpCli1.CloseAsync; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1Cookie( Sender : TObject; const Data : String; var Accept : Boolean); begin IcsCookies.SetCookie (Data, SslHttpCli1.Url); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1Display(Sender: TObject; const Msg: string); { V9.6 } begin Display(Msg); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1DocBegin(Sender: TObject); var HttpCli : TSslHttpCli; begin FByteCount := 0; FStartTime := IcsGetTickCount; HttpCli := Sender as TSslHttpCli; Display(HttpCli.ContentType + ' => ' + HttpCli.DocName); Display('Document = ' + HttpCli.DocName); FDocFileName := HttpCli.DocName; if HttpCli.ContentType = 'image/gif' then ReplaceExt(FDocFileName, 'gif') else if HttpCli.ContentType = 'image/jpeg' then ReplaceExt(FDocFileName, 'jpg') else if HttpCli.ContentType = 'image/bmp' then ReplaceExt(FDocFileName, 'bmp'); if FDocFileName = '' then FDocFileName := 'HttpTst.htm'; try HttpCli.RcvdStream := TFileStream.Create(FDocFileName, fmCreate); except on E:Exception do begin Display('Error opening file: ' + E.Message); FDocFileName := 'HttpTst.htm'; Display('Using default file name: ' + FDocFileName); HttpCli.RcvdStream := TFileStream.Create(FDocFileName, fmCreate); end; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1DocData(Sender: TObject; Buffer: Pointer; Len: Integer); begin Inc(FByteCount, Len); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.TransfertStats; var Buffer : String; BytesSec : Int64 ; Duration : Int64 ; { V2.100 allow wrap at 49 days, don't show 0 secs or silly bps } FStopTime : Integer; begin FStopTime := LongInt(IcsGetTickCount); Buffer := IntToSTr(FByteCount) + ' bytes document received/sent in '; if DWORD (FStopTime) >= DWORD (FStartTime) then { V2.102 fix zero duration downloads } Duration := DWORD (FStopTime) - DWORD (FStartTime) else Duration := ($FFFFFFFF - DWORD (FStartTime)) + DWORD (FStopTime); if Duration < 5000 then Buffer := Buffer + IntToStr(Duration) + ' milliseconds' else begin Buffer := Buffer + IntToStr(Duration div 1000) + ' seconds'; if FStopTime <> FStartTime then begin if FByteCount > 32767 then BytesSec := 1000 * (FByteCount div Duration) else BytesSec := (1000 * FByteCount) div Duration; Buffer := Buffer + ' (' + IntToStr(BytesSec) + ' Bytes/sec)'; end; end; Display('! ' + Buffer); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1DocEnd(Sender: TObject); var HttpCli : TSslHttpCli; begin TransfertStats; HttpCli := Sender as TSslHttpCli; if Assigned(HttpCli.RcvdStream) then begin HttpCli.RcvdStream.Free; HttpCli.RcvdStream := nil; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1LocationChange(Sender: TObject); var SslHttpCli : TSslHttpCli; begin SslHttpCli := Sender as TSslHttpCli; Display('Location changed to "' + SslHttpCli.Location + '"'); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1RequestDone( Sender : TObject; RqType : THttpRequest; ErrCode : Word); var DataIn : TStream; begin if RqType <> httpGet then // Head is sync Exit; GetButton.Enabled := TRUE; if (ErrCode <> 0) then begin Display('Request done, error #' + IntToStr(ErrCode)); Exit; end; Display('Request done, StatusCode #' + IntToStr(SslHttpCli1.StatusCode)); if SslHttpCli1.DocName = '' then DocumentMemo.Lines.Add('*** NO DOCUMENT FILE NAME ***') else begin if not FileExists(SslHttpCli1.DocName) then DocumentMemo.Lines.Add('*** NO DOCUMENT FILE ***') else begin DataIn := TFileStream.Create(SslHttpCli1.DocName, fmOpenRead); try if Copy(SslHttpCli1.ContentType, 1, 5) = 'text/' then DocumentMemo.Lines.LoadFromStream(DataIn) else begin DocumentMemo.Lines.Add('Content type is ' + SslHttpCli1.ContentType); DocumentMemo.Lines.Add('Document stored in ''' + SslHttpCli1.DocName + ''' Size=' + IntToStr(DataIn.Size)); end; finally DataIn.Free; end; end; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1SslCliNewSession(Sender: TObject; SslSession : Pointer; WasReused : Boolean; var IncRefCount : Boolean); begin end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1SslCliGetSession( Sender : TObject; var SslSession : Pointer; var FreeSession : Boolean); begin end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1SslVerifyPeer( Sender : TObject; var Ok : Integer; Cert : TX509Base); begin end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1SslHandshakeDone(Sender: TObject; ErrCode: Word; PeerCert: TX509Base; var Disconnect : Boolean); // If TRUE will close the connection delayed! begin // Display('Handshake done, error #' + IntToStr(ErrCode)); now done in WSocket end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SslHttpCli1SslCliCertRequest(Sender: TObject; var Cert: TX509Base); var X : TX509Base; begin { A very simple test of the SslCliCertRequest event. } { This event is triggered only if CertFileEdit.Text is empty, } { the server requested a certificate from the client, } { and of course only in case of the SSL session wasn't reused. } if not Assigned(FClientCerts) then begin if not Assigned(ClientCertDlg) then Application.CreateForm(TClientCertDlg, ClientCertDlg); { Create a pool of client certs } ClientCertDlg.CertListBox.Clear; FClientCerts := TX509List.Create(Self); try X := FClientCerts.Add; X.LoadFromPemFile('01cert.pem'); X.PrivateKeyLoadFromPemFile('01key.pem', 'password'); ClientCertDlg.CertListBox.Items.Add(X.SubjectOneLine); X := FClientCerts.Add; X.LoadFromPemFile('client.pem', True, 'password'); ClientCertDlg.CertListBox.Items.Add(X.SubjectOneLine); except FreeAndNil(FClientCerts); raise end; end; ClientCertDlg.CertListBox.ItemIndex := 0; if ClientCertDlg.ShowModal = mrOK then Cert := FClientCerts[ClientCertDlg.CertListBox.ItemIndex]; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.ButtonOSSLVersionClick(Sender: TObject); begin end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.BackgroundException( Sender : TObject; E : Exception; var CanClose : Boolean); begin Display('!' + E.ClassName + ': ' + E.Message); CanClose := TRUE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.IcsCookiesNewCookie(Sender: TObject; ACookie: TCookie; var Save: Boolean); var S: string; begin with ACookie do begin S := 'NewCookie: ' + CName + '=' + CValue + ', Domain=' + CDomain + ', Path=' + CPath ; if CPersist then S := S + ', Expires=' + DateTimeToStr (CExpireDT) else S := S + ', Not Persisent'; if CSecureOnly then S := S + ', SecureOnly'; if CHttpOnly then S := S + ', HttpOnly'; Display (S); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.IcsLogger1IcsLogEvent(Sender: TObject; DebugOption: TLogOption; const Msg: String); begin Display(Msg); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.SetButtonState(State : Boolean); begin GetButton.Enabled := State; HeadButton.Enabled := State; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.HeadButtonClick(Sender: TObject); begin DisplayMemo.Lines.Clear; DocumentMemo.Lines.Clear; SetButtonState(FALSE); try PrepareConnection; SslHttpCli1.RcvdStream := nil; try FCurrentRequest := httpHead; SslHttpCli1.Head; except Display('HEAD Failed !'); Display('StatusCode = ' + IntToStr(SslHttpCli1.StatusCode)); Display('ReasonPhrase = ' + SslHttpCli1.ReasonPhrase); Exit; end; Display('StatusCode = ' + IntToStr(SslHttpCli1.StatusCode)); finally SetButtonState(TRUE); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpsTstForm.AbortButtonClick(Sender: TObject); begin SslHttpCli1.Abort; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} end.