492 lines
18 KiB
Scheme
492 lines
18 KiB
Scheme
(define-module (env)
|
|
#:use-module (gcrypt hash)
|
|
#:use-module (guix base32)
|
|
#:use-module (guix build syscalls)
|
|
#:use-module (guix build utils)
|
|
#:use-module (guix hash)
|
|
#:use-module (ice-9 ftw)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 textual-ports)
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module ((scheme base) #:select (bytevector-append))
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:export (add-layer
|
|
call-with-env
|
|
collect-garbage!
|
|
<overlay-mount>
|
|
make-overlay-mount
|
|
overlay-mount?
|
|
overlay-mount-lower
|
|
overlay-mount-upper
|
|
overlay-mount-work
|
|
overlay-mount-merged
|
|
<environment>
|
|
environment-current
|
|
environment-name
|
|
environment-root
|
|
environment-tag-layers
|
|
environment-tag-root?
|
|
environment-tag-value
|
|
environment-tags
|
|
environment-tree
|
|
environment?
|
|
init-environment
|
|
layers-in-use
|
|
list-environments
|
|
lookup-environment
|
|
mount-environment
|
|
remove-env-no-checks!
|
|
roll-back!
|
|
environment->overlay-mount-maybe
|
|
unmount-environment-maybe
|
|
environment-mounted?))
|
|
|
|
(define directory-files (@@ (ice-9 ftw) directory-files))
|
|
|
|
(define (overlayfs-command lower upper work merged)
|
|
;; NOTE lower dirs are listed top to bottom from left to right!
|
|
(let ((lower* (match lower
|
|
(() (throw 'overlayfs-no-lower-dir))
|
|
((l ...) (string-join l ":"))
|
|
(l l))))
|
|
(list "fuse-overlayfs"
|
|
"-o"
|
|
(string-append "lowerdir=" lower*
|
|
",upperdir=" upper
|
|
",workdir=" work)
|
|
merged)))
|
|
|
|
;; TODO handle missing env variables
|
|
;; TODO handle missing directory
|
|
(define-syntax-rule (define-env-path name s s* ...)
|
|
;; Canonicalize path?
|
|
(define name (string-append s s* ...)))
|
|
|
|
(define-env-path %cache-directory (or (getenv "XDG_CACHE_HOME")
|
|
(string-append (getenv "HOME")
|
|
"/.cache")))
|
|
(define-env-path %env-cache %cache-directory "/env")
|
|
(define-env-path %env-layers %env-cache "/layers")
|
|
(define-env-path %env-links %env-layers "/l")
|
|
(define-env-path %env-by-name %env-cache "/by-name")
|
|
(define-env-path %env-directory (getenv "HOME") "/env")
|
|
|
|
(define (metadata-file name . path)
|
|
(apply
|
|
string-append (cons* %env-by-name
|
|
"/" (symbol->string name)
|
|
path)))
|
|
|
|
(define (layer-file hash)
|
|
(string-append %env-layers "/" hash))
|
|
|
|
(define (symlink-layer! hash)
|
|
;; TODO: check for collisions
|
|
(symlink (string-append "../" hash)
|
|
(string-append %env-links "/" (string-take hash 7))))
|
|
|
|
(define (ensure-environment-metadata-directory! name)
|
|
(for-each mkdir-p (list %env-layers
|
|
%env-links
|
|
(metadata-file name)
|
|
%env-directory
|
|
(metadata-file name "/tags"))))
|
|
|
|
;; TODO Should we detect symlink loops here?
|
|
(define (file->string file)
|
|
(call-with-input-file file get-string-all))
|
|
|
|
(define (file->sexp file)
|
|
(with-input-from-file file read))
|
|
|
|
(define-record-type <environment>
|
|
(%make-environment name current root tags tree)
|
|
environment?
|
|
(name environment-name)
|
|
(current environment-current)
|
|
(root environment-root)
|
|
(tags environment-tags)
|
|
(tree environment-tree))
|
|
|
|
(define-record-type <overlay-mount>
|
|
(make-overlay-mount lower upper work merged)
|
|
overlay-mount?
|
|
(lower overlay-mount-lower)
|
|
(upper overlay-mount-upper)
|
|
(work overlay-mount-work)
|
|
(merged overlay-mount-merged))
|
|
|
|
(define (lookup-environment name)
|
|
;; NOTE will fail if .../by-name/name is a symlink
|
|
(if (directory-exists? (metadata-file name))
|
|
(%make-environment
|
|
name
|
|
(file->string (metadata-file name "/tags/current"))
|
|
(file->string (metadata-file name "/tags/root"))
|
|
(map string->symbol (directory-files (metadata-file name "/tags")))
|
|
(file->sexp (metadata-file name "/tree")))
|
|
#f))
|
|
|
|
(define (environment-tag-value env tag)
|
|
(file->string (metadata-file (environment-name env)
|
|
"/tags/" (symbol->string tag))))
|
|
|
|
(define (hash-link v1 v2)
|
|
(bytevector-hash (bytevector-append v1 v2)
|
|
(hash-algorithm sha256)))
|
|
|
|
(define (decode-hash-link-encode s1 s2)
|
|
(bytevector->base32-string
|
|
(apply hash-link
|
|
(map base32-string->bytevector (list s1 s2)))))
|
|
|
|
(define (decode-hash-link-encode/chain hashes)
|
|
(match hashes
|
|
(() (throw 'missformed-argument))
|
|
((h) h)
|
|
((h h* ...) (fold (λ (e acc) (decode-hash-link-encode acc e))
|
|
h h*))))
|
|
|
|
(define (file-hash/overlay file)
|
|
|
|
(define trim
|
|
(let ((n (1+ (string-length file))))
|
|
(λ (f) (string-drop f n))))
|
|
|
|
(define (canonicalize-deleted l)
|
|
(if (null? l)
|
|
l
|
|
(let ((bvs (map string->utf8 (sort (map trim l) string<?))))
|
|
(apply bytevector-append
|
|
(cdr (reverse
|
|
(fold (λ (a b) (cons* a #vu8(0) b))
|
|
'()
|
|
bvs)))))))
|
|
|
|
(let* ((res '())
|
|
(select? (λ (f stat)
|
|
(if (eq? (stat:type stat) 'char-special)
|
|
(begin (set! res (cons f res))
|
|
#f)
|
|
#t)))
|
|
(dirhash (file-hash* file #:select? select?)))
|
|
(if (null? res)
|
|
dirhash
|
|
(hash-link dirhash
|
|
(canonicalize-deleted res)))))
|
|
|
|
(define (environment-tag-root? env tag)
|
|
(equal? (environment-tag-value env tag) (environment-root env)))
|
|
|
|
(define (environment-tag-layers env tag)
|
|
(let ((root-hash (environment-root env))
|
|
(pinned (environment-tag-value env tag))
|
|
(atom? (compose not pair?)))
|
|
(call/cc
|
|
(λ (cont)
|
|
(when (environment-tag-root? env tag)
|
|
(cont (list (environment-root env))))
|
|
(let loop ((tree (cdr (environment-tree env)))
|
|
(hash root-hash)
|
|
(route (list root-hash)))
|
|
(match tree
|
|
(() route)
|
|
(((? atom? head) tail ...)
|
|
(let ((h (decode-hash-link-encode hash head))
|
|
(r (cons head route)))
|
|
(if (equal? pinned h)
|
|
(cont (reverse r))
|
|
(loop tail h r))))
|
|
((((? atom? head)
|
|
(? pair? branch1)
|
|
(? pair? branch2)
|
|
(? pair? branch3) ...)
|
|
tail ...)
|
|
(let* ((h (decode-hash-link-encode hash head))
|
|
(r (cons head route)))
|
|
(if (eq? pinned h)
|
|
(cont (reverse r))
|
|
(begin
|
|
(loop tail h r)
|
|
(for-each (λ (br) (loop br h r))
|
|
(cons* branch1 branch2 branch3))))))
|
|
(else (throw 'missformed-tree))))))))
|
|
|
|
(define (copy-file/overlay source destination)
|
|
(if (eq? (stat:type (stat source)) 'char-special)
|
|
(mknod destination 'char-special #o000 0)
|
|
(copy-file source destination)))
|
|
|
|
(define (copy-recursively/overlay source dest)
|
|
(copy-recursively source dest #:copy-file copy-file/overlay))
|
|
|
|
(define (init-environment name dir)
|
|
;; should we include vcs files?
|
|
(if (lookup-environment name)
|
|
(throw 'environment-esists!)
|
|
(begin
|
|
(ensure-environment-metadata-directory! name)
|
|
(let* ((dirhash (bytevector->base32-string (file-hash* dir)))
|
|
(loc (layer-file dirhash)))
|
|
(copy-recursively dir loc)
|
|
(symlink-layer! dirhash)
|
|
(with-directory-excursion (metadata-file name)
|
|
(with-output-to-file "./tags/root" (λ () (display dirhash)))
|
|
(symlink "./root" "./tags/current")
|
|
(symlink "./tags/current" "current")
|
|
(with-output-to-file "tree" (λ () (write (list dirhash))))))
|
|
(lookup-environment name))))
|
|
|
|
(define* (add-layer env layer #:optional (onto 'current) (tag onto))
|
|
;; TODO deduplicate with init-env
|
|
(unless (file-exists? layer)
|
|
(throw 'add-layer-directory-doesnt-exist!))
|
|
(let* ((name (environment-name env))
|
|
(dirhash (bytevector->base32-string (file-hash/overlay layer)))
|
|
(metadata-dir (metadata-file (environment-name env)))
|
|
(pin (environment-tag-value env onto))
|
|
(new-pin (decode-hash-link-encode pin dirhash))
|
|
(stack (environment-tag-layers env onto))
|
|
(loc (layer-file dirhash)))
|
|
|
|
(define (grow tree pinned layer)
|
|
;; TODO abstract away
|
|
(let ((atom? (compose not pair?)))
|
|
(match tree
|
|
(() (throw 'missformed-tree))
|
|
((root) (if (equal? pinned root)
|
|
(list root layer)
|
|
(throw 'missformed-tree)))
|
|
((root _ ...)
|
|
(cons root
|
|
(let loop ((tree (cdr tree))
|
|
(hash (environment-root env)))
|
|
(match tree
|
|
(() '())
|
|
(((? atom? head))
|
|
(let ((h (decode-hash-link-encode hash head)))
|
|
(if (equal? pinned h)
|
|
(list head layer)
|
|
(list head))))
|
|
(((? atom? head) tail ...)
|
|
(let ((h (decode-hash-link-encode hash head)))
|
|
(if (equal? pinned h)
|
|
(list (list head (list layer) tail))
|
|
(cons head (loop tail h)))))
|
|
((((? atom? head)
|
|
(? pair? branch1)
|
|
(? pair? branch2)
|
|
(? pair? branch3) ...))
|
|
(let* ((h (decode-hash-link-encode hash head)))
|
|
(if (eq? pinned h)
|
|
(list (cons head
|
|
(cons (list layer)
|
|
(cons* branch1 branch2 branch3))))
|
|
(list (cons head (map (λ (br) (loop br h))
|
|
(cons* branch1 branch2 branch3)))))))
|
|
(else (throw 'missformed-tree)))))))))
|
|
|
|
;; TODO check if appendable
|
|
(unless (file-exists? loc)
|
|
(copy-recursively/overlay layer loc)
|
|
;; TODO: check for collisions
|
|
(symlink-layer! dirhash))
|
|
(with-directory-excursion (metadata-file name)
|
|
(let ((tags/tag (string-append "./tags/" (symbol->string tag))))
|
|
(when (and (file-exists? tags/tag) (symbolic-link? tags/tag))
|
|
(delete-file tags/tag))
|
|
(with-output-to-file tags/tag
|
|
(λ () (display new-pin))))
|
|
(with-output-to-file "./tree"
|
|
(λ () (write (grow (environment-tree env) pin dirhash)))))
|
|
(lookup-environment name)))
|
|
|
|
(define* (roll-back! env #:optional (tag 'current))
|
|
(let* ((stack (environment-tag-layers env tag))
|
|
(new-stack (match stack
|
|
(() (throw 'empty-stack))
|
|
((a) (throw 'first-generation-cant-roll-back))
|
|
((a a* ...) (drop-right (cons a a*) 1)))))
|
|
(with-directory-excursion (metadata-file (environment-name env))
|
|
(with-output-to-file "./tree"
|
|
(λ () (write new-stack)))
|
|
(with-output-to-file "./tags/current"
|
|
(λ () (display (decode-hash-link-encode/chain new-stack)))))
|
|
(values (lookup-environment (environment-name env))
|
|
(last stack))))
|
|
|
|
(define (remove-env-no-checks! name)
|
|
"Remove environment brutally. No checks whether any layers are shared
|
|
by other environments made."
|
|
(let* ((metadata-dir (string-append %env-by-name "/" name))
|
|
(tree (with-input-from-file (string-append metadata-dir "/tree")
|
|
read))
|
|
(layers (let loop ((tree tree)
|
|
(layers '()))
|
|
(match tree
|
|
(() layers)
|
|
(((a ...) tail ...)
|
|
(append (loop a '())
|
|
(loop tail layers)))
|
|
((a tail ...)
|
|
(loop tail
|
|
(cons a layers)))))))
|
|
(for-each
|
|
(λ (l)
|
|
(format (current-error-port) "Deleting layer: ~a\n" l)
|
|
(delete-file-recursively (string-append %env-layers "/" l))
|
|
(format (current-error-port) "Cleaning up links for: ~a\n" l)
|
|
(delete-file (string-append %env-links "/" (string-take l 7))))
|
|
layers)
|
|
(format (current-error-port) "Deleting metadata: ~a\n" name)
|
|
(delete-file-recursively metadata-dir)))
|
|
|
|
(define (list-environments)
|
|
(let loop ((names (map string->symbol (directory-files %env-by-name)))
|
|
(envs '()))
|
|
(match names
|
|
(() envs)
|
|
((n n* ...)
|
|
(let ((e (lookup-environment n)))
|
|
(if e
|
|
(loop n* (cons e envs))
|
|
(begin
|
|
(format (current-error-port)
|
|
"Warning: Clobbered by-name directory: ~a\n" n)
|
|
(loop n* envs))))))))
|
|
|
|
(define (layers-in-use)
|
|
(let loop ((envs (list-environments))
|
|
(used '()))
|
|
(match envs
|
|
(() used)
|
|
((e e* ...)
|
|
(loop e*
|
|
(fold
|
|
(λ (t acc)
|
|
(lset-union equal?
|
|
acc
|
|
(environment-tag-layers e t)))
|
|
used
|
|
(environment-tags e)))))))
|
|
|
|
(define* (collect-garbage! #:optional dry-run)
|
|
(with-directory-excursion %env-layers
|
|
(for-each
|
|
(λ (l)
|
|
(if dry-run
|
|
(format (current-error-port) "Would delete layer ~a\n" l)
|
|
(begin
|
|
(format (current-error-port) "Deleting layer ~a\n" l)
|
|
(delete-file-recursively l)
|
|
(delete-file (string-append "l/" (string-take l 7))))))
|
|
(lset-xor equal?
|
|
(delete "l" (directory-files "."))
|
|
(layers-in-use)))))
|
|
|
|
(define* (mount-environment env #:key (tag 'current) target)
|
|
(let* ((name (environment-name env))
|
|
(metadata-dir (metadata-file name))
|
|
(tree (environment-tree env))
|
|
;; TODO sanity check
|
|
(current (environment-current env))
|
|
(layers-stack (environment-tag-layers env tag)))
|
|
|
|
(when (or (not layers-stack) (null? layers-stack))
|
|
(throw 'no-layers-stack-found))
|
|
|
|
(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 (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
|
|
(match (apply system*
|
|
(overlayfs-command (reverse layers-links)
|
|
upper
|
|
work
|
|
merged))
|
|
(0 (values (make-overlay-mount layers-links upper work merged) 0))
|
|
(err (values #f err)))))))
|
|
|
|
(define (unmount-environment-maybe env)
|
|
(let* ((name (symbol->string (environment-name env)))
|
|
(dir (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))
|
|
(when (file-exists? tmpdirln)
|
|
(delete-file tmpdirln))))))
|
|
|
|
(define (fuse-overlayfs-mounts)
|
|
(filter (λ (m) (equal? "fuse.fuse-overlayfs"
|
|
(mount-type m) ))
|
|
(mounts)))
|
|
|
|
(define (fuse-overlayfs-mount-points)
|
|
(map mount-point (fuse-overlayfs-mounts)))
|
|
|
|
(define (environment-mounted? env)
|
|
(if (member (string-append %env-directory
|
|
"/" (symbol->string (environment-name env)))
|
|
(fuse-overlayfs-mount-points))
|
|
#t
|
|
#f))
|
|
|
|
(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)
|
|
(let ((res (proc merged)))
|
|
(sync)
|
|
(when save?
|
|
(when (not (equal? 0 (system* "umount" merged)))
|
|
(throw 'umount-error))
|
|
(add-layer env upper))
|
|
(when clean?
|
|
(when file-exists? upper
|
|
(delete-file-recursively upper))
|
|
(delete-file-recursively merged)
|
|
(delete-file-recursively work))
|
|
res))
|
|
(#f (throw 'mount-failure))))
|