guix/import/snix.scm

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