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.

转载于:https://www.cnblogs.com/toosuo/archive/2012/02/17/2355522.html