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

rust: Use with-store macro instead of manual conn handling

Browse source
This commit is contained in:
Davie Li 2024-01-10 15:12:56 +01:00
parent deb9602e05
commit b00e6e8bf5
Signed by: davie
GPG key ID: 29FD88532FC91BF4
1 changed files with 54 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

110
env/rust.scm vendored
View file

@ -69,7 +69,7 @@
0 7)) 0 7))
(item rustup-init-script-derivation))))) (item rustup-init-script-derivation)))))
(define* (exec-in-rustup-environment store launch cmd #:optional home) (define* (exec-in-rustup-environment launch cmd #:optional home)
(let* ((mappings (if home (let* ((mappings (if home
(list (list
(file-system-mapping (file-system-mapping
@ -77,35 +77,35 @@
(target "/home/rustup") (target "/home/rustup")
(writable? #t))) (writable? #t)))
'()))) '())))
(run-with-store store (with-store store
(mlet* %store-monad ((bash (package->derivation bash)) (run-with-store store
(profile (profile-derivation (mlet* %store-monad ((bash (package->derivation bash))
rustup-environment-manifest))) (profile (profile-derivation
(mbegin %store-monad rustup-environment-manifest)))
(built-derivations (list bash profile)) (mbegin %store-monad
(let ((bash-binary (string-append (derivation->output-path bash) (built-derivations (list bash profile))
"/bin/sh")) (let ((bash-binary (string-append (derivation->output-path bash)
(profile-dir (derivation->output-path profile))) "/bin/sh"))
(launch #:command cmd (profile-dir (derivation->output-path profile)))
#:bash bash-binary (launch #:command cmd
#:user "rustup" #:bash bash-binary
#:user-mappings mappings #:user "rustup"
#:profile profile-dir #:user-mappings mappings
#:manifest rustup-environment-manifest #:profile profile-dir
#:link-profile? #f #:manifest rustup-environment-manifest
#:network? #t #:link-profile? #f
#:map-cwd? #f #:network? #t
#:emulate-fhs? #t #:map-cwd? #f
#:nesting? #f))))))) #:emulate-fhs? #t
#:nesting? #f))))))))
(define (call-with-guix-shell-hacks proc) (define (call-with-guix-shell-hacks proc)
"Overcome several pitfails calling launch-environment/container procedure we "Overcome several pitfails calling launch-environment/container procedure we
aren't supposed to. PROC is passed store connection and aren't supposed to. PROC is passed curried launch-environment/container
launch-environment/container function." function."
(let* ((_ (reload-module (resolve-module '(guix scripts environment)))) (let* ((_ (reload-module (resolve-module '(guix scripts environment))))
(launch (@@ (guix scripts environment) launch-environment/container)) (launch (@@ (guix scripts environment) launch-environment/container))
(setup-fhs (@@ (guix scripts environment) setup-fhs)) (setup-fhs (@@ (guix scripts environment) setup-fhs))
(store (open-connection))
(tcgrp (tcgetpgrp (current-input-port)))) (tcgrp (tcgetpgrp (current-input-port))))
;; during launch-environment/container does at least one fork take place, ;; during launch-environment/container does at least one fork take place,
;; for some reason when child exits this process receives SIGTTOU and ;; for some reason when child exits this process receives SIGTTOU and
@ -113,41 +113,39 @@ launch-environment/container function."
;; inside script folder or linux-container module. ;; inside script folder or linux-container module.
(sigaction SIGTTOU SIG_IGN) (sigaction SIGTTOU SIG_IGN)
(sigaction SIGTTIN SIG_IGN) (sigaction SIGTTIN SIG_IGN)
(dynamic-wind (match (primitive-fork)
(const #t) (0
(λ () (catch 'system-error
(match (primitive-fork) (λ ()
(0 (proc
(catch 'system-error ;; Curried launch function with setup-hook = setup-fhs
(λ () (λ args
(proc store (apply
;; Curried launch function with setup-hook = setup-fhs launch (append args
(λ args (list #:setup-hook setup-fhs))))))
(apply (λ args
launch (append args (format (current-error-port)
(list #:setup-hook setup-fhs)))))) "error: ~a" (strerror (system-error-errno args))))))
(λ args (pid (waitpid pid)
(format (current-error-port) ;; Again, maybe because of guix shell hacks or because of hacks
"error: ~a" (strerror (system-error-errno args)))))) ;; to make guix shell importable (eg ignoring signals) group ID
(pid (waitpid pid) ;; for the terminal used by input port changed after child
;; Again, maybe because of guix shell hacks or because of hacks ;; exits. That causes input/output error when we jump back to
;; to make guix shell importable (eg ignoring signals) group ID ;; the prompt.
;; for the terminal used by input port changed after child (tcsetpgrp (current-input-port) tcgrp)
;; exits. That causes input/output error when we jump back to ;; Why not?
;; the prompt. (flush-all-ports)))))
(tcsetpgrp (current-input-port) tcgrp)
;; Why not?
(flush-all-ports))))
(λ () (close-connection store)))))
(define* (init-rustup-environment #:optional home) (define* (init-rustup-environment #:optional home)
(call-with-guix-shell-hacks (call-with-guix-shell-hacks
(λ (store launch) (λ (launch)
(exec-in-rustup-environment (exec-in-rustup-environment launch
store launch'("rustup-init.sh" "-q" "-y") home)))) '("rustup-init.sh" "-q" "-y")
home))))
(define* (launch-rustup-environment #:optional home) (define* (launch-rustup-environment #:optional home)
(call-with-guix-shell-hacks (call-with-guix-shell-hacks
(λ (store launch) (λ (launch)
(exec-in-rustup-environment (exec-in-rustup-environment launch
store launch '("/bin/sh") home)))) '("/bin/sh")
home))))