summaryrefslogtreecommitdiff
path: root/guix/extracting-download.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/extracting-download.scm')
-rw-r--r--guix/extracting-download.scm179
1 files changed, 0 insertions, 179 deletions
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)))))))))
generated by cgit v1.2.3 (git 2.50.1) at 2025-10-31 03:11:33 +0000