ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

import: Add hex.pm importer.

Browse source 
hex.pm is a package repository for Erlang and Elixir.

* guix/scripts/import.scm (importers): Add "hexpm".
* guix/scripts/import/hexpm.scm, guix/import/hexpm.scm,
  guix/hexpm-download.scm: New files.
* guix/import/utils.scm (source-spec->object): Add "hexpm-fetch" to list of
  fetch methods.
* guix/upstream.scm (package-update/hexpm-fetch): New function.
  (%method-updates) Add it.
* Makefile.am: Add them.
This commit is contained in:
Hartmut Goebel 2020-05-24 22:17:30 +02:00
parent f63c79bf76
commit d780d0a2bb
No known key found for this signature in database
GPG key ID: 634A8DFFD3F631DF
7 changed files with 504 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile.am
View file

@ -99,6 +99,7 @@ MODULES = \
guix/extracting-download.scm \
guix/git-download.scm \
guix/hg-download.scm \
guix/hexpm-download.scm \
guix/swh.scm \
guix/monads.scm \
guix/monad-repl.scm \
@ -262,6 +263,7 @@ MODULES = \
guix/import/gnu.scm \
guix/import/go.scm \
guix/import/hackage.scm \
guix/import/hexpm.scm \
guix/import/json.scm \
guix/import/kde.scm \
guix/import/launchpad.scm \
@ -309,6 +311,7 @@ MODULES = \
guix/scripts/import/gnu.scm \
guix/scripts/import/go.scm \
guix/scripts/import/hackage.scm \
guix/scripts/import/hexpm.scm \
guix/scripts/import/json.scm \
guix/scripts/import/minetest.scm \
guix/scripts/import/opam.scm \

76
guix/hexpm-download.scm Normal file
View file

@ -0,0 +1,76 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2020 Hartmut Goebel <h.goebel@crazy-compilers.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 hexpm-download)
#:use-module (ice-9 match)
#:use-module (guix extracting-download)
#:use-module (guix packages) ;; for %current-system
#:use-module (srfi srfi-26)
#:export (hexpm-fetch
%hexpm-repo-url
hexpm-url
hexpm-url?
hexpm-uri))
;;;
;;; An <origin> method that fetches a package from the hex.pm repository,
;;; unwrapping the actual content from the download tarball.
;;;
;; URL and paths from
;; https://github.com/hexpm/specifications/blob/master/endpoints.md
(define %hexpm-repo-url
(make-parameter "https://repo.hex.pm"))
(define hexpm-url
(string-append (%hexpm-repo-url) "/tarballs/"))
(define hexpm-url?
(cut string-prefix? hexpm-url <>))
(define (hexpm-uri name version)
"Return a URI string for the package hosted at hex.pm corresponding to NAME
and VERSION."
(string-append hexpm-url name "-" version ".tar"))
(define* (hexpm-fetch url hash-algo hash
#:optional name
#:key
(filename-to-extract "contents.tar.gz")
(system (%current-system))
(guile (default-guile)))
"Return a fixed-output derivation that fetches URL and extracts
\"contents.tar.gz\". The output is expected to have hash HASH of type
HASH-ALGO (a symbol). By default, the file name is the base name of URL;
optionally, NAME can specify a different file name. By default, the file name
is the base name of URL with \".gz\" appended; optionally, NAME can specify a
different file name."
(define file-name
(match url
((head _ ...)
(basename head))
(_
(basename url))))
(http-fetch/extract url "contents.tar.gz" hash-algo hash
;; urls typically end with .tar, but contents is .tar.gz
(or name (string-append file-name ".gz"))
#:system system #:guile guile))

290
guix/import/hexpm.scm Normal file
View file

@ -0,0 +1,290 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2020, 2021 Hartmut Goebel <h.goebel@crazy-compilers.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 import hexpm)
#:use-module (guix base32)
#:use-module ((guix download) #:prefix download:)
#:use-module (guix hexpm-download)
#:use-module (gcrypt hash)
#:use-module (guix http-client)
#:use-module (json)
#:use-module (guix import utils)
#:use-module ((guix import json) #:select (json-fetch))
#:use-module ((guix build utils)
#:select ((package-name->name+version
. hyphen-package-name->name+version)
dump-port))
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 popen)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-26)
#:export (hexpm->guix-package
guix-package->hexpm-name
strings->licenses
hexpm-recursive-import
%hexpm-updater))
;;;
;;; Interface to https://hex.pm/api, version 2.
;;; https://github.com/hexpm/specifications/blob/master/apiary.apib
;;; https://github.com/hexpm/specifications/blob/master/endpoints.md
;;;
(define %hexpm-api-url
(make-parameter "https://hex.pm/api"))
(define (package-url name)
(string-append (%hexpm-api-url) "/packages/" name))
;; Hexpm Package. /api/packages/${name}
;; It can have several "releases", each of which has its own set of
;; requirements, buildtool, etc. - see <hexpm-release> below.
(define-json-mapping <hexpm-pkgdef> make-hexpm-pkgdef hexpm-pkgdef?
json->hexpm
(name hexpm-name) ;string
(html-url hexpm-html-url "html_url") ;string
(docs-html-url hexpm-docs-html-url "docs_html_url") ;string | #nil
(meta hexpm-meta "meta" json->hexpm-meta)
(versions hexpm-versions "releases" ;list of <hexpm-version>
(lambda (vector)
(map json->hexpm-version
(vector->list vector)))))
;; Hexpm meta.
(define-json-mapping <hexpm-meta> make-hexpm-meta hexpm-meta?
json->hexpm-meta
(description hexpm-meta-description) ;string
(licenses hexpm-meta-licenses "licenses" ;list of strings
(lambda (vector)
(or (and vector (vector->list vector))
#f))))
;; Hexpm version.
(define-json-mapping <hexpm-version> make-hexpm-version hexpm-version?
json->hexpm-version
(number hexpm-version-number "version") ;string
(url hexpm-version-url)) ;string
(define (lookup-hexpm name)
"Look up NAME on https://hex.pm and return the corresopnding <hexpm>
record or #f if it was not found."
(let ((json (json-fetch (package-url name))))
(and json
(json->hexpm json))))
;; Hexpm release. /api/packages/${name}/releases/${version}
(define-json-mapping <hexpm-release> make-hexpm-release hexpm-release?
json->hexpm-release
(number hexpm-release-number "version") ;string
(url hexpm-release-url) ;string
(requirements hexpm-requirements "requirements")) ;list of <hexpm-dependency>
;; meta:build_tools -> alist
;; Hexpm dependency. Each dependency (each edge in the graph) is annotated as
;; being a "normal" dependency or a development dependency. There also
;; information about the minimum required version, such as "^0.0.41".
(define-json-mapping <hexpm-dependency> make-hexpm-dependency
hexpm-dependency?
json->hexpm-dependency
(app hexpm-dependency-app "app") ;string
(optional hexpm-dependency-optional) ;bool
(requirement hexpm-dependency-requirement)) ;string
(define (hexpm-release-dependencies release)
"Return the list of dependency names of RELEASE, a <hexpm-release>."
(let ((reqs (or (hexpm-requirements release) '#())))
(map first reqs))) ;; TODO: also return required version
(define (lookup-hexpm-release version*)
"Look up RELEASE on hexpm-version-url and return the corresopnding
<hexpm-release> record or #f if it was not found."
(let* ((url (hexpm-version-url version*))
(json (json-fetch url)))
(json->hexpm-release json)))
;;;
;;; Converting hex.pm packages to Guix packages.
;;;
(define* (make-hexpm-sexp #:key name version tarball-url
home-page synopsis description license
#:allow-other-keys)
"Return the `package' s-expression for a rust package with the given NAME,
VERSION, tarball-url, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
(call-with-temporary-directory
(lambda (directory)
(let ((port (http-fetch tarball-url))
(tar (open-pipe* OPEN_WRITE "tar" "-C" directory
"-xf" "-" "contents.tar.gz")))
(dump-port port tar)
(close-port port)
(let ((status (close-pipe tar)))
(unless (zero? status)
(error "tar extraction failure" status))))
(let ((guix-name (hexpm-name->package-name name))
(sha256 (bytevector->nix-base32-string
(call-with-input-file
(string-append directory "/contents.tar.gz")
port-sha256))))
`(package
(name ,guix-name)
(version ,version)
(source (origin
(method hexpm-fetch)
(uri (hexpm-uri ,name version))
(sha256 (base32 ,sha256))))
(build-system ,'rebar3-build-system)
(home-page ,(match home-page
(() "")
(_ home-page)))
(synopsis ,synopsis)
(description ,(beautify-description description))
(license ,(match license
(() #f)
((license) license)
(_ `(list ,@license)))))))))
(define (strings->licenses strings)
(filter-map (lambda (license)
(and (not (string-null? license))
(not (any (lambda (elem) (string=? elem license))
'("AND" "OR" "WITH")))
(or (spdx-string->license license)
license)))
strings))
(define (hexpm-latest-version package)
(let ((versions (map hexpm-version-number (hexpm-versions package))))
(fold (lambda (a b)
(if (version>? a b) a b)) (car versions) versions)))
(define* (hexpm->guix-package package-name #:key repo version)
"Fetch the metadata for PACKAGE-NAME from hexpms.io, and return the
`package' s-expression corresponding to that package, or #f on failure.
When VERSION is specified, attempt to fetch that version; otherwise fetch the
latest version of PACKAGE-NAME."
(define package
(lookup-hexpm package-name))
(define version-number
(and package
(or version
(hexpm-latest-version package))))
(define version*
(and package
(find (lambda (version)
(string=? (hexpm-version-number version)
version-number))
(hexpm-versions package))))
(define release
(and package version*
(lookup-hexpm-release version*)))
(and package version*
(let ((dependencies (hexpm-release-dependencies release))
(pkg-meta (hexpm-meta package)))
(values
(make-hexpm-sexp
#:name package-name
#:version version-number
#:home-page (or (hexpm-docs-html-url package)
;; TODO: Homepage?
(hexpm-html-url package))
#:synopsis (hexpm-meta-description pkg-meta)
#:description (hexpm-meta-description pkg-meta)
#:license (or (and=> (hexpm-meta-licenses pkg-meta)
strings->licenses))
#:tarball-url (hexpm-uri package-name version-number))
dependencies))))
(define* (hexpm-recursive-import pkg-name #:optional version)
(recursive-import pkg-name
#:version version
#:repo->guix-package hexpm->guix-package
#:guix-name hexpm-name->package-name))
(define (guix-package->hexpm-name package)
"Return the hex.pm name of PACKAGE."
(define (url->hexpm-name url)
(hyphen-package-name->name+version
(basename (file-sans-extension url))))
(match (and=> (package-source package) origin-uri)
((? string? url)
(url->hexpm-name url))
((lst ...)
(any url->hexpm-name lst))
(#f #f)))
(define (hexpm-name->package-name name)
(string-append "erlang-" (string-join (string-split name #\_) "-")))
;;;
;;; Updater
;;;
(define (hexpm-package? package)
"Return true if PACKAGE is a package from hex.pm."
(let ((source-url (and=> (package-source package) origin-uri))
(fetch-method (and=> (package-source package) origin-method)))
(and (eq? fetch-method hexpm-fetch)
(match source-url
((? string?)
(hexpm-url? source-url))
((source-url ...)
(any hexpm-url? source-url))))))
(define (latest-release package)
"Return an <upstream-source> for the latest release of PACKAGE."
(let* ((hexpm-name (guix-package->hexpm-name package))
(hexpm (lookup-hexpm hexpm-name))
(version (hexpm-latest-version hexpm))
(url (hexpm-uri hexpm-name version)))
(upstream-source
(package (package-name package))
(version version)
(urls (list url)))))
(define %hexpm-updater
(upstream-updater
(name 'hexpm)
(description "Updater for hex.pm packages")
(pred hexpm-package?)
(latest latest-release)))

1
guix/import/utils.scm
View file

@ -359,6 +359,7 @@ (define (source-spec->object source)
("git-fetch" (@ (guix git-download) git-fetch))
("svn-fetch" (@ (guix svn-download) svn-fetch))
("hg-fetch" (@ (guix hg-download) hg-fetch))
("hexpm-fetch" (@ (guix hexpm-download) hexpm-fetch))
(_ #f)))
(uri (assoc-ref orig "uri"))
(sha256 sha))))))

2
guix/scripts/import.scm
View file

@ -79,7 +79,7 @@ (define %standard-import-options '())
;;;
(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa"
"gem" "go" "cran" "crate" "texlive" "json" "opam"
"gem" "go" "cran" "crate" "texlive" "json" "opam" "hexpm"
"minetest"))
(define (resolve-importer name)

114
guix/scripts/import/hexpm.scm Normal file
View file

@ -0,0 +1,114 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2020 Hartmut Goebel <h.goebel@crazy-compilers.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 hexpm)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix scripts)
#:use-module (guix import hexpm)
#:use-module (guix scripts import)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (guix-import-hexpm))
;;;
;;; Command-line options.
;;;
(define %default-options
'())
(define (show-help)
(display (G_ "Usage: guix import hexpm PACKAGE-NAME
Import and convert the hex.pm package for PACKAGE-NAME.\n"))
(display (G_ "
-r, --recursive import packages recursively"))
(newline)
(display (G_ "
-h, --help display this help and exit"))
(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 hexpm")))
(option '(#\r "recursive") #f #f
(lambda (opt name arg result)
(alist-cons 'recursive #t result)))
%standard-import-options))
;;;
;;; Entry point.
;;;
(define (guix-import-hexpm . 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))))
(match args
((spec)
(define-values (name version)
(package-name->name+version spec))
(if (assoc-ref opts 'recursive)
(map (match-lambda
((and ('package ('name name) . rest) pkg)
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
(hexpm-recursive-import name version))
(let ((sexp (hexpm->guix-package name #:version version)))
(unless sexp
(leave (G_ "failed to download meta-data for package '~a'~%")
(if version
(string-append name "@" version)
name)))
sexp)))
(()
(leave (G_ "too few arguments~%")))
((many ...)
(leave (G_ "too many arguments~%"))))))

20
guix/upstream.scm
View file

@ -24,6 +24,10 @@ (define-module (guix upstream)
#:use-module (guix discovery)
#:use-module ((guix download)
#:select (download-to-store url-fetch))
#:use-module ((guix hexpm-download)
#:select (hexpm-fetch))
#:use-module ((guix extracting-download)
#:select (download-to-store/extract))
#:use-module (guix gnupg)
#:use-module (guix packages)
#:use-module (guix diagnostics)
@ -430,9 +434,23 @@ (define* (package-update/url-fetch store package source
#:key-download key-download)))
(values version tarball source))))))
(define* (package-update/hexpm-fetch store package source
#:key key-download)
"Return the version, tarball, and SOURCE, to update PACKAGE to
SOURCE, an <upstream-source>."
(match source
(($ <upstream-source> _ version urls signature-urls)
(let* ((url (first urls))
(name (or (origin-file-name (package-source package))
(string-append (basename url) ".gz")))
(tarball (download-to-store/extract
store url "contents.tar.gz" name)))
(values version tarball source)))))
(define %method-updates
;; Mapping of origin methods to source update procedures.
`((,url-fetch . ,package-update/url-fetch)))
`((,url-fetch . ,package-update/url-fetch)
(,hexpm-fetch . ,package-update/hexpm-fetch)))
(define* (package-update store package
#:optional (updaters (force %updaters))