Add (guix extracting-download).
* guix/extracting-download.scm: New file * Makefile.am (MODULES): Add it.
This commit is contained in:
Hartmut Goebel
parent
34baab7a7b
commit
f63c79bf76
|
|
@ -96,6 +96,7 @@ 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/swh.scm \
|
||||
|
|
|
|||
|
|
@ -0,0 +1,179 @@
|
|||
;;; 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)))))))))
|
||||
Loading…
Reference in New Issue