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, 80);
    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[0].IP,
          HTTPServer.Bindings[0].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 := 0;
  for i := 1 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 ', #8]) then
    Key := #0;
end;

procedure TfmHTTPServerMain.edPortExit(Sender: TObject);
begin
  if length(trim(edPort.text)) = 0 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 '], 0);
      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 ']) > 0 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 > -1 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> '#13 +
      '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> '#13 +
      'You   do   not   have   sufficient   priviligies   to   access   this   document. </body> </html> ';
    ResponseInfo.ResponseNo := 403;
  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)) = 1) 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, 1, 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 := 200;
            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 := 404; // 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) * 24 + hour) * 60 + min) * 60 + 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 > -1 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.