249 lines
9.7 KiB
Scheme
249 lines
9.7 KiB
Scheme
(define-module (env rust)
|
|
#:use-module (env)
|
|
#:use-module (gnu packages)
|
|
#:use-module (gnu packages base)
|
|
#:use-module (gnu packages bash)
|
|
#:use-module (gnu packages curl)
|
|
#:use-module (gnu packages certs)
|
|
#:use-module (gnu packages pkg-config)
|
|
#:use-module (gnu packages gcc)
|
|
#:use-module (gnu packages glib)
|
|
#:use-module (gnu packages commencement)
|
|
#:use-module (gnu packages compression)
|
|
#:use-module (gnu system file-systems)
|
|
#:use-module (guix build utils)
|
|
#:use-module (guix download)
|
|
#:use-module (guix git-download)
|
|
#:use-module ((guix licenses) #:prefix license:)
|
|
#:use-module (guix derivations)
|
|
#:use-module (guix packages)
|
|
#:use-module (guix profiles)
|
|
#:use-module (guix utils)
|
|
#:use-module (guix gexp)
|
|
#:use-module (guix monads)
|
|
#:use-module (guix store)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (srfi srfi-1)
|
|
#:export (launch-rustup-environment
|
|
init-rustup-environment
|
|
launch-rust-analyzer))
|
|
|
|
(define directory-files (@@ (ice-9 ftw) directory-files))
|
|
|
|
(define rustup-origin
|
|
(let ((name "rustup")
|
|
(commit "737ad82333742dfd350a733c1649ce4e36109773")
|
|
(version "1.26.0")
|
|
(revision "0"))
|
|
(origin
|
|
(method git-fetch)
|
|
(uri (git-reference
|
|
(url "https://github.com/rust-lang/rustup")
|
|
(commit commit)))
|
|
(file-name (git-file-name name version))
|
|
(sha256
|
|
(base32 "1b9dcy5ckaqy119r311ds6zr7h5l4b1q52q88ls82zkk4109rpg4")))))
|
|
|
|
(define rustup-init-script-derivation
|
|
(let ((file "rustup-init.sh"))
|
|
(computed-file
|
|
file
|
|
(with-imported-modules '((guix build utils))
|
|
#~(begin (use-modules (guix build utils))
|
|
(let ((bin (string-append #$output "/bin")))
|
|
(mkdir-p bin)
|
|
(symlink (string-append #$rustup-origin "/" #$file)
|
|
(string-append bin "/" #$file ))))))))
|
|
|
|
(define rustup-environment-manifest
|
|
(manifest-add
|
|
(packages->manifest
|
|
(list glibc-for-fhs ;; has to be first
|
|
(list (@@ (gnu packages gcc) gcc) "lib")
|
|
gcc-toolchain
|
|
coreutils
|
|
curl
|
|
grep
|
|
nss-certs
|
|
zlib)) ;; zlib is needed for rustc not for install
|
|
(list
|
|
(manifest-entry
|
|
(name (origin-file-name rustup-origin))
|
|
(version (substring (git-reference-commit
|
|
(origin-uri rustup-origin))
|
|
0 7))
|
|
(item rustup-init-script-derivation)))))
|
|
|
|
;; TODO This is ridiculous. Should get rid of it somehow.
|
|
(define (call-with-guix-shell-hacks proc)
|
|
"Overcome several pitfails calling launch-environment/container procedure we
|
|
aren't supposed to. PROC is passed curried launch-environment/container
|
|
function."
|
|
(let* ((_ (reload-module (resolve-module '(guix scripts environment))))
|
|
(launch (@@ (guix scripts environment) launch-environment/container))
|
|
(setup-fhs (@@ (guix scripts environment) setup-fhs))
|
|
(tcgrp (catch 'system-error
|
|
;; catching ioctl for some types of prompts.
|
|
(λ () (tcgetpgrp (current-input-port)))
|
|
(const #f))))
|
|
;; during launch-environment/container does at least one fork take place,
|
|
;; for some reason when child exits this process receives SIGTTOU and
|
|
;; SIGTTIN signals which put it to wait. Looks like a side-effect of hacks
|
|
;; inside script folder or linux-container module.
|
|
(sigaction SIGTTOU SIG_IGN)
|
|
(sigaction SIGTTIN SIG_IGN)
|
|
(match (primitive-fork)
|
|
(0
|
|
(catch 'system-error
|
|
(λ ()
|
|
(proc
|
|
;; Curried launch function with setup-hook = setup-fhs
|
|
(λ args
|
|
(apply
|
|
launch (append args
|
|
(list #:setup-hook setup-fhs))))))
|
|
(λ args
|
|
(format (current-error-port)
|
|
"error: ~a" (strerror (system-error-errno args))))))
|
|
(pid (waitpid pid)
|
|
;; Again, maybe because of guix shell hacks or because of hacks
|
|
;; to make guix shell importable (eg ignoring signals) group ID
|
|
;; for the terminal used by input port changed after child
|
|
;; exits. That causes input/output error when we jump back to
|
|
;; the prompt.
|
|
(when tcgrp
|
|
;; only setting it back when there were no ioctl error (see let*
|
|
;; form above)
|
|
(tcsetpgrp (current-input-port) tcgrp))
|
|
;; Why not?
|
|
(flush-all-ports)))))
|
|
|
|
(define* (exec-in-rustup-environment cmd #:key home mappings)
|
|
(let* ((mappings (append (if home
|
|
(list (file-system-mapping
|
|
(source home)
|
|
(target "/home/rustup")
|
|
(writable? #t)))
|
|
'())
|
|
mappings)))
|
|
(call-with-guix-shell-hacks
|
|
(λ (launch)
|
|
(with-store store
|
|
(run-with-store store
|
|
(mlet* %store-monad ((bash (package->derivation bash))
|
|
(profile (profile-derivation
|
|
rustup-environment-manifest)))
|
|
(mbegin %store-monad
|
|
(built-derivations (list bash profile))
|
|
(let ((bash-binary (string-append (derivation->output-path bash)
|
|
"/bin/sh"))
|
|
(profile-dir (derivation->output-path profile)))
|
|
(launch #:command cmd
|
|
#:bash bash-binary
|
|
#:user "rustup"
|
|
#:user-mappings mappings
|
|
#:profile profile-dir
|
|
#:manifest rustup-environment-manifest
|
|
#:link-profile? #f
|
|
#:network? #t
|
|
#:map-cwd? #f
|
|
#:emulate-fhs? #t
|
|
#:nesting? #f))))))))))
|
|
|
|
(define* (init-rustup-environment #:optional home)
|
|
(exec-in-rustup-environment '("rustup-init.sh" "-q" "-y") #:home home))
|
|
|
|
(define* (launch-rustup-environment #:optional home)
|
|
(exec-in-rustup-environment '("/bin/sh") #:home home))
|
|
|
|
(define* (launch-rust-analyzer env target-sym
|
|
#:key
|
|
(onto (if (member target-sym
|
|
(environment-tags env))
|
|
target-sym
|
|
'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")))
|
|
(λ (m)
|
|
(let loop ((m m))
|
|
(match m
|
|
((s t) (file-system-mapping (source s) (target t) (writable? w)))
|
|
(s (if (file-exists? s)
|
|
(if (string-prefix? home s)
|
|
(loop (list s (string-replace s "rustup"
|
|
6 (string-length home))))
|
|
(loop (list s s)))
|
|
(throw 'file-doesnt-exist))))))))
|
|
|
|
(let* ((target (string-append (@@ (env) %env-directory)
|
|
"/" (symbol->string target-sym)))
|
|
(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)
|
|
(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))))))
|