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中的一些常用函 ...
随机推荐
- 小强的HTML5移动开发之路(47)——jquery mobile基本的页面框架
一.单容器页面结构 <!DOCTYPE html> <html> <head> <title>Jquery mobile 基本页面框架</titl ...
- Hdu4771(杭州赛区)
Stealing Harry Potter's Precious Time Limit: 2000/1000 MS (Java/Others) Memory Limit: 32768/32768 ...
- Android 截取手机屏幕两种实现方案解析
近期在开发的过程中,遇到了一个须要截取屏幕保存为图片的需求,详细为截取webview的视图保存图片. 方法1:首先想到的思路是利用SDK提供的View.getDrawingCache()方法: pub ...
- 物理引擎UIDynamic
nUIDynamic n什么是UIDynamic pUIDynamic是从iOS 7开始引入的一种新技术,隶属于UIKit框架 p可以认为是一种物理引擎,能模拟和仿真现实生活中的物理现象 ü重力. ...
- 【t051】图书管理
Time Limit: 1 second Memory Limit: 128 MB [问题描述] 图书管理是一件十分繁杂的工作,在一个图书馆中每天都会有许多新书加入.为了更方便的管理图书(以便于帮助想 ...
- window.load和ready的差别
1.运行时机: window.onload:必须等待网页所有加在完成(包含图片等),然后再运行包裹代码 $(document).ready():仅仅须要等待网页中的DOM结构载入完成.就能运行包裹的代 ...
- UITextView的一些事1
TextView如果只是作为展示文本时,要设置如下属性: //不可编辑(是否弹出键盘) TextView_label.editable=NO; //不可选择(长按不会出现复制.粘贴) TextView ...
- UIApplicationsharedApplication的详解
iPhone应用程序是由主函数main启动,它负责调用UIApplicationMain函数,该函数的形式如下所示: int UIApplicationMain ( int argc, char *a ...
- 子查询及exists
子查询分为无关子查询和相关子查询 无关子查询,只查询一次,与外查询无关,可作为查询条件: select * from student where sno in (select sno from stu ...
- [think in java] 第8章 多态
多态 "封装"通过合并特征和行为来创建新的数据类型. "多态"的作用则是消除类型之间的耦合关系. 方法调用绑定 定义:将一个方法调用同一个方法主题关联起来被称为 ...