Проверка состояния HTTP и FTP серверов

← →
maDByte (2004-05-24 07:36) [0]

У нас есть локальная сеть, протянутая по всему городу. Есть куча разных серверов. Как хттп, так и фтп. Есть инет-страница, которая показывает статистику этих серверов. Определяет она это состояние следующим образом: на каждом сервере (HTTP or FTP) есть файл y.gif. Так вот если его нет, то картинка в браузер не грузится, а если есть, то грузится Таким образом юзеры видят состояние серверов в данный момент.
На Дельфи я хочу сделать тоже самое. Вернее почти уже сделал... но пока нашел функцию скачки файлов только по HTTP. Но на 11 сервере она почему-то останавливается и ничего не пишет. Причем если 11ым поставить другой сервер, все происходит также
Может как-то можно по-другому проверить состояние FTP и HTTP ?
Вот исходник проекта:

=== Unit1.pas ===

CODE

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Wininet,
StdCtrls, ExtCtrls, jpeg, Psock, NMHttp;

type
TForm1 = class(TForm)
Image1: TImage;
Image3: TImage;
Label2: TLabel;
Image2: TImage;
Image4: TImage;
img_on: TImage;
img_off: TImage;
Scroll: TScrollBox;
Label1: TLabel;
http: TNMHTTP;
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Image4Click(Sender: TObject);
procedure ScrollClick(Sender: TObject);
private
{ Private declarations }
public
procedure Load_Servers;
procedure Show_All (list, ip: TStringList);
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

var servers: array[1..50] of string;
ips: array[1..50] of string;

function GetFile(const fileURL, FileName: string): boolean;
const
BufferSize = 1024;
var
hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen: DWORD;
f: file;
sAppName: string;
begin
Result := False;
sAppName := ExtractFileName(Application.ExeName);
hSession := InternetOpen(PChar(sAppName),
INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
try
hURL := InternetOpenURL(hSession, PChar(fileURL), nil, 0, 0, 0);
try
//AssignFile(f, FileName);
//Rewrite(f,1);
repeat
InternetReadFile(hURL, @Buffer, SizeOf(Buffer), BufferLen);
//BlockWrite(f, Buffer, BufferLen);
until
BufferLen = 0;
//CloseFile(f);
Result := True;
finally
InternetCloseHandle(hURL);
end;
finally
InternetCloseHandle(hSession);
end;
end;

procedure TForm1.Show_All (list, ip: TStringList);
var
i: integer;
_label: TLabel;
_img: TImage;
l: TStringList;
_server, _ip: string;
begin
l := list;
for i:=0 to l.count-1 do begin
if (list.strings[i]<>"")and(ip.strings[i]<>"")then
begin
_server := l.strings[i];
_ip := ip.strings[i];
_label := TLabel.Create (Form1);
with _label do begin
Parent := Scroll;
Transparent := true;
Caption := _server;
Font.Size := 7;
Font.Name := "Tahoma";
Font.Style := [fsBold];
Left:=20;
Top:=Form1.Tag;
end;
_img := TImage.Create (nil);
with _img do begin
Parent := Scroll;
Picture := img_on.Picture;
AutoSize := true;
try
if (pos ("http://", _ip)<>0) and (_ip<>"") then begin
if GetFile(_ip+"/y.gif", "tmp.gif") = True then
Picture := img_on.Picture
else
Picture := img_off.Picture;
end;
except
end;
Left := 5;
Top:=Form1.Tag;

end;
Form1.Tag := Form1.Tag + 13;
end;
Label1.Caption := IntToStr(StrToInt(Label1.Caption)+1);
Application.ProcessMessages;
end;
Form1.Tag := 50;
end;

procedure TForm1.Load_Servers;
var
Handle: Thandle;
GetServers: function: TStringList;
GetIP: function: TStringList;
servers, ip: TStringList;
begin
handle:=LoadLibrary(pchar("Data\base.dll"));
if handle<>0 then begin
@GetServers:=GetProcAddress(handle,"GetServers");
@GetIP:=GetProcAddress(handle,"GetIP");
if (@GetServers<>nil)and(@GetIP<>nil) then begin
servers := GetServers;
ip := GetIP;
Show_All (servers, ip);
end;
end;

end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DragMove = $F012;
begin
ReleaseCapture;
Form1.Perform(WM_SysCommand, SC_DragMove, 0);
end;

procedure TForm1.Image2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Image4.Visible := True;
Image2.Visible := False;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Image2.Visible := True;
Image4.Visible := False;
end;

procedure TForm1.Image4Click(Sender: TObject);
begin
Form1.Close;
end;

procedure TForm1.ScrollClick(Sender: TObject);
begin
Load_Servers;
end;

end.

=== Base.DLL ===

CODE

library Base;

uses
SysUtils,
Classes;

{$R *.RES}

function GetServers: TStringList;
var
list1: TStringList;
begin
list1 := TStringList.Create;
list1.Add ("1ый сервер");
list1.Add ("2ой сервер");
list1.Add ("3ий сервер");
GetServers := list1;
end;

function GetIP: TStringList;
var
list2: TStringList;
begin
list2 := TStringList.Create;
list2.Add ("10.100.1.1");
list2.Add ("10.100.1.2");
list2.Add ("10.100.1.3");
result := list2;
end;

exports
GetServers,
GetIP;

begin
end.

После этого, я нашел выход не качать y.gif, а просто проверять существование URL функцией:

=== ==== ==== ==== ==== ===
function CheckUrl(url: string): boolean;
var
hSession, hfile, hRequest: hInternet;
dwindex, dwcodelen: dword;
dwcode: array [1..20] of char;
res: pchar;
begin
Result := false;
hSession := InternetOpen("InetURL:/1.0", INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if assigned(hsession) then
begin
hfile := InternetOpenUrl(hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
dwIndex := 0;
dwCodeLen := 10;
HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
res := pchar(@dwcode);
result := (res = "200") or (res = "302");
if assigned(hfile) then
InternetCloseHandle(hfile);
InternetCloseHandle(hsession);
end;
end;
=== ==== ==== ==== ==== ===

Но тут опять проблема. Если ресурс существует, программа тут же об этом извещает, но если нет - она перед ответом думает секунд 25. А это очень много. Нельзя ли ускорить как-то эту проверку?

← →
Izyum © (2004-05-25 15:31) [1]

Это как-то все геморно со скачиванием файла...
Не проще ли пробовать цеплятся телнетом на нужный хост+порт?

Проверка состояния HTTP и FTP серверов Найти похожие ветки