Command: ' + ClientCnx.Path + '
' + icsCRLF + 'Back to demo menu' + IcsCRLF; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1HttpMimeContentType(Sender, Client: TObject; const FileName: string; var ContentType: string); var ClientCnx : TMyHttpConnection; begin ClientCnx := TMyHttpConnection(Client); Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.CPeerAddr + '] ' + ': Document: ' + FileName + ', Content-Type: ' + ContentType); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1HttpRequestDone(Sender, Client: TObject); { V9.2 } var ClientCnx : TMyHttpConnection; begin ClientCnx := TMyHttpConnection(Client); Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.CPeerAddr + '] Request Completed, Status ' + IntToStr(ClientCnx.AnswerStatus) + IcsCRLF); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1HttpRespHdr(Sender, Client: TObject; const Header: string); { V8.69 } {var ClientCnx : TMyHttpConnection; } begin { if not DisplayHeaderCheckBox.Checked then V9.6 not needed Exit; ClientCnx := TMyHttpConnection(Client); Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.CPeerAddr + '] Response Headers'); Display(Header); } end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1OptionsDocument(Sender, Client: TObject; var Flags: THttpGetFlag); //var // ClientCnx : TMyHttpConnection; begin { It's easier to do the cast one time. Could use with clause... } // ClientCnx := TMyHttpConnection(Client); // { Count request and display a message } // InterlockedIncrement(FCountRequests); // Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.CPeerAddr + '] ' + ClientCnx.HostTag + ' OPTIONS ' + ClientCnx.Path); // DisplayHeader(ClientCnx); Exit; { let web server send general response } { path may be the resource for which OPTIONS should be checked } end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1PatchDocument(Sender, Client: TObject; var Flags: THttpGetFlag); var ClientCnx : TMyHttpConnection; begin if Flags = hg401 then { Not authenticated (yet), we might be still in an authentication } { session with ClientCnx.RequestContentLength = 0 which was valid, } { i.e. NTLM uses a challenge/response method, anyway just exit. } Exit; { It's easier to do the cast one time. Could use with clause... } ClientCnx := TMyHttpConnection(Client); // { Count request and display a message } // InterlockedIncrement(FCountRequests); // Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.CPeerAddr + '] ' + ClientCnx.HostTag + ' PATCH ' + ClientCnx.Path); // DisplayHeader(ClientCnx); if (ClientCnx.RequestContentLength > (SslHttpAppSrv1.MaxUploadMB * IcsMBYTE)) then begin // or { V9.1 } // (ClientCnx.RequestContentLength <= 0) then begin if (ClientCnx.RequestContentLength > (SslHttpAppSrv1.MaxUploadMB * IcsMBYTE)) then Display('Upload size exceeded limit (' + IntToKByte((SslHttpAppSrv1.MaxUploadMB * IcsMBYTE)) + ')'); Flags := hg403; Exit; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1PostDocument(Sender, Client: TObject; var Flags: THttpGetFlag); var ClientCnx : TMyHttpConnection; begin if Flags = hg401 then { Not authenticated (yet), we might be still in an authentication } { session with ClientCnx.RequestContentLength = 0 which was valid, } { i.e. NTLM uses a challenge/response method, anyway just exit. } Exit; { It's easier to do the cast one time. Could use with clause... } ClientCnx := TMyHttpConnection(Client); Display('PostDocument Event reached, Content Len=' + IntToStr(ClientCnx.RequestContentLength)); { V9.8 } // { Count request and display a message } // InterlockedIncrement(FCountRequests); // Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.CPeerAddr + '] ' + ClientCnx.HostTag + ' POST ' + ClientCnx.Path); // DisplayHeader(ClientCnx); { V8.69 webapp host is the one we handle here, V9.2 demoAuthAll.html now handled as template } if ClientCnx.HostTag = 'WEB-APP' then begin if CompareText(ClientCnx.Path, '/DemoBasicAuth.html') = 0 then begin // handled as virtual document CreateVirtualDocument_DemoBasicAuth(Sender, ClientCnx, Flags); Exit; end; end; { sanity check upload size } if (ClientCnx.RequestContentLength > (SslHttpAppSrv1.MaxUploadMB * IcsMBYTE)) then begin Display('Upload size exceeded limit (' + IntToKByte((SslHttpAppSrv1.MaxUploadMB * IcsMBYTE)) + ')'); Flags := hg403; Exit; end; { if (ClientCnx.RequestContentLength <= 0) then begin // V9.2 do we care? Display('No POST content'); Flags := hg404; Exit; end; } { NOTE - HttpAppSrv overrides POST data processing for which a UrlHandler must be provided. V8.69 incorrect, event is called! } end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { V9.2 this is where we'd accept posted data for virtual pages, but this sample only POSTs to template pages } procedure TWeblServerForm.SslHttpAppSrv1PostedData(Sender, Client: TObject; Error: Word); var ClientCnx : TMyHttpConnection; begin ClientCnx := TMyHttpConnection(Client); Display('PostedData Event reached'); { V9.8 } ClientCnx.PostedDataReceived; // got all the data we expected, ie none end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1PutDocument(Sender, Client: TObject; var Flags: THttpGetFlag); var ClientCnx : TMyHttpConnection; begin if Flags = hg401 then { Not authenticated (yet), we might be still in an authentication } { session with ClientCnx.RequestContentLength = 0 which was valid, } { i.e. NTLM uses a challenge/response method, anyway just exit. } Exit; { It's easier to do the cast one time. Could use with clause... } ClientCnx := TMyHttpConnection(Client); Display('PutDocument Event reached, Content Len=' + IntToStr(ClientCnx.RequestContentLength)); { V9.8 } // { Count request and display a message } // InterlockedIncrement(FCountRequests); // Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.CPeerAddr + '] ' + ClientCnx.HostTag + ' PUT ' + ClientCnx.Path); // DisplayHeader(ClientCnx); if (ClientCnx.RequestContentLength > (SslHttpAppSrv1.MaxUploadMB * IcsMBYTE)) then begin // or { V9.1 } // (ClientCnx.RequestContentLength <= 0) then begin if (ClientCnx.RequestContentLength > (SslHttpAppSrv1.MaxUploadMB * IcsMBYTE)) then Display('Upload size exceeded limit (' + IntToKByte((SslHttpAppSrv1.MaxUploadMB * IcsMBYTE)) + ')'); Flags := hg403; Exit; end; { URL may specify a file name or just a name, worry about it later } (* { Tell HTTP server that we will accept posted data } { OnPostedData event will be triggered when data comes in } Flags := hgAcceptData; { We wants to receive any data type. So we turn line mode off on } { client connection. } ClientCnx.LineMode := FALSE; { We need a buffer to hold posted data. We allocate as much as the } { size of posted data plus one byte for terminating nul char. } { We should check for ContentLength = 0 and handle that case... } ReallocMem(ClientCnx.FPostedRawData, ClientCnx.RequestContentLength + 1); { Clear received length } ClientCnx.FDataLen := 0; *) end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1QueryDocument(Sender, Client: TObject; var Flags: THttpGetFlag); { V9.8 } var ClientCnx : TMyHttpConnection; begin if Flags = hg401 then Exit; { It's easier to do the cast one time. Could use with clause... } ClientCnx := TMyHttpConnection(Client); Display('QueryDocument Event reached, Content Len=' + IntToStr(ClientCnx.RequestContentLength)); { V9.8 } end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1ServerStarted(Sender: TObject); begin Display('Server has started'); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1ServerStopped(Sender: TObject); begin SslHttpAppSrv1.WSessions.SaveToFile(FSessionFile); if Assigned(SslMultiWebDataModule) then { V9.8 prevent exception if freed } CleanupTimeStampedDir(SslMultiWebDataModule.DataDir); Display('Server is now stopped'); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1SslHandshakeDone(Sender: TObject; ErrCode: Word; PeerCert: TX509Base; var Disconnect: Boolean); var ClientCnx : TMyHttpConnection; Ciphers: String; begin ClientCnx := Sender as TMyHttpConnection; { V8.64 need to log client hello if no SNI, then ciphers } if DisplaySslInfo.Checked then begin if ClientCnx.SslServerName = '' then begin Display(ClientCnx.CPeerAddr + ' - Client Hello: ' + Trim(WSocketGetCliHelloStr(ClientCnx.CliHelloData))) ; end; Ciphers := Trim(ClientCnx.SslGetSupportedCiphers (True, True)); if Ciphers <> '' then begin Ciphers := StringReplace(Ciphers, #13#10, ', ', [rfReplaceAll]); Display('SSL Ciphers from Client: ' + Ciphers); end; end; Display(ClientCnx.CPeerAddr + ' - ' + ClientCnx.HostTag + ' ' + ClientCnx.SslHandshakeRespMsg); { V8.71 check if client has sent a certificate } if Assigned(PeerCert) and PeerCert.IsCertLoaded then begin Display(ClientCnx.CPeerAddr + ' - ' + ClientCnx.HostTag + ' Client certificate received, should we trust client?' + IcsCRLF + PeerCert.CertMainInfo); // we should now check common name and/or issuer against people we trust // Disconnect := True; // no, kill connection end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1SslServerName(Sender: TObject; var Ctx: TSslContext; var ErrCode: TTlsExtError); { V8.64 } var ClientCnx : TMyHttpConnection; begin if DisplaySslInfo.Checked then begin ClientCnx := Sender as TMyHttpConnection; Display('Client Hello from ' + ClientCnx.CPeerAddr + ', ' + Trim(WSocketGetCliHelloStr(ClientCnx.CliHelloData))) ; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1SslAlpnSelect(Sender: TObject; ProtoList: TStrings; var SelProto: string; var ErrCode: TTlsExtError); { V8.64 } var // ClientCnx : TMyHttpConnection; I: Integer; begin if ProtoList.Count = 0 then Exit; // ClientCnx := Sender as TMyHttpConnection; // { ALPN already logged from CliHelloData } // optionally select a protocol we want to use for I := 0 to ProtoList.Count - 1 do begin if ProtoList[I] = ALPN_ID_HTTP11 then begin SelProto := ALPN_ID_HTTP11; // SelProto := ALPN_ID_HTTP2; // TEMP confuse them ErrCode := teeOk; Exit; end; // if ProtoList[I] = ALPN_ID_HTTP2 then begin don't support HTTP/2 yet end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1TraceDocument(Sender, Client: TObject; var Flags: THttpGetFlag); //var // ClientCnx : TMyHttpConnection; begin { It's easier to do the cast one time. Could use with clause... } // ClientCnx := TMyHttpConnection(Client); // { Count request and display a message } // InterlockedIncrement(FCountRequests); // Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.CPeerAddr + '] ' + ClientCnx.HostTag + ' TRACE ' + ClientCnx.Path); // DisplayHeader(ClientCnx); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1VirtualException(Sender: TObject; E: Exception; Method: THttpMethod; const Path: string); begin Display('Exception creating virtual page: ' + Path + ' - ' + E.Message); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { V9.6 This event handler is triggered for serveral WebDAV commands } procedure TWeblServerForm.SslHttpAppSrv1WebDAVDocument(Sender, Client: TObject; HttpMethod: THttpMethod; var Flags: THttpGetFlag); var Remote : TMyHttpConnection; begin Remote := TMyHttpConnection(Client); Display('WebDAV Request: ' + Remote.Method + ' - ' + Remote.Path); if HttpMethod = httpMethodPropFind then Exit; // let server handle it Flags := hg400; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.SslHttpAppSrv1WellKnownDir(Sender, Client: TObject; const Path: string; var BodyStr: string); var ClientCnx : TMyHttpConnection; begin ClientCnx := Client as TMyHttpConnection; Display(ClientCnx.CPeerAddr + ' - ' + ClientCnx.HostTag + ' Well-Known File Requested: ' + Path); if (Pos('/acme-challenge/', Path) > 1) or (Pos('/ics-validation/', Path) > 1) then begin { V8.64 } // check challenge token received Let's Encrypt and return key authorization IcsSslX509Certs.WebSrvHttp(Self, ClientCnx.RequestHost, Path, BodyStr); if BodyStr <> '' then Display(ClientCnx.CPeerAddr + ' - ' + ClientCnx.HostTag + ' acme-challenge response: ' + BodyStr); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { V8.71 event called by IcsDomainNameCache component when it completes the lookup of of a remote host name, find the correct client and update it, for web logs } procedure TWeblServerForm.IcsDomainNameCache1DNUpdateEvent(Sender: TObject; ItemNr: Integer); var ClientCnx: TMyHttpConnection; I: Integer; begin if ItemNr >= 0 then begin // find client with the IP address we just looked up for I := 0 to SslHttpAppSrv1.ClientCount - 1 do begin ClientCnx := TMyHttpConnection(SslHttpAppSrv1.Client[I]); if ClientCnx.CPeerAddr = IcsDomainNameCache1.GetDNItem(ItemNr).Request then begin ClientCnx.CPeerHostName := IcsDomainNameCache1.BuildRespList(ItemNr); ClientCnx.FSessIpInfo.RemoteRDNS := ClientCnx.CPeerHostName; { V9.5 } Display (ClientCnx.CPeerAddr + ' - Client DNS Lookup: ' + ClientCnx.CPeerHostName) ; Break; end; end; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsMailQueueLogEvent(LogLevel: TMailLogLevel; const Info: string); begin if LogLevel <= MLogLevelInfo then { V9.3 less information } Display(Info); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsMailQueueOATokenEvent(ServNr: Integer; var Token, TokAccount: string; var TokExpireDT: TDateTime); { V8.70 } begin Display('Starting to get OAuth2 Bearer Token'); if NOT IcsRestEmail.GetNewToken(True) then // allow interaction, waits for browser window to be completed // !!! warning, if this is a real service application don't allow interaction since the browser will not work Display('Failed to get OAuth2 Bearer Token') else begin Token := IcsRestEmail.AccToken; TokExpireDT := IcsRestEmail.AccExpireDT; TokAccount := IcsRestEmail.NewAccEmail; // note, AccToken has a short life, few hours, no need to save it in INI file, it can be refreshed end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsRestEmailEmailNewToken(Sender: TObject); { V8.70 } var info: String; begin // we should save refresh token since only get it after a login window if (IcsRestEmail.RefrToken <> '') and (IcsRestEmail.RefrToken <> OldRefrToken) then begin info := 'New OAuth2 Refresh Token for Account: ' + IcsRestEmail.NewAccEmail + ', Should be Saved in INI File: ' + FIniFileName + IcsCRLF + 'RefrToken=' + IcsRestEmail.RefrToken; Display(info); if (AdminEmailTo <> '') then SendAdminEmail (AdminEmailTo, 'ICS Multi Web Server New OAuth2 Refresh Token', 'Web server New OAuth2 Refresh Token.' + IcsCRLF + IcsCRLF + info); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsRestEmailEmailProg(Sender: TObject; LogOption: TLogOption; const Msg: string); { V8.70 } begin Display(Msg); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsRestEmailOAAuthUrl(Sender: TObject; const URL: string); { V8.70 } begin // end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsSslX509CertsCertProg(Sender: TObject; LogOption: TLogOption; const Msg: string); begin Display(Msg); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsSslX509CertsChallengeDNS(Sender: TObject; ChallengeItem: TChallengeItem; var ChlgOK: Boolean); begin ChlgOK := False; // update DNS server with TXT challenge information // not sure worth the trouble for a web server end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsSslX509CertsChallgRefresh(Sender: TObject); { V9.5 } begin with Sender as TSslX509Certs do begin if IssueState > IssStateNone then Display('X509 Certificate Order State Change: ' + CertCommonName + ' - New State: ' + IssueStateLits[IssueState]); if (IssueState >= IssStateChallgTest) and (IssueState <= IssStateChallgOK) then ChallengeTestingActive := True else ChallengeTestingActive := False; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsSslX509CertsGeoEvent(Sender: TObject; const IpStr: string; var Geo: string); { V9.5 } var ISO2A, CountryName, AsnName: string; {$IFDEF USE_IcsGeoTools} { V9.7 } AsnNum: Int64; {$ENDIF USE_IcsGeoTools} begin {$IFDEF USE_IcsGeoTools} { V9.7 } ISO2A := IcsGeoTools.FindISOA2Code(IPStr); CountryName := IcsGeoTools.FindCountry(ISO2A); AsnName := IcsGeoTools.FindASNCode(IpStr, AsnNum); {$ENDIF USE_IcsGeoTools} Geo := ISO2A; if CountryName <> '' then Geo := CountryName; if AsnName <> '' then Geo := Geo + ', ' + AsnName; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsSslX509CertsNewCert(Sender: TObject); { V8.57 } begin CertCheckTrigger := Trigger64Immediate; // force certiificate check to load new ones Display ('Trigger Recheck Certificates') ; Display('Web server ordered new SSL cerrtificate.' + IcsCRLF + IcsSslX509Certs.GetOrderResult); if (AdminEmailTo <> '') then SendAdminEmail (AdminEmailTo, 'ICS Multi Web Server SSL Certificate Order Completed', 'Web server ordered new SSL cerrtificate.' + IcsCRLF + IcsCRLF + IcsSslX509Certs.GetOrderResult + IcsCRLF) ; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.IcsSslX509CertsOAuthAuthUrl(Sender: TObject; const URL: string); begin Display('Web server demo needs OAuth authenfication for new certificate, ' + 'Browse to this URL: ' + URL + ', From PC: ' + IcsGetCompName) ; if (AdminEmailTo <> '') then SendAdminEmail (AdminEmailTo, 'ICS Multi Web Server needs OAuth authenfication for new certificate', 'Browse to this URL: ' + URL + IcsCRLF + IcsCRLF + 'From Browser on PC: ' + SrvCompName + IcsCRLF) ; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.HttpAppSrvClientBgException(Sender: TObject; E: Exception; var CanClose : Boolean); begin Display('Exception processing page - ' + E.ClassName + ': ' + E.Message); CanClose := TRUE; // Shutdown client end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { This procedure is use to generate /demo.html document } procedure TWeblServerForm.CreateVirtualDocument_Demo( Sender : TObject; ClientCnx : TMyHttpConnection; var Flags : THttpGetFlag); begin ClientCnx.AnswerString(Flags, '', { Default Status '200 OK' } '', { Default Content-Type: text/html } '', { Default header } '' + '
' + '' + IcsReportOpenSSLVer + '
' + { V9.1 } '' + IcsVerLitRelDate + '
' + { V9.8 } '' +
'IP Address Database Lookup
' + { V9.8 }
'Server time
' +
'Template demo
' +
'Application Web Server session demo
' +
'Data entry
' +
'Upload a file using POST
' +
'Parameters Display
' + { V9.1 }
'Send Email Form
' + { V8.61 }
'WebSocket Client Echo Test
' + { V8.71 }
'Redirection
' +
'Show client IP and Host Name
' + { V8.71 }
'Password protected page (Basic method)
' +
'Password protected page (Digest MD5 method)
' +
'Password protected page (Digest SHA-256 method)
' + { V8.69 }
'Password protected page ' + '(Digest MD5 or SHA-256 methods))
' + { V8.69 }
'Password protected page ' + '(method is selected by the browser)
' +
'Password protected page ' + '(NTLM method, usercode=(Windows) user, password=(Windows) password)
' +
'Default document
' +
'ICS Home page
' +
'ICS Wiki and Downloads
' +
'
Login for protected pages (except NTLM) is "test" with password of "password"
' + { V8.69 } '' + '' + StatSrvSslCertWeb + '
' + { V8.71 } '' + ''); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { This procedure is use to generate /DemoBasicAuth.html document } procedure TWeblServerForm.CreateVirtualDocument_DemoBasicAuth( Sender : TObject; ClientCnx : TMyHttpConnection; var Flags : THttpGetFlag); var sPageUrl: String; begin sPageUrl := ClientCnx.Method + ' ' + ClientCnx.RequestProtocol + '://' + ClientCnx.RequestHost + ClientCnx.Path; if ClientCnx.PostedDataLen > 0 then sPageUrl := sPageUrl + ', PostParams: ' + ClientCnx.PostedDataStr; ClientCnx.AnswerString(Flags, '', { Default Status '200 OK' } '', { Default Content-Type: text/html } '', { Default header } '' + '' + 'This page is protected by a username and password.
' + 'Your browser selected the ' + HttpAuthTypeNames[ClientCnx.AuthType] + ' authentication mode.
' + '' + '' + ''); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { This procedure is use to generate /DemoNtlmAuth.html document } procedure TWeblServerForm.CreateVirtualDocument_DemoNtlmAuth( Sender : TObject; ClientCnx : TMyHttpConnection; var Flags : THttpGetFlag); begin ClientCnx.AnswerString(Flags, '', { Default Status '200 OK' } '', { Default Content-Type: text/html } '', { Default header } '' + '' + '' + DateTimeToStr(Now) +'
' + icsCRLF + 'Demo menu' + icsCRLF + '' + ''); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.CreateVirtualDocument_Bruno( Sender : TObject; { HTTP server component } ClientCnx : TMyHttpConnection; { Client connection issuing command } var Flags : THttpGetFlag); { Tells what HTTP server has to do next } var Body : String; Header : String; I : Integer; Buf : String; Count : Integer; begin Buf := ClientCnx.Params; Count := StrToIntDef(Buf, 5000); if Count > 20000 then Count := 20000; Body := '' + '' + 'Your IP is: ' + ClientCnx.CPeerAddr + '
' + icsCRLF + 'Your Host Name is: ' + ClientCnx.CPeerHostName + '
' + icsCRLF + { V8.71 } '' + ''); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.ClientWSLogEvent(Sender: TObject; const Msg: string); { V8.71 websockets } begin Display(Msg); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.ClientWSHandshakeEvent(Client: THttpWSSrvConn; var OK: Boolean; var WelcomeMsg: String); { V8.71 websockets } var S: String; begin OK := False; if CompareText(Client.WSReqPage, '/WebSocket/Echo') = 0 then begin OK := True; WelcomeMsg := 'Welcome to ICS WebSocket echo server, all messages will be echoed.'; end else if CompareText(Client.WSReqPage, '/WebSocket/EchoPing') = 0 then begin OK := True; WelcomeMsg := 'Welcome to ICS WebSocket echo/ping server, all messages will be echoed.'; Client.WSPingEnabled := True; end else if CompareText(Client.WSReqPage, '/WebSocket/Chat') = 0 then begin OK := True; if Client.WSReqParams = '' then // ideally they passed a chat name Client.WSReqParams := Client.CPeerAddr; end else if (CompareText(Client.WSReqPage, '/WebSocket/Serverinfo') = 0) then begin OK := True; Client.WSPingSecs := 10; // used for server push Client.WSPingEnabled := True; end; if OK then S := ' Accepted' else S := ' Rejected'; Display('WebSocket ' + Client.CPeerAddr + ': Request for ' + Client.WSReqPage + S); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TWeblServerForm.ClientWSReadyEvent(Client: THttpWSSrvConn); { V8.71 websockets } var S: String; begin // called once when the websocket is ready for traffic Display('Websocket ' + Client.CPeerAddr + ': Ready for ' + Client.WSReqPage); if (CompareText(Client.WSReqPage, '/WebSocket/Chat') = 0) then begin WSGetChatUsers(Client.WSReqPage, S); Client.WSSendText(Nil, 'Welcome to ICS WebSocket chat server, Users: ' + S); WSSendChatResp(Client, '!! Has Joined Chat', True); end else if (CompareText(Client.WSReqPage, '/WebSocket/Serverinfo') = 0) then begin // Client.WSSendText(Nil, '==1' + GetCurServInfo(TMagHttpConnection(Client))); // Client.WSSendText(Nil, '==2' + 'Server Sites and SSL Certificates: