Package: guix-patches;
Reported by: Nicolas Graves <ngraves <at> ngraves.fr>
Date: Wed, 15 Mar 2023 12:49:01 UTC
Severity: normal
Tags: moreinfo, patch
Message #190 received at 62202 <at> debbugs.gnu.org (full text, mbox):
From: Nicolas Graves <ngraves <at> ngraves.fr> To: 62202 <at> debbugs.gnu.org Cc: ngraves <at> ngraves.fr Subject: [PATCH v3 2/4] import: Add juliahub importer. Date: Thu, 21 Dec 2023 15:01:01 +0100
---
doc/guix.texi | 27 +++
guix/import/juliahub.scm | 309 +++++++++++++++++++++++++++++++
guix/scripts/import.scm | 2 +-
guix/scripts/import/juliahub.scm | 107 +++++++++++
4 files changed, 444 insertions(+), 1 deletion(-)
create mode 100644 guix/import/juliahub.scm
create mode 100644 guix/scripts/import/juliahub.scm
diff --git a/doc/guix.texi b/doc/guix.texi
index b742a3d5b2..f50bb3f328 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -14678,6 +14678,33 @@ guix import hexpm cf@@0.3.0
Additional options include:
+@table @code
+@item --recursive
+@itemx -r
+Traverse the dependency graph of the given upstream package recursively
+and generate package expressions for all those packages that are not yet
+in Guix.
+@end table
+
+@item juliahub
+@cindex juliahub
+Import metadata from both the General
+@uref{https://github.com/JuliaRegistries/General} and Juliahub
+@uref{https://juliahub.com} Julia package repositories, as in this
+example:
+
+@example
+guix import juliahub Cthulhu@@2.8.9
+@end example
+
+The supplied package name must have the same case as in the
+aforementioned package repositories, and the version used must be an
+exact version (e.g. @code{2.8.9} instead of @code{2.8}). The command
+will also fail in the case of a Julia package that doesn't use a git
+tag.
+
+Additional options include:
+
@table @code
@item --recursive
@itemx -r
diff --git a/guix/import/juliahub.scm b/guix/import/juliahub.scm
new file mode 100644
index 0000000000..ab838b6035
--- /dev/null
+++ b/guix/import/juliahub.scm
@@ -0,0 +1,309 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2023 Nicolas Graves <ngraves <at> ngraves.fr>
+;;;
+;;; 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 juliahub)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-71)
+ #:use-module (guix http-client)
+ #:use-module (guix git)
+ #:use-module (guix import utils)
+ #:use-module (guix import json)
+ #:use-module (guix base32)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (json)
+ #:use-module ((guix licenses) #:prefix license:)
+
+ #:export (juliahub->guix-package
+ %juliahub-updater
+ juliahub-recursive-import))
+
+
+;; JuliaHub API.
+(define (juliahub-redirect-uri name)
+ (let* ((url (string-append "https://docs.juliahub.com/" name "/"))
+ (port (http-fetch url #:text? #t))
+ (_ (get-line port))
+ (meta (get-line port))
+ (regex "url=[a-zA-Z0-9]{5}\\/[0-9\\.]*")
+ (redirect (match:substring (string-match regex meta))))
+ (close-port port)
+ (string-drop redirect 4)))
+
+(define (juliahub-url name)
+ (let* ((url (string-append "https://docs.juliahub.com/" name "/"))
+ (uri (juliahub-redirect-uri name)))
+ (string-append url uri "/")))
+
+;; General package repository.
+(define %general-base-url
+ "https://raw.githubusercontent.com/JuliaRegistries/General/master/")
+
+(define (general-url package-name file)
+ (let ((folder (string-capitalize (string-take package-name 1))))
+ (string-append
+ %general-base-url folder "/" package-name "/" file)))
+
+(define (ini-line->alist line)
+ (let* ((l (string-split line #\=))
+ (attribute (string->symbol (string-drop-right (car l) 1)))
+ (value (string-drop (string-drop-right (cadr l) 1) 2)))
+ `(,attribute . ,value)))
+
+(define (ini-fetch url)
+ (let* ((port (http-fetch url #:text? #t))
+ (raw (get-string-all port))
+ (lines (drop-right (string-split raw #\newline) 1)))
+ (close-port port)
+ (map ini-line->alist lines)))
+
+;; Filtering out julia-stdlibs.
+;; To update them, see file sysimg.jl.
+(define %julia-stdlibs
+ (list "julia"
+ "ArgTools"
+ "Artifacts"
+ "Base64"
+ "CRC32c"
+ "FileWatching"
+ "Libdl"
+ "Logging"
+ "Mmap"
+ "NetworkOptions"
+ "SHA"
+ "Serialization"
+ "Sockets"
+ "Unicode"
+ "DelimitedFiles"
+ "LinearAlgebra"
+ "Markdown"
+ "Printf"
+ "Random"
+ "Tar"
+ "Dates"
+ "Distributed"
+ "Future"
+ "InteractiveUtils"
+ "LibGit2"
+ "Profile"
+ "SparseArrays"
+ "UUIDs"
+ "REPL"
+ "SharedArrays"
+ "Statistics"
+ "SuiteSparse"
+ "TOML"
+ "Test"
+ "LibCURL"
+ "Downloads"
+ "Pkg"
+ "LazyArtifacts"))
+
+;; Julia package.
+(define-json-mapping <juliahub-package> make-juliahub-package juliahub-package?
+ json->juliahub-package
+ (homepage juliahub-package-homepage) ;string
+ (readme juliahub-package-readme) ;string
+ (version juliahub-package-version) ;string
+ (description juliahub-package-description) ;string
+ (dependencies
+ juliahub-package-dependencies "deps"
+ json->juliahub-dependencies) ;list of <juliahub-dependency>
+ (url juliahub-package-url) ;string
+ (uuid juliahub-package-uuid) ;string
+ (license juliahub-package-license)) ;string
+
+(define-json-mapping <juliahub-dependency>
+ make-juliahub-dependency juliahub-dependency?
+ json->juliahub-dependency
+ (direct? juliahub-dependency-direct? "direct") ;boolean
+ (name juliahub-dependency-name) ;string
+ (uuid juliahub-dependency-uuid) ;string
+ (versions juliahub-dependency-versions "versions" vector->list)) ;list of strings
+
+(define (julia-name->guix-name name)
+ (string-append "julia-" (snake-case name)))
+
+(define* (juliahub-fetch name #:key (version #f))
+ "Return a <juliahub-package> record for package NAME, or #f on failure."
+ (let* ((uri (juliahub-redirect-uri name))
+ (slug (string-take uri 5))
+ (url (if version
+ (string-append "https://docs.juliahub.com/" name "/"
+ slug "/" version "/pkg.json")
+ (string-append (juliahub-url name) "pkg.json"))))
+ (and=> (json-fetch url) json->juliahub-package)))
+
+(define (make-julia-sexp name version source home-page synopsis description
+ direct-dependencies test-dependencies-names license)
+ "Return the `package' s-expression for a Julia package with the given NAME,
+VERSION, SOURCE, HOME-PAGE, DESCRIPTION, DIRECT-DEPENDENCIES,
+TEST-DEPENDENCIES-NAMES and LICENSE."
+ `(package
+ (name ,(julia-name->guix-name name))
+ (version ,version)
+ (source ,source)
+ (build-system julia-build-system)
+ ,@(if (null? direct-dependencies)
+ '()
+ `((propagated-inputs
+ (list ,@(map (compose string->symbol
+ julia-name->guix-name
+ juliahub-dependency-name)
+ direct-dependencies)))))
+ ,@(if (null? test-dependencies-names)
+ '()
+ `((native-inputs
+ (list ,@(map (compose string->symbol julia-name->guix-name)
+ test-dependencies-names)))))
+ (synopsis ,synopsis)
+ (description ,description)
+ (home-page ,home-page)
+ (license ,(if license (spdx-string->license license) #f))))
+
+;; Dependencies helpers.
+(define (json->juliahub-dependencies vector)
+ (if (vector? vector)
+ (filter-map
+ (lambda (el)
+ (let ((dep (json->juliahub-dependency el)))
+ (if (and (juliahub-dependency-direct? dep)
+ (not (member (juliahub-dependency-name dep)
+ %julia-stdlibs)))
+ dep
+ #f)))
+ (vector->list vector))))
+
+(define (parse-test-dependencies directory)
+ (let* ((port (open-input-file (string-append directory "/Project.toml")))
+ (project.toml (get-string-all port))
+ (regex "\ntest = \\[.*\\]")
+ (deps (match:substring (string-match regex project.toml)))
+ (pure (string-delete (list->char-set (list #\" #\ )) deps)))
+ (close-port port)
+ (filter (lambda (x) (not (member x %julia-stdlibs)))
+ (string-split (string-drop (string-drop-right pure 1) 7) #\,))))
+
+;; Juliahub may be more up-to-date than the General registry or the actual git
+;; tag (it seems around 6 hours pass between the time a commit is supplied to
+;; JuliaRegistrator as a release, and the time Julia TagBot Github Action makes
+;; the git tag). We have no simple way to get the commit of the latest-version.
+;; Thus the best simple thing we can do is get the latest-git-tag, and import
+;; this version instead. We do this by parsing Package.toml in the General
+;; registry, and then getting the refs of the git repo supplied by this
+;; file. Parsing this file is also necessary if the package is in a subdir of a
+;; git repository, because the information isn't present in Juliahub.
+
+;; There's a last case where some Julia packages are not based on a particular
+;; git tag. In this case, the script fails, but it seems quite rare. We could
+;; introduce the tree-commit which is available in the Versions.toml file in the
+;; General repository. This can be used to identify the state of a repository,
+;; since we have a unique hash of the listing of files and directories.
+
+(define (latest-git-tag repo)
+ (let* ((last-ref (last (remote-refs repo #:tags? #t)))
+ (last-git-tag (last (string-split last-ref #\/))))
+ (string-drop last-git-tag 1)))
+
+(define* (juliahub->guix-package package-name
+ #:key version #:allow-other-keys)
+ "Fetch the metadata for PACKAGE-NAME from juliahub.org, and return the
+`package' s-expression corresponding to that package, or #f on failure.
+Optionally include a VERSION string to fetch a specific version juliahub."
+ (let* ((package-toml (ini-fetch (general-url package-name "Package.toml")))
+ (subdir (assoc-ref package-toml 'subdir))
+ (tag (latest-git-tag (assoc-ref package-toml 'repo)))
+ (package (if version
+ (juliahub-fetch package-name #:version version)
+ (if tag
+ (juliahub-fetch package-name #:version tag)
+ (juliahub-fetch package-name)))))
+ (if package
+ (let* ((source directory
+ (git->origin
+ (juliahub-package-url package)
+ `(tag-or-commit
+ . ,(string-append
+ "v" (juliahub-package-version package)))))
+ (direct-dependencies
+ (filter juliahub-dependency-direct?
+ (juliahub-package-dependencies package)))
+ (dependencies-names (map juliahub-dependency-name
+ direct-dependencies))
+ (test-dependencies-names
+ (if subdir
+ (parse-test-dependencies
+ (string-append subdir "/" directory))
+ (parse-test-dependencies directory)))
+ (homepage (juliahub-package-homepage package)))
+ (values (make-julia-sexp
+ package-name
+ (juliahub-package-version package)
+ source
+ (match homepage
+ ("" (juliahub-package-url package))
+ ((? string?) homepage)
+ (_ (juliahub-package-url package)))
+ (juliahub-package-description package)
+ (beautify-description
+ (juliahub-package-readme package))
+ direct-dependencies
+ test-dependencies-names
+ (juliahub-package-license package))
+ (append dependencies-names test-dependencies-names)))
+ (values #f '()))))
+
+;; We must use the url to get a name with the true case of juliahub/general.
+(define (guix-package->juliahub-name package)
+ (let* ((url (juliahub-package-url package))
+ (git-name (last (string-split url #\/)))
+ (ungitted-name (if (string-suffix? ".git" git-name)
+ (string-drop-right git-name 4)
+ git-name))
+ (package-name (if (string-suffix? ".jl" ungitted-name)
+ (string-drop-right ungitted-name 4)
+ ungitted-name)))
+ package-name))
+
+(define* (import-release package #:key (version #f))
+ "Return an <upstream-source> for the latest release of PACKAGE."
+ (let* ((package-name (guix-package->juliahub-name package))
+ (package (juliahub-fetch package-name))
+ (version (or version (juliahub-package-version package))))
+ (upstream-source
+ (package (package-name package))
+ (version version)
+ (urls (list (juliahub-package-url package))))))
+
+(define %juliahub-updater
+ (upstream-updater
+ (name 'juliahub)
+ (description "Updater for Juliahub packages")
+ (pred juliahub-package?)
+ (import import-release)))
+
+(define* (juliahub-recursive-import package-name #:optional version)
+ (recursive-import package-name
+ #:repo '()
+ #:repo->guix-package juliahub->guix-package
+ #:guix-name julia-name->guix-name
+ #:version version))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index d2a1cee56e..8926c9610f 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -47,7 +47,7 @@ (define %standard-import-options '())
(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa"
"gem" "go" "cran" "crate" "texlive" "json" "opam"
- "minetest" "elm" "hexpm" "composer"))
+ "minetest" "elm" "hexpm" "composer" "juliahub"))
(define (resolve-importer name)
(let ((module (resolve-interface
diff --git a/guix/scripts/import/juliahub.scm b/guix/scripts/import/juliahub.scm
new file mode 100644
index 0000000000..1317c67aa3
--- /dev/null
+++ b/guix/scripts/import/juliahub.scm
@@ -0,0 +1,107 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2023 Nicolas Graves <ngraves <at> ngraves.fr>
+;;;
+;;; 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 juliahub)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix import juliahub)
+ #: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)
+ #:use-module (ice-9 receive)
+ #:export (guix-import-juliahub))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ '())
+
+(define (show-help)
+ (display (G_ "Usage: guix import juliahub PACKAGE-NAME[@VERSION] Import and
+convert the Julia package for PACKAGE-NAME. Optionally, a version can be
+specified after the at-sign (@) character.\n"))
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (display (G_ "
+ -r, --recursive generate package expressions for all Gem packages\
+ that are not yet in Guix"))
+ (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 gem")))
+ (option '(#\r "recursive") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'recursive #t result)))
+ %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-juliahub . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (parse-command-line args %options (list %default-options)
+ #:build-options? #f))
+
+ (let* ((opts (parse-options))
+ (args (filter-map (match-lambda
+ (('argument . value)
+ value)
+ (_ #f))
+ (reverse opts))))
+ (match args
+ ((spec)
+ (receive (package-name package-version)
+ (package-name->name+version spec)
+ (let ((code (if (assoc-ref opts 'recursive)
+ (map (match-lambda
+ ((and ('package ('name name) . rest) pkg)
+ `(define-public ,(string->symbol name)
+ ,pkg))
+ (_ #f))
+ (juliahub-recursive-import package-name package-version))
+ (let ((sexp (juliahub->guix-package package-name #:version package-version)))
+ (if sexp sexp #f)))))
+ (match code
+ ((or #f '(#f))
+ (leave (G_ "failed to download meta-data for package '~a'~%")
+ package-name))
+ (_ code)))))
+ (()
+ (leave (G_ "too few arguments~%")))
+ ((many ...)
+ (leave (G_ "too many arguments~%"))))))
--
2.41.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.