feat: file-based locking

aaa_base/aaa.gpr

@@ -5,7 +5,19 @@ project Aaa is
    for Library_Name use "aaa";
    for Library_Version use Project'Library_Name & ".so." & Aaa_Config.Crate_Version;
 
-   for Source_Dirs use ("src/");
+   --  OS-specific sources, autodetected from environment
+
+   OS_Sources := ();
+   Detect_Windows := external ("SystemRoot", "not_windows");
+
+   case Detect_Windows is
+      when "not_windows" =>
+         OS_Sources := OS_Sources & ("src/unix/");
+      when others =>
+         OS_Sources := OS_Sources & ("src/windows/");
+   end case;
+
+   for Source_Dirs use ("src/") & OS_Sources;
    for Object_Dir use "obj/" & Aaa_Config.Build_Profile;
    for Create_Missing_Dirs use "True";
    for Library_Dir use "lib";

aaa_base/alire.toml

@@ -1,6 +1,7 @@
 name = "aaa"
-version = "0.3.1-dev"
 description = "Alex's Ada Assortment (of miscellaneous utilities)"
+version = "0.3.2-dev"
+# 0.3.2: file-based locking
 
 long-description = """
 Alex's Ada Assortment of Utilities
@@ -12,6 +13,7 @@ Alex's Ada Assortment of Utilities
 - String containers and utilities.
 - Simple subprocess spawning.
 - Write-through minimal cache for objects stored in files
+- Advisory file locks that the OS releases when a process ends.
 """
 
 authors = ["Alejandro R. Mosteo"]

aaa_base/src/aaa-filesystem-locks.adb

@@ -0,0 +1,112 @@
+with Ada.IO_Exceptions;
+
+package body AAA.Filesystem.Locks is
+
+   package OS renames GNAT.OS_Lib;
+
+   use type OS.File_Descriptor;
+
+   type Outcomes is (Locked, Busy, Unsupported);
+
+   function Lock_File (File : OS.File_Descriptor;
+                       Wait : Boolean)
+                       return Outcomes is separate;
+   --  Lock File exclusively with the OS facility, which differs between Unix
+   --  and Windows. Without Wait, returns Busy at once if already locked.
+
+   ----------
+   -- Open --
+   ----------
+
+   procedure Open (This : in out Lock; Path : String) is
+      Unused : Boolean;
+   begin
+      This.File := OS.Open_Read_Write (Path, OS.Binary);
+
+      if This.File = OS.Invalid_FD then
+         This.File := OS.Create_New_File (Path, OS.Binary);
+      end if;
+
+      --  Another process may have created it in the meantime
+      if This.File = OS.Invalid_FD then
+         This.File := OS.Open_Read_Write (Path, OS.Binary);
+      end if;
+
+      if This.File = OS.Invalid_FD then
+         raise Ada.IO_Exceptions.Use_Error with
+           "Cannot open lock file " & Path & ": " & OS.Errno_Message;
+      end if;
+
+      OS.Set_Close_On_Exec (This.File, True, Unused);
+   end Open;
+
+   ----------------
+   -- Lock_Using --
+   ----------------
+
+   function Lock_Using (This : in out Lock;
+                        Path : String;
+                        Wait : Boolean)
+                        return Boolean
+   is
+   begin
+      Open (This, Path);
+
+      case Lock_File (This.File, Wait) is
+         when Locked | Unsupported =>
+            return True;
+         when Busy =>
+            This.Release;
+            return False;
+      end case;
+   end Lock_Using;
+
+   -----------------
+   -- Try_Acquire --
+   -----------------
+
+   function Try_Acquire (This : in out Lock; Path : String) return Boolean
+   is (Lock_Using (This, Path, Wait => False));
+
+   -------------
+   -- Acquire --
+   -------------
+
+   procedure Acquire (This : in out Lock; Path : String) is
+   begin
+      if not Lock_Using (This, Path, Wait => True) then
+         raise Program_Error with "Lock reported as busy after waiting";
+      end if;
+   end Acquire;
+
+   -------------
+   -- Is_Held --
+   -------------
+
+   function Is_Held (This : Lock) return Boolean
+   is (This.File /= OS.Invalid_FD);
+
+   -------------
+   -- Release --
+   -------------
+
+   procedure Release (This : in out Lock) is
+   begin
+      --  Closing the file releases its lock
+
+      if This.Is_Held then
+         OS.Close (This.File);
+         This.File := OS.Invalid_FD;
+      end if;
+   end Release;
+
+   --------------
+   -- Finalize --
+   --------------
+
+   overriding procedure Finalize (This : in out Lock) is
+   begin
+      This.Release;
+   end Finalize;
+
+end AAA.Filesystem.Locks;

aaa_base/src/aaa-filesystem-locks.ads

@@ -0,0 +1,42 @@
+private with Ada.Finalization;
+private with GNAT.OS_Lib;
+
+package AAA.Filesystem.Locks is
+
+   --  Exclusive advisory locks on files, to keep processes off a resource that
+   --  another process is using. Only processes that lock the same file notice
+   --  them. A lock belongs to an open file of the process holding it, so the
+   --  OS releases it when that process ends, whatever the reason, and no lock
+   --  can be left behind. Two Lock objects exclude each other also within one
+   --  process. Programs spawned by the holder don't inherit the lock.
+
+   --  On filesystems where the OS can't lock files, and on NFS under Linux,
+   --  where trying may hang, the lock is taken as held without excluding
+   --  anyone.
+
+   type Lock is tagged limited private;
+
+   function Is_Held (This : Lock) return Boolean;
+
+   function Try_Acquire (This : in out Lock; Path : String) return Boolean
+     with Pre => not This.Is_Held;
+   --  Lock Path, which is created empty if missing. Returns False without
+   --  waiting if another Lock holds it. Raises Ada.IO_Exceptions.Use_Error if
+   --  the file can't be opened or created.
+
+   procedure Acquire (This : in out Lock; Path : String)
+     with Pre => not This.Is_Held;
+   --  As Try_Acquire, but waits for as long as another Lock holds the file
+
+   procedure Release (This : in out Lock);
+   --  Nothing to do if not held. Also done on finalization.
+
+private
+
+   type Lock is new Ada.Finalization.Limited_Controlled with record
+      File : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD;
+   end record;
+
+   overriding procedure Finalize (This : in out Lock);
+
+end AAA.Filesystem.Locks;

aaa_base/src/unix/aaa-filesystem-locks-lock_file.adb

@@ -0,0 +1,71 @@
+with Interfaces.C;
+
+with System;
+
+separate (AAA.Filesystem.Locks)
+function Lock_File (File : OS.File_Descriptor;
+                    Wait : Boolean)
+                    return Outcomes
+is
+   use Interfaces.C;
+
+   --  Same values on Linux, macOS and the BSDs
+
+   LOCK_EX : constant := 2;
+   LOCK_NB : constant := 4;
+   EINTR   : constant := 4;
+
+   --  EWOULDBLOCK is 11 on Linux and 35 on macOS and the BSDs. On each of
+   --  them, the other value is EDEADLK, which flock doesn't report.
+
+   function Is_Would_Block (Error : Integer) return Boolean
+   is (Error = 11 or else Error = 35);
+
+   NFS_Super_Magic : constant := 16#6969#;
+
+   function Flock (File : int; Operation : int) return int;
+   pragma Import (C, Flock, "flock");
+
+   function Fstatfs (File : int; Buffer : System.Address) return int;
+   pragma Import (C, Fstatfs, "fstatfs");
+
+   ------------
+   -- On_NFS --
+   ------------
+
+   function On_NFS return Boolean is
+      Buffer : array (1 .. 512) of aliased long := (others => 0);
+      --  Bigger than struct statfs on any of them (2168 bytes on macOS)
+   begin
+      --  Only Linux has f_type as the first field. Elsewhere, the first word
+      --  holds block sizes or a version, never equal to the NFS magic number.
+
+      return Fstatfs (int (File), Buffer'Address) = 0
+        and then Buffer (Buffer'First) = NFS_Super_Magic;
+   end On_NFS;
+
+begin
+   --  flock on NFS may wait forever even when told not to, so don't try
+
+   if On_NFS then
+      return Unsupported;
+   end if;
+
+   loop
+      if Flock (int (File),
+                LOCK_EX + (if Wait then 0 else LOCK_NB)) = 0
+      then
+         return Locked;
+      end if;
+
+      declare
+         Error : constant Integer := OS.Errno;
+      begin
+         if Is_Would_Block (Error) then
+            return Busy;
+         elsif Error /= EINTR then
+            return Unsupported;
+         end if;
+      end;
+   end loop;
+end Lock_File;

aaa_base/src/windows/aaa-filesystem-locks-lock_file.adb

@@ -0,0 +1,63 @@
+with Interfaces.C;
+
+with System;
+
+separate (AAA.Filesystem.Locks)
+function Lock_File (File : OS.File_Descriptor;
+                    Wait : Boolean)
+                    return Outcomes
+is
+   use Interfaces.C;
+
+   subtype DWORD is unsigned_long; -- 32 bits on Windows
+
+   LOCKFILE_FAIL_IMMEDIATELY : constant := 1;
+   LOCKFILE_EXCLUSIVE_LOCK   : constant := 2;
+   ERROR_LOCK_VIOLATION      : constant := 33;
+
+   type OVERLAPPED is record
+      Internal      : System.Address := System.Null_Address;
+      Internal_High : System.Address := System.Null_Address;
+      Offset        : DWORD          := 0;
+      Offset_High   : DWORD          := 0;
+      Event         : System.Address := System.Null_Address;
+   end record
+     with Convention => C;
+   --  Unused but required, for the start of the region to lock (0)
+
+   function Get_OS_Handle (File : int) return System.Address;
+   pragma Import (C, Get_OS_Handle, "_get_osfhandle");
+
+   function Lock_File_Ex (File        : System.Address;
+                          Flags       : DWORD;
+                          Reserved    : DWORD;
+                          Length_Low  : DWORD;
+                          Length_High : DWORD;
+                          Start       : access OVERLAPPED)
+                          return int;
+   pragma Import (Stdcall, Lock_File_Ex, "LockFileEx");
+
+   function Get_Last_Error return DWORD;
+   pragma Import (Stdcall, Get_Last_Error, "GetLastError");
+
+   Region : aliased OVERLAPPED;
+
+begin
+   --  Lock the first byte, which is enough as everybody locks that one
+
+   if Lock_File_Ex
+     (Get_OS_Handle (int (File)),
+      Flags       => LOCKFILE_EXCLUSIVE_LOCK
+                       + (if Wait then 0 else LOCKFILE_FAIL_IMMEDIATELY),
+      Reserved    => 0,
+      Length_Low  => 1,
+      Length_High => 0,
+      Start       => Region'Access) /= 0
+   then
+      return Locked;
+   elsif Get_Last_Error = ERROR_LOCK_VIOLATION then
+      return Busy;
+   else
+      return Unsupported;
+   end if;
+end Lock_File;

aaa_base/tests/src/aaa_tests-filesystem-locks.adb

@@ -0,0 +1,48 @@
+with AAA.Filesystem.Locks;
+
+with Ada.Directories;
+
+pragma Alire_Test;
+
+procedure Aaa_Tests.Filesystem.Locks is
+
+   package Locks renames AAA.Filesystem.Locks;
+
+   Temp : AAA.Filesystem.Temp_File := AAA.Filesystem.New_Name;
+   Path : constant String := Temp.Filename;
+
+   First, Second : Locks.Lock;
+   --  Declared after Temp, so released before it deletes the file
+
+begin
+   --  The file is created when missing
+
+   Assert (First.Try_Acquire (Path), "Could not lock a new file");
+   Assert (First.Is_Held, "Lock not reported as held");
+   Assert (Ada.Directories.Exists (Path), "Lock file not created");
+
+   --  Nobody else gets it while held, also within the same process
+
+   Assert (not Second.Try_Acquire (Path), "Lock held twice");
+   Assert (not Second.Is_Held, "Failed lock reported as held");
+
+   --  Until released
+
+   First.Release;
+   Assert (not First.Is_Held, "Released lock reported as held");
+   Assert (Second.Try_Acquire (Path), "Released lock not available");
+
+   --  Finalization releases it too
+
+   Second.Release;
+
+   declare
+      Third : Locks.Lock;
+   begin
+      Third.Acquire (Path); -- Free, so it doesn't wait
+      Assert (not First.Try_Acquire (Path), "Lock held twice by Acquire");
+   end;
+
+   Assert (First.Try_Acquire (Path), "Lock not released on finalization");
+   First.Release;
+end Aaa_Tests.Filesystem.Locks;