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)) (0 (values (make-overlay-mount layers-links upper work merged) 0))
(err (values #f err))))))) (err (values #f err)))))))
(define (unmount-environment-maybe env) (define* (unmount-environment-maybe env #:optional target)
(let* ((name (symbol->string (environment-name env))) (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))) (tmpdirln (string-append "/tmp/genv/" name)))
(if (file-exists? (string-append tmpdirln "/lock")) (if (file-exists? (string-append tmpdirln "/lock"))
#f #f
(begin (begin
(when (file-exists? dir) (when (file-exists? dir)
(system* "umount" dir) ;; TODO check if actually mounted
(delete-file-recursively dir)) (system* "umount" dir))
(when (file-exists? tmpdirln) (when (file-exists? tmpdirln)
(delete-file tmpdirln)))))) (delete-file tmpdirln))))))
@ -459,13 +459,13 @@ by other environments made."
#t #t
#f)) #f))
(define (environment->overlay-mount-maybe env) (define* (environment->overlay-mount-maybe env #:optional target)
(let* ((name (symbol->string (environment-name env))) (let* ((name (symbol->string (environment-name env)))
(dir (readlink (string-append "/tmp/genv/" name)))) (dir (readlink (string-append "/tmp/genv/" name))))
(if (file-exists? dir) (if (file-exists? dir)
(let ((upper (string-append dir "/upper")) (let ((upper (string-append dir "/upper"))
(work (string-append dir "/work")) (work (string-append dir "/work"))
(merged (string-append %env-directory "/" name)) (merged (or target (string-append %env-directory "/" name)))
(layers-links (layers-links
(map (λ (s) (readlink (string-append dir "/" s))) (map (λ (s) (readlink (string-append dir "/" s)))
(filter (λ (s) (string-prefix? "layer" s)) (filter (λ (s) (string-prefix? "layer" s))

86
env/rust.scm vendored
View file

@ -164,6 +164,42 @@ function."
'current)) 'current))
(share '()) (share '())
(expose '())) (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 controlled-files '(".cargo" ".rustup" ".profile"))
(define (remap w) (define (remap w)
(let ((home (getenv "HOME"))) (let ((home (getenv "HOME")))
@ -180,35 +216,33 @@ function."
(let* ((target (string-append (@@ (env) %env-directory) (let* ((target (string-append (@@ (env) %env-directory)
"/" (symbol->string target-sym))) "/" (symbol->string target-sym)))
(mnt (if (environment-mounted? env) (mnt (mount-and-lock target))
(or (environment->overlay-mount-maybe env)
(throw 'wrong-mount?))
(mount-environment env #:tag onto #:target target)))
(mappings (append (map (remap #f) expose) (mappings (append (map (remap #f) expose)
(map (remap #t) share)))) (map (remap #t) share))))
(exec-in-rustup-environment '("./.cargo/bin/rust-analyzer") (exec-in-rustup-environment '("./.cargo/bin/rust-analyzer")
#:home (overlay-mount-merged mnt) #:home (overlay-mount-merged mnt)
#:mappings mappings) #:mappings mappings)
(sync) (sync)
(unmount-environment env) (when (nil? (unlock))
(with-directory-excursion (overlay-mount-upper mnt) (with-directory-excursion (overlay-mount-upper mnt)
(for-each (λ (f) (for-each (λ (f)
(unless (member f controlled-files) (unless (member f controlled-files)
(format (current-output-port) (format (current-output-port)
"Deleting uncontrolled-file: ~a\n" "Deleting uncontrolled-file: ~a\n"
f) f)
(delete-file-recursively f))) (delete-file-recursively f)))
(directory-files "."))) (directory-files ".")))
(if (nil? (directory-files (overlay-mount-upper mnt))) (if (nil? (directory-files (overlay-mount-upper mnt)))
(display "No files to add\n") (display "No files to add\n")
(begin (begin
(display "Adding layer\n") (display "Adding layer\n")
(apply add-layer (apply add-layer
(list env (list env
(overlay-mount-upper mnt) (overlay-mount-upper mnt)
onto onto
target-sym)))) target-sym))))
(for-each delete-file-recursively (unmount-environment-maybe env target)
(list target (for-each delete-file-recursively
(overlay-mount-upper mnt) (list target
(overlay-mount-work mnt))))) (overlay-mount-upper mnt)
(overlay-mount-work mnt))))))