mirror of
https://codeberg.org/guix/guix.git
synced 2025-10-02 02:15:12 +00:00
guix: nuget importer: Add it.
* guix/import/nuget.scm: New file. * guix/scripts/import/nuget.scm: New file. * guix/scripts/import.scm: Add reference to it. * gnu/packages/guile-xyz.scm (guile-semver): Update to 0.2.0. [source]: Switch. Change-Id: I159c5cf3b02b42435b03d989d5815d3fcf001c92
This commit is contained in:
Danny Milosavljevic
parent
bbd63d1470
commit
a6c8217ee7
4 changed files with 545 additions and 9 deletions
398
guix/import/nuget.scm
Normal file
398
guix/import/nuget.scm
Normal file
|
|
@ -0,0 +1,398 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2015-2025 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;; Copyright © 2015-2017, 2019-2021, 2023 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
|
||||
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
|
||||
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
|
||||
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
|
||||
;;; Copyright © 2025 Danny Milosavljevic <dannym@friendly-machines.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 nuget)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 pretty-print)
|
||||
#:use-module ((rnrs) #:select (open-bytevector-input-port put-bytevector))
|
||||
#:use-module ((sxml xpath) #:select (sxpath)) ; filter... grr
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34) ; For catch
|
||||
#:use-module (srfi srfi-37)
|
||||
#:use-module (srfi srfi-71) ; multi-value let
|
||||
#:use-module (sxml simple)
|
||||
#:use-module (sxml match)
|
||||
#:use-module (web client)
|
||||
#:use-module (json)
|
||||
#:use-module (semver)
|
||||
#:use-module (semver ranges)
|
||||
#:use-module (semver partial)
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (guix http-client)
|
||||
#:use-module (guix memoization)
|
||||
#:use-module (guix utils)
|
||||
#:use-module ((guix import utils)
|
||||
#:select (factorize-uri recursive-import flatten))
|
||||
#:use-module (guix base32)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module (guix git)
|
||||
#:use-module ((guix download) #:select (url-fetch))
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix upstream)
|
||||
#:use-module (guix http-client)
|
||||
#:export (nuget->guix-package
|
||||
nuget-recursive-import))
|
||||
|
||||
;;; See also <https://learn.microsoft.com/en-us/nuget/concepts/package-versioning?tabs=semver20sort>.
|
||||
;;; Therefore, excluding prerelease and metadata labels, a version string is Major.Minor.Patch.Revision.
|
||||
;;; As per version normalization described above, if Revision is zero, it is omitted from the normalized version string.
|
||||
;;; TODO: NuGetVersion uses case insensitive string comparisons for pre-release components. This means that 1.0.0-alpha and 1.0.0-Alpha are equal.
|
||||
;;; TODO: nuget-name->guix-name should also provide semantic major version; what about 0. ?
|
||||
;;;
|
||||
;;; NuGet considers a package version to be SemVer v2.0.0 specific, if either of the following is true:
|
||||
;;; - The pre-release label is dot-separated, for example, 1.0.0-alpha.1
|
||||
;;; - The version has build-metadata, for example, 1.0.0+githash
|
||||
|
||||
(define %nuget-v3-service-index-url "https://api.nuget.org/v3/index.json")
|
||||
;; Example: <https://api.nuget.org/v3/registration5-semver1/newtonsoft.json/index.json>.
|
||||
;; List of all packages. You get a lot of references to @type CatalogPage out.
|
||||
(define %nuget-v3-feed-catalog-url "https://api.nuget.org/v3/catalog0/index.json")
|
||||
(define %nuget-v3-registration-url "https://api.nuget.org/v3/registration5-semver1/")
|
||||
(define %nuget-v3-package-versions-url "https://api.nuget.org/v3-flatcontainer/")
|
||||
(define %nuget-symbol-packages-url "https://globalcdn.nuget.org/symbol-packages/")
|
||||
|
||||
;;; Version index https://api.nuget.org/v3-flatcontainer/{id-lower}/index.json
|
||||
;;; nupkg download url https://api.nuget.org/v3-flatcontainer/{id-lower}/{version-lower}/{id-lower}.{version-lower}.nupkg
|
||||
;;; nuspec url https://api.nuget.org/v3-flatcontainer/{id-lower}/{version-lower}/{id-lower}.nuspec
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;
|
||||
;;; Part 1: Version Range Solver
|
||||
;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Fancy false-if-exception.
|
||||
(define* (string->semver/safe str)
|
||||
"A safe wrapper around 'string->semver'. Returns a semver object on
|
||||
success or #f on failure, without crashing."
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(string->semver str))
|
||||
(lambda (key . args)
|
||||
(warning (G_ "Not a semantic version: ~s.~%") str)
|
||||
#f)))
|
||||
|
||||
(define* (parse-nuget-range->primitives range-str)
|
||||
"Parses a NuGet-style version range string and returns a list of lists of
|
||||
primitives suitable for the 'semver-range' constructor."
|
||||
(let ((str (string-trim range-str)))
|
||||
(let ((m-range (string-match "^([([])([^,]*),([^,]*)([])])$" str)))
|
||||
(if m-range
|
||||
(let* ((lower-bracket (match:substring m-range 1))
|
||||
(min-ver-str (string-trim (match:substring m-range 2)))
|
||||
(max-ver-str (string-trim (match:substring m-range 3)))
|
||||
(upper-bracket (match:substring m-range 4)))
|
||||
(filter-map
|
||||
identity
|
||||
(list
|
||||
(if (string-null? min-ver-str)
|
||||
#f
|
||||
(let* ((op (if (string=? lower-bracket "[")
|
||||
'>=
|
||||
'>)))
|
||||
(and=> (string->semver/safe min-ver-str)
|
||||
(cute list op <>))))
|
||||
(if (string-null? max-ver-str)
|
||||
#f
|
||||
(let* ((op (if (string=? upper-bracket "]")
|
||||
'<=
|
||||
'<)))
|
||||
(and=> (string->semver/safe max-ver-str)
|
||||
(cute list op <>)))))))
|
||||
(let ((m-exact (string-match "^\\[([0-9][^\\]]*)\\]$" str)))
|
||||
(if m-exact
|
||||
(let ((slice (string->partial-semver (match:substring m-exact 1))))
|
||||
(if slice (list `((= ,slice))) '()))
|
||||
(if (string-match "^[0-9.]+" str)
|
||||
(let ((slice (string->partial-semver str)))
|
||||
(if slice
|
||||
`((>= ,slice))
|
||||
'()))
|
||||
(begin
|
||||
(warning (G_ "Unrecognized NuGet range format: '~a'.~%") str)
|
||||
'()))))))))
|
||||
|
||||
(define (nuget->semver-range range-str)
|
||||
(semver-range (parse-nuget-range->primitives range-str)))
|
||||
|
||||
(define* (nuget-find-best-version-for-range name range-str)
|
||||
"Given a package NAME and a version RANGE string, find the highest
|
||||
version that satisfies the range. This version correctly handles list
|
||||
creation and filtering to avoid type errors."
|
||||
(let* ((name-lower (string-downcase name))
|
||||
(versions-url (string-append %nuget-v3-package-versions-url name-lower "/index.json")))
|
||||
(let-values (((response body) (http-get versions-url)))
|
||||
(if body
|
||||
(let* ((versions-json (json->scm (open-bytevector-input-port body)))
|
||||
(available-versions (vector->list (or (assoc-ref versions-json "versions")
|
||||
#())))
|
||||
(semver-range (nuget->semver-range range-str)))
|
||||
;; Create a single, clean list of all valid semver objects first.
|
||||
(let ((all-valid-semvers (filter-map string->semver/safe available-versions)))
|
||||
;; First, try to find a matching stable version from this list.
|
||||
(let* ((stable-semvers (filter (lambda (sv)
|
||||
(null? (semver-pre sv)))
|
||||
all-valid-semvers))
|
||||
(matching-stable (filter (lambda (sv)
|
||||
(semver-range-contains? semver-range sv))
|
||||
stable-semvers)))
|
||||
(if (not (null? matching-stable))
|
||||
;; Success: Found a stable version.
|
||||
(semver->string (car (sort matching-stable semver>?)))
|
||||
|
||||
;; Fallback: No stable version matched. Check pre-releases.
|
||||
(begin
|
||||
(warning (G_ "No stable version of ~a matches '~a'. Checking for pre-releases...~%") name range-str)
|
||||
(let ((matching-all (filter
|
||||
(lambda (sv)
|
||||
(semver-range-contains? semver-range sv #:include-prerelease? #t))
|
||||
all-valid-semvers)))
|
||||
(if (not (null? matching-all))
|
||||
(semver->string (car (sort matching-all semver>?)))
|
||||
(begin
|
||||
(warning (G_ "No suitable stable or pre-release version found.~%"))
|
||||
#f))))))))
|
||||
(begin
|
||||
(warning (G_ "Failed to fetch version list for ~a~%") name)
|
||||
#f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;
|
||||
;;; Part 2: Core Data Fetching and Package Generation
|
||||
;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define* (nuget-fetch-catalog-entry name version)
|
||||
"Fetch the full 'catalogEntry' JSON object for a specific package version,
|
||||
correctly handling the paginated structure of the registration index."
|
||||
(let* ((name-lower (string-downcase name))
|
||||
(index-url (string-append %nuget-v3-registration-url name-lower "/index.json"))
|
||||
(index-response index-body (http-get index-url)))
|
||||
(if index-body
|
||||
(let* ((index-json (json->scm (open-bytevector-input-port index-body)))
|
||||
;; Get the list of page objects.
|
||||
(pages (vector->list (or (assoc-ref index-json "items")
|
||||
#()))))
|
||||
(let loop ((pages-to-check pages))
|
||||
(if (null? pages-to-check)
|
||||
;; If we've checked all pages and found nothing, fail.
|
||||
(begin
|
||||
(warning (G_ "Could not find catalog entry for ~a version ~a in any page.~%") name version)
|
||||
#f)
|
||||
(let* ((current-page (car pages-to-check))
|
||||
;; Get the items for the current page. This may require another
|
||||
;; network request if the items are not inlined.
|
||||
(page-items
|
||||
(or (and=> (assoc-ref current-page "items")
|
||||
vector->list)
|
||||
(let-values (((page-response page-body)
|
||||
(http-get (assoc-ref current-page "@id"))))
|
||||
(if page-body
|
||||
(let ((page-json (json->scm (open-bytevector-input-port page-body))))
|
||||
(vector->list (or (assoc-ref page-json "items")
|
||||
#())))
|
||||
'())))))
|
||||
;; Search for our specific version within THIS page's items.
|
||||
(let ((entry-in-page
|
||||
(find (lambda (item)
|
||||
(and=>
|
||||
(and=> (assoc-ref item "catalogEntry")
|
||||
(cut assoc-ref <> "version"))
|
||||
(lambda (v) (string=? v version)))) ; fixme semver equal
|
||||
page-items)))
|
||||
(if entry-in-page
|
||||
;; Found it! Return the catalogEntry object.
|
||||
(assoc-ref entry-in-page "catalogEntry")
|
||||
;; Not in this page, recurse to the next page.
|
||||
(loop (cdr pages-to-check))))))))
|
||||
(begin
|
||||
(warning (G_ "Failed to fetch registration index for ~a~%") name)
|
||||
#f))))
|
||||
|
||||
(define (car-safe lst)
|
||||
(if (null? lst)
|
||||
'()
|
||||
(car lst)))
|
||||
|
||||
(define* (fetch-repo-info-from-snupkg package-name version)
|
||||
"Fetch the .snupkg file for PACKAGE-NAME and VERSION, extract the .nuspec
|
||||
file using the system 'unzip' command, and parse it to find the repository URL
|
||||
and commit. Returns an association list with 'url' and 'commit' keys on
|
||||
success, or #f on failure."
|
||||
(let* ((name-lower (string-downcase package-name))
|
||||
(snupkg-url (string-append %nuget-symbol-packages-url
|
||||
name-lower "." version ".snupkg")))
|
||||
(format (current-error-port)
|
||||
"~%;; Source repository not found in NuGet catalog entry.~%;; ~
|
||||
Attempting to find it in symbol package: ~a~%"
|
||||
snupkg-url)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(let-values (((response body)
|
||||
(http-get snupkg-url)))
|
||||
(if (not body)
|
||||
(begin
|
||||
(warning (G_ "Failed to download: ~a~%") snupkg-url)
|
||||
#f)
|
||||
(call-with-temporary-directory
|
||||
(lambda (dir)
|
||||
(let* ((archive-port (mkstemp "/tmp/myfile-XXXXXX"))
|
||||
(archive-file (port-filename archive-port)))
|
||||
(put-bytevector archive-port body)
|
||||
(force-output archive-port)
|
||||
(invoke "unzip" "-q" archive-file "-d" dir))
|
||||
(let ((nuspec-files (find-files dir "\\.nuspec$")))
|
||||
(chmod (car nuspec-files) #o400) ; some have 000 (example: flurl)
|
||||
(if (null? nuspec-files)
|
||||
(begin
|
||||
(warning (G_ "No .nuspec file found in ~a~%") snupkg-url)
|
||||
#f)
|
||||
(call-with-input-file (car nuspec-files)
|
||||
(lambda (port)
|
||||
(let* ((sxml (xml->sxml port #:trim-whitespace? #t)))
|
||||
(car-safe
|
||||
(filter-map
|
||||
(lambda (node)
|
||||
(sxml-match node
|
||||
[(http://schemas.microsoft.com/packaging/2013/05/nuspec.xsd:repository
|
||||
(@ . ,attrs-raw)
|
||||
. ,_)
|
||||
(let ((attrs (map (lambda (attr)
|
||||
(cons (symbol->string (car attr))
|
||||
(cadr attr)))
|
||||
attrs-raw)))
|
||||
(if (or (assoc-ref attrs "url")
|
||||
(assoc-ref attrs "commit"))
|
||||
attrs
|
||||
#f))]
|
||||
[,otherwise #f]))
|
||||
((sxpath '(// http://schemas.microsoft.com/packaging/2013/05/nuspec.xsd:metadata
|
||||
http://schemas.microsoft.com/packaging/2013/05/nuspec.xsd:repository))
|
||||
sxml)))))))))))))
|
||||
(lambda (key . args)
|
||||
(warning (G_ "Failed to fetch or process snupkg file: ~a (Reason: ~a ~s)~%")
|
||||
snupkg-url key args)
|
||||
'()))))
|
||||
|
||||
(define (nuget-name->guix-name name)
|
||||
(string-downcase (string-append "dotnet-" (string-map (lambda (c)
|
||||
(if (char=? c #\.)
|
||||
#\-
|
||||
c))
|
||||
name))))
|
||||
|
||||
(define nuget->guix-package
|
||||
(memoize
|
||||
(lambda* (package-name #:key (repo 'nuget) (version #f) (license-prefix identity) #:allow-other-keys)
|
||||
"Fetch metadata for PACKAGE-NAME and return two values: the Guix package
|
||||
s-expression and a flat list of its dependency names (strings)."
|
||||
(let ((resolved-version (or version
|
||||
(nuget-find-best-version-for-range package-name
|
||||
"[0.0.0,)"))))
|
||||
(if (not resolved-version)
|
||||
(values #f '())
|
||||
(let ((entry (nuget-fetch-catalog-entry package-name resolved-version)))
|
||||
(if (not entry)
|
||||
(values #f '())
|
||||
(let* ((name (assoc-ref entry "id"))
|
||||
(guix-name (nuget-name->guix-name name))
|
||||
(description (assoc-ref entry "description"))
|
||||
(synopsis (or (assoc-ref entry "summary")
|
||||
description))
|
||||
(home-page (or (assoc-ref entry "projectUrl")
|
||||
(string-append "https://www.nuget.org/packages/" name)))
|
||||
(license (license-prefix (or (and=> (assoc-ref entry "licenseExpression")
|
||||
string->symbol)
|
||||
'unspecified)))
|
||||
;(repository (assoc-ref entry "repository"))
|
||||
(repository
|
||||
(let ((repo-from-catalog (assoc-ref entry "repository")))
|
||||
(if (and (list? repo-from-catalog)
|
||||
(let ((url (assoc-ref repo-from-catalog "url")))
|
||||
(and (string? url)
|
||||
;; For example <https://api.nuget.org/v3/catalog0/data/2023.03.08.07.46.17/newtonsoft.json.13.0.3.json>
|
||||
;; has "repository" "".
|
||||
(not (string-null? url))))
|
||||
(assoc-ref repo-from-catalog "commit"))
|
||||
repo-from-catalog
|
||||
(fetch-repo-info-from-snupkg name resolved-version))))
|
||||
(dependencies (delete-duplicates
|
||||
(flatten
|
||||
(filter-map
|
||||
(lambda (group)
|
||||
(map (lambda (dep) (assoc-ref dep "id"))
|
||||
(vector->list (or
|
||||
(assoc-ref group "dependencies")
|
||||
#()))))
|
||||
(or (and=> (assoc-ref entry "dependencyGroups")
|
||||
vector->list)
|
||||
'()))))))
|
||||
(let ((package-sexp
|
||||
`(package
|
||||
(name ,guix-name)
|
||||
(version ,resolved-version)
|
||||
(source
|
||||
,(if (and repository (assoc-ref repository "url")
|
||||
(assoc-ref repository "commit"))
|
||||
`(origin (method git-fetch)
|
||||
(uri (git-reference
|
||||
(url ,(assoc-ref repository "url"))
|
||||
(commit ,(assoc-ref repository "commit"))))
|
||||
(file-name (git-file-name ,guix-name ,resolved-version))
|
||||
(sha256 (base32 "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")))
|
||||
`(origin (method url-fetch)
|
||||
(uri "FIXME: No source URL found.")
|
||||
(sha256 (base32 "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")))))
|
||||
(build-system mono-build-system)
|
||||
,@(if (not (null? dependencies))
|
||||
`((inputs
|
||||
(list ,@(map (compose string->symbol nuget-name->guix-name)
|
||||
dependencies))))
|
||||
'())
|
||||
(home-page ,home-page)
|
||||
(synopsis ,synopsis)
|
||||
(description ,description)
|
||||
(license ,license))))
|
||||
(values package-sexp dependencies))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;
|
||||
;;; Part 3: Recursive Importer
|
||||
;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define* (nuget-recursive-import package-name #:key (repo 'nuget) version
|
||||
(license-prefix identity))
|
||||
"Recursively import PACKAGE-NAME and all its dependencies from NuGet. This
|
||||
procedure is a simple wrapper around the generic 'recursive-import' helper."
|
||||
(recursive-import package-name
|
||||
#:version version
|
||||
#:repo repo
|
||||
#:repo->guix-package nuget->guix-package
|
||||
#:guix-name nuget-name->guix-name
|
||||
#:license-prefix license-prefix))
|
||||
|
|
@ -51,7 +51,7 @@
|
|||
;; please keep this list alphabetically sorted!
|
||||
(define importers '("composer" "cpan" "cran" "crate" "egg" "elm" "elpa"
|
||||
"gem" "gnu" "go" "hackage" "hexpm" "json" "minetest"
|
||||
"npm-binary" "opam" "pypi" "stackage" "texlive"))
|
||||
"npm-binary" "nuget" "opam" "pypi" "stackage" "texlive"))
|
||||
|
||||
(define (resolve-importer name)
|
||||
(let ((module (resolve-interface
|
||||
|
|
|
|||
136
guix/scripts/import/nuget.scm
Normal file
136
guix/scripts/import/nuget.scm
Normal file
|
|
@ -0,0 +1,136 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
|
||||
;;; Copyright © 2015, 2017, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
|
||||
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
|
||||
;;;
|
||||
;;; 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 nuget)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (guix utils)
|
||||
#:use-module (guix scripts)
|
||||
#:use-module (guix import nuget)
|
||||
#:use-module (guix import utils)
|
||||
#:use-module (guix scripts import)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-37)
|
||||
#:use-module (srfi srfi-71)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 format)
|
||||
#:export (guix-import-nuget))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Command-line options.
|
||||
;;;
|
||||
|
||||
(define %default-options
|
||||
'())
|
||||
|
||||
(define (show-help)
|
||||
(display (G_ "Usage: guix import nuget PACKAGE-NAME
|
||||
Import and convert the NuGet package for PACKAGE-NAME.\n"))
|
||||
(display (G_ "
|
||||
-a, --archive=ARCHIVE specify the archive repository"))
|
||||
(display (G_ "
|
||||
-h, --help display this help and exit"))
|
||||
(display (G_ "
|
||||
-r, --recursive import packages recursively"))
|
||||
(display (G_ "
|
||||
-s, --style=STYLE choose output style, either specification or variable"))
|
||||
(display (G_ "
|
||||
-p, --license-prefix=PREFIX
|
||||
add custom prefix to licenses"))
|
||||
(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 nuget")))
|
||||
(option '(#\a "archive") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'repo (string->symbol arg)
|
||||
(alist-delete 'repo result))))
|
||||
(option '(#\s "style") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'style (string->symbol arg)
|
||||
(alist-delete 'style result))))
|
||||
(option '(#\p "license-prefix") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'license-prefix arg
|
||||
(alist-delete 'license-prefix result))))
|
||||
(option '(#\r "recursive") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'recursive #t result)))
|
||||
%standard-import-options))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Entry point.
|
||||
;;;
|
||||
|
||||
(define (guix-import-nuget . 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)))
|
||||
(prefix (assoc-ref opts 'license-prefix))
|
||||
(prefix-proc (if (string? prefix)
|
||||
(lambda (symbol)
|
||||
(string->symbol
|
||||
(string-append prefix (symbol->string symbol))))
|
||||
identity)))
|
||||
(match args
|
||||
((spec)
|
||||
(let ((name version (package-name->name+version spec)))
|
||||
(if (assoc-ref opts 'recursive)
|
||||
;; Recursive import
|
||||
(with-error-handling
|
||||
(map package->definition
|
||||
(filter identity
|
||||
(nuget-recursive-import name
|
||||
#:version version
|
||||
#:repo (or (assoc-ref opts 'repo) 'nuget)
|
||||
#:license-prefix prefix-proc))))
|
||||
;; Single import
|
||||
(let ((sexp (nuget->guix-package name
|
||||
#:version version
|
||||
#:repo (or (assoc-ref opts 'repo) 'nuget)
|
||||
#:license-prefix prefix-proc)))
|
||||
(unless sexp
|
||||
(leave (G_ "failed to download description for package '~a'~%")
|
||||
name))
|
||||
sexp))))
|
||||
(()
|
||||
(leave (G_ "too few arguments~%")))
|
||||
((many ...)
|
||||
(leave (G_ "too many arguments~%"))))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue