diff --git a/guix/scripts/prefetch.scm b/guix/scripts/prefetch.scm new file mode 100644 index 0000000..16346bb --- /dev/null +++ b/guix/scripts/prefetch.scm @@ -0,0 +1,149 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Nikita Karetnikov +;;; +;;; 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 . + +(define-module (guix scripts prefetch) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-prefetch)) + +;;; Commentary: +;;; +;;; This program is used to download and add to the store all inputs that are +;;; needed to build the specified packages. +;;; +;;; Code: + +(define (fold-values f acc seen lst) + (if (null-list? lst) + (values acc seen) + (let-values (((acc* seen*) + (f acc seen (first lst)))) + (fold-values f + acc* + seen* + (cdr lst))))) + +(define (derivations-to-prefetch store drv) + "Return the list of fixed-output derivations that DRV depends on, directly +or indirectly." + (define (unique-derivations acc seen lst) + ;; Return two values: the list of unique fixed-output derivations and the + ;; list of seen derivations. + (fold-values (lambda (acc seen drv-input) + (let ((drv* (call-with-input-file (derivation-input-path drv-input) + read-derivation))) + (cond ((fixed-output-derivation? drv*) + (values (lset-adjoin equal? acc drv*) + seen)) + ((member drv* seen) + (values acc seen)) + (else + (unique-derivations acc + (cons drv* seen) + (derivation-inputs drv*)))))) + acc + seen + lst)) + + (identity ; discard the second value + (unique-derivations '() '() (derivation-inputs drv)))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix prefetch [OPTION]... PACKAGES... +Download and add to the store all inputs that are needed to build +PACKAGES.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line 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 prefetch"))))) + + +;;; +;;; Entry point. +;;; + +;; XXX: remove me. +(define specification->package+output + (@@ (guix scripts package) specification->package+output)) + +(define (guix-prefetch . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let ((opts (parse-options)) + (store (open-connection))) + (map (lambda (package) + (format #t "Prefetching the derivations for '~a':~%" + (package-name package)) + + (build-derivations + store + (map (lambda (drv) + ;; (format #t " ~a~%" (derivation-file-name drv)) + (format #t " ~a~%" drv) + drv) + (derivations-to-prefetch + store + (package-derivation store package))))) + + (delete-duplicates + (filter-map (match-lambda + (('argument . value) + (identity ; discard the second value + ;; Check that all VALUEs in the list are valid + ;; packages before calling 'derivations-to-prefetch'. + ;; If VALUE is not a valid package, + ;; 'specification->package+output' will raise an + ;; error. + (specification->package+output value))) + (_ #f)) + (reverse opts))))))