From 00d25998781d1181212da6609b3232d85ca36e71 Mon Sep 17 00:00:00 2001
From: Davie Li <hello@davie.li>
Date: Thu, 8 Feb 2024 18:39:28 +0100
Subject: [PATCH] rust: Use the lock file

---
 env.scm      | 12 ++++----
 env/rust.scm | 86 ++++++++++++++++++++++++++++++++++++----------------
 2 files changed, 66 insertions(+), 32 deletions(-)

diff --git a/env.scm b/env.scm
index f6ad7e5..62fdddc 100644
--- a/env.scm
+++ b/env.scm
@@ -431,16 +431,16 @@ by other environments made."
           (0 (values (make-overlay-mount layers-links upper work merged) 0))
           (err (values #f err)))))))
 
-(define (unmount-environment-maybe env)
+(define* (unmount-environment-maybe env #:optional target)
   (let* ((name (symbol->string (environment-name env)))
-         (dir (string-append %env-directory "/" name))
+         (dir (or target (string-append %env-directory "/" name)))
          (tmpdirln (string-append "/tmp/genv/" name)))
     (if (file-exists? (string-append tmpdirln "/lock"))
         #f
         (begin
           (when (file-exists? dir)
-            (system* "umount" dir)
-            (delete-file-recursively dir))
+            ;; TODO check if actually mounted
+            (system* "umount" dir))
           (when (file-exists? tmpdirln)
             (delete-file tmpdirln))))))
 
@@ -459,13 +459,13 @@ by other environments made."
       #t
       #f))
 
-(define (environment->overlay-mount-maybe env)
+(define* (environment->overlay-mount-maybe env #:optional target)
   (let* ((name (symbol->string (environment-name env)))
          (dir (readlink (string-append "/tmp/genv/" name))))
     (if (file-exists? dir)
         (let ((upper (string-append dir "/upper"))
               (work (string-append dir "/work"))
-              (merged (string-append %env-directory "/" name))
+              (merged (or target (string-append %env-directory "/" name)))
               (layers-links
                (map (λ (s) (readlink (string-append dir "/" s)))
                     (filter (λ (s) (string-prefix? "layer" s))
diff --git a/env/rust.scm b/env/rust.scm
index a7a8941..7182576 100644
--- a/env/rust.scm
+++ b/env/rust.scm
@@ -164,6 +164,42 @@ function."
                                          'current))
                                (share '())
                                (expose '()))
+  (define pidf
+    (string-append "/tmp/genv/"
+                   (symbol->string (environment-name env))
+                   "/lock"))
+  (define (lock)
+    ;; Should only be invoked after mount!
+    (let* ((pids (if (file-exists? pidf)
+                     (with-input-from-file pidf read)
+                     '())))
+      (with-output-to-file pidf
+        (λ () (write (cons (getpid) pids))))))
+  (define (unlock)
+    ;; returns list of processes left
+    (let* ((pids (with-input-from-file pidf read))
+           (cpid (getpid))
+           (fpids (filter (λ (pid)
+                            (not (equal? pid cpid)))
+                          pids)))
+      (if (nil? fpids)
+          (delete-file pidf)
+          (with-output-to-file pidf
+            (λ () (write fpids))))
+      fpids))
+  (define (mounted? target)
+    (if (member target ((@@ (env) fuse-overlayfs-mount-points)))
+        #t #f))
+  (define (mount-and-lock target)
+    (if (mounted? target)
+        (let ((mnt (environment->overlay-mount-maybe env target)))
+          (when (not mnt)
+            (throw 'wrong-mount?))
+          (lock)
+          mnt)
+        (let ((mnt (mount-environment env #:tag onto #:target target)))
+          (lock)
+          mnt)))
   (define controlled-files '(".cargo" ".rustup" ".profile"))
   (define (remap w)
     (let ((home (getenv "HOME")))
@@ -180,35 +216,33 @@ function."
 
   (let* ((target (string-append (@@ (env) %env-directory)
                                 "/" (symbol->string target-sym)))
-         (mnt (if (environment-mounted? env)
-                  (or (environment->overlay-mount-maybe env)
-                      (throw 'wrong-mount?))
-                  (mount-environment env #:tag onto #:target target)))
+         (mnt (mount-and-lock target))
          (mappings (append (map (remap #f) expose)
                            (map (remap #t) share))))
     (exec-in-rustup-environment '("./.cargo/bin/rust-analyzer")
                                 #:home (overlay-mount-merged mnt)
                                 #:mappings mappings)
     (sync)
-    (unmount-environment env)
-    (with-directory-excursion (overlay-mount-upper mnt)
-      (for-each (λ (f)
-                  (unless (member f controlled-files)
-                    (format (current-output-port)
-                            "Deleting uncontrolled-file: ~a\n"
-                            f)
-                    (delete-file-recursively f)))
-                (directory-files ".")))
-    (if (nil? (directory-files (overlay-mount-upper mnt)))
-        (display "No files to add\n")
-        (begin
-          (display "Adding layer\n")
-          (apply add-layer
-                 (list env
-                       (overlay-mount-upper mnt)
-                       onto
-                       target-sym))))
-    (for-each delete-file-recursively
-              (list target
-                    (overlay-mount-upper mnt)
-                    (overlay-mount-work mnt)))))
+    (when (nil? (unlock))
+      (with-directory-excursion (overlay-mount-upper mnt)
+        (for-each (λ (f)
+                    (unless (member f controlled-files)
+                      (format (current-output-port)
+                              "Deleting uncontrolled-file: ~a\n"
+                              f)
+                      (delete-file-recursively f)))
+                  (directory-files ".")))
+      (if (nil? (directory-files (overlay-mount-upper mnt)))
+          (display "No files to add\n")
+          (begin
+            (display "Adding layer\n")
+            (apply add-layer
+                   (list env
+                         (overlay-mount-upper mnt)
+                         onto
+                         target-sym))))
+      (unmount-environment-maybe env target)
+      (for-each delete-file-recursively
+                (list target
+                      (overlay-mount-upper mnt)
+                      (overlay-mount-work mnt))))))