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