tribes/guix-fork
1
0
Fork 0
forked from tribes/guix
Code Pull Requests Activity
Files
javascript-team
guix-fork/guix/scripts/perform-download.scm
T
Maxim Cournoyer e122291204 build: Patch the git-lfs hooks shebangs in `git-fetch'. 
This reverts commit b6a070d2a3, which patched
git-lfs so its hooks would refer to a 'sh' from the store, but this reference
was at risk of going stale since the hooks are installed and preserved outside
the store.  The shebangs are now patched in the `git-fetch' procedure
directly.

* guix/scripts/perform-download.scm (perform-git-download): Expand comment.
* guix/git-download.scm (bash-package): New variable.
(git-fetch/in-band*): Add #:bash argument.
(git-fetch-builder): Add it to `inputs', so that it gets added to PATH.
* guix/build/git.scm (git-fetch): Substitute /bin/bash in the post-checkout
git-lfs hook shebang.

Fixes: https://codeberg.org/guix/guix/issues/5616
Reported-by: Simon Josefsson <simon@josefsson.org>
Change-Id: Ife81737705bef5d0a1edad307ed77a479af4609e
2026-02-26 09:59:20 +09:00

295 lines
13 KiB
Scheme
Raw Permalink Blame History

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016-2018, 2020, 2023-2024 Ludovic Courtès <ludo@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 perform-download)
#:use-module (guix ui)
#:use-module (guix scripts)
#:use-module (guix derivations)
#:use-module ((guix store) #:select (derivation-path? store-path?))
#:use-module ((guix build utils) #:select (store-file-name?
strip-store-file-name))
#:autoload (guix build download) (%download-methods url-fetch)
#:autoload (guix build git) (git-fetch-with-fallback)
#:autoload (guix config) (%git)
#:use-module (ice-9 match)
#:use-module (ice-9 sandbox)
#:use-module (web uri)
#:export (guix-perform-download
;; exported so that eval-in-sandbox can find this
syntax-noop))
;; This program is a helper for the daemon's 'download' built-in builder.
(define-syntax derivation-let
(syntax-rules ()
((_ drv ((id name) rest ...) body ...)
(let ((id (assoc-ref (derivation-builder-environment-vars drv)
name)))
(derivation-let drv (rest ...) body ...)))
((_ drv () body ...)
(begin body ...))))
(define-syntax-rule (syntax-noop ...) #t)
;; Bindings to be made available in the sandbox in which mirror procedures are
;; evaluated. We opt for a somewhat conservative selection.
(define %safe-bindings
`( ;; Historically used, must be available for backwards compatibility
((guile)
lambda begin define string-append symbol->string list quote
(noop . module-autoload!)
(noop . current-module))
((guix base16) bytevector->base16-string base16-string->bytevector)
((guix base32)
bytevector->base32-string bytevector->nix-base32-string
base32-string->bytevector nix-base32-string->bytevector)
((guix scripts perform-download)
(syntax-noop . use-modules))
;; Potentially useful for custom content-addressed-mirrors and future
;; changes
((guile) symbol?)
((rnrs bytevectors)
bytevector? bytevector=? bytevector-length bytevector-u8-ref
bytevector->u8-list u8-list->bytevector utf8->string)
,@core-bindings
,@string-bindings
,@list-bindings
,@pair-bindings
,@alist-bindings
,@iteration-bindings
,@number-bindings
,@predicate-bindings))
(define %sandbox-module
(make-sandbox-module %safe-bindings))
(define* (read/safe #:optional (port (current-input-port)))
(with-fluids ((read-eval? #f))
(parameterize ((read-hash-procedures '()))
(read port))))
(define (eval-content-addressed-mirrors content-addressed-mirrors file algo hash)
"Evaluate the expression CONTENT-ADDRESSED-MIRRORS in a sandbox, and produce
a list of wrapper procedures for safely calling the list of procedures that
CONTENT-ADDRESSED-MIRRORS evaluates to."
(map const
(eval-in-sandbox `(map (lambda (proc)
(proc ,file ',algo ,hash))
(let ()
,content-addressed-mirrors))
#:bindings %safe-bindings
#:module %sandbox-module)))
(define (assert-store-file file)
"Canonicalize FILE and exit if the result is not in the store. Return the
result of canonicalization."
(let ((canon (canonicalize-path file)))
(unless (store-file-name? canon)
(leave (G_ "~S is not in the store~%") canon))
canon))
(define (call-with-input-file/no-symlinks file proc)
(call-with-port (open file (logior O_NOFOLLOW O_RDONLY))
proc))
(define (assert-non-local-urls url)
"Exit if URL (or any element of URL if it is a list) is either not a valid
URL or is a URL for a local file."
(for-each (lambda (url)
(let ((scheme (and=> (string->uri url) uri-scheme)))
(unless scheme
(leave (G_ "URL ~S can't be decoded~%") url))
(when (eq? scheme 'file)
(leave (G_ "URL ~S is for a local file~%") url))))
(if (list? url)
url
(list url))))
(define* (perform-download drv output
#:key print-build-trace?)
"Perform the download described by DRV, a fixed-output derivation, to
OUTPUT.
Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
'bmRepair' builds."
(derivation-let drv ((url "url")
(executable "executable")
(mirrors "mirrors")
(content-addressed-mirrors "content-addressed-mirrors")
(disarchive-mirrors "disarchive-mirrors")
(download-methods "download-methods"))
(unless url
(leave (G_ "~a: missing URL~%") (derivation-file-name drv)))
(let* ((mirrors
(and=> mirrors assert-store-file))
(content-addressed-mirrors
(and=> content-addressed-mirrors assert-store-file))
(disarchive-mirrors
(and=> disarchive-mirrors assert-store-file))
(url (call-with-input-string url read/safe))
(drv-output (assoc-ref (derivation-outputs drv) "out"))
(algo (derivation-output-hash-algo drv-output))
(hash (derivation-output-hash drv-output)))
;; Disallow access to local files, e.g. "/tmp/foo", "file:///tmp/foo",
;; etc, since in the case of the rootless daemon we can access sensitive
;; files like /etc/guix/signing-key.sec.
(assert-non-local-urls url)
;; We're invoked by the daemon, which gives us write access to OUTPUT.
(when (parameterize ((%download-methods
(and download-methods
(call-with-input-string download-methods
read/safe))))
(url-fetch url output
#:print-build-trace? print-build-trace?
#:mirrors (if mirrors
(call-with-input-file/no-symlinks
mirrors
read/safe)
'())
#:content-addressed-mirrors
(if content-addressed-mirrors
(call-with-input-file/no-symlinks
content-addressed-mirrors
(lambda (port)
(eval-content-addressed-mirrors
(read/safe port)
(strip-store-file-name output)
algo
hash)))
'())
#:disarchive-mirrors
(if disarchive-mirrors
(call-with-input-file/no-symlinks
disarchive-mirrors
read/safe)
'())
#:hashes `((,algo . ,hash))
;; Since DRV's output hash is known, X.509 certificate
;; validation is pointless.
#:verify-certificate? #f))
(when (and executable (string=? executable "1"))
(chmod output #o755))))))
(define* (perform-git-download drv output
#:key print-build-trace?)
"Perform the download described by DRV, a fixed-output derivation, to
OUTPUT.
Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
'bmRepair' builds."
(derivation-let drv ((url "url")
(commit "commit")
(recursive? "recursive?")
(download-methods "download-methods"))
(unless url
(leave (G_ "~a: missing Git URL~%") (derivation-file-name drv)))
(unless commit
(leave (G_ "~a: missing Git commit~%") (derivation-file-name drv)))
(let* ((url (call-with-input-string url read/safe))
(recursive? (and recursive?
(call-with-input-string recursive? read/safe)))
(drv-output (assoc-ref (derivation-outputs drv) "out"))
(algo (derivation-output-hash-algo drv-output))
(hash (derivation-output-hash drv-output)))
;; Disallow access to local files, e.g. "/tmp/foo", "file:///tmp/foo",
;; etc, since in the case of the rootless daemon we can access sensitive
;; files like /etc/guix/signing-key.sec.
(assert-non-local-urls url)
;; Commands such as 'git submodule' expect Coreutils and sed (among
;; others) to be in $PATH. The 'git' package in Guix should address it
;; with wrappers but packages on other distros such as Debian may rely
;; on ambient authority, hence the PATH value below. The ambient 'sh'
;; command is also used to patch the Git LFS hooks, which uses
;; '/bin/sh'.
(setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin")
(parameterize ((%download-methods
(and download-methods
(call-with-input-string download-methods
read/safe))))
;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are
;; different, hence the #:item argument below.
(git-fetch-with-fallback url commit output
#:hash hash
#:hash-algorithm algo
#:recursive? recursive?
#:item (derivation-output-path drv-output)
#:git-command %git)))))
(define (assert-low-privileges)
(when (zero? (getuid))
(leave (G_ "refusing to run with elevated privileges (UID ~a)~%")
(getuid))))
(define-command (guix-perform-download . args)
(category internal)
(synopsis "perform download described by fixed-output derivations")
;; This is an "out-of-band" download in that this code is executed directly
;; by the daemon and not explicitly described as an input of the derivation.
;; This allows us to sidestep bootstrapping problems, such as downloading
;; the source code of GnuTLS over HTTPS before we have built GnuTLS. See
;; <https://bugs.gnu.org/22774>.
(define print-build-trace?
(match (getenv "_NIX_OPTIONS")
(#f #f)
(str (string-contains str "print-extended-build-trace=1"))))
;; We read untrusted input, best to be sure this is #f!
(fluid-set! read-eval? #f)
;; ... and out of an abundance of caution, remove the ability to use '#.'
;; constructs entirely
(read-hash-procedures '())
;; This program must be invoked by guix-daemon under an unprivileged UID to
;; prevent things downloading from 'file:///etc/shadow'. (That means we
;; exclude users who did not pass '--build-users-group'.)
(with-error-handling
(match args
(((? derivation-path? drv) (? store-path? output))
(assert-low-privileges)
(let* ((drv (read-derivation-from-file drv))
(download (match (derivation-builder drv)
("builtin:download" perform-download)
("builtin:git-download" perform-git-download)
(unknown (leave (G_ "~a: unknown builtin builder")
unknown))))
(drv-output (assoc-ref (derivation-outputs drv) "out"))
(algo (derivation-output-hash-algo drv-output))
(hash (derivation-output-hash drv-output)))
(unless (and hash algo)
(leave (G_ "~a is not a fixed-output derivation~%")
(derivation-file-name drv)))
(download drv output #:print-build-trace? print-build-trace?)))
(("--version")
(show-version-and-exit))
(x
(leave
(G_ "fixed-output derivation and output file name expected~%"))))))
;; Local Variables:
;; eval: (put 'derivation-let 'scheme-indent-function 2)
;; End:
;; perform-download.scm ends here
View Git Blame Copy Permalink