VPF::web server - Форум программистов

Плаха

Дата 2.6.2005, 13:07 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 126
Регистрация: 10.11.2004
Где: МО п. Киевский

Репутация: нет
Всего: нет

скажите что не так.
Делаю web сервер. использую компонент IdHTTPServer

Код


procedure Tfr_Main.HTTPServerCommandGet(AThread: TIdPeerThread;
  ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
put:string;
begin
put:=ComboBox1.Text;
HTTPServer.ServeFile(AThread, AResponseInfo,put+ARequestInfo.Document);

страничка нормально загружается, но когда пытаешся скачать какой либо фаил с этой страницы то место скачивания он его открывает.

--------------------

Принимай то что есть и устраивайся как хочеш

_hunter

Дата 2.6.2005, 13:27 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 8564
Регистрация: 24.6.2003
Где: Europe::Ukraine:: Kiev

Репутация: 5
Всего: 98

content type задавай

--------------------

Tempora mutantur, et nos mutamur in illis...

Плаха

Дата 2.6.2005, 15:20 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 126
Регистрация: 10.11.2004
Где: МО п. Киевский

Репутация: нет
Всего: нет

Цитата(_hunter @ 2.6.2005, 13:27)

content type задавай

А можеш пример привести.
Плиз

--------------------

Принимай то что есть и устраивайся как хочеш

_hunter

Дата 2.6.2005, 16:14 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 8564
Регистрация: 24.6.2003
Где: Europe::Ukraine:: Kiev

Репутация: 5
Всего: 98

не могу -- не работал я с ним.

--------------------

Tempora mutantur, et nos mutamur in illis...

Borland_Delphi_6

Дата 2.6.2005, 16:19 (ссылка)

(нет голосов)

Загрузка ...

LoneLINEss

Профиль
Группа: Участник Клуба
Сообщений: 2509
Регистрация: 5.11.2002
Где: in fortune dreams ...

Репутация: нет
Всего: 20

В DRKB пример всего сервера.
Добавлено @ 16:20
Короче, вот:

Код


unit uMainForm; 

interface 

uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  IdBaseComponent, IdComponent, IdTCPServer, IdHTTPServer, StdCtrls, 
  ExtCtrls, HTTPApp; 

type 
  TfrmServer = class(TForm) 
    httpServer: TIdHTTPServer; 
    chkActive: TCheckBox; 
    Label1: TLabel; 
    edtRootFolder: TEdit; 
    btnGetFolder: TButton; 
    Label2: TLabel; 
    edtDefaultDoc: TEdit; 
    lstLog: TListBox; 
    Bevel1: TBevel; 
    btnClearLog: TButton; 
    procedure btnGetFolderClick(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure chkActiveClick(Sender: TObject); 
    procedure btnClearLogClick(Sender: TObject); 
    procedure httpServerCommandGet(AThread: TIdPeerThread; 
      RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); 
    procedure pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag; 
      const TagString: string; TagParams: TStrings; 
      var ReplaceText: string); 
  private 
    procedure Log(Data: string); 
    procedure LogServerState; 
  public 
  end; 

var 
  frmServer: TfrmServer; 

implementation 

uses 
  ShlObj, FileCtrl; 

{$R *.DFM} 

// copied from the last "Latium Software - Pascal Newsletter #33" 

function BrowseCallbackProc(Wnd: HWND; uMsg: UINT; 
  lParam, lpData: LPARAM): Integer stdcall; 
var 
  Buffer: array[0..MAX_PATH - 1] of char; 
begin 
  case uMsg of 
    BFFM_INITIALIZED: 
      if lpData <> 0 then 
        SendMessage(Wnd, BFFM_SETSELECTION, 1, lpData); 
    BFFM_SELCHANGED: 
      begin 
        SHGetPathFromIDList(PItemIDList(lParam), Buffer); 
        SendMessage(Wnd, BFFM_SETSTATUSTEXT, 0, Integer(@Buffer)); 
      end; 
  end; 
  Result := 0; 
end; 

// copied from the last "Latium Software - Pascal Newsletter #33" 

function BrowseForFolder(Title: string; RootCSIDL: integer = 0; 
  InitialFolder: string = ''): string; 
var 
  BrowseInfo: TBrowseInfo; 
  Buffer: array[0..MAX_PATH - 1] of char; 
  ResultPItemIDList: PItemIDList; 
begin 
  with BrowseInfo do 
  begin 
    hwndOwner := Application.Handle; 
    if RootCSIDL = 0 then 
      pidlRoot := nil 
    else 
      SHGetSpecialFolderLocation(hwndOwner, RootCSIDL, 
        pidlRoot); 
    pszDisplayName := @Buffer; 
    lpszTitle := PChar(Title); 
    ulFlags := BIF_RETURNONLYFSDIRS or BIF_STATUSTEXT; 
    lpfn := BrowseCallbackProc; 
    lParam := Integer(Pointer(InitialFolder)); 
    iImage := 0; 
  end; 
  Result := ''; 
  ResultPItemIDList := SHBrowseForFolder(BrowseInfo); 
  if ResultPItemIDList <> nil then 
  begin 
    SHGetPathFromIDList(ResultPItemIDList, Buffer); 
    Result := Buffer; 
    GlobalFreePtr(ResultPItemIDList); 
  end; 
  with BrowseInfo do 
    if pidlRoot <> nil then 
      GlobalFreePtr(pidlRoot); 
end; 

// clear log file 

procedure TfrmServer.btnClearLogClick(Sender: TObject); 
begin 
  lstLog.Clear; 
end; 

// got http server root folder 

procedure TfrmServer.btnGetFolderClick(Sender: TObject); 
var 
  NewFolder: string; 
begin 
  NewFolder := BrowseForFolder('Web Root Folder', 0, edtRootFolder.Text); 
  if NewFolder <> '' then 
    if DirectoryExists(NewFolder) then 
      edtRootFolder.Text := NewFolder; 
end; 

// de-activate http server 

procedure TfrmServer.chkActiveClick(Sender: TObject); 
begin 
  if chkActive.Checked then 
  begin 
    // root folder must exists 
    if AnsiLastChar(edtRootFolder.Text)^ = '\' then 
      edtRootFolder.Text := 
        Copy(edtRootFolder.Text, 1, Pred(Length(edtRootFolder.Text))); 
    chkActive.Checked := DirectoryExists(edtRootFolder.Text); 
    if not chkActive.Checked then 
      ShowMessage('Root Folder does not exist.'); 
  end; 
  // de-/activate server 
  httpServer.Active := chkActive.Checked; 
  // log to list box 
  LogServerState; 
  // set interactive state for user fields 
  edtRootFolder.Enabled := not chkActive.Checked; 
  edtDefaultDoc.Enabled := not chkActive.Checked; 
end; 

// prepare ! 

procedure TfrmServer.FormCreate(Sender: TObject); 
begin 
  edtRootFolder.Text := ExtractFilePath(Application.ExeName) + 'WebSite'; 
  ForceDirectories(edtRootFolder.Text); 
end; 

// incoming client request for download 

procedure TfrmServer.httpServerCommandGet(AThread: TIdPeerThread; 
  RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); 
var 
  I: Integer; 
  RequestedDocument, FileName, CheckFileName: string; 
  EHTMLParser: TPageProducer; 
begin 
  // requested document 
  RequestedDocument := RequestInfo.Document; 
  // log request 
  Log('Client: ' + RequestInfo.RemoteIP + ' request for: ' + RequestedDocument); 

  // 001 
  if Copy(RequestedDocument, 1, 1) <> '/' then 
    // invalid request 
    raise Exception.Create('invalid request: ' + RequestedDocument); 

  // 002 
  // convert all '/' to '\' 
  FileName := RequestedDocument; 
  I := Pos('/', FileName); 
  while I > 0 do 
  begin 
    FileName[I] := '\'; 
    I := Pos('/', FileName); 
  end; 
  // locate requested file 
  FileName := edtRootFolder.Text + FileName; 

  try 
    // check whether file or folder was requested 
    if AnsiLastChar(FileName)^ = '\' then 
      // folder - reroute to default document 
      CheckFileName := FileName + edtDefaultDoc.Text 
    else 
      // file - use it 
      CheckFileName := FileName; 
    if FileExists(CheckFileName) then 
    begin 
      // file exists 
      if LowerCase(ExtractFileExt(CheckFileName)) = '.ehtm' then 
      begin 
        // Extended HTML - send through internal tag parser 
        EHTMLParser := TPageProducer.Create(Self); 
        try 
          // set source file name 
          EHTMLParser.HTMLFile := CheckFileName; 
          // set event handler 
          EHTMLParser.OnHTMLTag := pgpEHTMLHTMLTag; 
          // parse ! 
          ResponseInfo.ContentText := EHTMLParser.Content; 
        finally 
          EHTMLParser.Free; 
        end; 
      end 
      else 
      begin 
        // return file as-is 
        // log 
        Log('Returning Document: ' + CheckFileName); 
        // open file stream 
        ResponseInfo.ContentStream := 
          TFileStream.Create(CheckFileName, fmOpenRead or fmShareCompat); 
      end; 
    end; 
  finally 
    if Assigned(ResponseInfo.ContentStream) then 
    begin 
      // response stream does exist 
      // set length 
      ResponseInfo.ContentLength := ResponseInfo.ContentStream.Size; 
      // write header 
      ResponseInfo.WriteHeader; 
      // return content 
      ResponseInfo.WriteContent; 
      // free stream 
      ResponseInfo.ContentStream.Free; 
      ResponseInfo.ContentStream := nil; 
    end 
    else if ResponseInfo.ContentText <> '' then 
    begin 
      // set length 
      ResponseInfo.ContentLength := Length(ResponseInfo.ContentText); 
      // write header 
      ResponseInfo.WriteHeader; 
      // return content 
    end 
    else 
    begin 
      if not ResponseInfo.HeaderHasBeenWritten then 
      begin 
        // set error code 
        ResponseInfo.ResponseNo := 404; 
        ResponseInfo.ResponseText := 'Document not found'; 
        // write header 
        ResponseInfo.WriteHeader; 
      end; 
      // return content 
      ResponseInfo.ContentText := 'The document requested is not availabe.'; 
      ResponseInfo.WriteContent; 
    end; 
  end; 
end; 

procedure TfrmServer.Log(Data: string); 
begin 
  lstLog.Items.Add(DateTimeToStr(Now) + ' - ' + Data); 
end; 

procedure TfrmServer.LogServerState; 
begin 
  if httpServer.Active then 
    Log(httpServer.ServerSoftware + ' is active') 
  else 
    Log(httpServer.ServerSoftware + ' is not active'); 
end; 

procedure TfrmServer.pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag; 
  const TagString: string; TagParams: TStrings; var ReplaceText: string); 
var 
  LTag: string; 
begin 
  LTag := LowerCase(TagString); 
  if LTag = 'date' then 
    ReplaceText := DateToStr(Now) 
  else if LTag = 'time' then 
    ReplaceText := TimeToStr(Now) 
  else if LTag = 'datetime' then 
    ReplaceText := DateTimeToStr(Now) 
  else if LTag = 'server' then 
    ReplaceText := httpServer.ServerSoftware; 
end; 

end.

--------------------

Blind Guardian Fan :: BMSTU Student :: A polar bear is a rectangular bear after a coordinate transform.

Мои фотографии

Плаха

Дата 2.6.2005, 16:33 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 126
Регистрация: 10.11.2004
Где: МО п. Киевский

Репутация: нет
Всего: нет

Цитата(Borland_Delphi_6 @ 2.6.2005, 16:19)

В DRKB пример всего сервера.

[

я уже смотрел это. там тоже самое.

--------------------

Принимай то что есть и устраивайся как хочеш

_hunter

Дата 2.6.2005, 16:53 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 8564
Регистрация: 24.6.2003
Где: Europe::Ukraine:: Kiev

Репутация: 5
Всего: 98

в ResponseInfo.ContentType запихни правильное значение ( посмотри что в том же ReGet' e пишется )

--------------------

Tempora mutantur, et nos mutamur in illis...

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Сети \| Следующая тема »