diff options
author | Hartmut Goebel <h.goebel@crazy-compilers.com> | 2022-03-15 22:28:45 +0100 |
---|---|---|
committer | Hartmut Goebel <h.goebel@crazy-compilers.com> | 2022-06-15 10:17:24 +0200 |
commit | 2f3cea45b97533e3bb480e69ff88810c43f389f7 (patch) | |
tree | fadde23a0a1b47237fbdcae2e062155635b31a54 | |
parent | 8a04ac4b2f5d356719d896536dabc95a9520c938 (diff) | |
download | guix-2f3cea45b97533e3bb480e69ff88810c43f389f7.tar.gz |
Revert "Add (guix extracting-download)."
This reverts commit f63c79bf7674df012517f8e9148f94c611e35f32, which was missed when reverting the #51061 patch series for now in a1679b74c9aa20bb51bc4add82ebb7ba78926b9c.
-rw-r--r-- | Makefile.am | 1 | ||||
-rw-r--r-- | guix/extracting-download.scm | 179 |
2 files changed, 0 insertions, 180 deletions
diff --git a/Makefile.am b/Makefile.am index e8d4b7ef8a..c1b48d9af0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -97,7 +97,6 @@ MODULES = \ guix/discovery.scm \ guix/android-repo-download.scm \ guix/bzr-download.scm \ - guix/extracting-download.scm \ guix/git-download.scm \ guix/hg-download.scm \ guix/hash.scm \ diff --git a/guix/extracting-download.scm b/guix/extracting-download.scm deleted file mode 100644 index 4b7dcc7e83..0000000000 --- a/guix/extracting-download.scm +++ /dev/null @@ -1,179 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> -;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> -;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> -;;; Copyright © 2020 Hartmut Goebel <h.goebel@crazy-compilers.com> -;;; -;;; 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 extracting-download) - #:use-module (ice-9 match) - #:use-module (ice-9 popen) - #:use-module ((guix build download) #:prefix build:) - #:use-module ((guix build utils) #:hide (delete)) - #:use-module (guix gexp) - #:use-module (guix modules) - #:use-module (guix monads) - #:use-module (guix packages) ;; for %current-system - #:use-module (guix store) - #:use-module (guix utils) - #:use-module (srfi srfi-26) - #:export (http-fetch/extract - download-to-store/extract)) - -;;; -;;; Produce fixed-output derivations with data extracted from n archive -;;; fetched over HTTP or FTP. -;;; -;;; This is meant to be used for package repositories where the actual source -;;; archive is packed into another archive, eventually carrying meta-data. -;;; Using this derivation saves both storing the outer archive and extracting -;;; the actual one at build time. The hash is calculated on the actual -;;; archive to ease validating the stored file. -;;; - -(define* (http-fetch/extract url filename-to-extract hash-algo hash - #:optional name - #:key (system (%current-system)) (guile (default-guile))) - "Return a fixed-output derivation that fetches an archive at URL, and -extracts FILE_TO_EXTRACT from the archive. The FILE_TO_EXTRACT is expected to -have hash HASH of type HASH-ALGO (a symbol). By default, the file name is the -base name of URL; optionally, NAME can specify a different file name." - (define file-name - (match url - ((head _ ...) - (basename head)) - (_ - (basename url)))) - - (define guile-zlib - (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) - - (define guile-json - (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) - - (define gnutls - (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) - - (define inputs - `(("tar" ,(module-ref (resolve-interface '(gnu packages base)) - 'tar)))) - - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module (guix config) - #:export (%system)) - - (define %system - #$(%current-system))))) - - (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure '((guix build download) - (guix build utils) - (guix utils) - (web uri)))))) - - (define build - (with-imported-modules modules - (with-extensions (list guile-json gnutls ;for (guix swh) - guile-zlib) - #~(begin - (use-modules (guix build download) - (guix build utils) - (guix utils) - (web uri) - (ice-9 match) - (ice-9 popen)) - ;; The code below expects tar to be in $PATH. - (set-path-environment-variable "PATH" '("bin") - (match '#+inputs - (((names dirs outputs ...) ...) - dirs))) - - (setvbuf (current-output-port) 'line) - (setvbuf (current-error-port) 'line) - - (call-with-temporary-directory - (lambda (directory) - ;; TODO: Support different archive types, based on content-type - ;; or archive name extention. - (let* ((file-to-extract (getenv "extract filename")) - (port (http-fetch (string->uri (getenv "download url")) - #:verify-certificate? #f)) - (tar (open-pipe* OPEN_WRITE "tar" "-C" directory - "-xf" "-" file-to-extract))) - (dump-port port tar) - (close-port port) - (let ((status (close-pipe tar))) - (unless (zero? status) - (error "tar extraction failure" status))) - (copy-file (string-append directory "/" - (getenv "extract filename")) - #$output)))))))) - - (mlet %store-monad ((guile (package->derivation guile system))) - (gexp->derivation (or name file-name) build - - ;; Use environment variables and a fixed script name so - ;; there's only one script in store for all the - ;; downloads. - #:script-name "extract-download" - #:env-vars - `(("download url" . ,url) - ("extract filename" . ,filename-to-extract)) - #:leaked-env-vars '("http_proxy" "https_proxy" - "LC_ALL" "LC_MESSAGES" "LANG" - "COLUMNS") - #:system system - #:local-build? #t ; don't offload download - #:hash-algo hash-algo - #:hash hash - #:guile-for-build guile))) - - -(define* (download-to-store/extract store url filename-to-extract - #:optional (name (basename url)) - #:key (log (current-error-port)) - (verify-certificate? #t)) - "Download an archive from URL, and extracts FILE_TO_EXTRACT from the archive -to STORE, either under NAME or URL's basename if omitted. Write progress -reports to LOG. VERIFY-CERTIFICATE? determines whether or not to validate -HTTPS server certificates." - (call-with-temporary-output-file - (lambda (temp port) - (let ((result - (parameterize ((current-output-port log)) - (build:url-fetch url temp - ;;#:mirrors %mirrors - #:verify-certificate? - verify-certificate?)))) - (close port) - (and result - (call-with-temporary-output-file - (lambda (contents port) - (let ((tar (open-pipe* OPEN_READ - "tar" ;"--auto-compress" - "-xf" temp "--to-stdout" filename-to-extract))) - (dump-port tar port) - (close-port port) - (let ((status (close-pipe tar))) - (unless (zero? status) - (error "tar extraction failure" status))) - (add-to-store store name #f "sha256" contents))))))))) |