@@ -5,6 +5,7 @@
;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -32,6 +33,7 @@
#:use-module (guix discovery)
#:use-module (guix build-system)
#:use-module (guix gexp)
+ #:use-module (guix memoization)
#:use-module (guix store)
#:use-module (guix download)
#:use-module (gnu packages)
@@ -43,6 +45,8 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-41)
+ #:use-module (semver)
+ #:use-module (semver ranges)
#:export (factorize-uri
flatten
@@ -69,7 +73,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
@@ -257,13 +262,15 @@ package definition."
((package-inputs ...)
`((native-inputs (,'quasiquote ,package-inputs))))))
-(define (package->definition guix-package)
+(define* (package->definition guix-package #:optional (latest #t))
(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 latest
+ name
+ (string-append name "-" version)))
,guix-package))))
(define (build-system-modules)
@@ -414,3 +421,163 @@ dependencies."
step
;; initial state
(step initial-state)))
+
+(define* (recursive-import-semver #:key name
+ (version #f)
+ name->metadata
+ metadata->package
+ metadata-versions
+ package-dependencies
+ dependency-name
+ dependency-range
+ guix-name
+ make-sexp)
+ "Generates a stream of package expressions for the dependencies of the given
+NAME and VERSION. The dependencies will be resolved using semantic versioning.
+This procedure makes the assumption that most package repositories will, for a
+given package provide some <metadata> 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
+ VERSION - The version of the package to import
+ NAME->METADATA - A procedure that takes a NAME of a package and returns that
+package's <metadata>
+ METADATA->PACKAGE A procedure that takes a package's <metadata> and VERSION
+and returns the <package> for the given VERSION
+ METADATA-VERSIONS A procedure that that takes a packages <metadata> and
+returns a list of version as strings that are available for the given package
+ PACKAGE-DEPENDENCIES a procedure that returns a list of <dependency> given a
+<package>
+ DEPENDENCY-NAME A procedure that takes a <dependency> and returns the its name
+ DEPENDENCY-RANGE A procedure that takes a <dependency> 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 <metadata>, <package> and a list of pairs
+containing (EXPORT-NAME <dependency>), returning the package expression as an
+s-expression"
+ (define mem-name->metadata (memoize name->metadata))
+
+ (define (latest? versions version)
+ (equal? (car versions) version))
+
+ (define (sorted-versions metadata)
+ (sort (metadata-versions metadata) version>?))
+
+ (define (name->versions name)
+ (sorted-versions (mem-name->metadata name)))
+
+ (define (semver-range-contains-string? range version)
+ (semver-range-contains? range
+ (string->semver version)))
+
+ (define (guix-export-name name version)
+ (let ((versions (name->versions name))
+ (name (guix-name name)))
+ (if (latest? versions version)
+ name
+ (string-append name "-" version))))
+
+ ;; checks to see if we already defined or want to define a dep
+ (define (find-known name range known)
+ (match
+ (find
+ (match-lambda ((dep-name version)
+ (and
+ (string=? dep-name name)
+ (semver-range-contains-string? range version))))
+ known)
+
+ (#f #f)
+ ((name version) (list (guix-export-name name version) version #f)))
+ )
+
+ ;; searches searches for a package in guix
+ (define (find-locally name range)
+ (match
+ (find
+ (match-lambda ((_ _ package)
+ (semver-range-contains-string?
+ range
+ (package-version package))))
+ (find-packages-by-name*/direct (guix-name name)))
+ (#f #f)
+ ((_ export-symbol package) (list
+ (symbol->string export-symbol)
+ (package-version package) #f))))
+
+ ;; searches for a package in some external repo
+ (define (find-remote name range)
+ (let* ((versions (name->versions name))
+ (version (find
+ (lambda (ver)
+ (semver-range-contains-string? range ver))
+ versions))
+ (export-name (guix-export-name name version)))
+ `(,export-name ,version #t)))
+
+
+ (define (find-dep-version dep known-deps)
+ (let* ((name (dependency-name dep))
+ (range (string->semver-range (dependency-range dep)))
+ (export-name-version-needed
+ (or (find-known name range known-deps)
+ (find-locally name range)
+ (find-remote name range))))
+ `(,name ,@export-name-version-needed ,dep)
+ ))
+
+ (define (make-package-definition name version known-deps)
+ (let* ((metadata (mem-name->metadata name))
+ (versions (sorted-versions metadata))
+ (package (metadata->package metadata version))
+ (deps (map (lambda (dep)
+ (find-dep-version dep known-deps))
+ (package-dependencies package)))
+ (sexp
+ (make-sexp metadata package
+ (map
+ (match-lambda ((_ export-symbol _ _ dep)
+ (list export-symbol dep)))
+ deps))))
+ (values
+ (package->definition sexp (latest? versions version))
+ (filter-map
+ (match-lambda ((name _ version need? dep)
+ (if need?
+ (list name version)
+ #f)))
+ deps))))
+
+ (define initial-state
+ (list #f
+ (list
+ ;; packages to find
+ (list name (if version
+ version
+ (car (name->versions name)))))
+ ;; packages that have been found
+ (list)))
+
+ (define (step state)
+ (match state
+ ((prev ((next-name next-version) . rest) done)
+ (receive (package dependencies)
+ (make-package-definition next-name next-version
+ (append done rest `((,next-name ,next-version))))
+ (list
+ package
+ (append rest dependencies)
+ (cons (list next-name next-version) done))))
+ ((prev '() done)
+ (list #f '() done))))
+
+ (stream-unfold
+ ;; map: produce a stream element
+ (match-lambda ((latest queue done) latest))
+ ;; predicate
+ (match-lambda ((latest queue done) latest))
+ step
+ (step initial-state)))
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
+;;; Copyright © 2016 Martin Becze <mjbecze@riseup.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,6 +25,10 @@
#:use-module (guix packages)
#:use-module (guix build-system)
#:use-module (gnu packages)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-41)
#:use-module (srfi srfi-64))
(test-begin "import-utils")
@@ -120,4 +125,161 @@
("license" . #f))))
(package-native-inputs (alist->package meta))))
+(define-record-type <metadata>
+ (make-metadata name versions)
+ metadata?
+ (name metadata-name)
+ (versions metadata-versions))
+
+(define-record-type <package>
+ (make-package version dependencies)
+ package?
+ (version package-version)
+ (dependencies package-dependencies))
+
+(define-record-type <dependency>
+ (make-dependency name range)
+ dependency?
+ (name dependency-name)
+ (range dependency-range))
+
+(define (metadata-semver-versions metadata)
+ (map (lambda (p)
+ (package-version p))
+ (metadata-versions metadata)))
+
+(define (metadata->package metadata version)
+ (find
+ (lambda (package)
+ (equal? (package-version package) version))
+ (metadata-versions metadata)))
+
+(define (make-sexp metadata package dependencies)
+ `(package
+ (name ,(guix-name (metadata-name metadata)))
+ (version ,(package-version package))
+ (dependcies ,(map
+ (match-lambda ((public-name dep)
+ (list (guix-name (dependency-name dep)) public-name)))
+ dependencies))))
+
+(define (guix-name name)
+ (string-append "test-" name))
+
+(define packages
+ `(("no-deps" . (("1.0.0" . ()) ("0.1.0" . ())))
+ ("one-dep" . (("1.0.0" . (("no-deps" "^1.0")))
+ ("0.1.0" . (("no-deps" "^0.1.0")))))
+ ("shared-dep" . (("1.0.0" . (("one-dep" "^0.1.0")
+ ("no-deps" "*")))))
+ ("recursive" . (("1.0.0" . (("recursive" "=1.0.0")))))
+ ("already-packaged" . (("1.0.0" . (("rust" "~1.28")))))))
+
+(define (name->metadata name)
+ (let ((versions (assoc-ref packages name)))
+ (make-metadata name
+ (map
+ (match-lambda
+ ((version . deps)
+ (make-package version
+ (map
+ (lambda (name-range)
+ (apply make-dependency name-range))
+ deps))))
+ versions))))
+
+(define* (test-recursive-importer name version #:optional (guix-name guix-name))
+ (recursive-import-semver #:name name
+ #:version version
+ #:name->metadata name->metadata
+ #:metadata->package metadata->package
+ #:metadata-versions metadata-semver-versions
+ #:package-dependencies package-dependencies
+ #:dependency-name dependency-name
+ #:dependency-range dependency-range
+ #:guix-name guix-name
+ #:make-sexp make-sexp))
+
+(test-equal "recursive import test with no dependencies"
+ `((define-public test-no-deps
+ (package
+ (name "test-no-deps")
+ (version "1.0.0")
+ (dependcies ()))))
+ (stream->list (test-recursive-importer "no-deps" "1.0.0")))
+
+(test-equal "recursive import test with one dependencies"
+ `((define-public test-one-dep
+ (package
+ (name "test-one-dep")
+ (version "1.0.0")
+ (dependcies (("test-no-deps" "test-no-deps")))))
+ (define-public test-no-deps
+ (package
+ (name "test-no-deps")
+ (version "1.0.0")
+ (dependcies ()))))
+ (stream->list (test-recursive-importer "one-dep" "1.0.0")))
+
+(test-equal "recursive import test with recursuve dependencies"
+ `((define-public test-recursive
+ (package
+ (name "test-recursive")
+ (version "1.0.0")
+ (dependcies (("test-recursive" "test-recursive"))))))
+ (stream->list (test-recursive-importer "recursive" "1.0.0")))
+
+(test-equal "recursive import test with no dependencies using an old version"
+ `((define-public test-no-deps-0.1.0
+ (package
+ (name "test-no-deps")
+ (version "0.1.0")
+ (dependcies ()))))
+ (stream->list (test-recursive-importer "no-deps" "0.1.0")))
+
+(test-equal "recursive import test with one dependencies unsing an old version"
+ `((define-public test-one-dep-0.1.0
+ (package
+ (name "test-one-dep")
+ (version "0.1.0")
+ (dependcies (("test-no-deps" "test-no-deps-0.1.0")))))
+ (define-public test-no-deps-0.1.0
+ (package
+ (name "test-no-deps")
+ (version "0.1.0")
+ (dependcies ()))))
+ (stream->list (test-recursive-importer "one-dep" "0.1.0")))
+
+(test-equal "recursive import test with with dependency that is already in the repo"
+ `((define-public test-already-packaged
+ (package (name "test-already-packaged")
+ (version "1.0.0")
+ (dependcies
+ (("test-rust" "rust-1.28"))))))
+ (stream->list (test-recursive-importer "already-packaged" "1.0.0" identity)))
+
+(test-equal "shared dependencies"
+ `((define-public test-shared-dep
+ (package
+ (name "test-shared-dep")
+ (version "1.0.0")
+ (dependcies (("test-one-dep" "test-one-dep-0.1.0")
+ ("test-no-deps" "test-no-deps")))))
+ (define-public test-one-dep-0.1.0
+ (package
+ (name "test-one-dep")
+ (version "0.1.0")
+ (dependcies (("test-no-deps" "test-no-deps-0.1.0")))))
+ (define-public test-no-deps
+ (package
+ (name "test-no-deps")
+ (version "1.0.0")
+ (dependcies ())))
+ (define-public test-no-deps-0.1.0
+ (package
+ (name "test-no-deps")
+ (version "0.1.0")
+ (dependcies()))))
+ (stream->list (test-recursive-importer "shared-dep" "1.0.0")))
+
(test-end "import-utils")