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

env: Add unmount-environment, environment->overlay-mount-maybe

Browse source 
Restructure /tmp folder. Provide metadata.
This commit is contained in:
Davie Li 2024-02-04 18:55:01 +01:00
parent dd295d30ad
commit b00cb803ee
Signed by: davie
GPG key ID: 29FD88532FC91BF4
1 changed files with 44 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

55
env.scm
View file

@ -36,7 +36,9 @@
lookup-environment
mount-environment
remove-env-no-checks!
roll-back!))
roll-back!
environment->overlay-mount-maybe
unmount-environment))
(define directory-files (@@ (ice-9 ftw) directory-files))
@ -392,23 +394,30 @@ by other environments made."
(when (or (not layers-stack) (null? layers-stack))
(throw 'no-layers-stack-found))
(let* ((mkdtemp*
(λ (pfix)
;; /tmp/env name is too common
(mkdir-p "/tmp/env")
(mkdtemp (string-append
"/tmp/env/" (symbol->string name)
"." pfix ".XXXXXX"))))
(let* ((dir (begin
(mkdir-p "/tmp/genv")
(mkdtemp "/tmp/genv/XXXXXX")))
(id (string-take-right dir 6))
(merged (let ((f (or target
(string-append %env-directory
"/" (symbol->string name)))))
(if (directory-exists? f) f (begin (mkdir-p f) f))))
(upper (mkdtemp* "upper"))
(work (mkdtemp* "work"))
(upper (string-append dir "/upper"))
(work (string-append dir "/work"))
;; TODO abstract away
(layers-links (map (λ (l) (string-take l 7))
layers-stack)))
(mkdir upper)
(mkdir work)
(let ((dirln (string-append "/tmp/genv/" (symbol->string name))))
(when (file-exists? dirln)
(delete-file dirln))
(symlink dir dirln)
(let loop ((links layers-links)
(n 0))
(unless (nil? links)
(symlink (car links) (string-append dir "/layer" (number->string n)))
(loop (cdr links) (1+ n)))))
(with-directory-excursion %env-links
;; TODO report missing links? or global sanity check.
;; TODO handle errors
@ -420,6 +429,30 @@ by other environments made."
(0 (values (make-overlay-mount layers-links upper work merged) 0))
(err (values #f err)))))))
(define (unmount-environment env)
(let* ((name (symbol->string (environment-name env)))
(dir (string-append %env-directory "/" name))
(tmpdirln (string-append "/tmp/genv/" name)))
(when (file-exists? dir)
(system* "umount" dir)
(delete-file-recursively dir))
(when (file-exists? tmpdirln)
(delete-file tmpdirln))))
(define (environment->overlay-mount-maybe env)
(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))
(layers-links
(map (λ (s) (readlink (string-append dir "/" s)))
(filter (λ (s) (string-prefix? "layer" s))
(directory-files dir)))))
(make-overlay-mount layers-links upper work merged))
#f)))
(define* (call-with-env env proc #:optional save? clean?)
(match (mount-environment env)
(($ <overlay-mount> lower upper work merged)