mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 13:36:36 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

import: Add binary npm importer.

Browse source 
* guix/scripts/import.scm: (importers): Add "npm-binary".
* guix/import/npm-binary.scm: New file.
* guix/scripts/import/npm-binary.scm: New file.
* Makefile.am: Add them.

Co-authored-by: Timothy Sample <samplet@ngyro.com>
Co-authored-by: Lars-Dominik Braun <lars@6xq.net>
This commit is contained in:
Jelle Licht 2020-12-04 00:35:14 +01:00
parent b12bb7d297
commit fafad6b17c
No known key found for this signature in database
GPG key ID: DA4597F947B41025
4 changed files with 351 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile.am
View file

@ -258,6 +258,7 @@ MODULES = \
guix/import/json.scm \ guix/import/json.scm \
guix/import/kde.scm \ guix/import/kde.scm \
guix/import/launchpad.scm \ guix/import/launchpad.scm \
guix/import/npm-binary.scm \
guix/import/opam.scm \ guix/import/opam.scm \
guix/import/print.scm \ guix/import/print.scm \
guix/import/pypi.scm \ guix/import/pypi.scm \
@ -299,6 +300,7 @@ MODULES = \
guix/scripts/import/go.scm \ guix/scripts/import/go.scm \
guix/scripts/import/hackage.scm \ guix/scripts/import/hackage.scm \
guix/scripts/import/json.scm \ guix/scripts/import/json.scm \
guix/scripts/import/npm-binary.scm \
guix/scripts/import/opam.scm \ guix/scripts/import/opam.scm \
guix/scripts/import/pypi.scm \ guix/scripts/import/pypi.scm \
guix/scripts/import/stackage.scm \ guix/scripts/import/stackage.scm \

235
guix/import/npm-binary.scm Normal file
View file

@ -0,0 +1,235 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2020 Jelle Licht <jlicht@fsfe.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix import npm-binary)
#:use-module (guix import json)
#:use-module (guix import utils)
#:use-module (guix memoization)
#:use-module (guix utils)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 receive)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-41)
#:use-module (web client)
#:use-module (web response)
#:use-module (web uri)
#:export (npm-binary-recursive-import
npm-binary->guix-package
package-json->guix-package
make-versioned-package
name+version->symbol))
;; Autoload Guile-Semver so we only have a soft dependency.
(module-autoload! (current-module)
'(semver) '(string->semver semver? semver->string semver=? semver>?))
(module-autoload! (current-module)
'(semver ranges) '(*semver-range-any* string->semver-range semver-range-contains?))
;; Dist-tags
(define-json-mapping <dist-tags> make-dist-tags dist-tags?
json->dist-tags
(latest dist-tags-latest "latest" string->semver))
(define-record-type <versioned-package>
(make-versioned-package name version)
versioned-package?
(name versioned-package-name) ;string
(version versioned-package-version)) ;string
(define (dependencies->versioned-packages entries)
(match entries
(((names . versions) ...)
(map make-versioned-package names versions))
(_ '())))
(define-json-mapping <dist> make-dist dist?
json->dist
(tarball dist-tarball))
(define-json-mapping <package-revision> make-package-revision package-revision?
json->package-revision
(name package-revision-name)
(version package-revision-version "version" string->semver) ;semver
(home-page package-revision-home-page "homepage") ;string
(dependencies package-revision-dependencies "dependencies" ;list of versioned-package
dependencies->versioned-packages)
(license package-revision-license "license" spdx-string->license) ;license
(description package-revision-description) ;string
(dist package-revision-dist "dist" json->dist)) ;dist
(define (versions->package-revisions versions)
(match versions
(((version . package-spec) ...)
(map json->package-revision package-spec))
(_ '())))
(define (versions->package-versions versions)
(match versions
(((version . package-spec) ...)
(map string->semver versions))
(_ '())))
(define-json-mapping <meta-package> make-meta-package meta-package?
json->meta-package
(name meta-package-name) ;string
(description meta-package-description) ;string
(dist-tags meta-package-dist-tags "dist-tags" json->dist-tags) ;dist-tags
(revisions meta-package-revisions "versions" versions->package-revisions))
;; TODO: Support other registries
(define *registry* "https://registry.npmjs.org")
(define *default-page* "https://www.npmjs.com/package")
(define (lookup-meta-package name)
(let ((json (json-fetch (string-append *registry* "/" (uri-encode name)))))
(and=> json json->meta-package)))
(define lookup-meta-package* (memoize lookup-meta-package))
(define (http-error-code arglist)
(match arglist
(('http-error _ _ _ (code)) code)
(_ #f)))
(define (meta-package-versions meta)
(map package-revision-version
(meta-package-revisions meta)))
(define (meta-package-latest meta)
(and=> (meta-package-dist-tags meta) dist-tags-latest))
(define* (meta-package-package meta #:optional
(version (meta-package-latest meta)))
(match version
((? semver?) (find (lambda (revision)
(semver=? version (package-revision-version revision)))
(meta-package-revisions meta)))
((? string?) (meta-package-package meta (string->semver version)))
(_ #f)))
(define* (semver-latest svs #:optional (svr *semver-range-any*))
(find (cut semver-range-contains? svr <>)
(sort svs semver>?)))
(define* (resolve-package name #:optional (svr *semver-range-any*))
(let ((meta (lookup-meta-package* name)))
(and meta
(let* ((version (semver-latest (or (meta-package-versions meta) '()) svr))
(pkg (meta-package-package meta version)))
pkg))))
;;;
;;; Converting packages
;;;
(define (hash-url url)
"Downloads the resource at URL and computes the base32 hash for it."
(call-with-temporary-output-file
(lambda (temp port)
(begin ((@ (guix import utils) url-fetch) url temp)
(guix-hash-url temp)))))
(define (npm-name->name npm-name)
"Return a Guix package name for the npm package with name NPM-NAME."
(define (clean name)
(string-map (lambda (chr) (if (char=? chr #\/) #\- chr))
(string-filter (negate (cut char=? <> #\@)) name)))
(guix-name "node-" (clean npm-name)))
(define (name+version->symbol name version)
(string->symbol (string-append name "-" version)))
(define (package-revision->symbol package)
(let* ((npm-name (package-revision-name package))
(version (semver->string (package-revision-version package)))
(name (npm-name->name npm-name)))
(name+version->symbol name version)))
(define (package-revision->input package)
"Return the `inputs' entry for PACKAGE."
(let* ((npm-name (package-revision-name package))
(name (npm-name->name npm-name)))
`(,name
(,'unquote ,(package-revision->symbol package)))))
(define (npm-package->package-sexp npm-package)
"Return the `package' s-expression for an NPM-PACKAGE."
(match npm-package
(($ <package-revision> name version home-page dependencies license description dist)
(let* ((name (npm-name->name name))
(url (dist-tarball dist))
(home-page (if (string? home-page)
home-page
(string-append *default-page* "/" (uri-encode name))))
(synopsis description)
(resolved-deps (map (match-lambda (($ <versioned-package> name version)
(resolve-package name (string->semver-range version)))) dependencies)))
(values
`(package
(name ,name)
(version ,(semver->string (package-revision-version npm-package)))
(source (origin
(method url-fetch)
(uri ,url)
(sha256 (base32 ,(hash-url url)))))
(build-system node-build-system)
(arguments
`(#:tests? #f
#:phases
(modify-phases %standard-phases
(delete 'configure)
(delete 'build))))
,@(match dependencies
(() '())
((dependencies ...)
`((inputs
(,'quasiquote ,(map package-revision->input
resolved-deps))))))
(home-page ,home-page)
(synopsis ,synopsis)
(description ,description)
(license ,license))
(map (match-lambda (($ <package-revision> name version)
(list name (semver->string version))))
resolved-deps))))
(_ #f)))
;;;
;;; Interface
;;;
(define npm-binary->guix-package
(lambda* (name #:key (version *semver-range-any*) #:allow-other-keys)
(let* ((svr (match version
((? string?) (string->semver-range version))
(_ version)))
(pkg (resolve-package name svr)))
(and=> pkg npm-package->package-sexp))))
(define* (npm-binary-recursive-import package-name #:key version)
(recursive-import package-name
#:repo->guix-package (memoize npm-binary->guix-package)
#:version version
#:guix-name npm-name->name))

2
guix/scripts/import.scm
View file

@ -77,7 +77,7 @@ (define %standard-import-options '())
;;; ;;;
(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "elpa" "gem"
"go" "cran" "crate" "texlive" "json" "opam")) "go" "cran" "crate" "texlive" "json" "opam" "npm-binary"))
(define (resolve-importer name) (define (resolve-importer name)
(let ((module (resolve-interface (let ((module (resolve-interface

113
guix/scripts/import/npm-binary.scm Normal file
View file

@ -0,0 +1,113 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts import npm-binary)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix scripts)
#:use-module (guix import npm-binary)
#:use-module (guix scripts import)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-37)
#:use-module (srfi srfi-41)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (guix-import-npm-binary))
;;;
;;; Command-line options.
;;;
(define %default-options
'())
(define (show-help)
(display (G_ "Usage: guix import npm-binary PACKAGE-NAME [VERSION]
Import and convert the NPM package PACKAGE-NAME using the
`npm-build-system' (but without building the package from source)."))
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
-r, --recursive import packages recursively"))
(display (G_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(define %options
;; Specification of the command-line options.
(cons* (option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix import npm-binary")))
(option '(#\r "recursive") #f #f
(lambda (opt name arg result)
(alist-cons 'recursive #t result)))
%standard-import-options))
;;;
;;; Entry point.
;;;
(define (guix-import-npm-binary . args)
(define (parse-options)
;; Return the alist of option values.
(args-fold* args %options
(lambda (opt name arg result)
(leave (G_ "~A: unrecognized option~%") name))
(lambda (arg result)
(alist-cons 'argument arg result))
%default-options))
(let* ((opts (parse-options))
(args (filter-map (match-lambda
(('argument . value)
value)
(_ #f))
(reverse opts))))
(let loop ((args args))
(match args
((package-name version)
(if (assoc-ref opts 'recursive)
;; Recursive import
(map (match-lambda
((and ('package ('name name) ('version version) . rest) pkg)
`(define-public ,(name+version->symbol name version)
,pkg))
(_ #f))
(npm-binary-recursive-import package-name #:version version))
;; Single import
(let ((sexp (npm-binary->guix-package package-name #:version version)))
(unless sexp
(leave (G_ "failed to download meta-data for package '~a@~a'~%")
package-name version))
sexp)))
((package-name)
(loop (list package-name "*")))
(()
(leave (G_ "too few arguments~%")))
((many ...)
(leave (G_ "too many arguments~%")))))))