0ca575f3bb
* guix/scripts/container/exec.scm (guix-container-exec): Capture the value of the TERM environment variable, and pass it through to the container. This means some applications now work where they did not before (e.g. htop), and others have more functionality, providing that the terminal was capable of enabling that functionality in the first place. Co-authored-by: Ludovic Courtès <ludo@gnu.org>
106 lines
4.0 KiB
Scheme
106 lines
4.0 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2015 David Thompson <davet@gnu.org>
|
|
;;;
|
|
;;; This file is part of GNU Guix.
|
|
;;;
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (guix scripts container exec)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-11)
|
|
#:use-module (srfi srfi-37)
|
|
#:use-module (guix scripts)
|
|
#:use-module (guix ui)
|
|
#:use-module (guix utils)
|
|
#:use-module (gnu build linux-container)
|
|
#:export (guix-container-exec))
|
|
|
|
(define %options
|
|
(list (option '(#\h "help") #f #f
|
|
(lambda args
|
|
(show-help)
|
|
(exit 0)))
|
|
(option '(#\V "version") #f #f
|
|
(lambda args
|
|
(show-version-and-exit "guix container exec")))))
|
|
|
|
(define (show-help)
|
|
(display (_ "Usage: guix container exec PID COMMAND [ARGS...]
|
|
Execute COMMMAND within the container process PID.\n"))
|
|
(newline)
|
|
(display (_ "
|
|
-h, --help display this help and exit"))
|
|
(display (_ "
|
|
-V, --version display version information and exit"))
|
|
(newline)
|
|
(show-bug-report-information))
|
|
|
|
(define (partition-args args)
|
|
"Split ARGS into two lists; one containing the arguments for this program,
|
|
and the other containing arguments for the command to be executed."
|
|
(define (number-string? str)
|
|
(false-if-exception (string->number str)))
|
|
|
|
(let loop ((a '())
|
|
(b args))
|
|
(match b
|
|
(()
|
|
(values (reverse a) '()))
|
|
(((? number-string? head) . tail)
|
|
(values (reverse (cons head a)) tail))
|
|
((head . tail)
|
|
(loop (cons head a) tail)))))
|
|
|
|
(define (guix-container-exec . args)
|
|
(define (handle-argument arg result)
|
|
(if (assoc-ref result 'pid)
|
|
(leave (_ "~a: extraneous argument~%") arg)
|
|
(alist-cons 'pid (string->number* arg) result)))
|
|
|
|
(with-error-handling
|
|
(let-values (((args command) (partition-args args)))
|
|
(let* ((opts (parse-command-line args %options '(())
|
|
#:argument-handler
|
|
handle-argument))
|
|
(pid (assoc-ref opts 'pid))
|
|
(environment (filter-map (lambda (name)
|
|
(let ((value (getenv name)))
|
|
(and value (cons name value))))
|
|
;; Pass through the TERM environment
|
|
;; variable to inform processes about
|
|
;; the capabilities of the terminal.
|
|
'("TERM"))))
|
|
|
|
(unless pid
|
|
(leave (_ "no pid specified~%")))
|
|
|
|
(when (null? command)
|
|
(leave (_ "no command specified~%")))
|
|
|
|
(unless (file-exists? (string-append "/proc/" (number->string pid)))
|
|
(leave (_ "no such process ~d~%") pid))
|
|
|
|
(let ((result (container-excursion pid
|
|
(lambda ()
|
|
(match command
|
|
((program . program-args)
|
|
(for-each (match-lambda
|
|
((name . value)
|
|
(setenv name value)))
|
|
environment)
|
|
(apply execlp program program program-args)))))))
|
|
(unless (zero? result)
|
|
(leave (_ "exec failed with status ~d~%") result)))))))
|