ddc29a782e
* guix/utils.scm (bytevector-quintet-ref, bytevector-quintet-ref-right, bytevector-quintet-length, bytevector-quintet-fold, bytevector-quintet-fold-right, make-bytevector->base32-string, %nix-base32-chars, %rfc4648-base32-chars, bytevector->base32-string, bytevector->nix-base32-string, bytevector-quintet-set!, bytevector-quintet-set-right!, base32-string-unfold, base32-string-unfold-right, make-base32-string->bytevector, base32-string->bytevector, nix-base32-string->bytevector): Move to... * guix/base32.scm: ... here. New file. * tests/utils.scm (%nix-hash, "bytevector->base32-string", "base32-string->bytevector", "nix-base32-string->bytevector", "sha256 & bytevector->base32-string"): Move to... * tests/base32.scm: ... here. New file * guix-download.in, guix/derivations.scm, guix/packages.scm, guix/snix.scm, tests/builders.scm, tests/derivations.scm: Adjust accordingly. * guix.scm (%public-modules): Add `base32'.
310 lines
11 KiB
Scheme
310 lines
11 KiB
Scheme
;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
|
||
;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
|
||
;;;
|
||
;;; This file is part of Guix.
|
||
;;;
|
||
;;; 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.
|
||
;;;
|
||
;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (guix packages)
|
||
#:use-module (guix utils)
|
||
#:use-module (guix store)
|
||
#:use-module (guix base32)
|
||
#:use-module (guix build-system)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-9 gnu)
|
||
#:use-module (srfi srfi-34)
|
||
#:use-module (srfi srfi-35)
|
||
#:export (origin
|
||
origin?
|
||
origin-uri
|
||
origin-method
|
||
origin-sha256
|
||
origin-file-name
|
||
base32
|
||
|
||
package
|
||
package?
|
||
package-name
|
||
package-version
|
||
package-full-name
|
||
package-source
|
||
package-build-system
|
||
package-arguments
|
||
package-inputs
|
||
package-native-inputs
|
||
package-propagated-inputs
|
||
package-outputs
|
||
package-search-paths
|
||
package-synopsis
|
||
package-description
|
||
package-license
|
||
package-platforms
|
||
package-maintainers
|
||
package-properties
|
||
package-location
|
||
|
||
package-transitive-inputs
|
||
package-transitive-propagated-inputs
|
||
package-source-derivation
|
||
package-derivation
|
||
package-cross-derivation
|
||
|
||
&package-error
|
||
package-error?
|
||
package-error-package
|
||
&package-input-error
|
||
package-input-error?
|
||
package-error-invalid-input))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; This module provides a high-level mechanism to define packages in a
|
||
;;; Guix-based distribution.
|
||
;;;
|
||
;;; Code:
|
||
|
||
;; The source of a package, such as a tarball URL and fetcher---called
|
||
;; "origin" to avoid name clash with `package-source', `source', etc.
|
||
(define-record-type* <origin>
|
||
origin make-origin
|
||
origin?
|
||
(uri origin-uri) ; string
|
||
(method origin-method) ; symbol
|
||
(sha256 origin-sha256) ; bytevector
|
||
(file-name origin-file-name (default #f))) ; optional file name
|
||
|
||
(define-syntax base32
|
||
(lambda (s)
|
||
"Return the bytevector corresponding to the given Nix-base32
|
||
representation."
|
||
(syntax-case s ()
|
||
((_ str)
|
||
(string? (syntax->datum #'str))
|
||
(with-syntax ((bv (nix-base32-string->bytevector
|
||
(syntax->datum #'str))))
|
||
#''bv)))))
|
||
|
||
;; A package.
|
||
|
||
(define-record-type* <package>
|
||
package make-package
|
||
package?
|
||
(name package-name) ; string
|
||
(version package-version) ; string
|
||
(source package-source) ; <origin> instance
|
||
(build-system package-build-system) ; build system
|
||
(arguments package-arguments ; arguments for the build method
|
||
(default '()))
|
||
|
||
(inputs package-inputs ; input packages or derivations
|
||
(default '()))
|
||
(propagated-inputs package-propagated-inputs ; same, but propagated
|
||
(default '()))
|
||
(native-inputs package-native-inputs ; native input packages/derivations
|
||
(default '()))
|
||
(self-native-input? package-self-native-input? ; whether to use itself as
|
||
; a native input when cross-
|
||
(default #f)) ; compiling
|
||
|
||
(outputs package-outputs ; list of strings
|
||
(default '("out")))
|
||
(search-paths package-search-paths ; list of (ENV-VAR (DIRS ...))
|
||
(default '())) ; tuples; see
|
||
; `set-path-environment-variable'
|
||
; (aka. "setup-hook")
|
||
|
||
(synopsis package-synopsis) ; one-line description
|
||
(description package-description) ; one or two paragraphs
|
||
(license package-license (default '()))
|
||
(home-page package-home-page)
|
||
(platforms package-platforms (default '()))
|
||
(maintainers package-maintainers (default '()))
|
||
|
||
(properties package-properties (default '())) ; alist for anything else
|
||
|
||
(location package-location
|
||
(default (and=> (current-source-location)
|
||
source-properties->location))))
|
||
|
||
(set-record-type-printer! <package>
|
||
(lambda (package port)
|
||
(let ((loc (package-location package))
|
||
(format simple-format))
|
||
(format port "#<package ~a-~a ~a:~a ~a>"
|
||
(package-name package)
|
||
(package-version package)
|
||
(location-file loc)
|
||
(location-line loc)
|
||
(number->string (object-address
|
||
package)
|
||
16)))))
|
||
|
||
|
||
;; Error conditions.
|
||
|
||
(define-condition-type &package-error &error
|
||
package-error?
|
||
(package package-error-package))
|
||
|
||
(define-condition-type &package-input-error &package-error
|
||
package-input-error?
|
||
(input package-error-invalid-input))
|
||
|
||
|
||
(define (package-full-name package)
|
||
"Return the full name of PACKAGE--i.e., `NAME-VERSION'."
|
||
(string-append (package-name package) "-" (package-version package)))
|
||
|
||
(define* (package-source-derivation store source
|
||
#:optional (system (%current-system)))
|
||
"Return the derivation path for SOURCE, a package source, for SYSTEM."
|
||
(match source
|
||
(($ <origin> uri method sha256 name)
|
||
(method store uri 'sha256 sha256 name
|
||
#:system system))))
|
||
|
||
(define (transitive-inputs inputs)
|
||
(let loop ((inputs inputs)
|
||
(result '()))
|
||
(match inputs
|
||
(()
|
||
(delete-duplicates (reverse result))) ; XXX: efficiency
|
||
(((and i (name (? package? p) sub ...)) rest ...)
|
||
(let ((t (map (match-lambda
|
||
((dep-name derivation ...)
|
||
(cons (string-append name "/" dep-name)
|
||
derivation)))
|
||
(package-propagated-inputs p))))
|
||
(loop (append t rest)
|
||
(append t (cons i result)))))
|
||
((input rest ...)
|
||
(loop rest (cons input result))))))
|
||
|
||
(define (package-transitive-inputs package)
|
||
"Return the transitive inputs of PACKAGE---i.e., its direct inputs along
|
||
with their propagated inputs, recursively."
|
||
(transitive-inputs (append (package-native-inputs package)
|
||
(package-inputs package)
|
||
(package-propagated-inputs package))))
|
||
|
||
(define (package-transitive-propagated-inputs package)
|
||
"Return the propagated inputs of PACKAGE, and their propagated inputs,
|
||
recursively."
|
||
(transitive-inputs (package-propagated-inputs package)))
|
||
|
||
|
||
;;;
|
||
;;; Package derivations.
|
||
;;;
|
||
|
||
(define %derivation-cache
|
||
;; Package to derivation-path mapping.
|
||
(make-weak-key-hash-table 100))
|
||
|
||
(define (cache package system drv)
|
||
"Memoize DRV as the derivation of PACKAGE on SYSTEM."
|
||
|
||
;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
|
||
;; same value for all structs (as of Guile 2.0.6), and because pointer
|
||
;; equality is sufficient in practice.
|
||
(hashq-set! %derivation-cache package `((,system . ,drv)))
|
||
drv)
|
||
|
||
(define (cached-derivation package system)
|
||
"Return the cached derivation path of PACKAGE for SYSTEM, or #f."
|
||
(match (hashq-ref %derivation-cache package)
|
||
((alist ...)
|
||
(assoc-ref alist system))
|
||
(#f #f)))
|
||
|
||
(define* (package-derivation store package
|
||
#:optional (system (%current-system)))
|
||
"Return the derivation of PACKAGE for SYSTEM."
|
||
(define (intern file)
|
||
;; Add FILE to the store. Set the `recursive?' bit to #t, so that
|
||
;; file permissions are preserved.
|
||
(add-to-store store (basename file)
|
||
#t #t "sha256" file))
|
||
|
||
(define expand-input
|
||
;; Expand the given input tuple such that it contains only
|
||
;; references to derivation paths or store paths.
|
||
(match-lambda
|
||
(((? string? name) (? package? package))
|
||
(list name (package-derivation store package system)))
|
||
(((? string? name) (? package? package)
|
||
(? string? sub-drv))
|
||
(list name (package-derivation store package system)
|
||
sub-drv))
|
||
(((? string? name)
|
||
(and (? string?) (? derivation-path?) drv))
|
||
(list name drv))
|
||
(((? string? name)
|
||
(and (? string?) (? file-exists? file)))
|
||
;; Add FILE to the store. When FILE is in the sub-directory of a
|
||
;; store path, it needs to be added anyway, so it can be used as a
|
||
;; source.
|
||
(list name (intern file)))
|
||
(((? string? name) (? origin? source))
|
||
(list name (package-source-derivation store source system)))
|
||
((and i ((? string? name) (? procedure? proc) sub-drv ...))
|
||
;; This form allows PROC to make a SYSTEM-dependent choice.
|
||
|
||
;; XXX: Currently PROC must return a .drv, a store path, a local
|
||
;; file name, or an <origin>. If it were allowed to return a
|
||
;; package, then `transitive-inputs' and co. would need to be
|
||
;; adjusted.
|
||
(let ((input (proc system)))
|
||
(if (or (string? input) (origin? input))
|
||
(expand-input (cons* name input sub-drv))
|
||
(raise (condition (&package-input-error
|
||
(package package)
|
||
(input i)))))))
|
||
(x
|
||
(raise (condition (&package-input-error
|
||
(package package)
|
||
(input x)))))))
|
||
|
||
(or (cached-derivation package system)
|
||
|
||
;; Compute the derivation and cache the result. Caching is
|
||
;; important because some derivations, such as the implicit inputs
|
||
;; of the GNU build system, will be queried many, many times in a
|
||
;; row.
|
||
(cache
|
||
package system
|
||
(match package
|
||
(($ <package> name version source (= build-system-builder builder)
|
||
args inputs propagated-inputs native-inputs self-native-input?
|
||
outputs)
|
||
;; TODO: For `search-paths', add a builder prologue that calls
|
||
;; `set-path-environment-variable'.
|
||
(let ((inputs (map expand-input
|
||
(package-transitive-inputs package))))
|
||
|
||
(apply builder
|
||
store (package-full-name package)
|
||
(and source
|
||
(package-source-derivation store source system))
|
||
inputs
|
||
#:outputs outputs #:system system
|
||
(if (procedure? args)
|
||
(args system)
|
||
args))))))))
|
||
|
||
(define* (package-cross-derivation store package)
|
||
;; TODO
|
||
#f)
|