TidHttpServer 使用示例
unit Main; interface uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActnList, StdCtrls, IdComponent, IdTCPServer, IdHTTPServer, Buttons,
ComCtrls, IdGlobal, IdBaseComponent, IdThreadMgr, IdThreadMgrDefault, syncobjs,
IdThreadMgrPool, ExtCtrls, IdIntercept, IdSSLOpenSSL, IdIOHandlerSocket,
IdServerIOHandler, IdCustomHTTPServer; type
TfmHTTPServerMain = class(TForm)
HTTPServer: TIdHTTPServer;
alGeneral: TActionList;
acActivate: TAction;
edPort: TEdit;
cbActive: TCheckBox;
StatusBar1: TStatusBar;
edRoot: TEdit;
LabelRoot: TLabel;
cbAuthentication: TCheckBox;
cbManageSessions: TCheckBox;
cbEnableLog: TCheckBox;
Label1: TLabel;
Panel1: TPanel;
lbLog: TListBox;
lbSessionList: TListBox;
Splitter1: TSplitter;
cbSSL: TCheckBox;
IdServerInterceptOpenSSL: TIdServerIOHandlerSSL;
procedure acActivateExecute(Sender: TObject);
procedure edPortChange(Sender: TObject);
procedure edPortKeyPress(Sender: TObject; var Key: Char);
procedure edPortExit(Sender: TObject);
procedure HTTPServerCommandGet(AThread: TIdPeerThread; RequestInfo: TIdHTTPRequestInfo;
ResponseInfo: TIdHTTPResponseInfo);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure HTTPServerSessionEnd(Sender: TIdHTTPSession);
procedure HTTPServerSessionStart(Sender: TIdHTTPSession);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure lbSessionListDblClick(Sender: TObject);
procedure cbSSLClick(Sender: TObject);
procedure HTTPServerConnect(AThread: TIdPeerThread);
procedure HTTPServerDisconnect(AThread: TIdPeerThread);
procedure HTTPServerExecute(AThread: TIdPeerThread);
procedure HTTPServerCommandOther(Thread: TIdPeerThread; const asCommand, asData, asVersion: String);
procedure HTTPServerStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: String);
private
UILock: TCriticalSection;
procedure ServeVirtualFolder(AThread: TIdPeerThread; RequestInfo: TIdHTTPRequestInfo;
ResponseInfo: TIdHTTPResponseInfo);
procedure DisplayMessage(const Msg: String);
procedure DisplaySessionChange(const session: string);
procedure ManageUserSession(AThread: TIdPeerThread; RequestInfo: TIdHTTPRequestInfo;
ResponseInfo: TIdHTTPResponseInfo);
function GetMIMEType(sFile: TFileName): String;
{ Private declarations }
public
{ Public declarations }
EnableLog: Boolean;
MIMEMap: TIdMIMETable;
procedure MyInfoCallback(Msg: String);
procedure GetKeyPassword(var Password: String);
end; var
fmHTTPServerMain: TfmHTTPServerMain; implementation uses FileCtrl, IdStack; {$R *.DFM} procedure TfmHTTPServerMain.acActivateExecute(Sender: TObject);
var
AppDir: String;
begin
acActivate.Checked := not acActivate.Checked;
lbSessionList.Items.Clear;
if not HTTPServer.Active then
begin
HTTPServer.Bindings.Clear;
HTTPServer.DefaultPort := StrToIntDef(edPort.text, );
HTTPServer.Bindings.Add;
end; if not DirectoryExists(edRoot.text) then
begin
DisplayMessage(Format('Web root folder (%s) not found. ', [edRoot.text]));
acActivate.Checked := False;
end
else
begin
if acActivate.Checked then
begin
try
EnableLog := cbEnableLog.Checked;
HTTPServer.SessionState := cbManageSessions.Checked; // SSL stuff
if cbSSL.Checked then
begin
with IdServerInterceptOpenSSL.SSLOptions do
begin
Method := sslvSSLv23;
AppDir := ExtractFilePath(Application.ExeName);
RootCertFile := AppDir + 'cert\CAcert.pem ';
CertFile := AppDir + 'cert\WSScert.pem ';
KeyFile := AppDir + 'cert\WSSkey.pem ';
end;
IdServerInterceptOpenSSL.OnStatusInfo := MyInfoCallback;
IdServerInterceptOpenSSL.OnGetPassword := GetKeyPassword;
HTTPServer.IOHandler := IdServerInterceptOpenSSL;
end;
// END SSL stuff HTTPServer.Active := true;
DisplayMessage(Format('Listening for HTTP connections on %s:%d. ', [HTTPServer.Bindings[].IP,
HTTPServer.Bindings[].Port]));
except
on e: exception do
begin
acActivate.Checked := False;
DisplayMessage(Format('Exception %s in Activate. Error is: "%s ". ', [e.ClassName, e.Message]));
end;
end;
end
else
begin
HTTPServer.Active := False;
// SSL stuff
HTTPServer.Intercept := nil;
// End SSL stuff
DisplayMessage('Stop listening. ');
end;
end;
if HTTPServer.Active then
caption := 'HTTP Server Active '
else
caption := 'HTTP Server Inactive ';
edPort.Enabled := not acActivate.Checked;
edRoot.Enabled := not acActivate.Checked;
cbAuthentication.Enabled := not acActivate.Checked;
cbEnableLog.Enabled := not acActivate.Checked;
cbManageSessions.Enabled := not acActivate.Checked;
end; procedure TfmHTTPServerMain.edPortChange(Sender: TObject);
var
FinalLength, i: Integer;
FinalText: String;
begin
// Filter routine. Remove every char that is not a numeric (must do that for cut 'n paste)
Setlength(FinalText, length(edPort.text));
FinalLength := ;
for i := to length(edPort.text) do
begin
if edPort.text[i] in ['0 ' .. '9 '] then
begin
inc(FinalLength);
FinalText[FinalLength] := edPort.text[i];
end;
end;
Setlength(FinalText, FinalLength);
edPort.text := FinalText;
end; procedure TfmHTTPServerMain.edPortKeyPress(Sender: TObject; var Key: Char);
begin
if not(Key in ['0 ' .. '9 ', #]) then
Key := #;
end; procedure TfmHTTPServerMain.edPortExit(Sender: TObject);
begin
if length(trim(edPort.text)) = then
edPort.text := '80 ';
end; procedure TfmHTTPServerMain.ManageUserSession(AThread: TIdPeerThread; RequestInfo: TIdHTTPRequestInfo;
ResponseInfo: TIdHTTPResponseInfo);
var
NumberOfView: Integer;
begin
// Manage session informations
if assigned(RequestInfo.session) or (HTTPServer.CreateSession(AThread, ResponseInfo, RequestInfo) <> nil) then
begin
RequestInfo.session.Lock;
try
NumberOfView := StrToIntDef(RequestInfo.session.Content.Values['NumViews '], );
inc(NumberOfView);
RequestInfo.session.Content.Values['NumViews '] := IntToStr(NumberOfView);
RequestInfo.session.Content.Values['UserName '] := RequestInfo.AuthUsername;
RequestInfo.session.Content.Values['Password '] := RequestInfo.AuthPassword;
finally
RequestInfo.session.Unlock;
end;
end;
end; procedure TfmHTTPServerMain.ServeVirtualFolder(AThread: TIdPeerThread; RequestInfo: TIdHTTPRequestInfo;
ResponseInfo: TIdHTTPResponseInfo);
begin
ResponseInfo.ContentType := 'text/HTML ';
ResponseInfo.ContentText := ' <html> <head> <title> Virtual folder </title> </head> <body> '; if AnsiSameText(RequestInfo.Params.Values['action '], 'close ') then
begin
// Closing user session
RequestInfo.session.Free;
ResponseInfo.ContentText := ResponseInfo.ContentText +
' <h1> Session cleared </h1> <p> <a href= "/sessions "> Back </a> </p> ';
end
else
begin
if assigned(RequestInfo.session) then
begin
if length(RequestInfo.Params.Values['ParamName ']) > then
begin
// Add a new parameter to the session
ResponseInfo.session.Content.Values[RequestInfo.Params.Values['ParamName ']] :=
RequestInfo.Params.Values['Param '];
end;
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <h1> Session informations </h1> ';
RequestInfo.session.Lock;
try
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <table border=1> ';
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <tr> <td> SessionID </td> <td> ' +
RequestInfo.session.SessionID + ' </td> </tr> ';
ResponseInfo.ContentText := ResponseInfo.ContentText +
' <tr> <td> Number of page requested during this session </td> <td> ' +
RequestInfo.session.Content.Values['NumViews '] + ' </td> </tr> ';
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <tr> <td> Session data (raw) </td> <td> <pre> ' +
RequestInfo.session.Content.text + ' </pre> </td> </tr> ';
ResponseInfo.ContentText := ResponseInfo.ContentText + ' </table> ';
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <h1> Tools: </h1> ';
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <h2> Add new parameter </h2> ';
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <form method= "POST "> ';
ResponseInfo.ContentText := ResponseInfo.ContentText +
' <p> Name: <input type= "text " Name= "ParamName "> </p> ';
ResponseInfo.ContentText := ResponseInfo.ContentText +
' <p> value: <input type= "text " Name= "Param "> </p> ';
ResponseInfo.ContentText := ResponseInfo.ContentText +
' <p> <input type= "Submit "> <input type= "reset "> </p> ';
ResponseInfo.ContentText := ResponseInfo.ContentText + ' </form> ';
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <h2> Other: </h2> ';
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <p> <a href= " ' + RequestInfo.Document +
'?action=close "> Close current session </a> </p> ';
finally
RequestInfo.session.Unlock;
end;
end
else
begin
ResponseInfo.ContentText := ResponseInfo.ContentText + ' <p color=#FF000> No session </p> ';
end;
end;
ResponseInfo.ContentText := ResponseInfo.ContentText + ' </body> </html> ';
end; procedure TfmHTTPServerMain.DisplaySessionChange(const session: string);
var
Index: Integer;
begin
if EnableLog then
begin
UILock.Acquire;
try
Index := lbSessionList.Items.IndexOf(session);
if Index > - then
lbSessionList.Items.Delete(Index)
else
lbSessionList.Items.Append(session);
finally
UILock.Release;
end;
end;
end; procedure TfmHTTPServerMain.DisplayMessage(const Msg: String);
begin
if EnableLog then
begin
UILock.Acquire;
try
lbLog.ItemIndex := lbLog.Items.Add(Msg);
finally
UILock.Release;
end;
end;
end; const
sauthenticationrealm = 'Indy http server demo '; procedure TfmHTTPServerMain.HTTPServerCommandGet(AThread: TIdPeerThread; RequestInfo: TIdHTTPRequestInfo;
ResponseInfo: TIdHTTPResponseInfo); procedure AuthFailed;
begin
ResponseInfo.ContentText :=
' <html> <head> <title> Error </title> </head> <body> <h1> Authentication failed </h1> '# +
'Check the demo source code to discover the password: <br> <ul> <li> Search for <b> AuthUsername </b> in <b> Main.pas </b> ! </ul> </body> </html> ';
ResponseInfo.AuthRealm := sauthenticationrealm;
end; procedure AccessDenied;
begin
ResponseInfo.ContentText := ' <html> <head> <title> Error </title> </head> <body> <h1> Access denied </h1> '# +
'You do not have sufficient priviligies to access this document. </body> </html> ';
ResponseInfo.ResponseNo := ;
end; var
LocalDoc: string;
ByteSent: Cardinal;
ResultFile: TFileStream;
begin
ResponseInfo.Server := 'LY HTTP Server ';
// Log the request
DisplayMessage(Format('Command %s %s received from %s:%d ', [RequestInfo.Command, RequestInfo.Document,
TIdIOHandlerSocket(AThread.Connection.IOHandler).Binding.PeerIP, TIdIOHandlerSocket(AThread.Connection.IOHandler)
.Binding.PeerPort]));
if cbAuthentication.Checked and ((RequestInfo.AuthUsername <> 'Indy ') or (RequestInfo.AuthPassword <> 'rocks ')) then
begin
AuthFailed;
exit;
end;
if cbManageSessions.Checked then
ManageUserSession(AThread, RequestInfo, ResponseInfo);
if (Pos('/session ', LowerCase(RequestInfo.Document)) = ) then
begin
ServeVirtualFolder(AThread, RequestInfo, ResponseInfo);
end
else
begin
// Interprete the command to it 's final path (avoid sending files in parent folders)
LocalDoc := ExpandFilename(edRoot.text + RequestInfo.Document);
// Default document (index.html) for folder
if not FileExists(LocalDoc) and DirectoryExists(LocalDoc) and FileExists(ExpandFilename(LocalDoc + '/index.html '))
then
begin
LocalDoc := ExpandFilename(LocalDoc + '/index.html ');
end;
if FileExists(LocalDoc) then // File exists
begin
if AnsiSameText(Copy(LocalDoc, , length(edRoot.text)), edRoot.text) then // File down in dir structure
begin
if AnsiSameText(RequestInfo.Command, 'HEAD ') then
begin
// HEAD request, don 't send the document but still send back it 's size
ResultFile := TFileStream.create(LocalDoc, fmOpenRead or fmShareDenyWrite);
try
ResponseInfo.ResponseNo := ;
ResponseInfo.ContentType := GetMIMEType(LocalDoc);
ResponseInfo.ContentLength := ResultFile.Size;
finally
ResultFile.Free;
// We must free this file since it won 't be done by the web server component
end;
end
else
begin
// Normal document request
// Send the document back
// fixed for support Breakpoint download --- by Liu Yang 2002.2.5
ResultFile := TFileStream.create(LocalDoc, fmOpenRead or fmShareDenyWrite);
try
ByteSent := ResultFile.Size - RequestInfo.ContentRangeStart;
ResponseInfo.ContentLength := ByteSent;
ResponseInfo.ContentRangeStart := RequestInfo.ContentRangeStart;
ResponseInfo.ContentType := HTTPServer.MIMETable.GetFileMIMEType(LocalDoc);
ResponseInfo.WriteHeader;
ResultFile.Seek(RequestInfo.ContentRangeStart, soFromBeginning);
AThread.Connection.WriteStream(ResultFile, False, False, ByteSent);
finally
ResultFile.Free;
// We must free this file since it won 't be done by the web server component
end;
// ByteSent := HTTPServer.ServeFile(AThread, ResponseInfo, LocalDoc);
DisplayMessage(Format('Serving file %s (%d bytes / %d bytes sent) to %s:%d ',
[LocalDoc, ByteSent, FileSizeByName(LocalDoc), TIdIOHandlerSocket(AThread.Connection.IOHandler)
.Binding.PeerIP, TIdIOHandlerSocket(AThread.Connection.IOHandler).Binding.PeerPort]));
end;
end
else
AccessDenied;
end
else
begin
ResponseInfo.ResponseNo := ; // Not found
ResponseInfo.ContentText := ' <html> <head> <title> Error </title> </head> <body> <h1> ' +
ResponseInfo.ResponseText + ' </h1> </body> </html> ';
end;
end;
end; procedure TfmHTTPServerMain.FormCreate(Sender: TObject);
begin
UILock := TCriticalSection.create;
MIMEMap := TIdMIMETable.create(true);
edRoot.text := ExtractFilePath(Application.ExeName) + 'Web ';
end; procedure TfmHTTPServerMain.FormDestroy(Sender: TObject);
begin
MIMEMap.Free;
UILock.Free;
end; function TfmHTTPServerMain.GetMIMEType(sFile: TFileName): String;
begin
result := MIMEMap.GetFileMIMEType(sFile);
end; procedure TfmHTTPServerMain.HTTPServerSessionEnd(Sender: TIdHTTPSession);
var
dt: TDateTime;
i: Integer;
hour, min, s, ms: word;
begin
DisplayMessage(Format('Ending session %s at %s ', [Sender.SessionID, FormatDateTime(LongTimeFormat, now)]));
dt := (StrToDateTime(Sender.Content.Values['StartTime ']) - now);
DecodeTime(dt, hour, min, s, ms);
i := ((Trunc(dt) * + hour) * + min) * + s;
DisplayMessage(Format('Session duration was: %d seconds ', [i]));
DisplaySessionChange(Sender.SessionID);
end; procedure TfmHTTPServerMain.HTTPServerSessionStart(Sender: TIdHTTPSession);
begin
Sender.Content.Values['StartTime '] := DateTimeToStr(now);
DisplayMessage(Format('Starting session %s at %s ', [Sender.SessionID, FormatDateTime(LongTimeFormat, now)]));
DisplaySessionChange(Sender.SessionID);
end; procedure TfmHTTPServerMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
// desactivate the server
if cbActive.Checked then
acActivate.execute;
end; procedure TfmHTTPServerMain.lbSessionListDblClick(Sender: TObject);
begin
if lbSessionList.ItemIndex > - then
begin
HTTPServer.EndSession(lbSessionList.Items[lbSessionList.ItemIndex]);
end;
end; // SSL stuff
procedure TfmHTTPServerMain.MyInfoCallback(Msg: String);
begin
DisplayMessage(Msg);
end; procedure TfmHTTPServerMain.GetKeyPassword(var Password: String);
begin
Password := 'aaaa '; // this is a password for unlocking the server
// key. If you have your own key, then it would
// probably be different
end; procedure TfmHTTPServerMain.cbSSLClick(Sender: TObject);
begin
if cbSSL.Checked then
begin
edPort.text := '443 ';
end
else
begin
edPort.text := '80 ';
end;
end;
// End SSL stuff procedure TfmHTTPServerMain.HTTPServerConnect(AThread: TIdPeerThread);
begin
DisplayMessage('User logged in ');
end; procedure TfmHTTPServerMain.HTTPServerDisconnect(AThread: TIdPeerThread);
begin
DisplayMessage('User logged out ');
end; procedure TfmHTTPServerMain.HTTPServerExecute(AThread: TIdPeerThread);
begin
DisplayMessage('Execute ');
end; procedure TfmHTTPServerMain.HTTPServerCommandOther(Thread: TIdPeerThread; const asCommand, asData, asVersion: String);
begin
DisplayMessage('Command other: ' + asCommand);
end; procedure TfmHTTPServerMain.HTTPServerStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: String);
begin
DisplayMessage('Status: ' + AStatusText);
end; end.
http://www.cnblogs.com/toosuo/archive/2012/02/17/2355522.html
TidHttpServer 使用示例的更多相关文章
- Swift3.0服务端开发(一) 完整示例概述及Perfect环境搭建与配置(服务端+iOS端)
本篇博客算是一个开头,接下来会持续更新使用Swift3.0开发服务端相关的博客.当然,我们使用目前使用Swift开发服务端较为成熟的框架Perfect来实现.Perfect框架是加拿大一个创业团队开发 ...
- .NET跨平台之旅:将示例站点升级至 ASP.NET Core 1.1
微软今天在 Connect(); // 2016 上发布了 .NET Core 1.1 ,ASP.NET Core 1.1 以及 Entity Framework Core 1.1.紧跟这次发布,我们 ...
- 通过Jexus 部署 dotnetcore版本MusicStore 示例程序
ASPNET Music Store application 是一个展示最新的.NET 平台(包括.NET Core/Mono等)上使用MVC 和Entity Framework的示例程序,本文将展示 ...
- WCF学习之旅—第三个示例之四(三十)
上接WCF学习之旅—第三个示例之一(二十七) WCF学习之旅—第三个示例之二(二十八) WCF学习之旅—第三个示例之三(二十九) ...
- JavaScript学习笔记(一)——延迟对象、跨域、模板引擎、弹出层、AJAX示例
一.AJAX示例 AJAX全称为“Asynchronous JavaScript And XML”(异步JavaScript和XML) 是指一种创建交互式网页应用的开发技术.改善用户体验,实现无刷新效 ...
- XAMARIN ANDROID 二维码扫描示例
现在二维码的应用越来越普及,二维码扫描也成为手机应用程序的必备功能了.本文将基于 Xamarin.Android 平台使用 ZXing.Net.Mobile 做一个简单的 Android 条码扫描示 ...
- iOS之ProtocolBuffer搭建和示例demo
这次搭建iOS的ProtocolBuffer编译器和把*.proto源文件编译成*.pbobjc.h 和 *.pbobjc.m文件时,碰到不少问题! 搭建pb编译器到时没有什么问题,只是在把*.pro ...
- Android种使用Notification实现通知管理以及自定义通知栏(Notification示例四)
示例一:实现通知栏管理 当针对相同类型的事件多次发出通知,作为开发者,应该避免使用全新的通知,这时就应该考虑更新之前通知栏的一些值来达到提醒用户的目的.例如我们手机的短信系统,当不断有新消息传来时,我 ...
- oracle常用函数及示例
学习oracle也有一段时间了,发现oracle中的函数好多,对于做后台的程序猿来说,大把大把的时间还要学习很多其他的新东西,再把这些函数也都记住是不太现实的,所以总结了一下oracle中的一些常用函 ...
随机推荐
- [Angular] FormBuildAPI
Using FormBuilder API can simply our code, for example we want to refactor following code by using F ...
- java 原子量Atomic举例(AtomicReference)
java并发库提供了很多原子类来支持并发访问的数据安全性,除了常用的 AtomicInteger.AtomicBoolean.AtomicLong 外还有 AtomicReference 用以支持对象 ...
- js进阶 9-8 html标签如何实现禁止复制和粘贴
js进阶 9-8 html标签如何实现禁止复制和粘贴 一.总结 一句话总结: 1.在oncopy方法中return false即可阻止在控件中复制内容 2.在onpaste方法中return fal ...
- UIPasteboard粘贴板:UIMenuController自定义(三)
这篇咱总结总结自定义剪贴板的使用 其实自定义剪贴板也非常简单,无非是放开响应时间,通过UIMenuController自定义剪贴板,然后就是最关键的实现你所用的copy方法拉. 为了方便实用,我给ce ...
- svn X在Xcode中使用
1 在终端输入命令:清除以前的svn链接地址( /Users/mac/Desktop/SHiosProject/SVNmangerfiles) nie-xiao-bo-mac-pro:~ mac$ s ...
- matlab 求解线性规划问题
线性规划 LP(Linear programming,线性规划)是一种优化方法,在优化问题中目标函数和约束函数均为向量变量的线性函数,LP问题可描述为: minf(x):待最小化的目标函数(如果问题本 ...
- 微信,支付宝,支付异步通知验签,notify_url
在支付接口开发中 ,当用户支付完成之后,阿里或者微信会向我们服务器发送一个支付结果的通知,里边带有一系列参数:其中特殊的是签名类型,和签名(他们根据这些参数做出来的签名). 我们的得到这些参数之后要去 ...
- Parallel.For
Parallel.For 你可能忽视的一个非常实用的重载方法 说起Parallel.For大家都不会陌生,很简单,不就是一个提供并行功能的for循环吗? 或许大家平时使用到的差不多就是其中最简单 ...
- so文件成品评论【整理】
这是我的 @布加迪20 AZ在一篇文章中写道:<汉化so文件的心得>中的技术附件做的简洁性整理.原来的看起来不是非常方便.一起分享学习.. 正文 SO文件汉化心得 --By布加迪20 ...
- 强大的 pdf 编辑器 —— Acrobat
菜单栏中的 [编辑](Edit)⇒ [编辑文本和图像](Edit Text & Images) 可以随意地编辑当前 pdf 中的文本信息,和图像信息: pdf 格式的转换,更是不在话下. 转 ...