paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-22 21:11:08 +02:00
Code Issues Packages Projects Releases Wiki Activity

* SimpleFileModule for use with new router

Browse Source 
git-svn-id: trunk@35821 -
This commit is contained in:
michael 2017-04-17 11:30:58 +00:00
parent 5051a0ccc5
commit 5a7a05bd3f
1 changed files with 68 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
packages/fcl-web/src/base/fpwebfile.pp
View File

@ -4,7 +4,7 @@ unit fpwebfile;
interface
uses SysUtils, Classes, httpdefs, fphttp;
uses SysUtils, Classes, httpdefs, fphttp, httproute;
Type
TFPCustomFileModule = Class(TCustomHTTPModule)
@ -22,6 +22,28 @@ Type
end;
TFPCustomFileModuleClass = Class of TFPCustomFileModule;
{ TSimpleFileModule }
TSimpleFileLog = Procedure (EventType : TEventType; Const Msg : String) of object;
TSimpleFileModule = class(TFPCustomFileModule,IRouteInterface)
private
FRequestedFileName,
FMappedFileName : String;
class procedure HandleSimpleFileRequest(ARequest: TRequest; AResponse: TResponse); static;
Function MapFileName(Const AFileName : String) : String; override;
Function GetRequestFileName(Const ARequest : TRequest) : String; override;
Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); override;
Public
Class var
// Where to serve files from
BaseDir : String;
// For directories, convert to index.html if this is set.
IndexPageName : String;
// If you want some logging, set this.
OnLog : TSimpleFileLog;
Class Procedure RegisterDefaultRoute;
end;
Var
// Set this if you want a descendent class to serve the files.
// You can use this to customize the behaviour in the descendent, for instance if you have multiple virtual hosts.
@ -75,6 +97,51 @@ begin
RegisterHTTPModule(ALocation,DefaultFileModuleClass,true);
end;
{ TSimpleFileModule }
Class Procedure TSimpleFileModule.HandleSimpleFileRequest(ARequest : TRequest; AResponse : TResponse); static;
begin
With TSimpleFileModule.CreateNew(Nil) do
try
HandleRequest(ARequest,AResponse);
finally
Free;
end;
end;
function TSimpleFileModule.MapFileName(const AFileName: String): String;
begin
Result:=AFileName;
While (Result<>'') and (Result[1]='/') do
Delete(Result,1,1);
Result:=IncludeTrailingPathDelimiter(BaseDir)+Result;
FRequestedFileName:=AFileName;
FMappedFileName:=Result;
end;
function TSimpleFileModule.GetRequestFileName(const ARequest: TRequest): String;
begin
Result:=inherited GetRequestFileName(ARequest);
if (IndexPageName<>'') and ((Result='') or (Result[Length(Result)]='/')) then
Result:=Result+IndexPageName;
end;
procedure TSimpleFileModule.HandleRequest(ARequest: TRequest; AResponse: TResponse);
begin
Inherited;
if Assigned (OnLog) then
OnLog(etInfo,Format('%d serving "%s" -> "%s"',[AResponse.Code,FRequestedFileName,FMappedFileName]));
end;
class procedure TSimpleFileModule.RegisterDefaultRoute;
begin
if BaseDir='' then
BaseDir:=IncludeTrailingPathDelimiter(GetCurrentDir);
httprouter.RegisterRoute('/*',@HandleSimpleFileRequest);
end;
Function TFPCustomFileModule.GetRequestFileName(Const ARequest : TRequest) : String;
procedure sb;