From eeffdf569c4d7fbfd843e0b48404b6a2f3d46343 Mon Sep 17 00:00:00 2001 From: Martin Becze Date: Mon, 16 Dec 2019 17:08:16 -0500 Subject: [PATCH v5 1/4] guix: import: added recusive-import-semver * guix/import/utils.scm (recusive-import-semver): New Varible * guix/import/utils.scm (package->definition)[arguments]: Add append-verions option --- guix/import/utils.scm | 168 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 161 insertions(+), 7 deletions(-) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index d17d400ddf..7f75f50e23 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2017, 2019 Ricardo Wurmus ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2019 Robert Vollmert +;;; Copyright © 2019 Martin Becze ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,10 +41,13 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) + #:use-module (semver) + #:use-module (semver ranges) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #:export (factorize-uri flatten @@ -70,7 +74,8 @@ guix-name - recursive-import)) + recursive-import + recursive-import-semver)) (define (factorize-uri uri version) "Factorize URI, a package tarball URI as a string, such that any occurrences @@ -258,13 +263,13 @@ package definition." ((package-inputs ...) `((native-inputs (,'quasiquote ,package-inputs)))))) -(define (package->definition guix-package) +(define* (package->definition guix-package #:optional append-version?) (match guix-package - (('package ('name (? string? name)) _ ...) - `(define-public ,(string->symbol name) - ,guix-package)) - (('let anything ('package ('name (? string? name)) _ ...)) - `(define-public ,(string->symbol name) + ((or ('package ('name name) ('version version) . rest) + ('let _ ('package ('name name) ('version version) . rest))) + `(define-public ,(string->symbol (if append-version? + (string-append name "-" version) + version)) ,guix-package)))) (define (build-system-modules) @@ -428,3 +433,152 @@ name corresponding to the upstream name." (remove exists? (node-dependencies node)))) node-name))) + +(define* (recursive-import-semver #:key + name + (range "*") + name->metadata + metadata->package + metadata-versions + package-dependencies + dependency-name + dependency-range + guix-name + make-sexp) + "Generates a list of package expressions for the dependencies of the given +NAME and version RANGE. The dependencies will be resolved using semantic versioning. +This procedure makes the assumption that most package repositories will, for a +given package provide some on that package that includes what +versions of the package that are available and a list of dependencies for each +version. Dependencies are assumed to be composed of a NAME, a semantic RANGE and +other data. + +This procedure takes the following keys: + NAME - The name of the package to import + RANGE - The version range of the package to import + NAME->METADATA - A procedure that takes a NAME of a package and returns that +package's + METADATA->PACKAGE A procedure that takes a package's and VERSION +and returns the for the given VERSION + METADATA-VERSIONS A procedure that that takes a packages and +returns a list of version as strings that are available for the given package + PACKAGE-DEPENDENCIES a procedure that returns a list of given a + + DEPENDENCY-NAME A procedure that takes a and returns the its name + DEPENDENCY-RANGE A procedure that takes a and returns that +decency's range as a string + GUIX-NAME A procedure that take a NAME and returns the Guix version of it + MAKE-SEXP A procedure that takes , and a list of pairs +containing (EXPORT-NAME ), returning the package expression as an +s-expression" + (define-record-type + (make-node-dependency dependency version exists?) + node-dependency? + (dependency node-dependency-dependency) + (version node-dependency-version) + (exists? node-dependency-exists?)) + + (define-record-type + (make-node name version metadata package dependencies) + node? + (name node-name) + (version node-version) + (metadata node-metadata) + (package node-package) + (dependencies node-dependencies)) + + (define mem-name->metadata (memoize name->metadata)) + (define mem-package-dependencies (memoize package-dependencies)) + + (define (semver-range-contains-string? range version) + (semver-range-contains? range (string->semver version))) + + (define (name+version name version) + (string-append name "-" version)) + + (define (public-name name version) + "Given a NAME and a VERSION of a package, returns the name of the +symbol used is define-public" + (guix-name (name+version name version))) + + ;; searches searches for a package in guix + (define (find-locally name range) + (match (find + (lambda (package) + (semver-range-contains-string? + range + (package-version package))) + (find-packages-by-name (guix-name name))) + (#f #f) + (package (list (package-version package) #t)))) + + ;; searches for a package in some external repo + (define (find-remote name range) + (let* ((versions (sort + (metadata-versions + (mem-name->metadata name)) + version>?)) + (version (find + (lambda (ver) + (semver-range-contains-string? range ver)) + versions))) + (list version #f))) + + (define (find-by-name-range name range) + "Given a NAME, RANGE this will return a VERSION and BOOL which repesents +whether the package has been encountered or not." + (let ((semver-range (string->semver-range range))) + (apply values + (or (find-locally name semver-range) + (find-remote name semver-range))))) + + (define (make-package-definition node) + (let* ((metadata (node-metadata node)) + (package (node-package node)) + (dependencies ;; a list of (public-name dependency) + (map (lambda (node-dep) + (let* ((dep (node-dependency-dependency node-dep)) + (ver (node-dependency-version node-dep)) + (name (dependency-name dep))) + (list (public-name name ver) dep))) + (node-dependencies node))) + (sexp (make-sexp metadata package dependencies))) + (package->definition sexp #t))) + + (define (dependency->node-dependency dep) + (let* ((name (dependency-name dep)) + (range (dependency-range dep)) + (version exists? (find-by-name-range name range))) + (make-node-dependency dep version exists?))) + + (define (name-version->node name version) + (let* ((metadata (mem-name->metadata name)) + (package (metadata->package metadata version)) + (dependencies (mem-package-dependencies package)) + (node-dependencies (map (lambda (dep) + (dependency->node-dependency dep)) + dependencies))) + (make-node name version metadata package node-dependencies))) + + (define (node-dependency->node node-dependency) + (let* ((dependency (node-dependency-dependency node-dependency)) + (name (dependency-name dependency)) + (version (node-dependency-version node-dependency))) + (name-version->node name version))) + + (let ((version exists? (find-by-name-range name range))) + (if exists? + (display + (string-append "package " (name+version name version) " alread exists - ") + (current-error-port)) + (map make-package-definition + (topological-sort (list (name-version->node name version)) + (lambda (node) + (map (lambda (dep) + (node-dependency->node dep)) + (remove node-dependency-exists? + (node-dependencies node)))) + (lambda (node) + (name+version + (node-name node) + (node-version node)))))))) -- 2.24.1