[bug#42180] [PATCH 1/1] guix: Add importer for hex.pm.

[pukkamustard <pukkamustard@posteo.net>]

From: pukkamustard@posteo.net

* 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.
---
 Makefile.am                   |   3 +
 guix/hexpm-download.scm       |  73 +++++++++
 guix/import/hexpm.scm         | 298 ++++++++++++++++++++++++++++++++++
 guix/import/utils.scm         |   1 +
 guix/scripts/import.scm       |   2 +-
 guix/scripts/import/hexpm.scm | 114 +++++++++++++
 guix/upstream.scm             |  20 ++-
 7 files changed, 509 insertions(+), 2 deletions(-)
 create mode 100644 guix/hexpm-download.scm
 create mode 100644 guix/import/hexpm.scm
 create mode 100644 guix/scripts/import/hexpm.scm

diff --git a/Makefile.am b/Makefile.am
index eb1d34198f..32607b7704 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -96,6 +96,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				\
@@ -246,6 +247,7 @@ MODULES =					\
   guix/import/gnome.scm				\
   guix/import/gnu.scm				\
   guix/import/hackage.scm			\
+  guix/import/hexpm.scm				\
   guix/import/json.scm				\
   guix/import/kde.scm				\
   guix/import/launchpad.scm   			\
@@ -289,6 +291,7 @@ MODULES =					\
   guix/scripts/import/gem.scm			\
   guix/scripts/import/gnu.scm			\
   guix/scripts/import/hackage.scm		\
+  guix/scripts/import/hexpm.scm			\
   guix/scripts/import/json.scm  		\
   guix/scripts/import/nix.scm			\
   guix/scripts/import/opam.scm			\
diff --git a/guix/hexpm-download.scm b/guix/hexpm-download.scm
new file mode 100644
index 0000000000..69d0cf285c
--- /dev/null
+++ b/guix/hexpm-download.scm
@@ -0,0 +1,73 @@
+;;; 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.
+;;;
+
+(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))
diff --git a/guix/import/hexpm.scm b/guix/import/hexpm.scm
new file mode 100644
index 0000000000..129482ac6e
--- /dev/null
+++ b/guix/import/hexpm.scm
@@ -0,0 +1,298 @@
+;;; 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 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 (guix json)
+  #:use-module (guix import json)
+  #:use-module (guix import utils)
+  #: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))
+
+\f
+;;;
+;;; Interface to https://hex.pm/api, version 2.
+;;;
+
+(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)))
+
+\f
+;;;
+;;; Converting hex.pm packages to Guix packages.
+;;;
+
+(define (maybe-arguments arguments)
+  (match arguments
+    (()
+     '())
+    ((args ...)
+     `((arguments (,'quasiquote ,args))))))
+
+(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 #:optional 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 #f
+                    #:repo->guix-package
+                    (lambda (name repo)
+                      (let ((version (and (string=? name pkg-name)
+                                          version)))
+                        (hexpm->guix-package name version)))
+                    #: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 #\_) "-")))
+
+\f
+;;;
+;;; 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)))
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 145515c489..b128580a8b 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -310,6 +310,7 @@ the expected fields of an <origin> object."
                         ("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))))))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 0a3863f965..81fa36956b 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" "hexpm"))
 
 (define (resolve-importer name)
   (let ((module (resolve-interface
diff --git a/guix/scripts/import/hexpm.scm b/guix/scripts/import/hexpm.scm
new file mode 100644
index 0000000000..be5625ca46
--- /dev/null
+++ b/guix/scripts/import/hexpm.scm
@@ -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))
+
+\f
+;;;
+;;; 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))
+
+\f
+;;;
+;;; 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)))
+             (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~%"))))))
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 6584d5e4c4..0abf7ce038 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -24,6 +24,10 @@
   #: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)
@@ -398,9 +402,23 @@ SOURCE, an <upstream-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 updaters
                          #:key (key-download 'interactive))
-- 
2.28.0