Command: ' + ClientCnx.Path + '
' + icsCRLF + 'Back to demo menu' + IcsCRLF; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TDDWebServiceSrv.SslHttpAppSrv1HttpMimeContentType(Sender, Client: TObject; const FileName: string; var ContentType: string); var ClientCnx : TMyHttpConnection; begin ClientCnx := TMyHttpConnection(Client); Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.GetPeerAddr + '] ' + ': Document: ' + FileName + ', Content-Type: ' + ContentType); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TDDWebServiceSrv.SslHttpAppSrv1HttpRequestDone(Sender, Client: TObject); { V9.2 } var ClientCnx : TMyHttpConnection; begin ClientCnx := TMyHttpConnection(Client); Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' + ClientCnx.GetPeerAddr + '] Request Completed, Status ' + IntToStr(ClientCnx.AnswerStatus) + IcsCRLF); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TDDWebServiceSrv.SslHttpAppSrv1HttpRespHdr(Sender, Client: TObject; const Header: string); { V8.69 } begin end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TDDWebServiceSrv.SslHttpAppSrv1OptionsDocument(Sender, Client: TObject; var Flags: THttpGetFlag); begin Exit; { let web server send general response } { path may be the resource for which OPTIONS should be checked } end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TDDWebServiceSrv.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); if (ClientCnx.RequestContentLength > (SslHttpAppSrv1.MaxUploadMB * IcsMBYTE)) 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; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { 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: } { } {
} {' + IcsBuiltWithEx + '
' + { V9.6 } '' + IcsReportOpenSSLVer + '
' + { V9.1 } '' +
'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 } '' + { V9.6 added remote client information } 'Client Remote Address: ' + ClientCnx.SessIpInfo.RemoteRDNS + ' (' + ClientCnx.SessIpInfo.RemoteAddr + ') ' + ClientCnx.SessIpInfo.CountryName + ' - ' + ClientCnx.SessIpInfo.RegionName + ' - ' + ClientCnx.SessIpInfo.AsnName + '' + StatSrvSslCertWeb + '
' + { V8.71 } '' + ''); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { This procedure is use to generate /DemoBasicAuth.html document } procedure TDDWebServiceSrv.CreateVirtualDocument_DemoBasicAuth(Sender: TObject; ClientCnx: TMyHttpConnection; var Flags: THttpGetFlag); var sPageUrl: String; begin sPageUrl := ClientCnx.Method + ' ' + ClientCnx.RequestProtocol + '://' + ClientCnx.RequestHost + ClientCnx.Path; { V9.2 } 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.
' + 'The authentication is done using Digest MD5 mode.
' + '' + '' + ''); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { This procedure is use to generate /DemoDigestSha2Auth.html document } procedure TDDWebServiceSrv.CreateVirtualDocument_DemoDigest2Auth(Sender: TObject; ClientCnx: TMyHttpConnection; var Flags: THttpGetFlag); begin 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 TDDWebServiceSrv.CreateVirtualDocument_DemoNtlmAuth(Sender: TObject; ClientCnx: TMyHttpConnection; var Flags: THttpGetFlag); begin ClientCnx.AnswerString(Flags, '', { Default Status '200 OK' } '', { Default Content-Type: text/html } '', { Default header } '' + '' + 'This page is protected by a username and password.
' + 'The authentication is done using NTLM mode.
' + '' + '' + ''); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TDDWebServiceSrv.CreateVirtualDocument_Template(Sender: TObject; ClientCnx: TMyHttpConnection; var Flags: THttpGetFlag); begin ClientCnx.AnswerPage( Flags, '', NO_CACHE, 'TemplateDemo.html', nil, ['TIME', DateTimeToStr(Now), 'PROGVER', SrvCopyRight, 'SOURCE', TextToHtmlText(ClientCnx.TemplateDir + 'TemplateDemo.html')]); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { This procedure is use to generate /redir.html document } procedure TDDWebServiceSrv.CreateVirtualDocument_Redir(Sender: TObject; ClientCnx: TMyHttpConnection; var Flags: THttpGetFlag); { Tells what HTTP server has to do next } var Location : String; begin Location := ClientCnx.Params; // if Location = '' then // Location := Trim(RedirUrlEdit.text); ClientCnx.AnswerString(Flags, '302 Moved', { Tell the browser about relocation } '', { Default Content-Type: text/html } 'Location: ' + Location + icsCRLF, { Specify new location } '' + '' + '' + DateTimeToStr(Now) +'
' + icsCRLF + 'Demo menu' + icsCRLF + '' + ''); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TDDWebServiceSrv.CreateVirtualDocument_Bruno(Sender: TObject; ClientCnx: TMyHttpConnection; 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.PeerAddr + '
' + icsCRLF + 'Your Host Name is: ' + ClientCnx.CPeerHostName + '
' + icsCRLF + { V8.71 } '' + ''); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { RESTAPI using a URL Handler } procedure TUrlHandlerRestApi.Execute; var JsonResp: AnsiString; { V8.69 was string } {$IFDEF DATABASE} RestParamsSrv: TRestParamsSrv; sCountry: String; {$IFDEF YuDISQL} info: String; {$ENDIF} {$ELSE} JsonResult: TRestParams; {$ENDIF} begin JsonResp := ''; {$IFDEF DATABASE} sCountry := ''; RestParamsSrv := TRestParamsSrv.Create; if Client.Method <> 'GET' then begin // we could handle DELETE, POST and PUT here JsonResp := RestParamsSrv.JsonErr(RestErrUnsupported); end else begin ExtractURLEncodedValue (Client.Params, 'Country', sCountry) ; if sCountry = '' then JsonResp := RestParamsSrv.JsonErr(RestErrUnsupported); end; // open DISQLite database, if linked {$IFDEF YuDISQL} if (sCountry <> '') and (NOT DbOpened) then begin info := ProgDirectory + 'World.db3'; try if FileExists(info) then begin sqlite3_initialize; DISQLite3Database := TDISQLite3Database.Create(Self); DISQLite3Query := TDISQLite3UniDirQuery.Create(Self); DISQLite3Query.Database := DISQLite3Database; DISQLite3Database.DatabaseName := info; DISQLite3Database.Open; DbOpened := DISQLite3Database.Connected; if NOT DbOpened then JsonResp := RestParamsSrv.JsonErr(RestErrGeneral, 'Failed to Open Database'); end else JsonResp := RestParamsSrv.JsonErr(RestErrGeneral, 'Database File Not found: ' + info); except on E: ESQLite3 do begin info := E.ErrorMessage; Display(info); JsonResp := RestParamsSrv.JsonErr(RestErrGeneral, info); end; end end; if (sCountry <> '') and DbOpened then begin try DISQLite3Query.Close; DISQLite3Query.SelectSQL := 'SELECT ID,Name,Area,Population,"Birth Rate","Life Expectancy",Background FROM Countries WHERE Name = "' + sCountry + '"'; DISQLite3Query.Open; // DISQLite3Query does not set RecordCount !!!! DISQLite3Query.First; if DISQLite3Query.Eof then JsonResp := RestParamsSrv.JsonErr(RestErrNoRecords, 'Can not find country: ' + sCountry) ; except on E: ESQLite3 do begin info := E.ErrorMessage; Display(info); JsonResp := RestParamsSrv.JsonErr(RestErrGeneral, info); end; end; if DbOpened and (JsonResp = '') then begin // no error yet try if NOT RestParamsSrv.ResultSet2Json(DISQLite3Query, JsonResp) then // converts DB resultset to Json JsonResp := RestParamsSrv.JsonErr(RestErrConvert); except info := 'ApiCountry - ' + IcsGetExceptMess (ExceptObject) ; Display(info); JsonResp := RestParamsSrv.JsonErr(RestErrGeneral, info) ; end ; end; end; {$ELSE} // no DISQLite, simple Json response JsonResp := RestParamsSrv.JsonErr(RestErrGeneral, 'DISQLite is not linked'); {$ENDIF} RestParamsSrv.Free; {$ELSE} // no datanase, simple Json response JsonResult := TRestParams.Create(Nil); JsonResult.PContent := PContJson; JsonResult.AddItem('success', false); JsonResult.AddItem('reccount', 0); JsonResult.AddItem('errno', 8); JsonResult.AddItem('errdesc', 'Database is currently unavailable'); JsonResp := JsonResult.GetParameters; JsonResult.Free; {$ENDIF} Display(String(JsonResp)); Flags := hgWillSendMySelf ; AnswerString( '', { Default Status '200 OK' } 'application/json', { Default Content-Type: text/html } 'Pragma: no-cache' + icsCRLF + { No client caching please } 'Expires: -1' + icsCRLF, { I said: no caching ! } String(JsonResp), { the real response } {$IFDEF COMPILER12_UP} CP_UTF8, { V8.69 } {$ENDIF} Now); { when we sent the response } end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TDDWebServiceSrv.ClientWSLogEvent(Sender: TObject; const Msg: string); { V8.71 websockets } begin Display(Msg); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TDDWebServiceSrv.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.PeerAddr; 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 TDDWebServiceSrv.ClientWSReadyEvent(Client: THttpWSSrvConn); { V8.71 websockets } var S: String; begin // called once when the websocket is ready for traffic Display('Websocket ' + Client.PeerAddr + ': 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: