mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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:
parent
5901471cec
commit
10226c05b1
6 changed files with 662 additions and 1 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
138
guix-import.in
Normal 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
439
guix/snix.scm
Normal 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
79
tests/snix.scm
Normal 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:
|
Loading…
Reference in a new issue