rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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'.
This commit is contained in:
Ludovic Courtès 2012-11-04 19:38:31 +01:00
parent 5901471cec
commit 10226c05b1
6 changed files with 662 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -49,3 +49,4 @@ config.cache
/distro/packages/bootstrap/i686-linux/guile-bootstrap-2.0.6.tar.xz
/guix-package
/guix/config.scm
/guix-import

3
Makefile.am
View File

@ -19,6 +19,7 @@
bin_SCRIPTS = \
guix-build \
guix-download \
guix-import \
guix-package
MODULES = \
@ -38,6 +39,7 @@ MODULES = \
guix/build/utils.scm \
guix/build/union.scm \
guix/packages.scm \
guix/snix.scm \
guix.scm \
distro.scm \
distro/packages/base.scm \
@ -120,6 +122,7 @@ TESTS = \
tests/utils.scm \
tests/build-utils.scm \
tests/packages.scm \
tests/snix.scm \
tests/union.scm \
tests/guix-build.sh \
tests/guix-package.sh

3
configure.ac
View File

@ -88,10 +88,11 @@ AC_CONFIG_FILES([Makefile
guix/config.scm
guix-build
guix-download
guix-import
guix-package
pre-inst-env])
AC_CONFIG_COMMANDS([commands-exec],
[chmod +x guix-build guix-download guix-package pre-inst-env])
[chmod +x guix-build guix-download guix-import guix-package pre-inst-env])
AC_OUTPUT

138
guix-import.in Normal file
View File

@ -0,0 +1,138 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
prefix="@prefix@"
datarootdir="@datarootdir@"
GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
export GUILE_LOAD_COMPILED_PATH
main='(module-ref (resolve-interface '\''(guix-import)) '\'guix-import')'
exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
-c "(apply $main (cdr (command-line)))" "$@"
!#
;;; 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-import)
#:use-module (guix ui)
#:use-module (guix snix)
#: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)
#:use-module (ice-9 pretty-print)
#:export (guix-import))
;;;
;;; Helper.
;;;
(define (newline-rewriting-port output)
"Return an output port that rewrites strings containing the \\n escape
to an actual newline. This works around the behavior of `pretty-print'
and `write', which output these as \\n instead of actual newlines,
whereas we want the `description' field to contain actual newlines
rather than \\n."
(define (write-string str)
(let loop ((chars (string->list str)))
(match chars
(()
#t)
((#\\ #\n rest ...)
(newline output)
(loop rest))
((chr rest ...)
(write-char chr output)
(loop rest)))))
(make-soft-port (vector (cut write-char <>)
write-string
(lambda _ #t) ; flush
#f
(lambda _ #t) ; close
#f)
"w"))
;;;
;;; Command-line options.
;;;
(define %default-options
'())
(define (show-help)
(display (_ "Usage: guix-import NIXPKGS ATTRIBUTE
Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n"))
(display (_ "
-h, --help display this help and exit"))
(display (_ "
-V, --version display version information and exit"))
(newline)
(format #t (_ "
Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(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-import")))))
;;;
;;; Entry point.
;;;
(define (guix-import . 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))
(setlocale LC_ALL "")
(textdomain "guix")
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
(let* ((opts (parse-options))
(args (filter-map (match-lambda
(('argument . value)
value)
(_ #f))
(reverse opts))))
(match args
((nixpkgs attribute)
(let-values (((expr loc)
(nixpkgs->guix-package nixpkgs attribute)))
(format #t ";; converted from ~a:~a~%~%"
(location-file loc) (location-line loc))
(pretty-print expr (newline-rewriting-port (current-output-port)))))
(_
(leave (_ "wrong number of arguments~%"))))))

439
guix/snix.scm Normal file
View File

@ -0,0 +1,439 @@
;;; 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)
#: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
(method http-fetch)
(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

79
tests/snix.scm Normal file
View File

@ -0,0 +1,79 @@
;;; 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 (test-snix)
#:use-module (guix snix)
#:use-module ((guix utils) #:select (%nixpkgs-directory))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match))
(define factorize-uri
(@@ (guix snix) factorize-uri))
(define-syntax-rule (every? proc lists ...)
(not (not (every proc lists ...))))
(test-begin "snix")
(test-assert "factorize-uri"
(every? (match-lambda
((uri version '-> expected)
(equal? (factorize-uri uri version)
expected)))
'(("http://example.com/foo.tgz" "1.0"
-> "http://example.com/foo.tgz")
("http://example.com/foo-2.8.tgz" "2.8"
-> ("http://example.com/foo-" version ".tgz"))
("http://example.com/2.8/foo-2.8.tgz" "2.8"
-> ("http://example.com/" version "/foo-" version ".tgz")))))
(test-skip (if (and (%nixpkgs-directory)
(file-exists? (string-append (%nixpkgs-directory)
"/default.nix")))
0
1))
(test-assert "nixpkgs->guix-package"
(match (nixpkgs->guix-package (%nixpkgs-directory) "guile")
(('package
('name "guile")
('version (? string?))
('source ('origin _ ...))
('build-system _)
('inputs ('quasiquote (inputs ...)))
('propagated-inputs ('quasiquote (pinputs ...)))
('home-page (? string?))
('synopsis (? string?))
('description (? string?))
('license (? string?)))
(and (member '("libffi" ,libffi) inputs)
(member '("gmp" ,gmp) pinputs)
#t))
(x
(pk 'fail x #f))))
(test-end "snix")
(exit (= (test-runner-fail-count (test-runner-current)) 0))
;;; Local Variables:
;;; eval: (put 'test-assert 'scheme-indent-function 1)
;;; eval: (put 'guard 'scheme-indent-function 1)
;;; End: