rtcforumprovider.pas

著名的SecureBlackBox控件完整源码

unit rtcForumProvider;

{$INCLUDE defines.inc}

interface

uses
  SysUtils, Classes, Windows,
  rtcConn, rtcDataSrv, rtcInfo, rtcLog,
  uDB, uForumDB, uMessages, uCmdDisp;

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

type
  TForum_Provider = class(TDataModule)
    ServerLink: TRtcDataServerLink;
    PageProvider: TRtcDataProvider;
    FileProvider: TRtcDataProvider;

    procedure DataModuleDestroy(Sender: TObject);
    procedure PageProviderDisconnect(Sender: TRtcConnection);
    procedure PageProviderCheckRequest(Sender: TRtcConnection);
    procedure PageProviderDataReceived(Sender: TRtcConnection);
    procedure FileProviderCheckRequest(Sender: TRtcConnection);
    procedure FileProviderSendBody(Sender: TRtcConnection);
    procedure FileProviderDisconnect(Sender: TRtcConnection);
    procedure DataModuleCreate(Sender: TObject);

  private
    ExtList:TStringList;
    CTypesList:TList;

    Web_Host,
    Web_RootFile,
    Web_Root,
    Web_Files,

    Templates_Path, // Templates and static files are stored here
    Upload_Path:string; // Uploaded files are stored here

    function GetContentType(FName: string): string;

  public
    procedure Init(WebHost,WebRoot,LocalPath:string);

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

function GetForumProvider : TForum_Provider;

implementation


{$R *.dfm}

type
  TStringObject=class
    public
      value:string;
    end;

var
  __ForumDM : TForum_Provider;

function GetForumProvider : TForum_Provider;
  begin
  if not Assigned(__ForumDM) then
    __ForumDM := TForum_Provider.Create(nil);

  Result := __ForumDM;
  end;

procedure TForum_Provider.Init(WebHost, WebRoot, LocalPath: string);
  begin
  Web_Host:=LowerCase(WebHost); // Forum Host starts with ...

  // Forum Application URI
  if WebRoot='' then
    WebRoot:='/'
  else if Copy(WebRoot,length(WebRoot),1)<>'/' then
    WebRoot:=WebRoot+'/';

  Web_Root:= LowerCase(WebRoot);
  Web_RootFile:= Copy(Web_Root,1,length(Web_Root)-1);

  Web_Files:=Web_Root+'files/'; // URI where files will be downloaded from (used in templates)

  LocalPath:=IncludeTrailingPathDelimiter(ExpandFileName(LocalPath));

  Templates_Path:=LocalPath+'deploy\RtcForumData\www\';
  Upload_Path:=LocalPath+'files\';

  InitForumData(LocalPath+'data\',
                Templates_Path,
                Upload_Path);
  end;

procedure TForum_Provider.DataModuleDestroy(Sender: TObject);
begin
  __ForumDM := nil;

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

procedure TForum_Provider.PageProviderCheckRequest(Sender: TRtcConnection);
  begin
  with Sender as TRtcDataServer do
    if ( (Web_Host='') or (LowerCase(Copy(Request.Host,1,length(Web_Host))) = Web_Host) ) then
      if ( LowerCase(Request.FileName) = Web_Root ) or
         ( LowerCase(Request.FileName) = Web_RootFile ) then
        Accept;
  end;

procedure TForum_Provider.PageProviderDataReceived(Sender: TRtcConnection);
var
  Srv : TRtcDataServer;
  Disp : TCommandsDispatcher;
  len : cardinal;
  Body : string;
begin
  Srv := TRtcDataServer(Sender);

  if Srv.Request.Method='POST' then
    Srv.Request.Params.AddText(Srv.Read);

  if Srv.Request.Complete then
    begin
    if LowerCase(Srv.Request.FileName) = Web_RootFile then
      begin
      Srv.Response.Status(301,'Moved Permanently');
      Srv.Response['LOCATION']:= Web_Root;
      Srv.Write('Status 301: Moved Permanently');
      end
    else
      begin
      Disp := TCommandsDispatcher.Create(Srv);
      try
        Body := Disp.MakeDispatch;
        len := Length(Body);
        if len > 0 then
          Srv.Response['Content-Type'] := 'text/html';

        Srv.Response['Cache-Control'] := 'no-store, no-cache, must-revalidate, post-check=0, pre-check=0';
        Srv.Response['Pragma'] := 'no-cache';
        Srv.Write(Body);

        with Srv do
          XLog('EXEC '+PeerAddr+' > '+Request['HOST'] {.rHost} +
               ' "'+Request.Method+' '+Request.FileName+'"'+
               ' '+IntToStr(len)+
               ' REF "'+Request.Referer+'"'+
               ' AGENT "'+Request.Agent+'"');
      finally
        Disp.Free;
        // Make sure the session is unlocked, we don't need it anymore.
        Srv.UnLockSession;
      end;
    end;
  end;
end;

procedure TForum_Provider.PageProviderDisconnect(Sender: TRtcConnection);
begin
  with TRtcDataServer(Sender) do begin
    if Request.DataSize > Request.DataIn then
      begin
        // did not receive a complete request
        XLog('ERR! '+PeerAddr+' > '+Request['HOST'] {.rHost} +
             ' "'+Request.Method+' '+Request.URI+'"'+
             ' 0'+
             ' REF "'+Request.Referer+'"'+
             ' AGENT "'+Request.Agent+'" '+
             '> DISCONNECTED while receiving a Request ('+IntToStr(Request.DataIn)+' of '+IntToStr(Request.DataSize)+' bytes received).');
      end
    else if Response.DataSize > Response.DataOut then
      begin
        // did not send a complete result
        XLog('ERR! '+PeerAddr+' > '+Request.Host+
             ' "'+Request.Method+' '+Request.URI+'"'+
             ' -'+IntToStr(Response.DataSize-Response.DataOut)+
             ' REF "'+Request.Referer+'"'+
             ' AGENT "'+Request.Agent+'" '+
             '> DISCONNECTED while sending a Result ('+IntToStr(Response.DataOut)+' of '+IntToStr(Response.DataSize)+' bytes sent).');
      end;
    end;
end;

procedure TForum_Provider.FileProviderCheckRequest(Sender: TRtcConnection);

  procedure CheckDiskFile(Sender: TRtcDataServer);
    var
      fsize:int64;
      Content_Type:string;
      MyFileName,
      DocRoot:string;

    function _FindSession : boolean;
    begin
      Result :=
        Sender.FindSession(Sender.Request.Query['sid'])
        {$IFDEF USE_COOKIE_SESSIONID}
        or Sender.FindSession(Sender.Request.Cookie['session'])
        {$ENDIF}
    end;

    function RepairFileName(NeedAuth:boolean; FileName:string):string;

      function AccessAllowed:boolean;
        begin
        if not NeedAuth or (FileName='') then
          Result:=True
        else if not _FindSession then
          Result:=IsFileAvailableForUser('', ExtractFileName(FileName))
        else
          begin
          if Sender.Session.asBoolean['login'] and
              IsFileAvailableForUser(Sender.Session.asString['user_name'], ExtractFileName(FileName)) then
            Result:=True
          else
            Result:=False;
          { Make sure session is unlocked,
            so it can be used by the rest of the app. }
          Sender.UnLockSession;
          end;
        end;

      begin
      // Get only file name
      FileName:=ExtractFileName(StringReplace(FileName,'/','\',[rfreplaceall]));
      // Generate Full file name, with full path
      FileName:=ExpandFileName(DocRoot + FileName);

      // Using special characters to move outside of root folder, DENY access ...
      if (Pos('\..',FileName)>0) or
         (LowerCase(Copy(FileName,1,length(DocRoot)))<>LowerCase(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: "'+FileName+'".');

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

        Result:='';
        fsize:=-1;
        end
      else
        begin
        // Check if user is allowed to access this file ...
        if not AccessAllowed then
          begin
          // Forbidden