Run delayed post-fetch actions during build (#1441)

* Refactored flags into new crate

* Delay post-fetch to first build (ensures complete env)

* Folderize flags

* Self-review

* Simpler flag use, better encapsulation

* Fix Windows-only test

.gitmodules

@@ -54,3 +54,6 @@
 [submodule "deps/umwi"]
 	path = deps/umwi
 	url = https://github.com/mosteo/umwi
+[submodule "deps/diskflags"]
+	path = deps/diskflags
+	url = https://github.com/mosteo/diskflags

alire.gpr

@@ -4,6 +4,7 @@ with "alire_common";
 with "ajunitgen";
 with "ansiada";
 with "clic";
+with "diskflags";
 with "gnatcoll";
 with "minirest";
 with "optional";

alire.toml

@@ -20,6 +20,7 @@ ada_toml = "~0.3"
 ajunitgen = "^1.0.1"
 ansiada = "^1.0"
 clic = "~0.3"
+diskflags = "~0.1"
 gnatcoll = "^21"
 minirest = "~0.3"
 optional = "~0.1"
@@ -48,6 +49,7 @@ windows = { ALIRE_OS = "windows" }
 aaa = { url = "https://github.com/mosteo/aaa", commit = "ecc38772bd4a6b469b54c62363766ea1c0e9f912" }
 ada_toml = { url = "https://github.com/mosteo/ada-toml", commit = "da4e59c382ceb0de6733d571ecbab7ea4919b33d" }
 clic = { url = "https://github.com/alire-project/clic", commit = "6879b90876a1c918b4e112f59c6db0e25b713f52" }
+diskflags = { url = "https://github.com/mosteo/diskflags", branch = "main" }
 gnatcoll = { url = "https://github.com/alire-project/gnatcoll-core.git", commit = "4e663b87a028252e7e074f054f8f453661397166" }
 minirest = { url = "https://github.com/mosteo/minirest.git", commit = "9a9c660f9c6f27f5ef75417e7fac7061dff14d78" }
 semantic_versioning = { url = "https://github.com/alire-project/semantic_versioning", commit = "2f23fc5f6b4855b836b599adf292fed9c0ed4144" }

alr_env.gpr

@@ -14,6 +14,7 @@ aggregate project Alr_Env is
                          "deps/ajunitgen",
                          "deps/ansi",
                          "deps/clic",
+                         "deps/diskflags",
                          "deps/gnatcoll-slim",
                          "deps/minirest",
                          "deps/optional",

src/alire/alire-builds.adb

@@ -3,9 +3,8 @@ with AAA.Strings;
 with Alire.Config.Builtins;
 with Alire.Config.Edit;
 with Alire.Directories;
+with Alire.Flags;
 with Alire.Paths.Vault;
-with Alire.Platforms.Current;
-with Alire.Properties.Actions.Executor;
 with Alire.Roots;
 
 with GNATCOLL.VFS;
@@ -29,14 +28,14 @@ package body Alire.Builds is
                    Release   : Releases.Release;
                    Was_There : out Boolean)
    is
-      Src       : constant Absolute_Path := Paths.Vault.Path
+      Src    : constant Absolute_Path := Paths.Vault.Path
                                             / Release.Deployment_Folder;
-      Dst       : constant Absolute_Path := Builds.Path (Root, Release);
-      Completed : Directories.Completion := Directories.New_Completion (Dst);
+      Dst    : constant Absolute_Path := Builds.Path (Root, Release);
+      Synced : Flags.Flag := Flags.Complete_Copy (Dst);
    begin
       Was_There := False;
 
-      if Completed.Is_Complete then
+      if Synced.Exists then
          Trace.Detail ("Skipping build syncing to existing " & Dst);
          Was_There := True;
          return;
@@ -68,22 +67,11 @@ package body Alire.Builds is
       --  At this point we can generate the final crate configuration
       Root.Configuration.Generate_Config_Files (Root, Release, Full => Force);
 
-      declare
-         use Directories;
-         Work_Dir : Guard (Enter (Dst)) with Unreferenced;
-      begin
-         Alire.Properties.Actions.Executor.Execute_Actions
-           (Release => Release,
-            Env     => Platforms.Current.Properties,
-            Moment  => Properties.Actions.Post_Fetch);
-      exception
-         when E : others =>
-            Log_Exception (E);
-            Trace.Warning ("A post-fetch action failed, " &
-                             "re-run with -vv -d for details");
-      end;
+      --  We could run post-fetch now but for consistency with sandboxed deps
+      --  and to have a single call point, we delay until build time (which is
+      --  performed right after sync anyway).
 
-      Completed.Mark (Complete => True);
+      Synced.Mark (Done => True);
    end Sync;
 
    ----------

src/alire/alire-directories.adb

@@ -1112,38 +1112,4 @@ package body Alire.Directories is
       end if;
    end Touch;
 
-   ----------
-   -- File --
-   ----------
-
-   function File (This : Completion) return Absolute_File
-   is (This.Path
-       / Paths.Working_Folder_Inside_Root
-       / Paths.Complete_Flag);
-
-   -----------------
-   -- Is_Complete --
-   -----------------
-
-   function Is_Complete (This : Completion) return Boolean
-   is (Is_File (This.File));
-
-   ----------
-   -- Mark --
-   ----------
-
-   procedure Mark (This     : in out Completion;
-                   Complete : Boolean)
-   is
-   begin
-      if Complete then
-         Create_Tree (Parent (This.File));
-         Touch (This.File);
-      else
-         if This.Is_Complete then
-            Delete_Tree (This.File);
-         end if;
-      end if;
-   end Mark;
-
 end Alire.Directories;

src/alire/alire-directories.ads

@@ -217,26 +217,6 @@ package Alire.Directories is
    --  called, on going out of scope the Replacer will remove the temporary and
    --  the original file remains untouched.
 
-   --  To ensure that certain download/copy/sync operations are complete, we
-   --  use this type that will check/delete/create a <path>/alire/complete_copy
-   --  canary file.
-
-   type Completion (<>) is tagged limited private;
-
-   function New_Completion (Path : Directory_Path) return Completion;
-   --  This is the destination folder whose operation we want to ensure was
-   --  completed: a download/copy destination, for example.
-
-   function Is_Complete (This : Completion) return Boolean;
-   --  Say if the operation at This path was already complete in which case
-   --  nothing should be done.
-
-   procedure Mark (This     : in out Completion;
-                   Complete : Boolean)
-     with Post => This.Is_Complete = Complete;
-   --  Set/remove the canary flag of the operation on path being complete. This
-   --  should be called when the operation has actually been completed.
-
 private
 
    ------------
@@ -284,25 +264,4 @@ private
    function Find_Relative_Path_To (Path : Any_Path) return Any_Path
    is (Find_Relative_Path (Current, Path));
 
-   ----------------
-   -- Completion --
-   ----------------
-
-   type Completion (Length : Natural) is
-     new Ada.Finalization.Limited_Controlled with
-      record
-         Path : Absolute_Path (1 .. Length);
-      end record;
-
-   function File (This : Completion) return Absolute_File;
-
-   --------------------
-   -- New_Completion --
-   --------------------
-
-   function New_Completion (Path : Directory_Path) return Completion
-   is (Ada.Finalization.Limited_Controlled with
-       Length => Full_Name (Path)'Length,
-       Path   => Full_Name (Path));
-
 end Alire.Directories;

src/alire/alire-flags.adb

@@ -0,0 +1,24 @@
+with AAA.Strings;
+
+with Alire.Directories;
+with Alire.Paths;
+
+package body Alire.Flags is
+
+   use Directories.Operators; -- "/"
+
+   --------------
+   -- New_Flag --
+   --------------
+
+   function New_Flag (Name : Names;
+                      Base : Absolute_Path)
+                      return Flag
+   is (Diskflags.New_Flag
+        (Diskflags.Some_Path
+          (Base
+             / Paths.Working_Folder_Inside_Root
+             / Paths.Flags_Folder_Inside_Working_Folder
+             / AAA.Strings.To_Lower_Case (Name'Image))));
+
+end Alire.Flags;

src/alire/alire-flags.ads

@@ -0,0 +1,38 @@
+with Diskflags;
+
+package Alire.Flags is
+
+   --  Flags are empty files we store under the workspace's alire directory to
+   --  signal that some operation has succeeded.
+
+   subtype Flag is Diskflags.Flag;
+
+   --  All following `Base` paths point to a release top-dir, not necessarily
+   --  to a workspace's root.
+
+   function Complete_Copy (Base : Absolute_Path) return Flag;
+   --  Signals that a release deployment has completed successfully
+
+   function Post_Fetch (Base : Absolute_Path) return Flag;
+   --  Signals that post-fetch has been run for the release
+
+private
+
+   --  The following names directly translate into lowercase filenames
+   type Names is
+     (Complete_Copy,
+      Post_Fetch_Done);
+
+   function New_Flag (Name : Names;
+                      Base : Absolute_Path)
+                      return Flag;
+   --  Base refers to the top-dir of any release, not necessarily a workspace
+   --  root.
+
+   function Complete_Copy (Base : Absolute_Path) return Flag
+   is (New_Flag (Complete_Copy, Base));
+
+   function Post_Fetch (Base : Absolute_Path) return Flag
+   is (New_Flag (Post_Fetch_Done, Base));
+
+end Alire.Flags;

src/alire/alire-paths.ads

@@ -11,6 +11,8 @@ package Alire.Paths with Preelaborate is
 
    Deps_Folder_Inside_Cache_Folder : constant Relative_Path := "dependencies";
 
+   Flags_Folder_Inside_Working_Folder : constant Relative_Path := "flags";
+
    Release_Folder_Inside_Working_Folder : constant Relative_Path := "releases";
 
    Temp_Folder_Inside_Working_Folder : constant Relative_Path := "tmp";

src/alire/alire-properties-actions-executor.adb

@@ -1,10 +1,55 @@
 with Alire.Directories;
+with Alire.Flags;
 with Alire.OS_Lib.Subprocess;
 with Alire.Properties.Actions.Runners;
+with Alire.Roots;
 with Alire.Utils.TTY;
 
 package body Alire.Properties.Actions.Executor is
 
+   ---------------------
+   -- Execute_Actions --
+   ---------------------
+
+   procedure Execute_Actions (Root    : in out Roots.Root;
+                              State   : Dependencies.States.State;
+                              Moment  : Moments)
+   is
+      Rel : constant Releases.Release := State.Release;
+
+      CWD : constant Absolute_Path :=
+              Root.Release_Base (Rel.Name, Roots.For_Build);
+
+      CD  : Directories.Guard (Directories.Enter (CWD)) with Unreferenced;
+   begin
+      if Moment = Post_Fetch and then
+        Flags.Post_Fetch (CWD).Exists
+      then
+         Trace.Debug
+           ("Skipping already ran " &
+              Utils.TTY.Name (TOML_Adapters.Tomify (Moment'Image))
+            & " actions for " & Rel.Milestone.TTY_Image & "...");
+         return;
+      end if;
+
+      Execute_Actions
+        (Release => Rel,
+         Env     => Root.Environment,
+         Moment  => Moment);
+
+      if Moment = Post_Fetch then
+         Flags.Post_Fetch (CWD).Mark_Done;
+      end if;
+   exception
+      when E : others =>
+         Log_Exception (E);
+         Trace.Warning ("A " & TOML_Adapters.Tomify (Moment'Image)
+                        & " for release " & Rel.Milestone.TTY_Image
+                        & " action failed, " &
+                          "re-run with -vv -d for details");
+         raise Action_Failed;
+   end Execute_Actions;
+
    -----------------
    -- Execute_Run --
    -----------------
@@ -63,6 +108,14 @@ package body Alire.Properties.Actions.Executor is
          Err_To_Out => False,
          Code       => Unused_Code,
          Output     => Unused_Output);
+   exception
+      when E : others =>
+         Log_Exception (E);
+         Trace.Warning ("A " & TOML_Adapters.Tomify (Moment'Image)
+                        & " for release " & Release.Milestone.TTY_Image
+                        & " action failed, " &
+                          "re-run with -vv -d for details");
+         raise Action_Failed;
    end Execute_Actions;
 
    ---------------------
@@ -85,7 +138,7 @@ package body Alire.Properties.Actions.Executor is
 
       if not Release.On_Platform_Actions (Env, Now).Is_Empty then
          Put_Info ("Running " &
-                     Utils.TTY.Name (AAA.Strings.To_Lower_Case (Moment'Image))
+                     Utils.TTY.Name (TOML_Adapters.Tomify (Moment'Image))
                    & " actions for " & Release.Milestone.TTY_Image & "...");
       end if;
 

src/alire/alire-properties-actions-executor.ads

@@ -1,15 +1,28 @@
 with AAA.Strings;
 
+with Alire.Dependencies.States;
 with Alire.Releases;
+limited with Alire.Roots;
 
 package Alire.Properties.Actions.Executor is
 
+   procedure Execute_Actions (Root    : in out Roots.Root;
+                              State   : Dependencies.States.State;
+                              Moment  : Moments)
+     with Pre => State.Has_Release;
+   --  Execute actions for Release in the context of Root. Will raise
+   --  Action_Failed if the spawned command exits with failure. Will
+   --  skip post-fetch if already run.
+
    procedure Execute_Actions (Release : Releases.Release;
                               Env     : Properties.Vector;
                               Moment  : Moments);
    --  Run Release actions that apply to a given environment. IMPORTANT: the
    --  working directory at the moment of this call should be the workspace
-   --  root.
+   --  root. Recommended for toolchains or direct execution only (e.g. `alr
+   --  action`), otherwise better use the previous call that takes into account
+   --  the Root context. Will raise Action_Failed if the spawned command exits
+   --  with failure. Will not skip post-fetch even if already run.
 
    procedure Execute_Actions
      (Release    : Releases.Release;
@@ -22,6 +35,8 @@ package Alire.Properties.Actions.Executor is
       Prefix     : AAA.Strings.Vector := AAA.Strings.Empty_Vector);
    --  More general invocation. Prefix is prepended to the command (e.g., for
    --  dockerization). When capture is true, the rest of parameters are also
-   --  used; otherwise output goes untouched straight to console.
+   --  used; otherwise output goes untouched straight to console. Will not
+   --  raise Action_Failed as an error in the spawned command will be reported
+   --  through Code. Will not skip the post-fetch action even if already run.
 
 end Alire.Properties.Actions.Executor;

src/alire/alire-properties-actions.ads

@@ -4,6 +4,9 @@ with Alire.TOML_Keys;
 
 package Alire.Properties.Actions with Preelaborate is
 
+   Action_Failed : exception;
+   --  Raised by the action runner when an action fails
+
    type Moments is
      (
       Post_Fetch, -- After being downloaded/on dependency updates