📄 ftpserv1.pas
字号:
{$IFDEF NEVER}
{ It the right place to check if a user has access to a given directory }
{ The example below disable C:\ access to non root user. }
if (UpperCase(Client.UserName) <> 'ROOT') and
(UpperCase(Client.Directory) = 'C:\') then
Allowed := FALSE;
{$ENDIF}
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.Cleardisplay1Click(Sender: TObject);
begin
InfoMemo.Clear;
DisplayMemo.Clear;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.MnuListClientsClick(Sender: TObject);
var
I : Integer;
begin
if FtpServer1.ClientCount <= 0 then begin
InfoMemo.Lines.Add('No client');
Exit;
end;
for I := 0 to FtpServer1.ClientCount - 1 do begin
InfoMemo.Lines.Add('Client ' + IntToStr(I + 1) + ': ' +
FtpServer1.Client[I].GetPeerAddr + '/' +
FtpServer1.Client[I].GetPeerPort);
end;
end;
destructor TMyHttpConnection.Destroy;
begin
if Assigned(FPostedDataBuffer) then begin
FreeMem(FPostedDataBuffer, FPostedDataSize);
FPostedDataBuffer := nil;
FPostedDataSize := 0;
end;
inherited Destroy;
end;
procedure TMainForm.StopButtonClick(Sender: TObject);
begin
HttpServer1.Stop;
StartWebService1.Enabled:=True;
StopWebService1.Enabled:=False;
Image2.Visible := FALSE;
Image1.Visible := TRUE;
end;
procedure TMainForm.ClearButtonClick(Sender: TObject);
begin
DisplayMemo.Clear;
end;
procedure TMainForm.HttpServer1ServerStarted(Sender: TObject);
begin
DocDirEdit.Enabled := FALSE;
DefaultDocEdit.Enabled := FALSE;
PortEdit.Enabled := FALSE;
StartButton.Enabled := FALSE;
StopButton.Enabled := TRUE;
Display('^_^ Web Service started.');
end;
procedure TMainForm.HttpServer1ServerStopped(Sender: TObject);
begin
DocDirEdit.Enabled := TRUE;
DefaultDocEdit.Enabled := TRUE;
PortEdit.Enabled := TRUE;
StartButton.Enabled := TRUE;
StopButton.Enabled := FALSE;
Display('*_* Web Service stopped');
end;
procedure TMainForm.HttpServer1ClientConnect(Sender, Client: TObject;
Error: Word);
begin
ClientCountLabel.Caption := IntToStr(HttpServer1.ClientCount);
end;
procedure TMainForm.HttpServer1ClientDisconnect(Sender,
Client: TObject; Error: Word);
begin
ClientCountLabel.Caption := IntToStr(HttpServer1.ClientCount - 1);
end;
procedure TMainForm.HttpServer1HeadDocument(Sender, Client: TObject;
var Flags: THttpGetFlag);
begin
Inc(FCountRequests);
Display(IntToStr(FCountRequests) +
': HEAD ' + TMyHttpConnection(Client).Path);
end;
procedure TMainForm.HttpServer1GetDocument(Sender, Client: TObject;
var Flags: THttpGetFlag);
begin
{ Count request and display a message }
Inc(FCountRequests);
Display(IntToStr(FCountRequests) +
': GET ' + TMyHttpConnection(Client).Path);
DisplayHeader(TMyHttpConnection(Client));
{ Trap '/time.htm' path to dynamically generate an answer. }
if CompareText(THttpConnection(Client).Path, '/time.htm') = 0 then
CreateVirtualDocument_time_htm(Sender, Client, Flags);
end;
procedure TMainForm.CreateVirtualDocument_time_htm(Sender : TObject;Client : TObject;var Flags : THttpGetFlag);
var
Body : String;
Header : String;
Stream : TMemoryStream;
begin
{ Let HTTP server component know we will send data to client }
Flags := hgWillSendMySelf;
{ Create a stream to hold data sent to client that is the answer }
{ made of a HTTP header and a body made of HTML code. }
Stream := TMemoryStream.Create;
Body := '<HTML>' +
'<HEAD>' +
'<TITLE>ICS WebServer Demo</TITLE>' +
'</HEAD>' + #13#10 +
'<BODY>' +
'<H2>Time at server side:</H2>' + #13#10 +
'<P>' + DateTimeToStr(Now) +'</P>' + #13#10 +
'</BODY>' +
'</HTML>' + #13#10;
Header := TMyHttpConnection(Client).Version + ' 200 OK' + #13#10 +
'Content-Type: text/html' + #13#10 +
'Content-Length: ' +
IntToStr(Length(Body)) + #13#10 +
#13#10;
Stream.Write(Header[1], Length(Header));
Stream.Write(Body[1], Length(Body));
{ We need to seek to start of stream ! }
Stream.Seek(0, 0);
{ We ask server component to send the stream for us. }
TMyHttpConnection(Client).DocStream := Stream;
TMyHttpConnection(Client).SendStream;
end;
procedure TMainForm.HttpServer1PostDocument(Sender, Client: TObject;
var Flags: THttpGetFlag);
var
Remote : TMyHttpConnection;
begin
{ It's easyer to do the cast one time. Could use with clause... }
Remote := TMyHttpConnection(Client);
{ Count request and display a message }
Inc(FCountRequests);
Display(IntToStr(FCountRequests) + ': POST ' + Remote.Path);
DisplayHeader(Remote);
{ Check for request past. We only accept data for '/cgi-bin/cgifrm1.exe' }
if CompareText(Remote.Path, '/cgi-bin/cgifrm1.exe') = 0 then begin
{ Tell HTTP server that we will accept posted data }
{ OnPostedData event will be triggered when data comes in }
Flags := hgAcceptData;
{ We wants to receive any data type. So we turn line mode off on }
{ client connection. }
Remote.LineMode := FALSE;
{ We need a buffer to hold posted data. We allocate as much as the }
{ size of posted data plus one byte for terminating nul char. }
{ We should check for ContentLength = 0 and handle that case... }
{$IFDEF VER80}
if Remote.FPostedDataSize = 0 then begin
Remote.FPostedDataSize := Remote.RequestContentLength + 1;
GetMem(Remote.FPostedDataBuffer, Remote.FPostedDataSize);
end
else begin
ReallocMem(Remote.FPostedDataBuffer, Remote.FPostedDataSize, Remote.RequestContentLength + 1);
Remote.FPostedDataSize := Remote.RequestContentLength + 1;
end;
{$ELSE}
ReallocMem(Remote.FPostedDataBuffer, Remote.RequestContentLength + 1);
{$ENDIF}
{ Clear received length }
Remote.FDataLen := 0;
end
else
Flags := hg404;
end;
procedure TMainForm.HttpServer1PostedData(Sender, Client: TObject;
Error: Word);
var
Len : Integer;
Remains : Integer;
Junk : array [0..255] of char;
Remote : TMyHttpConnection;
begin
{ It's easyer to do the cast one time. Could use with clause... }
Remote := TMyHttpConnection(Client);
{ How much data do we have to receive ? }
Remains := Remote.RequestContentLength - Remote.FDataLen;
if Remains <= 0 then begin
{ We got all our data. Junk anything else ! }
Len := Remote.Receive(@Junk, SizeOf(Junk) - 1);
if Len >= 0 then
Junk[Len] := #0;
Exit;
end;
{ Receive as much data as we need to receive. But warning: we may }
{ receive much less data. Data will be split into several packets we }
{ have to assemble in our buffer. }
Len := Remote.Receive(Remote.FPostedDataBuffer + Remote.FDataLen, Remains);
{ Sometimes, winsock doesn't wants to givve any data... }
if Len <= 0 then
Exit;
{ Add received length to our count }
Inc(Remote.FDataLen, Len);
{ Add a nul terminating byte (handy to handle data as a string) }
Remote.FPostedDataBuffer[Remote.FDataLen] := #0;
{ Display receive data so far }
Display('Data: ''' + StrPas(Remote.FPostedDataBuffer) + '''');
{ When we received the whole thing, we can process it }
if Remote.FDataLen = Remote.RequestContentLength then begin
if CompareText(Remote.Path, '/cgi-bin/cgifrm1.exe') = 0 then
ProcessPostedData_CgiFrm1(Remote)
else
Remote.Answer404;
end;
end;
procedure TMainForm.ProcessPostedData_CgiFrm1(Client : TMyHttpConnection);
var
Stream : TStream;
FileName : String;
Body : String;
Header : String;
FirstName : String;
LastName : String;
HostName : String;
Buf : String;
begin
{ Extract fields from posted data. }
ExtractURLEncodedValue(Client.FPostedDataBuffer, 'FirstName', FirstName);
ExtractURLEncodedValue(Client.FPostedDataBuffer, 'LastName', LastName);
{ Get client IP address. We could to ReverseDnsLookup to get hostname }
HostName := Client.PeerAddr;
{ Build the record to write to data file }
Buf := FormatDateTime('YYYYMMDD HHNNSS ', Now) +
FirstName + '.' + LastName + '@' + HostName + #13#10;
{ Save data to a text file }
FileName := ExtractFilePath(Application.ExeName) + 'CgiFrm1.txt';
if FileExists(FileName) then
Stream := TFileStream.Create(FileName, fmOpenWrite)
else
Stream := TFileStream.Create(FileName, fmCreate);
Stream.Seek(0, soFromEnd);
Stream.Write(Buf[1], Length(Buf));
Stream.Destroy;
{ Now create output stream to send back to remote client }
Stream := TMemoryStream.Create;
Body := '<HTML>' +
'<HEAD>' +
'<TITLE>ICS WebServer Demo</TITLE>' +
'</HEAD>' + #13#10 +
'<BODY>' +
'<H2>Your data has been recorded:</H2>' + #13#10 +
'<P>' + FirstName + '.' + LastName + '@' + HostName +'</P>' +
'</BODY>' +
'</HTML>' + #13#10;
Header := Client.Version + ' 200 OK' + #13#10 +
'Content-Type: text/html' + #13#10 +
'Content-Length: ' +
IntToStr(Length(Body)) + #13#10 +
#13#10;
Stream.Write(Header[1], Length(Header));
Stream.Write(Body[1], Length(Body));
Stream.Seek(0, 0);
{ Ask HTTP server component to send data stream for us }
Client.DocStream := Stream;
Client.SendStream;
end;
procedure TMainForm.DisplayHeader(Client : TMyHttpConnection);
var
I : Integer;
begin
if not DisplayHeaderCheckBox.Checked then
Exit;
for I := 0 to Client.RequestHeader.Count - 1 do
Display('HDR' + IntToStr(I + 1) + ') ' +
Client.RequestHeader.Strings[I]);
end;
procedure TMainForm.StartWebService1Click(Sender: TObject);
begin
StartButton.Click;
SpeedButton1.Caption:='Stop'+#13+'Web Service';
end;
procedure TMainForm.StopWebService1Click(Sender: TObject);
begin
StopButton.Click;
SpeedButton1.Caption:='Start'+#13+'Web Service';
end;
procedure TMainForm.SpeedButton1Click(Sender: TObject);
begin
if pos('Start',SpeedButton1.Caption)<>0 then begin
StartButton.Click;
SpeedButton1.Caption:='Stop'+#13+'Web Service';
Exit;
end;
if pos('Stop',SpeedButton1.Caption)<>0 then begin
StopWebService1.Click;
SpeedButton1.Caption:='Start'+#13+'Web Service';
Exit;
end;
end;
procedure TMainForm.SpeedButton2Click(Sender: TObject);
begin
if pos('Start',SpeedButton2.Caption)<>0 then begin
StartServer;
SpeedButton2.Caption:='Stop'+#13+'FTP Service';
Exit;
end;
if pos('Stop',SpeedButton2.Caption)<>0 then begin
StopFTPService1.Click;
SpeedButton2.Caption:='Start'+#13+'FTP Service';
Exit;
end;
end;
procedure TMainForm.Image2DblClick(Sender: TObject);
begin
if StopWebService1.Enabled then
StopButton.Click
else
StartButton.Click;
end;
procedure TMainForm.Image1DblClick(Sender: TObject);
begin
if StopWebService1.Enabled then
StopButton.Click
else
StartButton.Click;
end;
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -