' + #13#10 + '
OpenSSL Version: ' + IcsReportOpenSSLVer + '
' + #13#10#13#10 + { V9.1 }
'Server SSL Certificates:
' + #13#10 +
FSrvSslCert + '
' + #13#10 +
'OpenSSL Server Ciphers: ' + FSrvCipherList + '
' + #13#10 + 'SSL Ciphers from Client: ' + FCliCipherList + '
' + #13#10 + 'Note: There is a better demo OverbyteIcsSslMultiWebServ.
' + #13#10 + '' + #13#10 + '' + #13#10; TMyHttpConnection(Client).AnswerString(Flags, '', { Default Status '200 OK' } '', { Default Content-Type: text/html } '', { Default header } Body); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { This procedure is use to generate /time.htm document } procedure TSslWebServForm.CreateVirtualDocument_time_htm( Sender : TObject; { HTTP server component } Client : TObject; { Client connection issuing command } var Flags : THttpGetFlag); { Tells what HTTP server has to do next } var Body : String; Header : String; Stream : TMemoryStream; begin { Let HTTP server component know we will send data to client } Flags := hgWillSendMySelf; { Create a stream to hold data sent to client that is the answer } { made of a HTTP header and a body made of HTML code. } Stream := TMemoryStream.Create; Body := '' + '
' + '' + DateTimeToStr(Now) +'
' + #13#10 + '' + '' + #13#10; Header := TMyHttpConnection(Client).Version + ' 200 OK' + #13#10 + 'Content-Type: text/html' + #13#10 + 'Content-Length: ' + IntToStr(Length(Body)) + #13#10 + #13#10; //Stream.Write(Header[1], Length(Header)); StreamWriteStrA(Stream, Header); //Stream.Write(Body[1], Length(Body)); StreamWriteStrA(Stream, Body); { We need to seek to start of stream ! } Stream.Seek(0, 0); { We ask server component to send the stream for us. } TMyHttpConnection(Client).DocStream := Stream; TMyHttpConnection(Client).SendStream; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { This event handler is triggered when HTTP server component receive a POST } { command from any client. } { We count the request, display a message and trap posted data. } { To check for posted data, you may construct the following HTML document: } { } { } {' + FirstName + '.' + LastName + '@' + HostName +'
' + '' + '' + #13#10; Header := Client.Version + ' 200 OK' + #13#10 + 'Content-Type: text/html' + #13#10 + 'Content-Length: ' + IntToStr(Length(Body)) + #13#10 + #13#10; //Stream.Write(Header[1], Length(Header)); StreamWriteStrA(Stream, Header); //Stream.Write(Body[1], Length(Body)); StreamWriteStrA(Stream, Body); Stream.Seek(0, 0); { Ask HTTP server component to send data stream for us } Client.DocStream := Stream; Client.SendStream; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { procedure TSslWebServForm.DisplayHeader(Client : TMyHttpConnection); V9.6 no longer needed, done in server var I : Integer; begin if not DisplayHeaderCheckBox.Checked then Exit; for I := 0 to Client.RequestHeader.Count - 1 do Display('HDR' + IntToStr(I + 1) + ') ' + Client.RequestHeader.Strings[I]); end; } {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} constructor TMyHttpConnection.Create(AOwner: TComponent); begin inherited; { Little speed test } //SndBlkSize := 10 * 1024; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { We need to override parent class destructor because we have allocated } { memory for our data buffer. } destructor TMyHttpConnection.Destroy; begin if Assigned(FPostedDataBuffer) then begin FreeMem(FPostedDataBuffer, FPostedDataSize); FPostedDataBuffer := nil; FPostedDataSize := 0; end; if Assigned(FPostedRawData) then begin FreeMem(FPostedRawData); FPostedRawData := nil; FPostedDataSize := 0; end; inherited Destroy; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.OpenLogFile; begin if FLogFileOpened then Exit; try AssignFile(FLogFile, FLogFileName); if FileExists(FLogFileName) then Append(FLogFile) else Rewrite(FLogFile); WriteLn(FLogFile, '[' + FormatDateTime('HH:NN:SS YYYY/MM/DD', Now) + ' Log file opened.]'); FLogFileOpened := TRUE; except FLogFileOpened := FALSE; Display('*** Unable to open log file ***'); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.CloseLogFile; begin if not FLogFileOpened then Exit; FLogFileOpened := FALSE; WriteLn(FLogFile, '[' + FormatDateTime('HH:NN:SS YYYY/MM/DD', Now) + ' Log file Closed.]'); CloseFile(FLogFile); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.WriteLogFileCheckBoxClick(Sender: TObject); begin if WriteLogFileCheckBox.Checked then OpenLogFile else CloseLogFile; WriteLogFileCheckBox.Checked := FLogFileOpened; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.SslHttpServer1SslVerifyPeer( Sender : TObject; var Ok : Integer; Cert : TX509Base); begin if DisplaySslInfoCheckBox.Checked then Display('Received certificate'#13#10 + 'Subject: ' + Cert.SubjectOneLine + #13#10 + 'Issuer: ' + Cert.IssuerOneLine); if OK <> 1 then begin if DisplaySslInfoCheckBox.Checked then Display('Error msg: ' + Cert.VerifyErrMsg + #13#10 + 'In this example we accept any cert'); OK := 1; //In this example we accept any client. end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.SslHttpServer1SslSetSessionIDContext( Sender : TObject; var SessionIDContext : String); begin { Tell Openssl a Session_ID_Context. } { Openssl uses this data to tag a session before it's cached. } SessionIDContext := Ssl_Session_ID_Context; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.SslHttpServer1SslSvrGetSession( Sender : TObject; var SslSession : Pointer; SessId : Pointer; Idlen : Integer; var IncRefCount : Boolean); var LookupKey : string; begin {$IFDEF UNICODE} { We need to get binary data into a UnicodeString, allocate enough space. } { Not nice, however works in this case. } SetLength(LookupKey, (IDLen div 2) + (IdLen mod 2)); {$ELSE} SetLength(LookupKey, IDLen); {$ENDIF} Move(SessId^, Pointer(LookupKey)^, IDLen); SslSession := SslAvlSessionCache1.GetSvrSession(LookupKey + Ssl_Session_ID_Context, IncRefCount); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.SslHttpServer1SslSvrNewSession( Sender : TObject; SslSession, SessId : Pointer; Idlen : Integer; var AddToInternalCache : Boolean); var LookupKey : string; begin {$IFDEF UNICODE} { We need to get binary data into a UnicodeString, allocate enough space. } { Not nice, however works in this case. } SetLength(LookupKey, (IDLen div 2) + (IdLen mod 2)); {$ELSE} SetLength(LookupKey, IDLen); {$ENDIF} Move(SessId^, Pointer(LookupKey)^, IDLen); SslAvlSessionCache1.CacheSvrSession(SslSession, LookupKey + Ssl_Session_ID_Context, AddToInternalCache); if DisplaySslInfoCheckBox.Checked then Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + TWSocket(Sender).GetPeerAddr + '] New SSL session created and ' + 'cached in external cache class.'); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.SslHttpServer1BeforeProcessRequest( Sender, Client : TObject); var Ticks : Longword; Remote : TMyHttpConnection; begin Remote := Client as TMyHttpConnection; { Request SSL3 renegotiation - doesn't work with IE so far!? } if Remote.SslEnable and (FRenegotiationInterval > 0) then begin Ticks := GetTickCount; if Remote.LastHandshake + FRenegotiationInterval < Ticks then begin if not Remote.SslStartRenegotiation then begin if DisplaySslInfoCheckBox.Checked then Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + Remote.GetPeerAddr + '] SslStartRenegotiation failed '); end else if DisplaySslInfoCheckBox.Checked then Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + Remote.GetPeerAddr + '] SSL renegotiation flag set.'); end; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.SslHttpServer1SslHandshakeDone( Sender : TObject; ErrCode : Word; PeerCert : TX509Base; var Disconnect : Boolean); var Remote : TMyHttpConnection; begin Remote := Sender as TMyHttpConnection; FCliCipherList := Remote.SslGetSupportedCiphers (True, True); FCliCipherList := StringReplace(FCliCipherList, #13#10, ', ', [rfReplaceAll]); // normally list Client Hello in Server Name event, do it here if no name // list SMI, ALPN, versioon, extensions and stuff from Cli.CliHelloData if Remote.SslServerName = '' then Display('Client Hello: ' + WSocketGetCliHelloStr(Remote.CliHelloData)); if ErrCode = 0 then begin Remote.LastHandshake := GetTickCount; if DisplaySslInfoCheckBox.Checked then begin Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + Remote.GetPeerAddr + '] ' + Remote.SslHandshakeRespMsg + ', SessionReused ' + IntToStr (Ord(Remote.SslSessionReused))); { V8.01 } Display('SSL Ciphers from Client: ' + #13#10 + FCliCipherList + #13#10); end; end else if DisplaySslInfoCheckBox.Checked then begin Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + Remote.GetPeerAddr + '] SslHandshake failed, error #' + IntToStr (ErrCode) + ' - ' + Remote.SslHandshakeRespMsg); { V8.01 } Display('SSL Ciphers from Client: ' + #13#10 + FCliCipherList + #13#10); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.ButtonOSSLVersionClick(Sender: TObject); begin end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.RenegotiationIntervalEditChange(Sender: TObject); begin try FRenegotiationInterval := StrToInt((Sender as TEdit).Text); except FRenegotiationInterval := 0; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSslWebServForm.BackgroundException( Sender : TObject; E : Exception; var CanClose : Boolean); begin raise Exception.Create('BgException: ' + E.ClassName + ': ' + E.Message); //Test CanClose := TRUE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} end.