From 5a7a05bd3ff6deca45dbb02f76dab18cbc4f2b16 Mon Sep 17 00:00:00 2001
From: michael <michael@freepascal.org>
Date: Mon, 17 Apr 2017 11:30:58 +0000
Subject: [PATCH] * SimpleFileModule for use with new router

git-svn-id: trunk@35821 -
---
 packages/fcl-web/src/base/fpwebfile.pp | 69 +++++++++++++++++++++++++-
 1 file changed, 68 insertions(+), 1 deletion(-)

diff --git a/packages/fcl-web/src/base/fpwebfile.pp b/packages/fcl-web/src/base/fpwebfile.pp
index 193b626a73..e8c334e575 100644
--- a/packages/fcl-web/src/base/fpwebfile.pp
+++ b/packages/fcl-web/src/base/fpwebfile.pp
@@ -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;