guix/import/snix.scm

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