guix/import/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
   4 ;;; Copyright © 2016 David Craven <david@craven.ch>
   5 ;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
   6 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
   7 ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (guix import utils)
  25   #:use-module (guix base32)
  26   #:use-module ((guix build download) #:prefix build:)
  27   #:use-module (gcrypt hash)
  28   #:use-module (guix http-client)
  29   #:use-module ((guix licenses) #:prefix license:)
  30   #:use-module (guix utils)
  31   #:use-module (guix packages)
  32   #:use-module (guix discovery)
  33   #:use-module (guix build-system)
  34   #:use-module (guix gexp)
  35   #:use-module (guix store)
  36   #:use-module (guix download)
  37   #:use-module (guix sets)
  38   #:use-module (gnu packages)
  39   #:use-module (ice-9 match)
  40   #:use-module (ice-9 rdelim)
  41   #:use-module (ice-9 receive)
  42   #:use-module (ice-9 regex)
  43   #:use-module (srfi srfi-1)
  44   #:use-module (srfi srfi-9)
  45   #:use-module (srfi srfi-11)
  46   #:use-module (srfi srfi-26)
  47   #:export (factorize-uri
  48
  49             flatten
  50             assoc-ref*
  51
  52             url-fetch
  53             guix-hash-url
  54
  55             package-names->package-inputs
  56             maybe-inputs
  57             maybe-native-inputs
  58             package->definition
  59
  60             spdx-string->license
  61             license->symbol
  62
  63             snake-case
  64             beautify-description
  65
  66             alist->package
  67
  68             read-lines
  69             chunk-lines
  70
  71             guix-name
  72
  73             recursive-import))
  74
  75 (define (factorize-uri uri version)
  76   "Factorize URI, a package tarball URI as a string, such that any occurrences
  77 of the string VERSION is replaced by the symbol 'version."
  78   (let ((version-rx (make-regexp (regexp-quote version))))
  79     (match (regexp-exec version-rx uri)
  80       (#f
  81        uri)
  82       (_
  83        (let ((indices (fold-matches version-rx uri
  84                                     '((0))
  85                                     (lambda (m result)
  86                                       (match result
  87                                         (((start) rest ...)
  88                                          `((,(match:end m))
  89                                            (,start . ,(match:start m))
  90                                            ,@rest)))))))
  91          (fold (lambda (index result)
  92                  (match index
  93                    ((start)
  94                     (cons (substring uri start)
  95                           result))
  96                    ((start . end)
  97                     (cons* (substring uri start end)
  98                            'version
  99                            result))))
 100                '()
 101                indices))))))
 102
 103 (define (flatten lst)
 104   "Return a list that recursively concatenates all sub-lists of LST."
 105   (fold-right
 106    (match-lambda*
 107     (((sub-list ...) memo)
 108      (append (flatten sub-list) memo))
 109     ((elem memo)
 110      (cons elem memo)))
 111    '() lst))
 112
 113 (define (assoc-ref* alist key . rest)
 114   "Return the value for KEY from ALIST.  For each additional key specified,
 115 recursively apply the procedure to the sub-list."
 116   (if (null? rest)
 117       (assoc-ref alist key)
 118       (apply assoc-ref* (assoc-ref alist key) rest)))
 119
 120 (define (url-fetch url file-name)
 121   "Save the contents of URL to FILE-NAME.  Return #f on failure."
 122   (parameterize ((current-output-port (current-error-port)))
 123     (build:url-fetch url file-name)))
 124
 125 (define (guix-hash-url filename)
 126   "Return the hash of FILENAME in nix-base32 format."
 127   (bytevector->nix-base32-string (file-sha256 filename)))
 128
 129 (define (spdx-string->license str)
 130   "Convert STR, a SPDX formatted license identifier, to a license object.
 131    Return #f if STR does not match any known identifiers."
 132   ;; https://spdx.org/licenses/
 133   ;; The psfl, gfl1.0, nmap, repoze
 134   ;; licenses doesn't have SPDX identifiers
 135   (match str
 136     ("AGPL-1.0"                    'license:agpl-1.0)
 137     ("AGPL-3.0"                    'license:agpl-3.0)
 138     ("Apache-1.1"                  'license:asl1.1)
 139     ("Apache-2.0"                  'license:asl2.0)
 140     ("BSL-1.0"                     'license:boost1.0)
 141     ("BSD-2-Clause-FreeBSD"        'license:bsd-2)
 142     ("BSD-3-Clause"                'license:bsd-3)
 143     ("BSD-4-Clause"                'license:bsd-4)
 144     ("CC0-1.0"                     'license:cc0)
 145     ("CC-BY-2.0"                   'license:cc-by2.0)
 146     ("CC-BY-3.0"                   'license:cc-by3.0)
 147     ("CC-BY-SA-2.0"                'license:cc-by-sa2.0)
 148     ("CC-BY-SA-3.0"                'license:cc-by-sa3.0)
 149     ("CC-BY-SA-4.0"                'license:cc-by-sa4.0)
 150     ("CDDL-1.0"                    'license:cddl1.0)
 151     ("CECILL-C"                    'license:cecill-c)
 152     ("Artistic-2.0"                'license:artistic2.0)
 153     ("ClArtistic"                  'license:clarified-artistic)
 154     ("CPL-1.0"                     'license:cpl1.0)
 155     ("EPL-1.0"                     'license:epl1.0)
 156     ("MIT"                         'license:expat)
 157     ("FTL"                         'license:freetype)
 158     ("GFDL-1.1"                    'license:fdl1.1+)
 159     ("GFDL-1.2"                    'license:fdl1.2+)
 160     ("GFDL-1.3"                    'license:fdl1.3+)
 161     ("Giftware"                    'license:giftware)
 162     ("GPL-1.0"                     'license:gpl1)
 163     ("GPL-1.0+"                    'license:gpl1+)
 164     ("GPL-2.0"                     'license:gpl2)
 165     ("GPL-2.0+"                    'license:gpl2+)
 166     ("GPL-3.0"                     'license:gpl3)
 167     ("GPL-3.0+"                    'license:gpl3+)
 168     ("ISC"                         'license:isc)
 169     ("IJG"                         'license:ijg)
 170     ("Imlib2"                      'license:imlib2)
 171     ("IPA"                         'license:ipa)
 172     ("IPL-1.0"                     'license:ibmpl1.0)
 173     ("LGPL-2.0"                    'license:lgpl2.0)
 174     ("LGPL-2.0+"                   'license:lgpl2.0+)
 175     ("LGPL-2.1"                    'license:lgpl2.1)
 176     ("LGPL-2.1+"                   'license:lgpl2.1+)
 177     ("LGPL-3.0"                    'license:lgpl3.0)
 178     ("LGPL-3.0+"                   'license:lgpl3.0+)
 179     ("MPL-1.0"                     'license:mpl1.0)
 180     ("MPL-1.1"                     'license:mpl1.1)
 181     ("MPL-2.0"                     'license:mpl2.0)
 182     ("MS-PL"                       'license:ms-pl)
 183     ("NCSA"                        'license:ncsa)
 184     ("OpenSSL"                     'license:openssl)
 185     ("OLDAP-2.8"                   'license:openldap2.8)
 186     ("CUA-OPL-1.0"                 'license:opl1.0)
 187     ("QPL-1.0"                     'license:qpl)
 188     ("Ruby"                        'license:ruby)
 189     ("SGI-B-2.0"                   'license:sgifreeb2.0)
 190     ("OFL-1.1"                     'license:silofl1.1)
 191     ("Sleepycat"                   'license:sleepycat)
 192     ("TCL"                         'license:tcl/tk)
 193     ("Unlicense"                   'license:unlicense)
 194     ("Vim"                         'license:vim)
 195     ("X11"                         'license:x11)
 196     ("ZPL-2.1"                     'license:zpl2.1)
 197     ("Zlib"                        'license:zlib)
 198     (_ #f)))
 199
 200 (define (license->symbol license)
 201   "Convert license to a symbol representing the variable the object is bound
 202 to in the (guix licenses) module, or #f if there is no such known license."
 203   (define licenses
 204     (module-map (lambda (sym var) `(,(variable-ref var) . ,sym))
 205                 (resolve-interface '(guix licenses) #:prefix 'license:)))
 206   (assoc-ref licenses license))
 207
 208 (define (snake-case str)
 209   "Return a downcased version of the string STR where underscores are replaced
 210 with dashes."
 211   (string-join (string-split (string-downcase str) #\_) "-"))
 212
 213 (define (beautify-description description)
 214   "Improve the package DESCRIPTION by turning a beginning sentence fragment
 215 into a proper sentence and by using two spaces between sentences."
 216   (let ((cleaned (cond
 217                   ((string-prefix? "A " description)
 218                    (string-append "This package provides a"
 219                                   (substring description 1)))
 220                   ((string-prefix? "Provides " description)
 221                    (string-append "This package provides"
 222                                   (substring description
 223                                              (string-length "Provides"))))
 224                   ((string-prefix? "Functions " description)
 225                    (string-append "This package provides functions"
 226                                   (substring description
 227                                              (string-length "Functions"))))
 228                   (else description))))
 229     ;; Use double spacing between sentences
 230     (regexp-substitute/global #f "\\. \\b"
 231                               cleaned 'pre ".  " 'post)))
 232
 233 (define* (package-names->package-inputs names #:optional (output #f))
 234   "Given a list of PACKAGE-NAMES, and an optional OUTPUT, tries to generate a
 235 quoted list of inputs, as suitable to use in an 'inputs' field of a package
 236 definition."
 237   (map (lambda (input)
 238          (cons* input (list 'unquote (string->symbol input))
 239                             (or (and output (list output))
 240                                 '())))
 241        names))
 242
 243 (define* (maybe-inputs package-names #:optional (output #f))
 244   "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
 245 package definition."
 246   (match (package-names->package-inputs package-names output)
 247     (()
 248      '())
 249     ((package-inputs ...)
 250      `((inputs (,'quasiquote ,package-inputs))))))
 251
 252 (define* (maybe-native-inputs package-names #:optional (output #f))
 253   "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
 254 package definition."
 255   (match (package-names->package-inputs package-names output)
 256     (()
 257      '())
 258     ((package-inputs ...)
 259      `((native-inputs (,'quasiquote ,package-inputs))))))
 260
 261 (define (package->definition guix-package)
 262   (match guix-package
 263     (('package ('name (? string? name)) _ ...)
 264      `(define-public ,(string->symbol name)
 265         ,guix-package))
 266     (('let anything ('package ('name (? string? name)) _ ...))
 267      `(define-public ,(string->symbol name)
 268         ,guix-package))))
 269
 270 (define (build-system-modules)
 271   (all-modules (map (lambda (entry)
 272                       `(,entry . "guix/build-system"))
 273                     %load-path)))
 274
 275 (define (lookup-build-system-by-name name)
 276   "Return a <build-system> value for the symbol NAME, representing the name of
 277 the build system."
 278   (fold-module-public-variables (lambda (obj result)
 279                                   (if (and (build-system? obj)
 280                                            (eq? name (build-system-name obj)))
 281                                       obj result))
 282                                 #f
 283                                 (build-system-modules)))
 284
 285 (define (specs->package-lists specs)
 286   "Convert each string in the SPECS list to a list of a package label and a
 287 package value."
 288   (map (lambda (spec)
 289          (let-values (((pkg out) (specification->package+output spec)))
 290            (match out
 291              ("out" (list (package-name pkg) pkg))
 292              (_ (list (package-name pkg) pkg out)))))
 293        specs))
 294
 295 (define (source-spec->object source)
 296   "Generate an <origin> object from a SOURCE specification.  The SOURCE can
 297 either be a simple URL string, #F, or an alist containing entries for each of
 298 the expected fields of an <origin> object."
 299   (match source
 300     ((? string? source-url)
 301      (let ((tarball (with-store store (download-to-store store source-url))))
 302        (origin
 303          (method url-fetch)
 304          (uri source-url)
 305          (sha256 (base32 (guix-hash-url tarball))))))
 306     (#f #f)
 307     (orig (let ((sha (match (assoc-ref orig "sha256")
 308                        ((("base32" . value))
 309                         (base32 value))
 310                        (_ #f))))
 311             (origin
 312               (method (match (assoc-ref orig "method")
 313                         ("url-fetch" (@ (guix download) url-fetch))
 314                         ("git-fetch" (@ (guix git-download) git-fetch))
 315                         ("svn-fetch" (@ (guix svn-download) svn-fetch))
 316                         ("hg-fetch"  (@ (guix hg-download) hg-fetch))
 317                         (_ #f)))
 318               (uri (assoc-ref orig "uri"))
 319               (sha256 sha))))))
 320
 321 (define (alist->package meta)
 322   (package
 323     (name (assoc-ref meta "name"))
 324     (version (assoc-ref meta "version"))
 325     (source (source-spec->object (assoc-ref meta "source")))
 326     (build-system
 327       (lookup-build-system-by-name
 328        (string->symbol (assoc-ref meta "build-system"))))
 329     (native-inputs
 330      (specs->package-lists
 331       (vector->list (or (assoc-ref meta "native-inputs") '#()))))
 332     (inputs
 333      (specs->package-lists
 334       (vector->list (or (assoc-ref meta "inputs") '#()))))
 335     (propagated-inputs
 336      (specs->package-lists
 337       (vector->list (or (assoc-ref meta "propagated-inputs") '#()))))
 338     (home-page
 339      (assoc-ref meta "home-page"))
 340     (synopsis
 341      (assoc-ref meta "synopsis"))
 342     (description
 343      (assoc-ref meta "description"))
 344     (license
 345      (match (assoc-ref meta "license")
 346        (#f #f)
 347        (l
 348         (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:)
 349                         (spdx-string->license l))
 350             (license:fsdg-compatible l)))))))
 351
 352 (define* (read-lines #:optional (port (current-input-port)))
 353   "Read lines from PORT and return them as a list."
 354   (let loop ((line (read-line port))
 355              (lines '()))
 356     (if (eof-object? line)
 357         (reverse lines)
 358         (loop (read-line port)
 359               (cons line lines)))))
 360
 361 (define* (chunk-lines lines #:optional (pred string-null?))
 362   "Return a list of chunks, each of which is a list of lines.  The chunks are
 363 separated by PRED."
 364   (let loop ((rest lines)
 365              (parts '()))
 366     (receive (before after)
 367         (break pred rest)
 368       (let ((res (cons before parts)))
 369         (if (null? after)
 370             (reverse res)
 371             (loop (cdr after) res))))))
 372
 373 (define (guix-name prefix name)
 374   "Return a Guix package name for a given package name."
 375   (string-append prefix (string-map (match-lambda
 376                                       (#\_ #\-)
 377                                       (#\. #\-)
 378                                       (chr (char-downcase chr)))
 379                                     name)))
 380
 381 (define (topological-sort nodes
 382                           node-dependencies
 383                           node-name)
 384   "Perform a breadth-first traversal of the graph rooted at NODES, a list of
 385 nodes, and return the list of nodes sorted in topological order.  Call
 386 NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to
 387 obtain a node's uniquely identifying \"key\"."
 388   (let loop ((nodes nodes)
 389              (result '())
 390              (visited (set)))
 391     (match nodes
 392       (()
 393        result)
 394       ((head . tail)
 395        (if (set-contains? visited (node-name head))
 396            (loop tail result visited)
 397            (let ((dependencies (node-dependencies head)))
 398              (loop (append dependencies tail)
 399                    (cons head result)
 400                    (set-insert (node-name head) visited))))))))
 401
 402 (define* (recursive-import package-name repo
 403                            #:key repo->guix-package guix-name
 404                            #:allow-other-keys)
 405   "Return a list of package expressions for PACKAGE-NAME and all its
 406 dependencies, sorted in topological order.  For each package,
 407 call (REPO->GUIX-PACKAGE NAME REPO), which should return a package expression
 408 and a list of dependencies; call (GUIX-NAME NAME) to obtain the Guix package
 409 name corresponding to the upstream name."
 410   (define-record-type <node>
 411     (make-node name package dependencies)
 412     node?
 413     (name         node-name)
 414     (package      node-package)
 415     (dependencies node-dependencies))
 416
 417   (define (exists? name)
 418     (not (null? (find-packages-by-name (guix-name name)))))
 419
 420   (define (lookup-node name)
 421     (receive (package dependencies) (repo->guix-package name repo)
 422       (make-node name package dependencies)))
 423
 424   (map node-package
 425        (topological-sort (list (lookup-node package-name))
 426                          (lambda (node)
 427                            (map lookup-node
 428                                 (remove exists?
 429                                         (node-dependencies node))))
 430                          node-name)))