ftpserv1.pas

Tu may tinh den may chu

unit FtpServ1;

interface

uses
  WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, IniFiles, FtpSrv, FtpSrvC, WSocket, StdCtrls, ExtCtrls, Menus,
  Winsock, HttpSrv, WSocketS, Buttons;

const
  FtpServVersion      = 110;
  WM_APPSTARTUP       = WM_USER + 1;

type
  TLogMsg = class(TComponent)
  public
     procedure Text(Prefix : Char; Msg : String);
  end;

  TMyHttpConnection = class(THttpConnection)
  protected
    FPostedDataBuffer : PChar;     { Will hold dynamically allocated buffer }
    FPostedDataSize   : Integer;   { Databuffer size                        }
    FDataLen          : Integer;   { Keep track of received byte count.     }
  public
    destructor  Destroy; override;
  end;

  TMainForm = class(TForm)
    FtpServer1: TFtpServer;
    InfoMemo: TMemo;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    StartFTPService1: TMenuItem;
    StopFTPService1: TMenuItem;
    About1: TMenuItem;
    Tools1: TMenuItem;
    Cleardisplay1: TMenuItem;
    MnuListClients: TMenuItem;
    N2: TMenuItem;
    HttpServer1: THttpServer;
    PortEdit: TEdit;
    DocDirEdit: TEdit;
    DefaultDocEdit: TEdit;
    DisplayHeaderCheckBox: TCheckBox;
    ClearButton: TButton;
    StartButton: TButton;
    StopButton: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    DisplayMemo: TMemo;
    WebService: TMenuItem;
    StartWebService1: TMenuItem;
    StopWebService1: TMenuItem;
    N1: TMenuItem;
    Viewstatus1: TMenuItem;
    ViewLog1: TMenuItem;
    ViewFTPLog1: TMenuItem;
    Viewalllogs1: TMenuItem;
    N3: TMenuItem;
    User1: TMenuItem;
    ServerOptions1: TMenuItem;
    GreenImage: TImage;
    RedImage: TImage;
    Label6: TLabel;
    ClientCountLabel: TLabel;
    StartMinimizedCheckBox: TCheckBox;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton4: TSpeedButton;
    Image1: TImage;
    Image2: TImage;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    CheckBox1: TCheckBox;
    Label12: TLabel;
    Edit1: TEdit;
    Label13: TLabel;
    Label14: TLabel;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    CheckBox4: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure FtpServer1ClientConnect(Sender: TObject;
      Client: TFtpCtrlSocket; Error: Word);
    procedure FtpServer1ClientDisconnect(Sender: TObject;
      Client: TFtpCtrlSocket; Error: Word);
    procedure FtpServer1Start(Sender: TObject);
    procedure FtpServer1Stop(Sender: TObject);
    procedure FtpServer1ClientCommand(Sender: TObject;
      Client: TFtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
    procedure FtpServer1StorSessionConnected(Sender: TObject;
      Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
    procedure FtpServer1StorSessionClosed(Sender: TObject;
      Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
    procedure FtpServer1RetrDataSent(Sender: TObject;
      Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
    procedure FtpServer1RetrSessionConnected(Sender: TObject;
      Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
    procedure FtpServer1RetrSessionClosed(Sender: TObject;
      Client: TFtpCtrlSocket; Data: TWSocket; Error: Word);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FtpServer1AnswerToClient(Sender: TObject;
      Client: TFtpCtrlSocket; var Answer: TFtpString);
    procedure FtpServer1Authenticate(Sender: TObject;
      Client: TFtpCtrlSocket; UserName, Password: TFtpString;
      var Authenticated: Boolean);
    procedure FtpServer1ChangeDirectory(Sender: TObject;
      Client: TFtpCtrlSocket; Directory: TFtpString; var Allowed: Boolean);
    procedure MnuQuitClick(Sender: TObject);
    procedure StopFTPService1Click(Sender: TObject);
    procedure StartFTPService1Click(Sender: TObject);
    procedure ImagesDblClick(Sender: TObject);
    procedure FtpServer1BuildDirectory(Sender: TObject;
      Client: TFtpCtrlSocket; var Directory: TFtpString; Detailed: Boolean);
    procedure FtpServer1AlterDirectory(Sender: TObject;
      Client: TFtpCtrlSocket; var Directory: TFtpString; Detailed: Boolean);
    procedure Cleardisplay1Click(Sender: TObject);
    procedure MnuListClientsClick(Sender: TObject);
    procedure StartButtonClick(Sender: TObject);
    procedure StopButtonClick(Sender: TObject);
    procedure ClearButtonClick(Sender: TObject);
    procedure HttpServer1ServerStarted(Sender: TObject);
    procedure HttpServer1ServerStopped(Sender: TObject);
    procedure HttpServer1ClientConnect(Sender, Client: TObject;
      Error: Word);
    procedure HttpServer1ClientDisconnect(Sender, Client: TObject;
      Error: Word);
    procedure HttpServer1HeadDocument(Sender, Client: TObject;
      var Flags: THttpGetFlag);
    procedure HttpServer1GetDocument(Sender, Client: TObject;
      var Flags: THttpGetFlag);
    procedure HttpServer1PostDocument(Sender, Client: TObject;
      var Flags: THttpGetFlag);
    procedure HttpServer1PostedData(Sender, Client: TObject; Error: Word);
    procedure StartWebService1Click(Sender: TObject);
    procedure StopWebService1Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure Image2DblClick(Sender: TObject);
    procedure Image1DblClick(Sender: TObject);
  private
    FInitialized      : Boolean;
    FIniFileName      : String;
    FPort             : String;
 //   FPort2            : String;
    FXTop             : Integer;
    FXLeft            : Integer;
    FXWidth           : Integer;
    FXHeight          : Integer;
    FInitialized2     : Boolean;
    FCountRequests    : Integer;
    procedure WMAppStartup(var msg: TMessage); message WM_APPSTARTUP;
    procedure StartServer;
    procedure StopServer;
    procedure UpdateClientCount;
    procedure CreateVirtualDocument_time_htm(Sender    : TObject;Client    : TObject;var Flags : THttpGetFlag);
    procedure DisplayHeader(Client : TMyHttpConnection);
    procedure ProcessPostedData_CgiFrm1(Client : TMyHttpConnection);
  public
    procedure Display(Msg : String);
    property  IniFileName : String read FIniFileName write FIniFileName;
  end;

var
  MainForm: TMainForm;
  Log          : TLogMsg;

implementation

{$R *.DFM}

const
    MainTitle   ='PC2Server';
    { Ini file layout }
    SectionData       = 'Data';
    KeyPort           = 'Port';
    KeyPort2          = 'Port2';
    SectionWindow     = 'Window';
    KeyMinim          = 'RunMinimized';

    STATUS_GREEN      = 0;
    STATUS_YELLOW     = 1;
    STATUS_RED        = 2;
    KeyDocDir          = 'DocDir';
    KeyDefaultDoc      = 'DefaultDoc';
    KeyDisplayHeader   = 'DisplayHeader';

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TLogMsg.Text(Prefix : Char; Msg : String);
begin
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FormShow(Sender: TObject);
var
    IniFile : TIniFile;
    Minim   : Integer;
    wsi     : TWSADATA;
begin

        IniFile  := TIniFile.Create(FIniFileName);
        Minim    := IniFile.ReadInteger(SectionWindow, KeyMinim,  0);
        DocDirEdit.Text     := IniFile.ReadString(SectionData, KeyDocDir,
                                                  'c:\WwwRoot');
        DefaultDocEdit.Text := IniFile.ReadString(SectionData, KeyDefaultDoc,
                                                  'index.htm');
        PortEdit.Text       := IniFile.ReadString(SectionData, KeyPort2,
                                                  '80');
        DisplayHeaderCheckBox.Checked :=
        Boolean(IniFile.ReadInteger(SectionData, KeyDisplayHeader, 0));
        IniFile.Free;

        StartMinimizedCheckBox.Checked := (Minim <> 0);

    if not FInitialized then begin
        //FInitialized        := TRUE;
        //Caption             := 'Starting ' + MainTitle;
         StartFTPService1.Enabled:=True;
         StopFTPService1.Enabled:=False;
        //Left := -Width;
        { We use a custom message to initialize things once the form }
        { is visible                                                 }
  //      PostMessage(Handle, WM_APPSTARTUP, 0, 0);
    end;
                         //HTTP Server
      if not FInitialized2 then begin
        //FInitialized2 := TRUE;
         StartWebService1.Enabled:=True;
         StopWebService1.Enabled:=False;
        { Initialize client count caption }
        ClientCountLabel.Caption := 'No connections';
        { Display version info for program and use components }
        wsi := WinsockInfo;
        DisplayMemo.Clear;
      //  Display(CopyRight);
      // Display('Using:');
      //  Display('   ' + WSocket.CopyRight);
      //  Display('   ' + WSocketS.CopyRight);
      //  Display('   ' + HttpSrv.CopyRight);
{        Display('Winsock Version ' +
                Format('%d.%d', [WinsockInfo.wHighVersion shr 8,
                                 WinsockInfo.wHighVersion and 15]));}
     //   ' ' + StrPas(@wsi.szSystemStatus));
{$IFNDEF VER100}
        { A bug in Delphi 3 makes lpVendorInfo invalid }
        if wsi.lpVendorInfo <> nil then
            Display('        ' + StrPas(wsi.lpVendorInfo));
{$ENDIF}
        { Automatically start server }
    //     StartButtonClick(Self);
    end;

end;

procedure TMainForm.StartButtonClick(Sender: TObject);
begin
    HttpServer1.DocDir      := Trim(DocDirEdit.Text);
    HttpServer1.DefaultDoc  := Trim(DefaultDocEdit.Text);
    HttpServer1.Port        := Trim(PortEdit.Text);
    HttpServer1.ClientClass := TMyHttpConnection;
    HttpServer1.Start;
    StartWebService1.Enabled:=False;
    StopWebService1.Enabled:=True;
    Image1.Visible := FALSE;
    Image2.Visible := TRUE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.FormClose(Sender: TObject;
  var Action: TCloseAction);
var
    IniFile : TIniFile;
    Minim   : Integer;
begin
        StopServer;    StopButton.Click;
    try
        Minim   := ord(StartMinimizedCheckBox.Checked);
        IniFile := TIniFile.Create(FIniFileName);
        IniFile.WriteString(SectionData,    KeyDocDir,      DocDirEdit.Text);
        IniFile.WriteString(SectionData,    KeyDefaultDoc,  DefaultDocEdit.Text);
        IniFile.WriteString(SectionData,    KeyPort2,        PortEdit.Text);
        IniFile.WriteInteger(SectionData,   KeyDisplayHeader, ord(DisplayHeaderCheckBox.Checked));
        IniFile.WriteInteger(SectionWindow, KeyMinim,  Minim);
        IniFile.WriteString(SectionData,    KeyPort,   FPort);
        IniFile.Free;
    except
        { Ignore any exception when we are closing }
    end;
end;

procedure TMainForm.Display(Msg : String);
begin
    DisplayMemo.Lines.BeginUpdate;
    try
        if DisplayMemo.Lines.Count > 200 then begin
            { We preserve only 200 lines }
            while DisplayMemo.Lines.Count > 200 do
                DisplayMemo.Lines.Delete(0);
        end;
        DisplayMemo.Lines.Add(Msg);
    finally
        DisplayMemo.Lines.EndUpdate;
        { Makes last line visible }
        {$IFNDEF VER80}
        SendMessage(DisplayMemo.Handle, EM_SCROLLCARET, 0, 0);
        {$ENDIF}
    end;
end;



{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This message handler is triggered by the FormShow event. We comes here    }
{ only when the form is visible on screen.                                  }
procedure TMainForm.WMAppStartup(var msg: TMessage);
var
    PrvWnd  : HWND;
    Buf     : String;
begin
    if StartMinimizedCheckBox.Checked then
        Application.Minimize;
    Top    := FXTop;
    Left   := FXLeft;
    Width  := FXWidth;
    Height := FXHeight;

    { Prevent the server from running twice }
    Buf    := ClassName + #0;
    PrvWnd := FindWindow(@Buf[1], MainTitle);
    if PrvWnd <> 0 then begin
        Log.Text('E', 'Server already running. Shutdown.');
        Close;
        Exit;
    end;
    Caption := MainTitle;
    Update;                { It's nice to have the form completely displayed }

    StartServer;
    UpdateClientCount;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFNDEF VER80 }
{ To debug event driven programs, it is often handy to just use writeln to  }
{ write debug messages to the console. To get a console, just ask the       }
{ linker to build a console mode application. Then you'll get the default   }
{ console. The function below will make it the size you like...             }
procedure BigConsole(nCols, nLines : Integer);
var
    sc : TCoord;
    N  : DWord;
begin
    if not IsConsole then
        Exit;
    sc.x := nCols;