diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | configure.ac | 3 | ||||
| -rw-r--r-- | guix-import.in | 138 | ||||
| -rw-r--r-- | guix/snix.scm | 439 | ||||
| -rw-r--r-- | tests/snix.scm | 79 |
6 files changed, 662 insertions, 1 deletions
diff --git a/.gitignore b/.gitignore index eb4238f0b0..1fe15621e2 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/Makefile.am b/Makefile.am index 24fc22e2d3..8403081cb7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 diff --git a/configure.ac b/configure.ac index cd07a54a3d..e67468504c 100644 --- a/configure.ac +++ b/configure.ac @@ -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 diff --git a/guix-import.in b/guix-import.in new file mode 100644 index 0000000000..5dc93708b4 --- /dev/null +++ b/guix-import.in @@ -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~%")))))) diff --git a/guix/snix.scm b/guix/snix.scm new file mode 100644 index 0000000000..ef98eb42a0 --- /dev/null +++ b/guix/snix.scm @@ -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 diff --git a/tests/snix.scm b/tests/snix.scm new file mode 100644 index 0000000000..da4754b7f3 --- /dev/null +++ b/tests/snix.scm @@ -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: |