diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | guix/import/npm-binary.scm | 235 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/npm-binary.scm | 113 |
4 files changed, 351 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index fc60d15561..3edee48263 100644 --- a/Makefile.am +++ b/Makefile.am @@ -248,6 +248,7 @@ MODULES = \ guix/import/json.scm \ guix/import/kde.scm \ guix/import/launchpad.scm \ + guix/import/npm-binary.scm \ guix/import/opam.scm \ guix/import/print.scm \ guix/import/pypi.scm \ @@ -290,6 +291,7 @@ MODULES = \ guix/scripts/import/hackage.scm \ guix/scripts/import/json.scm \ guix/scripts/import/nix.scm \ + guix/scripts/import/npm-binary.scm \ guix/scripts/import/opam.scm \ guix/scripts/import/pypi.scm \ guix/scripts/import/stackage.scm \ diff --git a/guix/import/npm-binary.scm b/guix/import/npm-binary.scm new file mode 100644 index 0000000000..916d59301e --- /dev/null +++ b/guix/import/npm-binary.scm @@ -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)) + + +(module-autoload! (current-module) '(semver) + '(string->semver + semver->string + semver? + semver=? + semver>?)) + +(module-autoload! (current-module) '(semver ranges) + '(string->semver-range + semver-range-contains? + *semver-range-any*)) + +(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)) + +(define *registry* (string->uri "https://registry.npmjs.org")) + +(define lookup-meta-package + (mlambda (name) + (let ((uri (build-uri (uri-scheme *registry*) + #:host (uri-host *registry*) + #:path (string-append "/" (uri-encode name))))) + (receive (response body) + (http-get uri #:streaming? #t) + (let ((status (response-code response))) + (unless (and (<= 200 status) (< status 300)) + (scm-error 'http-error "lookup-meta-package" + "Received HTTP error: ~s: ~s for ~s" + (list (response-code response) + (response-reason-phrase response)) + (list (response-code response))))) + (json->meta-package body))))) + +(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)) + (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 *suffix* "--binary") + +(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))) + (string-append (guix-name "node-" (clean npm-name)) *suffix*)) + +(define (npm-name->input npm-name) + "Return the `inputs' entry for NPM-NAME." + (let ((name (npm-name->name npm-name))) + `(,(if (string-suffix? *suffix* name) + (string-drop-right name (string-length *suffix*)) + name) + (,'unquote ,(string->symbol name))))) + +(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)) + (dependency-names (map versioned-package-name dependencies)) + (synopsis description)) + (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 + `(#:phases + (modify-phases %standard-phases + (delete 'configure) + (delete 'build)))) + ,@(match dependency-names + (() '()) + ((dependency-names ...) + `((inputs + (,'quasiquote ,(map npm-name->input + (sort dependency-names string<))))))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,license)) + (map (match-lambda (($ <versioned-package> name version) + (list name version))) + dependencies)))) + (_ #f))) + + +;;; +;;; Interface +;;; + +(define npm-binary->guix-package + ;; (memoize) + (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))) + (npm-package->package-sexp pkg)))) + +(define* (npm-binary-recursive-import package-name #:key version) + (recursive-import package-name + #:repo->guix-package npm-binary->guix-package + #:version version + #:guix-name npm-name->name)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 0a3863f965..286de874c5 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -77,7 +77,7 @@ rather than \\n." ;;; (define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" - "cran" "crate" "texlive" "json" "opam")) + "cran" "crate" "texlive" "json" "opam" "npm-binary")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/npm-binary.scm b/guix/scripts/import/npm-binary.scm new file mode 100644 index 0000000000..af661c7006 --- /dev/null +++ b/guix/scripts/import/npm-binary.scm @@ -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) . rest) pkg) + `(define-public ,(string->symbol name) + ,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'~%") + package-name)) + sexp))) + ((package-name) + (loop (list package-name "*"))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%"))))))) |