guix/import/utils.scm

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