davie/guile-env
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

rust: Use the lock file

Browse source
This commit is contained in:
Davie Li 2024-02-08 18:39:28 +01:00
parent 5af14d7504
commit 00d2599878
Signed by: davie
GPG key ID: 29FD88532FC91BF4
2 changed files with 66 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
env.scm
View file

@ -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))

86
env/rust.scm vendored
View file

@ -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))))))