guix/snix.scm

   1 ;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
   2 ;;; Copyright (C) 2010, 2011, 2012 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of Guix.
   5 ;;;
   6 ;;; Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix snix)
  20   #:use-module (sxml ssax)
  21   #:use-module (ice-9 popen)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 rdelim)
  24   #:use-module (ice-9 format)
  25   #:use-module (ice-9 regex)
  26   #:use-module (ice-9 vlist)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-9)
  29   #:use-module (srfi srfi-11)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (srfi srfi-37)
  32   #:use-module (system foreign)
  33   #:use-module (rnrs bytevectors)
  34   #:use-module (guix utils)
  35   #:use-module (guix base32)
  36   #:use-module (guix config)
  37   #:export (open-nixpkgs
  38             xml->snix
  39             nixpkgs->guix-package))
  40
  41 ;;; Commentary:
  42 ;;;
  43 ;;; Converting Nix code to s-expressions, and then to Guix `package'
  44 ;;; declarations, using the XML output of `nix-instantiate'.
  45 ;;;
  46 ;;; Code:
  47
  48 \f
  49 ;;;
  50 ;;; SNix.
  51 ;;;
  52
  53 ;; Nix object types visible in the XML output of `nix-instantiate' and
  54 ;; mapping to S-expressions (we map to sexps, not records, so that we
  55 ;; can do pattern matching):
  56 ;;
  57 ;;   at               (at varpat attrspat)
  58 ;;   attr             (attribute loc name value)
  59 ;;   attrs            (attribute-set attributes)
  60 ;;   attrspat         (attribute-set-pattern patterns)
  61 ;;   bool             #f|#t
  62 ;;   derivation       (derivation drv-path out-path attributes)
  63 ;;   ellipsis         '...
  64 ;;   expr             (snix loc body ...)
  65 ;;   function         (function loc at|attrspat|varpat)
  66 ;;   int              int
  67 ;;   list             list
  68 ;;   null             'null
  69 ;;   path             string
  70 ;;   string           string
  71 ;;   unevaluated      'unevaluated
  72 ;;   varpat           (varpat name)
  73 ;;
  74 ;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise;
  75 ;; however, handling `repeated' nodes makes it impossible to do anything
  76 ;; lazily because the whole SXML tree has to be traversed to maintain the
  77 ;; list of known derivations.
  78
  79 (define (xml-element->snix elem attributes body derivations)
  80   "Return an SNix element corresponding to XML element ELEM."
  81
  82   (define (loc)
  83     (location (assq-ref attributes 'path)
  84               (assq-ref attributes 'line)
  85               (assq-ref attributes 'column)))
  86
  87   (case elem
  88     ((at)
  89      (values `(at ,(car body) ,(cadr body)) derivations))
  90     ((attr)
  91      (let ((name (assq-ref attributes 'name)))
  92        (cond ((null? body)
  93               (values `(attribute-pattern ,name) derivations))
  94              ((and (pair? body) (null? (cdr body)))
  95               (values `(attribute ,(loc) ,name ,(car body))
  96                       derivations))
  97              (else
  98               (error "invalid attribute body" name (loc) body)))))
  99     ((attrs)
 100      (values `(attribute-set ,(reverse body)) derivations))
 101     ((attrspat)
 102      (values `(attribute-set-pattern ,body) derivations))
 103     ((bool)
 104      (values (string-ci=? "true" (assq-ref attributes 'value))
 105              derivations))
 106     ((derivation)
 107      (let ((drv-path (assq-ref attributes 'drvPath))
 108            (out-path (assq-ref attributes 'outPath)))
 109        (if (equal? body '(repeated))
 110            (let ((body (vhash-assoc drv-path derivations)))
 111              (if (pair? body)
 112                  (values `(derivation ,drv-path ,out-path ,(cdr body))
 113                          derivations)
 114
 115                  ;; DRV-PATH hasn't been encountered yet but may be later
 116                  ;; (see <http://article.gmane.org/gmane.linux.distributions.nixos/5946>.)
 117                  ;; Return an `unresolved' node.
 118                  (values `(unresolved
 119                            ,(lambda (derivations)
 120                               (let ((body (vhash-assoc drv-path derivations)))
 121                                 (if (pair? body)
 122                                     `(derivation ,drv-path ,out-path
 123                                                  ,(cdr body))
 124                                     (error "no previous occurrence of derivation"
 125                                            drv-path)))))
 126                          derivations)))
 127            (values `(derivation ,drv-path ,out-path ,body)
 128                    (vhash-cons drv-path body derivations)))))
 129     ((ellipsis)
 130      (values '... derivations))
 131     ((expr)
 132      (values `(snix ,(loc) ,@body) derivations))
 133     ((function)
 134      (values `(function ,(loc) ,body) derivations))
 135     ((int)
 136      (values (string->number (assq-ref attributes 'value))
 137              derivations))
 138     ((list)
 139      (values body derivations))
 140     ((null)
 141      (values 'null derivations))
 142     ((path)
 143      (values (assq-ref attributes 'value) derivations))
 144     ((repeated)
 145      (values 'repeated derivations))
 146     ((string)
 147      (values (assq-ref attributes 'value) derivations))
 148     ((unevaluated)
 149      (values 'unevaluated derivations))
 150     ((varpat)
 151      (values `(varpat ,(assq-ref attributes 'name)) derivations))
 152     (else (error "unhandled Nix XML element" elem))))
 153
 154 (define (resolve snix derivations)
 155   "Return a new SNix tree where `unresolved' nodes from SNIX have been
 156 replaced by the result of their application to DERIVATIONS, a vhash."
 157   (let loop ((node snix)
 158              (seen vlist-null))
 159     (if (vhash-assq node seen)
 160         (values node seen)
 161         (match node
 162           (('unresolved proc)
 163            (let ((n (proc derivations)))
 164              (values n seen)))
 165           ((tag body ...)
 166            (let ((body+seen (fold (lambda (n body+seen)
 167                                     (call-with-values
 168                                         (lambda ()
 169                                           (loop n (cdr body+seen)))
 170                                       (lambda (n* seen)
 171                                         (cons (cons n* (car body+seen))
 172                                               (vhash-consq n #t seen)))))
 173                                   (cons '() (vhash-consq node #t seen))
 174                                   body)))
 175              (values (cons tag (reverse (car body+seen)))
 176                      (vhash-consq node #t (cdr body+seen)))))
 177           (anything
 178            (values anything seen))))))
 179
 180 (define xml->snix
 181   (let ((parse
 182          (ssax:make-parser NEW-LEVEL-SEED
 183                            (lambda (elem-gi attributes namespaces expected-content
 184                                     seed)
 185                              (cons '() (cdr seed)))
 186
 187                            FINISH-ELEMENT
 188                            (lambda (elem-gi attributes namespaces parent-seed
 189                                             seed)
 190                              (let ((snix        (car seed))
 191                                    (derivations (cdr seed)))
 192                                (let-values (((snix derivations)
 193                                              (xml-element->snix elem-gi
 194                                                                 attributes
 195                                                                 snix
 196                                                                 derivations)))
 197                                  (cons (cons snix (car parent-seed))
 198                                        derivations))))
 199
 200                            CHAR-DATA-HANDLER
 201                            (lambda (string1 string2 seed)
 202                              ;; Discard inter-node strings, which are blanks.
 203                              seed))))
 204     (lambda (port)
 205       "Return the SNix represention of TREE, an SXML tree as returned by
 206 parsing the XML output of `nix-instantiate' on Nixpkgs."
 207       (match (parse port (cons '() vlist-null))
 208         (((snix) . derivations)
 209          (resolve snix derivations))))))
 210
 211 (define (attribute-value attribute)
 212   "Return the value of ATTRIBUTE."
 213   (match attribute
 214     (('attribute _ _ value) value)))
 215
 216 (define (derivation-source derivation)
 217   "Return the \"src\" attribute of DERIVATION or #f if not found."
 218   (match derivation
 219     (('derivation _ _ (attributes ...))
 220      (find-attribute-by-name "src" attributes))))
 221
 222 (define (derivation-output-path derivation)
 223   "Return the output path of DERIVATION."
 224   (match derivation
 225     (('derivation _ out-path _)
 226      out-path)
 227     (_ #f)))
 228
 229 (define (source-output-path src)
 230   "Return the output path of SRC, the \"src\" attribute of a derivation."
 231   (derivation-output-path (attribute-value src)))
 232
 233 (define (source-urls src)
 234   "Return the URLs of SRC, the \"src\" attribute of a derivation."
 235   (match src
 236     (('attribute _ _ ('derivation _ _ (attributes ...)))
 237      (match (find-attribute-by-name "urls" attributes)
 238        (('attribute _ _ value)
 239         value)))
 240     (_ #f)))
 241
 242 (define (source-sha256 src)
 243   "Return the sha256 of SRC, the \"src\" attribute of a derivation, as a
 244 bytevector."
 245   (match src
 246     (('attribute _ _ ('derivation _ _ (attributes ...)))
 247      (match (find-attribute-by-name "outputHash" attributes)
 248        (('attribute _ _ value)
 249         (match value
 250           ((= string-length 52)
 251            (nix-base32-string->bytevector value))
 252           ((= string-length 64)
 253            (base16-string->bytevector value))
 254           (_
 255            (error "unsupported hash format" value))))))
 256     (_ #f)))
 257
 258 (define (derivation-source-output-path derivation)
 259   "Return the output path of the \"src\" attribute of DERIVATION or #f
 260 if DERIVATION lacks an \"src\" attribute."
 261   (and=> (derivation-source derivation) source-output-path))
 262
 263 (define* (open-nixpkgs nixpkgs #:optional attribute)
 264   "Return an input pipe to the XML representation of Nixpkgs.  When
 265 ATTRIBUTE is true, only that attribute is considered."
 266   (with-fluids ((%default-port-encoding "UTF-8"))
 267     (let ((cross-system (format #f "{
 268   config = \"i686-guix-linux-gnu\";
 269   libc = \"glibc\";
 270   arch = \"guix\";
 271   withTLS = true;
 272   float = \"hard\";
 273   openssl.system = \"linux-generic32\";
 274   platform = (import ~a/pkgs/top-level/platforms.nix).sheevaplug;
 275 }" nixpkgs)))
 276       (apply open-pipe* OPEN_READ
 277              %nix-instantiate "--strict" "--eval-only" "--xml"
 278
 279              ;; Pass a dummy `crossSystem' argument so that `buildInputs' and
 280              ;; `buildNativeInputs' are not coalesced.
 281              ;; XXX: This is hacky and has other problems.
 282              ;"--arg" "crossSystem" cross-system
 283
 284              `(,@(if attribute
 285                      `("-A" ,attribute)
 286                      '())
 287                ,nixpkgs)))))
 288
 289 (define (pipe-failed? pipe)
 290   "Close pipe and return its status if it failed."
 291   (let ((status (close-pipe pipe)))
 292     (if (or (status:term-sig status)
 293             (not (= (status:exit-val status) 0)))
 294         status
 295         #f)))
 296
 297 (define (find-attribute-by-name name attributes)
 298   "Return attribute NAME in ATTRIBUTES, an attribute set or list of SNix
 299 attributes, or #f if NAME cannot be found."
 300   (find (lambda (a)
 301           (match a
 302             (('attribute _ (? (cut string=? <> name)) _)
 303              a)
 304             (_ #f)))
 305         (match attributes
 306           (('attribute-set (attributes ...))
 307            attributes)
 308           (_
 309            attributes))))
 310
 311 (define (package-source-output-path package)
 312   "Return the output path of the \"src\" derivation of PACKAGE."
 313   (derivation-source-output-path (attribute-value package)))
 314
 315 \f
 316 ;;;
 317 ;;; Conversion of "Nix expressions" to "Guix expressions".
 318 ;;;
 319
 320 (define (factorize-uri uri version)
 321   "Factorize URI, a package tarball URI as a string, such that any occurrences
 322 of the string VERSION is replaced by the symbol 'version."
 323   (let ((version-rx (make-regexp (regexp-quote version))))
 324     (match (regexp-exec version-rx uri)
 325       (#f
 326        uri)
 327       (_
 328        (let ((indices (fold-matches version-rx uri
 329                                     '((0))
 330                                     (lambda (m result)
 331                                       (match result
 332                                         (((start) rest ...)
 333                                          `((,(match:end m))
 334                                            (,start . ,(match:start m))
 335                                            ,@rest)))))))
 336          (fold (lambda (index result)
 337                  (match index
 338                    ((start)
 339                     (cons (substring uri start)
 340                           result))
 341                    ((start . end)
 342                     (cons* (substring uri start end)
 343                            'version
 344                            result))))
 345                '()
 346                indices))))))
 347
 348 (define (snix-derivation->guix-package derivation)
 349   "Return the `package' s-expression corresponding to SNix DERIVATION, a
 350 Nixpkgs `stdenv.mkDerivation'-style derivation, and the original source
 351 location of DERIVATION."
 352   (match derivation
 353     (('derivation _ _ (attributes ...))
 354      (let*-values (((full-name loc)
 355                     (match (find-attribute-by-name "name" attributes)
 356                       (('attribute loc _ value)
 357                        (values value loc))
 358                       (_
 359                        (values #f #f))))
 360                    ((name version)
 361                     (package-name->name+version full-name)))
 362        (define (convert-inputs type)
 363          ;; Convert the derivation's input from a list of SNix derivations to
 364          ;; a list of name/variable pairs.
 365          (match (and=> (find-attribute-by-name type attributes)
 366                        attribute-value)
 367            (#f
 368             '())
 369            ((('derivation _ _ (attributes ...)) ...)
 370             (map (lambda (attrs)
 371                    (let* ((full-name (attribute-value
 372                                       (find-attribute-by-name "name" attrs)))
 373                           (name      (package-name->name+version full-name)))
 374                      (list name
 375                            (list 'unquote
 376                                  (string->symbol name)))))
 377                  attributes))))
 378
 379        (define (maybe-inputs guix-name inputs)
 380          (match inputs
 381            (()
 382             '())
 383            ((inputs ...)
 384             (list (list guix-name
 385                         (list 'quasiquote inputs))))))
 386
 387        (define (pretty-uri uri version)
 388          (match (factorize-uri uri version)
 389            ((items ...)
 390             `(string-append ,@items))
 391            (x x)))
 392
 393        (let* ((source  (find-attribute-by-name "src" attributes))
 394               (urls    (source-urls source))
 395               (sha256  (source-sha256 source))
 396               (meta    (and=> (find-attribute-by-name "meta" attributes)
 397                               attribute-value)))
 398          (values
 399           `(package
 400              (name ,name)
 401              (version ,version)
 402              (source (origin
 403                       (method url-fetch)
 404                       (uri ,(pretty-uri (car urls) version))
 405                       (sha256
 406                        (base32
 407                         ,(bytevector->nix-base32-string sha256)))))
 408              (build-system gnu-build-system)
 409
 410              ;; When doing a native Nixpkgs build, `buildInputs' is empty and
 411              ;; everything is in `buildNativeInputs'.  So we can't distinguish
 412              ;; between both, here.
 413              ,@(maybe-inputs 'inputs
 414                              (convert-inputs "buildNativeInputs"))
 415              ,@(maybe-inputs 'propagated-inputs
 416                              (convert-inputs "propagatedBuildNativeInputs"))
 417
 418              (home-page ,(and=> (find-attribute-by-name "homepage" meta)
 419                                 attribute-value))
 420              (synopsis ,(and=> (find-attribute-by-name "description" meta)
 421                                attribute-value))
 422              (description
 423               ,(and=> (find-attribute-by-name "longDescription" meta)
 424                       attribute-value))
 425              (license ,(and=> (find-attribute-by-name "license" meta)
 426                               attribute-value)))
 427           loc))))))
 428
 429 (define (nixpkgs->guix-package nixpkgs attribute)
 430   "Evaluate ATTRIBUTE in NIXPKGS, the file name of a Nixpkgs checkout,
 431 and return the `package' s-expression corresponding to that package."
 432   (let ((port (open-nixpkgs nixpkgs attribute)))
 433     (match (xml->snix port)
 434       (('snix loc (and drv ('derivation _ ...)))
 435        (and (not (pipe-failed? port))
 436             (snix-derivation->guix-package drv)))
 437       (_
 438        (not (pipe-failed? port))))))
 439
 440 ;;; snix.scm ends here