Решил более детально разобраться с idHTTPServer. Думаю,что технология интересная, простая, понятная и надежная, но есть детали и нюансы, поэтому решил проанализировать имеющиеся в сети статьи и видео, чтобы улучшить свои знания об idHTTPServer. Итак, вот видео, которое мне попалось первым.
Пример простейший. Мне показалось интересным создание своего контекста.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
unit uClientContext; interface uses System.SysUtils, System.Classes, IdBaseComponent, IdComponent, IdCustomTCPServer, IdCustomHTTPServer, IdHTTPServer, IdContext; type TClientContext = class(TidServerContext) private FLogStrings: TStrings; FHellloMessage: string; procedure Log(const s: string); procedure SetLogStrings(const Value: TStrings); procedure SetHellloMessage(const Value: string); public procedure HandleRequest(ARequestInfo: TidHTTPRequestInfo; AResponseInfo: TidHTTPResponseInfo); property LogStrings: TStrings read FLogStrings write SetLogStrings; property HellloMessage: string read FHellloMessage write SetHellloMessage; end; implementation { TClientContext } procedure TClientContext.HandleRequest(ARequestInfo: TidHTTPRequestInfo; AResponseInfo: TidHTTPResponseInfo); begin try AResponseInfo.ContentText := Format('<HTML><BODY>%s</BODY></HTML>', [FHellloMessage]); except on E:Exception do Log('Exception occured from IP '+Connection.Socket.Binding.PeerIP+sLineBreak+e.Message); end; end; procedure TClientContext.Log(const s: string); begin if Assigned(FLogStrings) then FLogStrings.Add(s); end; procedure TClientContext.SetHellloMessage(const Value: string); begin FHellloMessage := Value; end; procedure TClientContext.SetLogStrings(const Value: TStrings); begin FLogStrings := Value; end; end. |
Метод HandleRequest обрабатывает запросы.
|
1 2 3 4 5 6 7 8 9 |
procedure TClientContext.HandleRequest(ARequestInfo: TidHTTPRequestInfo; AResponseInfo: TidHTTPResponseInfo); begin try AResponseInfo.ContentText := Format('<HTML><BODY>%s</BODY></HTML>', [FHellloMessage]); except on E:Exception do Log('Exception occured from IP '+Connection.Socket.Binding.PeerIP+sLineBreak+e.Message); end; end; |
Строка
|
1 |
Connection.Socket.Binding.PeerIP |
показывает IP с которого произошло исключение.
Чтобы этот контекст обрабатывался, нам нужно следующее
|
1 2 3 4 |
procedure TServer.DataModuleCreate(Sender: TObject); begin IdHTTPServer.ContextClass := TClientContext; end; |
Полный код uServer
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
unit uServer; interface uses System.SysUtils, System.Classes, IdBaseComponent, IdComponent, IdCustomTCPServer, IdCustomHTTPServer, IdHTTPServer, IdContext, uClientContext; type TServer = class(TDataModule) IdHTTPServer: TIdHTTPServer; procedure IdHTTPServerCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); procedure DataModuleCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Server: TServer; implementation uses uMain; {%CLASSGROUP 'Vcl.Controls.TControl'} {$R *.dfm} procedure TServer.DataModuleCreate(Sender: TObject); begin IdHTTPServer.ContextClass := TClientContext; end; procedure TServer.IdHTTPServerCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); var cContext: TClientContext; begin cContext := TClientContext(AContext); cContext.HellloMessage := Main.memoHello.Text; cContext.LogStrings := Main.MemoLog.Lines; cContext.HandleRequest(ARequestInfo, AResponseInfo); end; end. |
Код главного модуля
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
unit uMain; interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdBaseComponent, IdComponent, IdCustomTCPServer, IdCustomHTTPServer, IdHTTPServer, Vcl.StdCtrls, Vcl.Buttons, Vcl.ExtCtrls, uServer; type TMain = class(TForm) pTop: TPanel; bStop: TBitBtn; bStart: TBitBtn; gpHelloMessage: TGroupBox; gpLog: TGroupBox; memoHello: TMemo; MemoLog: TMemo; procedure FormCreate(Sender: TObject); procedure bStartClick(Sender: TObject); procedure bStopClick(Sender: TObject); private { Private declarations } FServer: TServer; procedure SetButtonsState; procedure ShowError(const s: string; args: array of const); public { Public declarations } end; var Main: TMain; implementation {$R *.dfm} resourcestring SERROR_START = 'Error occured while starting server.' + sLineBreak + '%s'; SERROR_STOP = 'Error occured while stopping server.' + sLineBreak + '%s'; procedure TMain.bStartClick(Sender: TObject); begin try FServer.IdHTTPServer.Active := true; MemoLog.Lines.Add('Successfully started at ' + DateTimeToStr(Now)); except on E: Exception do ShowError(SERROR_START, [E.Message]); end; SetButtonsState; end; procedure TMain.bStopClick(Sender: TObject); begin try FServer.IdHTTPServer.Active := false; MemoLog.Lines.Add('Successfully started at ' + DateTimeToStr(Now)); except on E: Exception do ShowError(SERROR_STOP, [E.Message]); end; SetButtonsState; end; procedure TMain.FormCreate(Sender: TObject); begin FServer := TServer.Create(Self); end; procedure TMain.SetButtonsState; begin bStart.Enabled := not FServer.IdHTTPServer.Active; bStop.Enabled := not bStart.Enabled; end; procedure TMain.ShowError(const s: string; args: array of const); begin MessageDlg(Format(s, args), mtError, [mbOk], 0); end; end. |