unit VfsBase;
(*
  Description: Implements in-memory virtual file system data storage.
  Author:      Alexander Shostak (aka Berserker aka EtherniDee aka BerSoft)
  TODO:        Use optimized hash-table storage for VfsItems instead of ansi-to-wide string keys in regular binary tree.
*)


(***)  interface  (***)

uses
  SysUtils, Math, Windows,
  Utils, WinNative, Alg, Concur, TypeWrappers, Lists, DataLib,
  StrLib,
  VfsUtils, VfsMatching;

type
  (* Import *)
  TDict    = DataLib.TDict;
  TObjDict = DataLib.TObjDict;
  TString  = TypeWrappers.TString;
  TList    = Lists.TList;

const
  OVERWRITE_EXISTING      = true;
  DONT_OVERWRITE_EXISTING = false;

  AUTO_PRIORITY                = MAXLONGINT div 2;
  INITIAL_OVERWRITING_PRIORITY = AUTO_PRIORITY + 1;
  INITIAL_ADDING_PRIORITY      = AUTO_PRIORITY - 1;

type
  (*
    Specifies the order, in which files from different mapped directories will be listed in virtual directory.
    Virtual directory sorting is performed by priorities firstly and lexicographically secondly.
    SORT_FIFO - Items of the first mapped directory will be listed before the second mapped directory items.
    SORT_LIFO - Items of The last mapped directory will be listed before all other mapped directory items.
  *)
  TDirListingSortType = (SORT_FIFO = 0, SORT_LIFO = 1);

  (* Single redirected VFS entry: file or directory *)
  TVfsItem = class
   private
    function  GetName: WideString; inline;
    procedure SetName (const NewName: WideString); inline;

   public
    (* Name in lower case, used for wildcard mask matching *)
    SearchName: WideString;

    (* Absolute path to real file/folder location without trailing slash for non-drives *)
    RealPath: WideString;

    (* The priority used in virtual directories sorting for listing *)
    Priority: integer;

    (* List of directory child items or nil *)
    {On} Children: {U} TList {OF TVfsItem};

    (* Up to 32 special non-Windows attribute flags *)
    Attrs: integer;

    (* Full file info *)
    Info: TNativeFileInfo;

    function IsDir (): boolean;

    destructor Destroy; override;

    (* Name in original case. Automatically sets/converts SearchName, Info.FileName, Info.Base.FileNameLength *)
    property Name: WideString read GetName write SetName;
  end; // .class TVfsItem

  (* Allows to disable VFS temporarily for current thread only *)
  TThreadVfsDisabler = record
    PrevDisableVfsForThisThread: boolean;

    procedure DisableVfsForThread;
    procedure EnableVfsForThread;
    procedure RestoreVfsForThread;
  end;

  TSingleArgExternalFunc = function (Arg: pointer = nil): integer; stdcall;

var
  (* Global VFS access synchronizer *)
  VfsCritSection: Concur.TCritSection;


function GetThreadVfsDisabler: TThreadVfsDisabler;

(* Runs VFS. Higher level API must install hooks in VfsCritSection protected area.
   Listing order is ignored if VFS is resumed from pause *)
function RunVfs (DirListingOrder: TDirListingSortType): boolean;

(* Temporarily pauses VFS, but does not reset existing mappings *)
function PauseVfs: LONGBOOL; stdcall;

(* Stops VFS and clears all mappings *)
function ResetVfs: LONGBOOL; stdcall;

(* If VFS is running or paused, pauses VFS, clears cache and fully reaplies all mappings in the same order and
   with the same arguments, as MapDir routines were called earlier. Restores VFS state afterwards *)
function RefreshVfs: LONGBOOL; stdcall;

(* Refreshes VFS item attributes info for given mapped file. File must exist to succeed *)
function RefreshMappedFile (const FilePath: WideString): boolean;

(* Returns true if VFS is active globally and for current thread *)
function IsVfsActive: boolean;

function  EnterVfs: boolean;
procedure LeaveVfs;
function  EnterVfsConfig: boolean;
procedure LeaveVfsConfig;

(* Returns real path for VFS item by its absolute virtual path or empty string. Optionally returns file info structure *)
function GetVfsItemRealPath (const AbsVirtPath: WideString; {n} FileInfo: PNativeFileInfo = nil): WideString;

(* Returns virtual directory info. Adds virtual entries to specified directory listing container *)
function GetVfsDirInfo (const NormalizedVirtPath, Mask: WideString; {OUT} var DirInfo: TNativeFileInfo; DirListing: TDirListing): boolean;

(* Maps real directory contents to virtual path. Target must exist for success *)
function MapDir (const VirtPath, RealPath: WideString; OverwriteExisting: boolean; Flags: integer = 0): boolean;

(* Calls specified function with a single argument and returns its result. VFS is disabled for current thread during function exection *)
function CallWithoutVfs (Func: TSingleArgExternalFunc; Arg: pointer = nil): integer; stdcall;


(***)  implementation  (***)


type
  (* Applied and remembered mapping. Used to refresh or report VFS *)
  TMapping = class
    AbsVirtPath:       WideString;
    AbsRealPath:       WideString;
    OverwriteExisting: boolean;
    Flags:             integer;

    class function Make (const AbsVirtPath, AbsRealPath: WideString; OverwriteExisting: boolean; Flags: integer): TMapping;
  end;

var
(*
  Global map of case-insensitive normalized path to file/directory => corresponding TVfsItem.
  Access is controlled via critical section and global/thread switchers.
  Represents the whole cached virtual file system contents.
*)
{O} VfsItems: {O} TDict {of TVfsItem};

(* Map of real (mapped) file path => VFS item. Used to update VFS info whenever mapped files are changed *)
{O} MappedFiles: {U} TDict {of TVfsItem};

(* List of all applied mappings *)
{O} Mappings: {O} TList {of TMapping};
  
  (* Global VFS state indicator. If false, all VFS search operations must fail *)
  VfsIsRunning: boolean = false;

  (* Directory listing ordering, chosen on first VFS run. Updated on any first run after reset *)
  VfsDirListingOrder: TDirListingSortType;

  (* If true, VFS file/directory hierarchy is built and no mapping is allowed untill full reset *)
  VfsTreeIsBuilt: boolean = false;
    
  (* Automatical VFS items priority management *)
  OverwritingPriority: integer = INITIAL_OVERWRITING_PRIORITY;
  AddingPriority:      integer = INITIAL_ADDING_PRIORITY;

// All threadvar variables are automatically zeroed during finalization, thus zero must be the safest default value
threadvar
  DisableVfsForThisThread: boolean;


function TVfsItem.IsDir: boolean;
begin
  result := (Self.Info.Base.FileAttributes and Windows.FILE_ATTRIBUTE_DIRECTORY) <> 0;
end;

function TVfsItem.GetName: WideString;
begin
  result := Self.Info.FileName;
end;

procedure TVfsItem.SetName (const NewName: WideString);
begin
  Self.Info.SetFileName(NewName);
  Self.SearchName := StrLib.WideLowerCase(NewName);
end;

destructor TVfsItem.Destroy;
begin
  SysUtils.FreeAndNil(Self.Children);
end;

procedure TThreadVfsDisabler.DisableVfsForThread;
begin
  Self.PrevDisableVfsForThisThread := DisableVfsForThisThread;
  DisableVfsForThisThread          := true;
end;

procedure TThreadVfsDisabler.EnableVfsForThread;
begin
  Self.PrevDisableVfsForThisThread := DisableVfsForThisThread;
  DisableVfsForThisThread          := false;
end;

procedure TThreadVfsDisabler.RestoreVfsForThread;
begin
  DisableVfsForThisThread := Self.PrevDisableVfsForThisThread;
end;

function GetThreadVfsDisabler: TThreadVfsDisabler;
begin
end;

function EnterVfs: boolean;
begin
  result := not DisableVfsForThisThread;

  if result then begin
    VfsCritSection.Enter;
    result := VfsIsRunning;

    if not result then begin
      VfsCritSection.Leave;
    end;
  end;
end;

procedure LeaveVfs;
begin
  VfsCritSection.Leave;
end;

function EnterVfsConfig: boolean;
begin
  VfsCritSection.Enter;
  result := not VfsIsRunning and not VfsTreeIsBuilt;

  if not result then begin
    VfsCritSection.Leave;
  end;
end;

procedure LeaveVfsConfig;
begin
  VfsCritSection.Leave;
end;

function CompareVfsItemsByPriorityDescAndNameAsc (Item1, Item2: integer): integer;
begin
  result := TVfsItem(Item2).Priority - TVfsItem(Item1).Priority;

  if result = 0 then begin
    result := StrLib.CompareBinStringsW(TVfsItem(Item1).SearchName, TVfsItem(Item2).SearchName);
  end;
end;

function CompareVfsItemsByPriorityAscAndNameAsc (Item1, Item2: integer): integer;
begin
  result := TVfsItem(Item1).Priority - TVfsItem(Item2).Priority;

  if result = 0 then begin
    result := StrLib.CompareBinStringsW(TVfsItem(Item1).SearchName, TVfsItem(Item2).SearchName);
  end;
end;

procedure SortVfsListing ({U} List: DataLib.TList {OF TVfsItem}; SortType: TDirListingSortType);
begin
  if SortType = SORT_FIFO then begin
    List.CustomSort(CompareVfsItemsByPriorityDescAndNameAsc);
  end else begin
    List.CustomSort(CompareVfsItemsByPriorityAscAndNameAsc);
  end;
end;

procedure SortVfsDirListings (SortType: TDirListingSortType);
var
{Un} Children: DataLib.TList {OF TVfsItem};

begin
  Children := nil;
  // * * * * * //
  with DataLib.IterateDict(VfsItems) do begin
    while IterNext() do begin
      Children := TVfsItem(IterValue).Children;

      if (Children <> nil) and (Children.Count > 1) then begin
        SortVfsListing(Children, SortType);
      end;
    end;
  end;
end; // .procedure SortVfsDirListings

function FindVfsItemByNormalizedPath (const Path: WideString; {U} var {OUT} Res: TVfsItem): boolean;
var
{Un} VfsItem: TVfsItem;

begin
  VfsItem := VfsItems[WideStrToCaselessKey(Path)];
  result  := VfsItem <> nil;

  if result then begin
    Res := VfsItem;
  end;
end;

function FindVfsItemByPath (const Path: WideString; {U} var {OUT} Res: TVfsItem): boolean;
begin
  result := FindVfsItemByNormalizedPath(NormalizePath(Path), Res);
end;

(* All children list of VFS items MUST be empty *)
procedure BuildVfsItemsTree;
var
{Un} DirVfsItem: TVfsItem;
     AbsDirPath: WideString;

begin
  DirVfsItem := nil;
  // * * * * * //
  with DataLib.IterateDict(VfsItems) do begin
    while IterNext() do begin
      AbsDirPath := StrLib.ExtractDirPathW(CaselessKeyToWideStr(IterKey));

      if FindVfsItemByNormalizedPath(AbsDirPath, DirVfsItem) then begin
        DirVfsItem.Children.Add(IterValue);
      end;
    end;
  end;
end; // .procedure BuildVfsItemsTree

class function TMapping.Make (const AbsVirtPath, AbsRealPath: WideString; OverwriteExisting: boolean; Flags: integer): {O} TMapping;
begin
  result                   := TMapping.Create;
  result.AbsVirtPath       := AbsVirtPath;
  result.AbsRealPath       := AbsRealPath;
  result.OverwriteExisting := OverwriteExisting;
  result.Flags             := Flags;
end;

function RunVfs (DirListingOrder: TDirListingSortType): boolean;
begin
  result := true;

  with VfsCritSection do begin
    Enter;

    if not VfsIsRunning then begin
      if not VfsTreeIsBuilt then begin
        VfsDirListingOrder := DirListingOrder;
        BuildVfsItemsTree();
        SortVfsDirListings(DirListingOrder);
        VfsTreeIsBuilt := true;
      end;
      
      VfsIsRunning := true;
    end;

    Leave;
  end; // .with
end; // .function RunVfs

function PauseVfs: LONGBOOL; stdcall;
begin
  result := true;

  with VfsCritSection do begin
    Enter;
    VfsIsRunning := false;
    Leave;
  end;
end;

function ResetVfs: LONGBOOL; stdcall;
begin
  result := true;

  with VfsCritSection do begin
    Enter;
    VfsItems.Clear;
    MappedFiles.Clear;
    Mappings.Clear;
    VfsIsRunning   := false;
    VfsTreeIsBuilt := false;
    Leave;
  end;
end;

function IsVfsActive: boolean;
begin
  result := EnterVfs;

  if result then begin
    LeaveVfs;
  end;
end;

(* Returns real path for vfs item by its absolute virtual path or empty string. Optionally returns file info structure *)
function GetVfsItemRealPath (const AbsVirtPath: WideString; {n} FileInfo: PNativeFileInfo = nil): WideString;
var
{n} VfsItem: TVfsItem;

begin
  VfsItem := nil;
  result  := '';
  // * * * * * //
  if EnterVfs then begin
    if FindVfsItemByNormalizedPath(AbsVirtPath, VfsItem) then begin
      result := VfsItem.RealPath;

      if FileInfo <> nil then begin
        FileInfo^ := VfsItem.Info;
      end;
    end;

    LeaveVfs;
  end; // .if
end; // .function GetVfsItemRealPath

function GetVfsDirInfo (const NormalizedVirtPath, Mask: WideString; {OUT} var DirInfo: TNativeFileInfo; DirListing: TDirListing): boolean;
var
{n} VfsItem:        TVfsItem;
    NormalizedMask: WideString;
    MaskPattern:    Utils.TArrayOfByte;
    i:              integer;

begin
  {!} Assert(DirListing <> nil);
  VfsItem := nil;
  // * * * * * //
  result := EnterVfs;

  if result then begin
    result := FindVfsItemByNormalizedPath(NormalizedVirtPath, VfsItem) and VfsItem.IsDir;

    if result then begin
      DirInfo := VfsItem.Info;

      if VfsItem.Children <> nil then begin
        NormalizedMask := StrLib.WideLowerCase(Mask);
        MaskPattern    := VfsMatching.CompilePattern(NormalizedMask);

        for i := 0 to VfsItem.Children.Count - 1 do begin
          if VfsMatching.MatchPattern(TVfsItem(VfsItem.Children[i]).SearchName, pointer(MaskPattern)) then begin
            DirListing.AddItem(@TVfsItem(VfsItem.Children[i]).Info);
          end;
        end;
      end; // .if
    end; // .if

    LeaveVfs;
  end; // .if
end; // .function GetVfsDirInfo

procedure CopyFileInfoWithoutNames (var Src, Dest: WinNative.FILE_ID_BOTH_DIR_INFORMATION);
begin
  Dest.FileIndex      := 0;
  Dest.CreationTime   := Src.CreationTime;
  Dest.LastAccessTime := Src.LastAccessTime;
  Dest.LastWriteTime  := Src.LastWriteTime;
  Dest.ChangeTime     := Src.ChangeTime;
  Dest.EndOfFile      := Src.EndOfFile;
  Dest.AllocationSize := Src.AllocationSize;
  Dest.FileAttributes := Src.FileAttributes;
  Dest.EaSize         := Src.EaSize;
end;

(* Redirects single file/directory path (not including directory contents). Target must exist for success *)
function RedirectFile (const AbsVirtPath, AbsRealPath: WideString; {n} FileInfoPtr: WinNative.PFILE_ID_BOTH_DIR_INFORMATION; OverwriteExisting: boolean; Priority: integer): {Un} TVfsItem;
const
  WIDE_NULL_CHAR_LEN = Length(#0);

var
{Un} VfsItem:        TVfsItem;
     PackedVirtPath: string;
     IsNewItem:      boolean;
     FileInfo:       TNativeFileInfo;
     Success:        boolean;

begin
  VfsItem := nil;
  result  := nil;
  // * * * * * //
  PackedVirtPath := WideStrToCaselessKey(AbsVirtPath);
  VfsItem        := VfsItems[PackedVirtPath];
  IsNewItem      := VfsItem = nil;
  Success        := true;

  if IsNewItem or OverwriteExisting then begin
    if FileInfoPtr = nil then begin
      Success := GetFileInfo(AbsRealPath, FileInfo);
    end;

    if Success then begin
      if IsNewItem then begin
        VfsItem                           := TVfsItem.Create();
        VfsItems[PackedVirtPath]          := VfsItem;
        VfsItem.Name                      := StrLib.ExtractFileNameW(AbsVirtPath);
        VfsItem.SearchName                := StrLib.WideLowerCase(VfsItem.Name);
        VfsItem.Info.Base.ShortNameLength := 0;
        VfsItem.Info.Base.ShortName[0]    := #0;
      end;

      if FileInfoPtr <> nil then begin
        CopyFileInfoWithoutNames(FileInfoPtr^, VfsItem.Info.Base);
      end else begin
        CopyFileInfoWithoutNames(FileInfo.Base, VfsItem.Info.Base);
      end;
 
      VfsItem.RealPath := AbsRealPath;
      VfsItem.Priority := Priority;
      VfsItem.Attrs    := 0;
      MappedFiles[WideStrToCaselessKey(AbsRealPath)] := VfsItem;
    end; // .if
  end; // .if

  if Success then begin
    result := VfsItem;
  end;
end; // .function RedirectFile

function _MapDir (const AbsVirtPath, AbsRealPath: WideString; {n} FileInfoPtr: WinNative.PFILE_ID_BOTH_DIR_INFORMATION; OverwriteExisting: boolean; Flags, Priority: integer): {Un} TVfsItem;
var
{O}  Subdirs:        {O} TList {OF TFileInfo};
{U}  SubdirInfo:     TFileInfo;
{Un} DirVfsItem:     TVfsItem;
     Success:        boolean;
     FileInfo:       TNativeFileInfo;
     VirtPathPrefix: WideString;
     RealPathPrefix: WideString;
     i:              integer;

begin
  DirVfsItem := nil;
  Subdirs    := DataLib.NewList(Utils.OWNS_ITEMS);
  SubdirInfo := nil;
  result     := nil;
  // * * * * * //
  if Priority = AUTO_PRIORITY then begin
    if OverwriteExisting then begin
      Priority := OverwritingPriority;
      Inc(OverwritingPriority);
    end else begin
      Priority := AddingPriority;
      Dec(AddingPriority);
    end;
  end;
  
  DirVfsItem := RedirectFile(AbsVirtPath, AbsRealPath, FileInfoPtr, OverwriteExisting, Priority);
  Success    := DirVfsItem <> nil;

  if Success then begin
    VirtPathPrefix := AddBackslash(AbsVirtPath);
    RealPathPrefix := AddBackslash(AbsRealPath);

    if DirVfsItem.Children = nil then begin
      DirVfsItem.Children := DataLib.NewList(not Utils.OWNS_ITEMS);
    end;

    with SysScanDir(AbsRealPath, '*') do begin
      while IterNext(FileInfo.FileName, @FileInfo.Base) do begin
        if Utils.HasFlag(FileInfo.Base.FileAttributes, Windows.FILE_ATTRIBUTE_DIRECTORY) then begin         
          if (FileInfo.FileName <> '.') and (FileInfo.FileName <> '..') then begin
            Subdirs.Add(TFileInfo.Create(@FileInfo));
          end;
        end else begin
          RedirectFile(VirtPathPrefix + FileInfo.FileName, RealPathPrefix + FileInfo.FileName, @FileInfo, OverwriteExisting, Priority);
        end;
      end;
    end;

    for i := 0 to Subdirs.Count - 1 do begin
      SubdirInfo := TFileInfo(Subdirs[i]);
      _MapDir(VirtPathPrefix + SubdirInfo.Data.FileName, RealPathPrefix + SubdirInfo.Data.FileName, @SubdirInfo.Data, OverwriteExisting, Flags, Priority);
    end;
  end; // .if

  if Success then begin
    result := DirVfsItem;
  end;
  // * * * * * //
  SysUtils.FreeAndNil(Subdirs);
end; // .function _MapDir

function MapDir (const VirtPath, RealPath: WideString; OverwriteExisting: boolean; Flags: integer = 0): boolean;
var
  AbsVirtPath: WideString;
  AbsRealPath: WideString;

begin
  result := EnterVfsConfig;

  if result then begin
    AbsVirtPath := VfsUtils.NormalizePath(VirtPath);
    AbsRealPath := VfsUtils.NormalizePath(RealPath);
    result      := (AbsVirtPath <> '') and (AbsRealPath <> '');

    if result then begin
      Mappings.Add(TMapping.Make(AbsVirtPath, AbsRealPath, OverwriteExisting, Flags));
      result := _MapDir(AbsVirtPath, AbsRealPath, nil, OverwriteExisting, Flags, AUTO_PRIORITY) <> nil;
    end;

    LeaveVfsConfig;
  end;
end; // .function MapDir

function CallWithoutVfs (Func: TSingleArgExternalFunc; Arg: pointer = nil): integer; stdcall;
begin
  with GetThreadVfsDisabler do begin
    try
      DisableVfsForThread;
      result := Func(Arg);
    finally
      RestoreVfsForThread;
    end;
  end;
end; // .function CallWithoutVfs

function RefreshVfs: LONGBOOL; stdcall;
var
  VfsWasRunning: boolean;
  i:             integer;

begin
  with VfsCritSection do begin
    Enter;
    result := VfsTreeIsBuilt;

    if result then begin
      VfsItems.Clear;
      MappedFiles.Clear;
      VfsWasRunning  := VfsIsRunning;
      VfsIsRunning   := false;
      VfsTreeIsBuilt := false;

      for i := 0 to Mappings.Count - 1 do begin
        with TMapping(Mappings[i]) do begin
          MapDir(AbsVirtPath, AbsRealPath, OverwriteExisting, Flags);
        end;
      end;

      if VfsWasRunning then begin
        BuildVfsItemsTree();
        SortVfsDirListings(VfsDirListingOrder);
        VfsTreeIsBuilt := true;
        VfsIsRunning   := true;
      end;
    end;

    Leave;
  end; // .with
end; // .function RefreshVfs

function RefreshMappedFile (const FilePath: WideString): boolean;
var
{U} VfsItem:       TVfsItem;
    AbsRealPath:   WideString;
    FileInfo:      TNativeFileInfo;
    VfsWasRunning: boolean;

begin
  VfsItem := nil;
  // * * * * * //
  with VfsCritSection do begin
    Enter;
    result := VfsTreeIsBuilt;

    if result then begin
      VfsWasRunning := VfsIsRunning;
      VfsIsRunning  := false;
      AbsRealPath   := NormalizePath(FilePath);
      VfsItem       := TVfsItem(MappedFiles[WideStrToCaselessKey(AbsRealPath)]);
      result        := (VfsItem <> nil) and GetFileInfo(AbsRealPath, FileInfo);

      if result then begin
        CopyFileInfoWithoutNames(FileInfo.Base, VfsItem.Info.Base);
      end;

      VfsIsRunning := VfsWasRunning;
    end;

    Leave;
  end; // .with
end; // .function RefreshMappedFile

begin
  VfsCritSection.Init;
  VfsItems    := DataLib.NewDict(Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE);
  MappedFiles := DataLib.NewDict(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE);
  Mappings    := DataLib.NewList(Utils.OWNS_ITEMS);
end.