nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
guix-devel/guix/snix.scm

441 lines
16 KiB
Scheme
Raw Normal View History

Add (guix snix) and the `guix-import' command. * guix/snix.scm, tests/snix.scm, guix-import.in: New files. * configure.ac: Output `guix-import' and make it executable. * Makefile.am (bin_SCRIPTS): Add `guix-import'. (MODULES): Add `guix/snix.scm'. (TESTS): Add `tests/snix.scm'.
2012-11-04 19:38:31 +01:00
;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
;;; Copyright (C) 2010, 2011, 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 snix)
#:use-module (sxml ssax)
#:use-module (ice-9 popen)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 format)
#:use-module (ice-9 regex)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (guix utils)
Move base32 code to (guix base32). * 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'.
2012-11-11 22:33:28 +01:00
#:use-module (guix base32)
Add (guix snix) and the `guix-import' command. * guix/snix.scm, tests/snix.scm, guix-import.in: New files. * configure.ac: Output `guix-import' and make it executable. * Makefile.am (bin_SCRIPTS): Add `guix-import'. (MODULES): Add `guix/snix.scm'. (TESTS): Add `tests/snix.scm'.
2012-11-04 19:38:31 +01:00
#:use-module (guix config)
#:export (open-nixpkgs
xml->snix
nixpkgs->guix-package))
;;; Commentary:
;;;
;;; Converting Nix code to s-expressions, and then to Guix `package'
;;; declarations, using the XML output of `nix-instantiate'.
;;;
;;; Code:
;;;
;;; SNix.
;;;
;; Nix object types visible in the XML output of `nix-instantiate' and
;; mapping to S-expressions (we map to sexps, not records, so that we
;; can do pattern matching):
;;
;; at (at varpat attrspat)
;; attr (attribute loc name value)
;; attrs (attribute-set attributes)
;; attrspat (attribute-set-pattern patterns)
;; bool #f|#t
;; derivation (derivation drv-path out-path attributes)
;; ellipsis '...
;; expr (snix loc body ...)
;; function (function loc at|attrspat|varpat)
;; int int
;; list list
;; null 'null
;; path string
;; string string
;; unevaluated 'unevaluated
;; varpat (varpat name)
;;
;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise;
;; however, handling `repeated' nodes makes it impossible to do anything
;; lazily because the whole SXML tree has to be traversed to maintain the
;; list of known derivations.
(define (xml-element->snix elem attributes body derivations)
"Return an SNix element corresponding to XML element ELEM."
(define (loc)
(location (assq-ref attributes 'path)
(assq-ref attributes 'line)
(assq-ref attributes 'column)))
(case elem
((at)
(values `(at ,(car body) ,(cadr body)) derivations))
((attr)
(let ((name (assq-ref attributes 'name)))
(cond ((null? body)
(values `(attribute-pattern ,name) derivations))
((and (pair? body) (null? (cdr body)))
(values `(attribute ,(loc) ,name ,(car body))
derivations))
(else
(error "invalid attribute body" name (loc) body)))))
((attrs)
(values `(attribute-set ,(reverse body)) derivations))
((attrspat)
(values `(attribute-set-pattern ,body) derivations))
((bool)
(values (string-ci=? "true" (assq-ref attributes 'value))
derivations))
((derivation)
(let ((drv-path (assq-ref attributes 'drvPath))
(out-path (assq-ref attributes 'outPath)))
(if (equal? body '(repeated))
(let ((body (vhash-assoc drv-path derivations)))
(if (pair? body)
(values `(derivation ,drv-path ,out-path ,(cdr body))
derivations)
;; DRV-PATH hasn't been encountered yet but may be later
;; (see <http://article.gmane.org/gmane.linux.distributions.nixos/5946>.)
;; Return an `unresolved' node.
(values `(unresolved
,(lambda (derivations)
(let ((body (vhash-assoc drv-path derivations)))
(if (pair? body)
`(derivation ,drv-path ,out-path
,(cdr body))
(error "no previous occurrence of derivation"
drv-path)))))
derivations)))
(values `(derivation ,drv-path ,out-path ,body)
(vhash-cons drv-path body derivations)))))
((ellipsis)
(values '... derivations))
((expr)
(values `(snix ,(loc) ,@body) derivations))
((function)
(values `(function ,(loc) ,body) derivations))
((int)
(values (string->number (assq-ref attributes 'value))
derivations))
((list)
(values body derivations))
((null)
(values 'null derivations))
((path)
(values (assq-ref attributes 'value) derivations))
((repeated)
(values 'repeated derivations))
((string)
(values (assq-ref attributes 'value) derivations))
((unevaluated)
(values 'unevaluated derivations))
((varpat)
(values `(varpat ,(assq-ref attributes 'name)) derivations))
(else (error "unhandled Nix XML element" elem))))
(define (resolve snix derivations)
"Return a new SNix tree where `unresolved' nodes from SNIX have been
replaced by the result of their application to DERIVATIONS, a vhash."
(let loop ((node snix)
(seen vlist-null))
(if (vhash-assq node seen)
(values node seen)
(match node
(('unresolved proc)
(let ((n (proc derivations)))
(values n seen)))
((tag body ...)
(let ((body+seen (fold (lambda (n body+seen)
(call-with-values
(lambda ()
(loop n (cdr body+seen)))
(lambda (n* seen)
(cons (cons n* (car body+seen))
(vhash-consq n #t seen)))))
(cons '() (vhash-consq node #t seen))
body)))
(values (cons tag (reverse (car body+seen)))
(vhash-consq node #t (cdr body+seen)))))
(anything
(values anything seen))))))
(define xml->snix
(let ((parse
(ssax:make-parser NEW-LEVEL-SEED
(lambda (elem-gi attributes namespaces expected-content
seed)
(cons '() (cdr seed)))
FINISH-ELEMENT
(lambda (elem-gi attributes namespaces parent-seed
seed)
(let ((snix (car seed))
(derivations (cdr seed)))
(let-values (((snix derivations)
(xml-element->snix elem-gi
attributes
snix
derivations)))
(cons (cons snix (car parent-seed))
derivations))))
CHAR-DATA-HANDLER
(lambda (string1 string2 seed)
;; Discard inter-node strings, which are blanks.
seed))))
(lambda (port)
"Return the SNix represention of TREE, an SXML tree as returned by
parsing the XML output of `nix-instantiate' on Nixpkgs."
(match (parse port (cons '() vlist-null))
(((snix) . derivations)
(resolve snix derivations))))))
(define (attribute-value attribute)
"Return the value of ATTRIBUTE."
(match attribute
(('attribute _ _ value) value)))
(define (derivation-source derivation)
"Return the \"src\" attribute of DERIVATION or #f if not found."
(match derivation
(('derivation _ _ (attributes ...))
(find-attribute-by-name "src" attributes))))
(define (derivation-output-path derivation)
"Return the output path of DERIVATION."
(match derivation
(('derivation _ out-path _)
out-path)
(_ #f)))
(define (source-output-path src)
"Return the output path of SRC, the \"src\" attribute of a derivation."
(derivation-output-path (attribute-value src)))
(define (source-urls src)
"Return the URLs of SRC, the \"src\" attribute of a derivation."
(match src
(('attribute _ _ ('derivation _ _ (attributes ...)))
(match (find-attribute-by-name "urls" attributes)
(('attribute _ _ value)
value)))
(_ #f)))
(define (source-sha256 src)
"Return the sha256 of SRC, the \"src\" attribute of a derivation, as a
bytevector."
(match src
(('attribute _ _ ('derivation _ _ (attributes ...)))
(match (find-attribute-by-name "outputHash" attributes)
(('attribute _ _ value)
(match value
((= string-length 52)
(nix-base32-string->bytevector value))
((= string-length 64)
(base16-string->bytevector value))
(_
(error "unsupported hash format" value))))))
(_ #f)))
(define (derivation-source-output-path derivation)
"Return the output path of the \"src\" attribute of DERIVATION or #f
if DERIVATION lacks an \"src\" attribute."
(and=> (derivation-source derivation) source-output-path))
(define* (open-nixpkgs nixpkgs #:optional attribute)
"Return an input pipe to the XML representation of Nixpkgs. When
ATTRIBUTE is true, only that attribute is considered."
(with-fluids ((%default-port-encoding "UTF-8"))
(let ((cross-system (format #f "{
config = \"i686-guix-linux-gnu\";
libc = \"glibc\";
arch = \"guix\";
withTLS = true;
float = \"hard\";
openssl.system = \"linux-generic32\";
platform = (import ~a/pkgs/top-level/platforms.nix).sheevaplug;
}" nixpkgs)))
(apply open-pipe* OPEN_READ
%nix-instantiate "--strict" "--eval-only" "--xml"
;; Pass a dummy `crossSystem' argument so that `buildInputs' and
;; `buildNativeInputs' are not coalesced.
;; XXX: This is hacky and has other problems.
;"--arg" "crossSystem" cross-system
`(,@(if attribute
`("-A" ,attribute)
'())
,nixpkgs)))))
(define (pipe-failed? pipe)
"Close pipe and return its status if it failed."
(let ((status (close-pipe pipe)))
(if (or (status:term-sig status)
(not (= (status:exit-val status) 0)))
status
#f)))
(define (find-attribute-by-name name attributes)
"Return attribute NAME in ATTRIBUTES, an attribute set or list of SNix
attributes, or #f if NAME cannot be found."
(find (lambda (a)
(match a
(('attribute _ (? (cut string=? <> name)) _)
a)
(_ #f)))
(match attributes
(('attribute-set (attributes ...))
attributes)
(_
attributes))))
(define (package-source-output-path package)
"Return the output path of the \"src\" derivation of PACKAGE."
(derivation-source-output-path (attribute-value package)))
;;;
;;; Conversion of "Nix expressions" to "Guix expressions".
;;;
(define (factorize-uri uri version)
"Factorize URI, a package tarball URI as a string, such that any occurrences
of the string VERSION is replaced by the symbol 'version."
(let ((version-rx (make-regexp (regexp-quote version))))
(match (regexp-exec version-rx uri)
(#f
uri)
(_
(let ((indices (fold-matches version-rx uri
'((0))
(lambda (m result)
(match result
(((start) rest ...)
`((,(match:end m))
(,start . ,(match:start m))
,@rest)))))))
(fold (lambda (index result)
(match index
((start)
(cons (substring uri start)
result))
((start . end)
(cons* (substring uri start end)
'version
result))))
'()
indices))))))
(define (snix-derivation->guix-package derivation)
"Return the `package' s-expression corresponding to SNix DERIVATION, a
Nixpkgs `stdenv.mkDerivation'-style derivation, and the original source
location of DERIVATION."
(match derivation
(('derivation _ _ (attributes ...))
(let*-values (((full-name loc)
(match (find-attribute-by-name "name" attributes)
(('attribute loc _ value)
(values value loc))
(_
(values #f #f))))
((name version)
(package-name->name+version full-name)))
(define (convert-inputs type)
;; Convert the derivation's input from a list of SNix derivations to
;; a list of name/variable pairs.
(match (and=> (find-attribute-by-name type attributes)
attribute-value)
(#f
'())
((('derivation _ _ (attributes ...)) ...)
(map (lambda (attrs)
(let* ((full-name (attribute-value
(find-attribute-by-name "name" attrs)))
(name (package-name->name+version full-name)))
(list name
(list 'unquote
(string->symbol name)))))
attributes))))
(define (maybe-inputs guix-name inputs)
(match inputs
(()
'())
((inputs ...)
(list (list guix-name
(list 'quasiquote inputs))))))
(define (pretty-uri uri version)
(match (factorize-uri uri version)
((items ...)
`(string-append ,@items))
(x x)))
(let* ((source (find-attribute-by-name "src" attributes))
(urls (source-urls source))
(sha256 (source-sha256 source))
(meta (and=> (find-attribute-by-name "meta" attributes)
attribute-value)))
(values
`(package
(name ,name)
(version ,version)
(source (origin
Add (guix download) and (guix build download). * guix/download.scm, guix/build/download.scm: New files. * Makefile.am (MODULES): Add them. * tests/builders.scm ("url-fetch"): New test. * distro/packages/bootstrap.scm (bootstrap-origin): Support `url-fetch'. * guix/snix.scm (snix-derivation->guix-package): Use `url-fetch' instead of `http-fetch'.
2012-11-12 23:10:26 +01:00
(method url-fetch)
Add (guix snix) and the `guix-import' command. * guix/snix.scm, tests/snix.scm, guix-import.in: New files. * configure.ac: Output `guix-import' and make it executable. * Makefile.am (bin_SCRIPTS): Add `guix-import'. (MODULES): Add `guix/snix.scm'. (TESTS): Add `tests/snix.scm'.
2012-11-04 19:38:31 +01:00
(uri ,(pretty-uri (car urls) version))
(sha256
(base32
,(bytevector->nix-base32-string sha256)))))
(build-system gnu-build-system)
;; When doing a native Nixpkgs build, `buildInputs' is empty and
;; everything is in `buildNativeInputs'. So we can't distinguish
;; between both, here.
,@(maybe-inputs 'inputs
(convert-inputs "buildNativeInputs"))
,@(maybe-inputs 'propagated-inputs
(convert-inputs "propagatedBuildNativeInputs"))
(home-page ,(and=> (find-attribute-by-name "homepage" meta)
attribute-value))
(synopsis ,(and=> (find-attribute-by-name "description" meta)
attribute-value))
(description
,(and=> (find-attribute-by-name "longDescription" meta)
attribute-value))
(license ,(and=> (find-attribute-by-name "license" meta)
attribute-value)))
loc))))))
(define (nixpkgs->guix-package nixpkgs attribute)
"Evaluate ATTRIBUTE in NIXPKGS, the file name of a Nixpkgs checkout,
and return the `package' s-expression corresponding to that package."
(let ((port (open-nixpkgs nixpkgs attribute)))
(match (xml->snix port)
(('snix loc (and drv ('derivation _ ...)))
(and (not (pipe-failed? port))
(snix-derivation->guix-package drv)))
(_
(not (pipe-failed? port))))))
;;; snix.scm ends here