rtcfileprovider.pas

来自「Delphi快速开发Web Server」· PAS 代码 · 共 740 行 · 第 1/2 页

unit rtcFileProvider;

interface

{$include rtcDefs.inc}

{ If you want to use a FileStream implementation, which leaves the files open
  while sending them to the client (instead of the default implementation which
  opens and closes each file as needed), define the RTC_FILESTREAM directive. }

{.$DEFINE RTC_FILESTREAM}

uses
  Windows, SysUtils, Classes,

  {$IFDEF VER120}
  Forms, FileCtrl, // D4
  {$ENDIF}
  {$IFDEF VER130}
  Forms, FileCtrl, // D5
  {$ENDIF}

  rtcLog,
  rtcInfo, rtcConn, rtcMemory,
  rtcDataSrv;

var
  MAX_SEND_BLOCK_SIZE:int64=1460*44; // larger files will be sent in smaller blocks
  MAX_ACCEPT_BODY_SIZE:int64=128000;

type
  TStringObject=class
    public
      value:string;
    end;

  TFile_Provider = class(TDataModule)
    FileProvider: TRtcDataProvider;
    TimeProvider: TRtcDataProvider;
    ServerLink: TRtcDataServerLink;

    procedure FileProviderDisconnect(Sender: TRtcConnection);
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
    procedure FileProviderSendBody(Sender: TRtcConnection);
    procedure TimeProviderDataReceived(Sender: TRtcConnection);
    procedure FileProviderCheckRequest(Sender: TRtcConnection);
    procedure TimeProviderCheckRequest(Sender: TRtcConnection);

  private
    { Private declarations }
    HostList:TStringList;
    PageList:TStringList;
    ExtList:TStringList;
    CTypesList:TList;

  protected
    function GetDocRoot(Host: string): string;
    function GetContentType(FName: string): string;

    function RepairWebFileName(FileName,DocRoot:string):string;

  public
    { Public declarations }
    procedure ClearHosts;
    procedure AddHost(a:string);

    procedure ClearIndexPages;
    procedure AddIndexPage(a:string);

    procedure ClearContentTypes;
    procedure AddContentType(a:string);
  end;

function GetDocRoot(Host: string): string;
function RepairWebFileName(FileName,DocRoot:string):string;

function GetFileProvider:TFile_Provider;

implementation

{$R *.dfm}

var
  File_Provider: TFile_Provider;

function GetFileProvider:TFile_Provider;
  begin
  if not assigned(File_Provider) then
    File_Provider:=TFile_Provider.Create(nil);
  Result:=File_Provider;
  end;

function RepairWebFileName(FileName,DocRoot:string):string;
  begin
  Result:=GetFileProvider.RepairWebFileName(FileName,DocRoot);
  end;

function GetDocRoot(Host: string): string;
  begin
  Result:=GetFileProvider.GetDocRoot(Host);
  end;

procedure TFile_Provider.DataModuleCreate(Sender: TObject);
  begin
  HostList:=TStringList.Create;
  HostList.Sorted:=True;
  PageList:=TStringList.Create;
  ExtList:=TStringList.Create;
  CTypesList:=TList.Create;
  end;

procedure TFile_Provider.DataModuleDestroy(Sender: TObject);
  begin
  File_Provider:=nil;

  ClearHosts;
  HostList.Free;

  ClearIndexPages;
  PageList.Free;

  ClearContentTypes;
  ExtList.Free;
  CTypesList.Free;
  end;

procedure TFile_Provider.ClearHosts;
  var
    a:integer;
  begin
  for a:=0 to HostList.Count-1 do
    with TStringObject(HostList.Objects[a]) do
      begin
      value:='';
      Free;
      end;
  HostList.Clear;
  end;

procedure TFile_Provider.ClearIndexPages;
  begin
  PageList.Clear;
  end;

procedure TFile_Provider.ClearContentTypes;
  var
    a:integer;
  begin
  for a:=0 to CTypesList.Count-1 do
    with TStringObject(CTypesList.Items[a]) do
      begin
      value:='';
      Free;
      end;
  CTypesList.Clear;
  ExtList.Clear;
  end;

procedure TFile_Provider.AddHost(a: string);
  var
    loc:integer;
    hname,hdir:string;
    odir:TStringObject;
  begin
  loc:=Pos('=',a);
  if loc>0 then
    begin
    hname:=UpperCase(Trim(Copy(a,1,loc-1)));
    hdir:=Trim(Copy(a,loc+1,MaxInt));
    hdir:=StringReplace(hdir,'/','\',[rfReplaceAll]);

    // Resolve a problem with relative paths
    if (Pos(':',hdir)=0) and (Copy(hdir,1,1)<>'\') then
      hdir:=ExtractFilePath(AppFileName)+hdir;

    // Remove trailing \
    if Copy(hdir,length(hdir),1)='\' then
      Delete(hdir,length(hdir),1);

    hdir:=ExpandFileName(hdir);

    odir:=TStringObject.Create;
    odir.value:=hdir;

    HostList.AddObject(hname,odir);
    end;
  HostList.Sort;
  HostList.Sorted:=True;
  end;

procedure TFile_Provider.AddIndexPage(a: string);
  begin
  if Trim(a)<>'' then
    PageList.Add(Trim(a));
  end;

procedure TFile_Provider.AddContentType(a: string);
  var
    elist,ext:string;
    loc:integer;
    htext:string;
    octype:TStringObject;
  begin
  loc:=Pos('=',a);
  if loc>0 then
    begin
    elist:=Trim(Copy(a,1,loc-1));
    htext:=Trim(Copy(a,loc+1,MaxInt));

    octype:=TStringObject.Create;
    octype.value:=htext;

    CTypesList.Add(octype);

    while elist<>'' do
      begin
      if Pos(',',elist)>0 then
        begin
        ext:=UpperCase(Trim(Copy(elist,1,Pos(',',elist)-1)));
        if Copy(ext,1,1)<>'.' then ext:='.'+ext;
        Delete(elist,1,Pos(',',elist));
        elist:=Trim(elist);
        end
      else
        begin
        ext:=UpperCase(elist);
        if Copy(ext,1,1)<>'.' then ext:='.'+ext;
        elist:='';
        end;
      ExtList.AddObject(ext,octype);
      end;
    end;
  ExtList.Sort;
  ExtList.Sorted:=True;
  end;

function TFile_Provider.GetContentType(FName: string): string;
  var
    loc:integer;
    ext:string;
  begin
  ext:=UpperCase(ExtractFileExt(FName));
  loc:=ExtList.IndexOf(ext);
  if loc>=0 then
    Result:=TStringObject(ExtList.Objects[loc]).value
  else
    begin
    loc:=ExtList.IndexOf('*');
    if loc>=0 then
      Result:=TStringObject(ExtList.Objects[loc]).value
    else
      Result:='';
    end;
  end;

function TFile_Provider.GetDocRoot(Host: string): string;
  var
    loc:integer;
  begin
  Host:=UpperCase(Host);
  loc:=HostList.IndexOf(Host);
  if loc>=0 then
    Result:=TStringObject(HostList.Objects[loc]).value
  else
    begin
    loc:=HostList.IndexOf('*');
    if loc>=0 then
      Result:=TStringObject(HostList.Objects[loc]).value
    else
      Result:='';
    end;
  end;

function TFile_Provider.RepairWebFileName(FileName,DocRoot:string):string;
  var
    a:integer;
    FullName:string;
  begin
  FileName:=StringReplace(FileName,'/','\',[rfreplaceall]);

  FullName:=ExpandFileName(DocRoot+FileName);
  // Check if our path is inside DocRoot
  if (Pos('\..',FullName)>0) or
     (UpperCase(Copy(FullName,1,length(DocRoot)))<>UpperCase(DocRoot)) then
    begin
    Result:='';
    Exit;
    end;

  FileName:=FullName;
  Delete(FileName,1,length(DocRoot));
  // Check if FileName is a folder with missing '\' at the end.
  if Copy(FileName,length(FileName),1)<>'\' then
    if DirectoryExists(DocRoot+FileName) then
      begin
      Result:='';
      Exit;
      end;

  // Check if FileName is a folder with existing index file
  if Copy(FileName,length(FileName),1)='\' then
    begin
    for a:=0 to PageList.Count-1 do
      begin
      if File_Exists(FullName+PageList.Strings[a]) then
        begin
        FileName:=FileName+PageList.Strings[a];
        Break;
        end;
      end;
    end;

  Result:=StringReplace(FileName,'\','/',[rfreplaceall]);
  end;

{ *** FILE PROVIDER *** }

procedure TFile_Provider.FileProviderCheckRequest(Sender: TRtcConnection);

  procedure CheckDiskFile(Sender: TRtcDataServer);
    var
      fsize:int64;
      Content_Type:string;
      rang_type, rang_from, rang_to:string;
      rang_start, rang_end:int64;

      MyFileName,
      DocRoot:string;

    function RepairFileName(FileName:string):string;
      var
        a:integer;
        FullName:string;
      begin
      FileName:=StringReplace(FileName,'/','\',[rfreplaceall]);

      FullName:=ExpandFileName(DocRoot+FileName);
      if (Pos('\..',FullName)>0) or
         (UpperCase(Copy(FullName,1,length(DocRoot)))<>UpperCase(DocRoot)) then
        begin
        Sender.Accept;

        XLog('DENY '+Sender.PeerAddr+' > '+Sender.Request.Host+
             ' "'+Sender.Request.Method+' '+Sender.Request.URI+'"'+
             ' 0'+
             ' REF "'+Sender.Request.Referer+'"'+
             ' AGENT "'+Sender.Request.Agent+'" > Invalid FileName: "'+FullName+'".');

        Sender.Response.Status(403,'Forbidden');
        Sender.Write('Status 403: Forbidden');

        Result:='';
        fsize:=-1;
        Exit;
        end
      else
        begin
        FileName:=FullName;
        Delete(FileName,1,length(DocRoot));
        end;

      if Copy(FileName,length(FileName),1)<>'\' then
        if DirectoryExists(DocRoot+FileName) then
          begin
          Sender.Accept;

          Sender.Response.Status(301,'Moved Permanently');
          Sender.Response['LOCATION']:= Sender.Request.FileName+'/';
          Sender.Write('Status 301: Moved Permanently');