diff options
| -rw-r--r-- | README | 108 | ||||
| -rw-r--r-- | guix-env.scm | 217 | ||||
| -rwxr-xr-x | pre-inst-env | 12 | ||||
| -rwxr-xr-x | pure-pre-inst-env | 3 | ||||
| -rw-r--r-- | pypi/api.scm | 62 | ||||
| -rw-r--r-- | pypi/build-configuration-graph.scm | 331 | ||||
| -rw-r--r-- | pypi/dependency-solver.scm | 475 | ||||
| -rw-r--r-- | pypi/logging.scm | 24 | ||||
| -rw-r--r-- | pypi/package.scm | 524 | ||||
| -rw-r--r-- | pypi/requirement.scm | 210 | ||||
| -rw-r--r-- | pypi/sdist-store.scm | 190 | ||||
| -rw-r--r-- | pypi/sdist-store/dependency-sets.scm | 66 | ||||
| -rw-r--r-- | pypi/sdist-store/import-master.scm | 401 | ||||
| -rw-r--r-- | pypi/sdist-store/import.scm | 720 | ||||
| -rw-r--r-- | pypi/sdist-store/utils.scm | 233 | ||||
| -rw-r--r-- | pypi/sdist.scm | 192 | ||||
| -rw-r--r-- | pypi/utils.scm | 24 | ||||
| -rw-r--r-- | pypi/version.scm | 18 | ||||
| -rw-r--r-- | solver/__init__.py | 184 |
19 files changed, 3994 insertions, 0 deletions
@@ -0,0 +1,108 @@ +Guix Python Package Utilities +============================= + +This library provides utilities for working with Python package indexes, or +PyPIs for short. + +It provides a generic framework, with which the contents of a PyPI can be +used from the Guix package manager. + +For example, the [Guix Python Integration Project][1] uses this library to +provide Guix packages for the contents of [pypi.org][2]. + +[1]: http://git.cbaines.net/guix-python-integration-project +[2]: https://pypi.org/ + +Implementation Details +---------------------- + +### sdist records + +The sdist record acts as a higher level representation of a set of Guix package +records. It is from this set of sdist records that a Guix package can be +generated for a specific version with a specific set of extras of the desired +software project. + +### Guix package generation + +A Guix package is a function of the following: + + - A sdist store + - The name and version of the sdist in the store, from which to create the + package + - A set of extras which can apply to this sdist + - A function, which takes a sdist and package, and can return a modified + version of the package (fix-function) + - A python package (e.g. python-3.4) (python) + +The fix-function should be used to adjust packages in ways which cannot be +represented by the sdist. For example, it can be used to unconditionally +disable the tests for a given sdist, or add a input from outside of the sdist +store. + +None of the inputs to the package returned by sdist->package should be used +directly. This is because they may have disabled test suites, or missing +propagated inputs as a result of breaking dependency loops when constructing +the package. sdist->package should just be called for each desired package. + +### Importer service + +*TODO:* Currently there is no importer service, but this describes how it could +work. + +The importer service keeps the repository up to date with the pypi.org Python +package index. It attempts to create sdist records for a given version of a +software project, and any packages in its dependency tree which do not have a +corresponding sdist record. + +This is quite complex, as the information for setup_requires, and tests_require +is inside the setup.py. They may differ depending on the environment in which +the setup.py is run, making it difficult to extract the metadata in a reliable +way. + +Due to current limitations described above with extracting information from +sdist archives, the importer service uses a number of strategies to create +sdist records, this is optimised for compatibility, while compromising speed. + +The steps are listed below: + + - pypi.org is queried to get the url for the sdist + - The sdist is downloaded and unpacked in a temporary directory + - The egg info metadata is read, which gives the version and install_requires + (including extras) + - An initial sdist record can now be constructed + - From this initial sdist record, a Guix package record is created if there + are inputs that are not present in the sdist store, these will be fetched + first (with this process) + - The package record is first built, first without running the tests + if the build fails, the log is read (through the use of regular expressions) + in an attempt to determine if the build failed due to a missing dependency, + if no match is found, the process stops, but if a missing dependency is + identified, this is added as a build requirement to the sdist, and the step + is attempted again. + - The package record is now built, but with the tests enabled. Like the + previous step, the logs are checked if the build fails, and any missing + requirements identified are added as test requirements to the sdist record. + - To confirm that it is possible to build the packages for all of the + combinations of extras, every possible combination is built. Again, the logs + for any build failure are analysed to determine missing sdist records + (*TODO:* This is disabled, as some projects, e.g. kombu have a large number + of extras). + +### Updater service + +*TODO:* There is currently no updater service. Its unclear how this could +relate to the import service should it exist. + +To reduce the possibility of packages failing to build, the versions of each +package in the dependency tree for an sdist are limited at the point at which +it is imported (as described int he previous section). The updater service is +used to bump when possible the version limits associated with an individual +sdist record. + +This involves raising all the limits to the latest versions for which there are +sdists available, while not violating the limits or requirements for any +propagated package in the dependency tree of the set of propagated packages. + +Inputs that are not propagated (inputs and native-inputs) are still subject to +the version limits, but only those of the corresponding sdist. diff --git a/guix-env.scm b/guix-env.scm new file mode 100644 index 0000000..eb188e3 --- /dev/null +++ b/guix-env.scm @@ -0,0 +1,217 @@ +(use-modules ((guix licenses) #:select (bsd-3 gpl3+ psfl)) + (guix packages) + (guix download) + (guix git-download) + (guix gexp) + (guix build-system gnu) + (guix build-system cmake) + (guix build-system python) + (guix build-system trivial) + (gnu packages python) + (gnu packages xml) + (gnu packages tls) + (gnu packages emacs) + (gnu packages package-management) + (gnu packages zip) + (gnu packages swig) + (gnu packages compression) + (gnu packages guile)) + +(define libsolv + (package + (name "libsolv") + (version "0.6.22") + (source (origin + (method url-fetch) + (uri (string-append "https://github.com/openSUSE/libsolv/archive/" + version ".tar.gz")) + (file-name (string-append name "-" version ".tar.gz")) + (modules '((guix build utils))) + (sha256 + (base32 + "0zl7dlqmib05y5f2wkbz66n68bmqk2fxhvph1dfr071v7jnzc6gf")) + (snippet + '(substitute* '("bindings/python/CMakeLists.txt") + (("EXECUTE_PROCESS.*") "") + (("libsolv ") "libsolv python2.7 ") + )))) + (build-system cmake-build-system) + (inputs + `(("expat" ,expat) + ("zlib" ,zlib) + ("python" ,python-2.7) + ("swig" ,swig))) + (arguments + '(#:configure-flags + (list (string-append "-DPYTHON_INSTALL_DIR=" + (assoc-ref %outputs "out") "/lib/python2.7/site-packages") + "-DENABLE_PYTHON=1" + (string-append ; uses lib64 by default + "-DLIB=lib") + (string-append "-DCMAKE_INSTALL_RPATH=" + (assoc-ref %outputs "out") "/lib")))) + ;(assoc-ref %outputs "out") "/lib:" + ;(assoc-ref %outputs "out") "/lib64")))) + (home-page "https://github.com/openSUSE/libsolv") + (synopsis "libsolv") + (description "") + (license bsd-3))) + +(define pyguile + (package + (name "pyguile") + (version "0.3.1") + (source (origin + (method git-fetch) + (uri (git-reference + (url "http://git.cbaines.net/pyguile") + (commit "HEAD"))) + (sha256 + (base32 + "037w1bf58yn4kfy5jydd1jzfi7dpg0m2w8p1sd2wnr6py03hybwq")))) + ;(source (origin + ; (method url-fetch) + ; (uri (string-append "https://github.com/cbaines/pyguile/archive/v" + ; version ".tar.gz")) + ; (file-name (string-append name "-" version ".tar.gz")) + ; (modules '((guix build utils))) + ; (sha256 + ; (base32 + ; "0ds5pnm4dc0vyfa5wlyw9dvzl6dyiizh4q8s153byyn8jkiimb5c")))) + (build-system cmake-build-system) + (inputs + `(("python" ,python-2.7) + ("guile" ,guile-2.0))) + (arguments + '(;#:tests? #f ; no tests + ;#:make-flags (list "CC=gcc" + ; (string-append "PREFIX=" %output)) + #:phases + (modify-phases %standard-phases + (delete 'configure) + (delete 'check) + (replace 'build + (lambda* (#:key outputs #:allow-other-keys) + ;(chdir "..") + (display "CWD ")(display (getcwd))(display "\n") + (let ((out (assoc-ref outputs "out"))) + (zero? + (system* "make" "CC=gcc"))))) + (replace + 'install + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (guild (string-append (assoc-ref %build-inputs "guile") + "/bin/guild")) + (scm-dir + (string-append out "/share/guile/site/2.0/")) + (scm-path + (string-append scm-dir "pyguile.scm")) + (lib-dir + (string-append out "/lib/")) + (lib-path + (string-append lib-dir "libpyguile.so"))) + (mkdir-p scm-dir) + (mkdir-p lib-dir) + (copy-file "pyguile.scm" scm-path) + (copy-file "libpyguile.so" lib-path) + (substitute* scm-path + (("libpyguile") + (string-append lib-dir "libpyguile"))) + (setenv "GUILE_AUTO_COMPILE" "0") + (unless (zero? + (system* guild "compile" scm-path + "-o" (string-append scm-dir "pyguile.go"))) + (error "failed to compile")) + #t)))))) + (home-page "https://github.com/tddpirate/pyguile") + (synopsis "pyguile") + (description "") + (license bsd-3))) + +(define python-packaging + (package + (name "python-packaging") + (version "16.7") + (source + (origin + (method url-fetch) + (uri (string-append + "https://pypi.python.org/packages/28/ad/4e6601d14b11bb300719a8bb6247f6ef5861467a692523c978a4e9e3981a/packaging-" + version + ".tar.gz")) + (sha256 + (base32 + "07h18mrpqs0lv2x4fl43pqi0xj6hdrmrnm6v9q634yliagg6q91f")))) + (build-system python-build-system) + (inputs + `(("python-setuptools" ,python-setuptools))) + (propagated-inputs + `(("python-pyparsing" ,python-pyparsing) + ("python-six" ,python-six))) + (home-page "https://github.com/pypa/packaging") + (synopsis "Core utilities for Python packages") + (description + "Core utilities for Python packages") + (license #f))) + +(define python2-packaging + (package-with-python2 python-packaging)) + +(define python-setuptools + (package + (name "python-setuptools") + (version "20.10.1") + (source + (origin + (method url-fetch) + (uri "https://pypi.python.org/packages/d3/16/21cf5dc6974280197e42d57bf7d372380562ec69aef9bb796b5e2dbbed6e/setuptools-20.10.1.tar.gz") + (sha256 + (base32 + "1pdm34rjixkdyp5j2yp774ri1da7ncqy8s34h4qxdl4yy22whn9y")))) + (build-system python-build-system) + ;; FIXME: Tests require pytest, which itself relies on setuptools. + ;; One could bootstrap with an internal untested setuptools. + (arguments + `(#:tests? #f)) + (home-page "https://pypi.python.org/pypi/setuptools") + (synopsis + "Library designed to facilitate packaging Python projects") + (description + "Setuptools is a fully-featured, stable library designed to facilitate +packaging Python projects, where packaging includes: +Python package and module definitions, +distribution package metadata, +test hooks, +project installation, +platform-specific details, +Python 3 support.") + (license psfl))) + +(define python2-setuptools + (package-with-python2 python-setuptools)) + +(define guix-pypi-utils + (package + (name "guix-pypi-utils") + (version "0.1") + (source (local-file "." #:recursive? #t)) + (build-system trivial-build-system) + (inputs + `(("unzip" ,unzip) + ("libsolv" ,libsolv) + ("guile" ,guile-2.0))) + (propagated-inputs + `(("guix" ,guix-0.11.0) + ("guile-lib" ,guile-lib) + ("guile-json" ,guile-json) + ("pyguile" ,pyguile) + ("python" ,python-2.7) + ("python2-setuptools" ,python2-setuptools) + ("python2-packaging" ,python2-packaging))) + (home-page "https://example.com") + (synopsis "guix-pypi-utils") + (description "") + (license gpl3+))) + +guix-pypi-utils diff --git a/pre-inst-env b/pre-inst-env new file mode 100755 index 0000000..cae58b0 --- /dev/null +++ b/pre-inst-env @@ -0,0 +1,12 @@ +#!/bin/sh + +GUILE_LOAD_PATH=".:../guix-python-intergration-project:$GUILE_LOAD_PATH" +export GUILE_LOAD_PATH + +GUIX_PACKAGE_PATH="$GUILE_LOAD_PATH" +export GUIX_PACKAGE_PATH + +GUILE_WARN_DEPRECATED="detailed" +export GUILE_WARN_DEPRECATED + +exec "$@" diff --git a/pure-pre-inst-env b/pure-pre-inst-env new file mode 100755 index 0000000..9ab3e82 --- /dev/null +++ b/pure-pre-inst-env @@ -0,0 +1,3 @@ +#!/bin/sh + +guix environment --pure -l guix-env.scm -- ./pre-inst-env "$@" diff --git a/pypi/api.scm b/pypi/api.scm new file mode 100644 index 0000000..9d884fb --- /dev/null +++ b/pypi/api.scm @@ -0,0 +1,62 @@ +(define-module (pypi api) + #:use-module (json) + #:use-module (logging logger) + #:use-module (web uri) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import utils) + #:use-module ((guix download) #:prefix download:) + #:use-module (guix import json) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix licenses) + #:use-module (guix build-system python) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (gnu packages python) + #:use-module (pypi version) + #:export (pypi-fetch + get-sdist-releases + available-versions)) + +(define pypi-fetch + (memoize + (lambda (name api-root) + (begin + (log-msg 'INFO (string-append "Fetching... " name)) + (let + ((data + (call-with-output-file "/dev/null" + (lambda (null) + (with-error-to-port (current-error-port) + (lambda () + (json-fetch (string-append api-root name "/json")))))))) + (if (eq? data #f) + (begin + (error (string-append "data from " api-root " is false")) + (sleep 2) + (pypi-fetch name api-root)) + data)))))) + +(define (available-versions name api-root) + (sort-versions + (map + car + (get-sdist-releases (pypi-fetch name api-root))))) + +(define (get-sdist-releases data) + (filter + (match-lambda + ((version . releases) + (> (length (car releases)) 0))) + (map + (match-lambda + ((version . releases) + (list + version + (filter + (lambda (r) (string=? "sdist" (assoc-ref r "packagetype"))) + releases)))) + (filter + (lambda (r) (> (length r) 1)) + (assoc-ref* data "releases"))))) diff --git a/pypi/build-configuration-graph.scm b/pypi/build-configuration-graph.scm new file mode 100644 index 0000000..02fc5cf --- /dev/null +++ b/pypi/build-configuration-graph.scm @@ -0,0 +1,331 @@ +(define-module (pypi build-configuration-graph) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (logging logger) + #:use-module (pyguile) + #:use-module (pypi requirement) + #:use-module (pypi sdist) + #:use-module (pypi sdist-store) + #:use-module (pypi package) + #:export (build-configuration-graph + build-configuration-graph? + build-configuration-graph-roots + build-configuration-graph-edges + + build-configuration + build-configuration? + build-configuration-sdist + build-configuration-extras + build-configuration-tests? + build-configuration-omitted-dependencies + + requirement-options + requirement-options? + requirement-options-type + requirement-options-requirement + requirement-options-options + + log-build-configuration-graph + + requirements->build-configuration-graph + + dependency-loop-can-be-broken-by-not-running-tests?)) + +(define-record-type <build-configuration-graph> + (build-configuration-graph + roots + edges) + build-configuration-graph? + (roots build-configuration-graph-roots) + (edges build-configuration-graph-edges)) + +(define-record-type <requirement-options> + (requirement-options + type + requirement + options) + requirement-options? + (type requirement-options-type) + (requirement requirement-options-requirement) + (options requirement-options-options)) + +(define-record-type <build-configuration> + (build-configuration + sdist + extras + tests? + omitted-dependencies) + build-configuration? + (sdist build-configuration-sdist) + (extras build-configuration-extras) + (tests? build-configuration-tests?) + (omitted-dependencies build-configuration-omitted-dependencies)) + +(define (requirements->build-configuration-graph + sdist-store + requirements) + (let + ((edges (make-hash-table)) + (roots + (map + (lambda (requirement) + (requirement-options + '() ; No type + requirement + (get-build-configurations-for-requirement + sdist-store + '() ; No dependant build configurations + requirement + #t + '()))) + requirements))) + (for-each + (lambda (requirement-options) + (for-each + (lambda (build-configuration) + (add-build-configuration-closure-to-graph! + sdist-store + build-configuration + '() + edges)) + (requirement-options-options requirement-options))) + roots) + (build-configuration-graph roots edges))) + +(define (requirement-options-for-sdist-requirements + sdist + sdist-store + run-tests + omitted-dependencies + dependant-build-configurations) + (concatenate + (map + (lambda (type requirements) + (map + (lambda (requirement) + (requirement-options + type + requirement + (get-build-configurations-for-requirement + sdist-store + dependant-build-configurations + requirement + run-tests + '()))) + (filter + (lambda (requirement) + (log-msg 'DEBUG "filtering requirements") + (log-msg 'DEBUG requirement) + (log-msg 'DEBUG omitted-dependencies) + (not (member (requirement-name requirement) + omitted-dependencies))) + requirements))) + '(build test install) + (list + (sdist-build-requires sdist) + (if run-tests + (sdist-tests-require sdist) + '()) + (sdist-install-requires sdist))))) + +(define (log-build-configuration-graph level graph) + (letrec + ((log-msg' + (lambda (msg . parts) + (if (null? level) + (begin + (for-each display (cons msg parts)) + (display "\n")) + (apply log-msg (cons level (cons msg parts)))))) + (log-requirement-options + (lambda (indent requirement-options) + (if (> indent 50) + (error "graph too deep")) + (log-msg' + (make-string (* 4 indent) #\space) + (requirement-name + (requirement-options-requirement + requirement-options))) + (for-each + (lambda (build-configuration) + (log-msg' + (make-string (+ 2 (* 4 indent)) #\space) + (sdist-short-description + (build-configuration-sdist build-configuration)) + " (tests? " (build-configuration-tests? build-configuration) ")") + (for-each + (lambda (requirement-options) + (log-requirement-options + (+ 1 indent) + requirement-options)) + (hash-ref + (build-configuration-graph-edges graph) + build-configuration))) + (requirement-options-options requirement-options))))) + (for-each + (lambda (requirement-options) + (log-requirement-options 0 requirement-options)) + (build-configuration-graph-roots graph)) + graph)) + +(define (sdist->build-configuration + sdist + dependant-build-configurations + extras + run-tests + omitted-dependencies) + (let + ((initial-build-configuration + (build-configuration + sdist + extras + run-tests + omitted-dependencies))) + (if (not (member + initial-build-configuration + dependant-build-configurations)) + initial-build-configuration + (if + (and + run-tests + (dependency-loop-can-be-broken-by-not-running-tests? + (reverse + (cons + initial-build-configuration + dependant-build-configurations)))) + (sdist->build-configuration + sdist + dependant-build-configurations + extras + #f + omitted-dependencies) + (let* + ((build-configuration-to-omit + (first dependant-build-configurations)) + (sdist-name + (pkg-info-name + (sdist-info + (build-configuration-sdist build-configuration-to-omit))))) + (if (not (member + sdist-name + omitted-dependencies)) + (sdist->build-configuration + sdist + dependant-build-configurations + extras + #f + (cons + sdist-name + omitted-dependencies)) + (begin + (log-dependency-loop dependant-build-configurations) + (error "Cannot solve build dependency issue")))))))) + +(define (log-dependency-loop + dependant-build-configurations) + (log-msg 'ERROR "Dependency loop:\n") + (for-each + (lambda (build-configuration) + (log-msg 'ERROR build-configuration "\n")) + (reverse dependant-build-configurations))) + +(define (add-build-configuration-closure-to-graph! + sdist-store + build-configuration + dependant-build-configurations + graph) + (if (not (hash-ref + graph + build-configuration)) + (let* + ((new-dependant-build-configurations + (cons build-configuration + dependant-build-configurations)) + (requirement-options-for-sdist + (requirement-options-for-sdist-requirements + (build-configuration-sdist build-configuration) + sdist-store + (build-configuration-tests? build-configuration) + (build-configuration-omitted-dependencies build-configuration) + new-dependant-build-configurations))) + (hash-set! + graph + build-configuration + requirement-options-for-sdist) + (for-each + (lambda (requirement-options) + (for-each + (lambda (build-configuration) + (add-build-configuration-closure-to-graph! + sdist-store + build-configuration + new-dependant-build-configurations + graph)) + (requirement-options-options + requirement-options))) + requirement-options-for-sdist)))) + +(define (dependency-loop-can-be-broken-by-not-running-tests? + dependant-build-configurations) + (let* + ((a (first dependant-build-configurations))) + (if (null? a) + #f + (let + ((b (if (null? (cdr dependant-build-configurations)) + '() + (second dependant-build-configurations)))) + (if (null? b) + #f + (or + (sdist-has-test-requirement-matching-normalised-requirement-name + a + (normalise-requirement-name + (pkg-info-name + (sdist-info + (build-configuration-sdist + b))))) + (dependency-loop-can-be-broken-by-not-running-tests? + (cdr dependant-build-configurations)))))))) + +(define (sdist-has-test-requirement-matching-normalised-requirement-name + sdist + normalised-requirement-name) + (any + (lambda (test-requirement) + (equal? normalised-requirement-name + (normalise-requirement-name + (requirement-name + test-requirement)))) + (sdist-tests-require + (build-configuration-sdist + sdist)))) + +(define (get-build-configurations-for-requirement + sdist-store + dependant-build-configurations + requirement + run-tests + omitted-dependencies) + (let + ((sdists + (get-sdists-by-version-meeting-requirement + sdist-store + requirement))) + (if (null? sdists) + (throw + unsatisfied-requirements-error + (list requirement)) + (map + (match-lambda + ((version . sdist) + (sdist->build-configuration + sdist + dependant-build-configurations + (requirement-extras requirement) + (and + run-tests + (requirement-run-tests requirement)) + omitted-dependencies))) + sdists)))) diff --git a/pypi/dependency-solver.scm b/pypi/dependency-solver.scm new file mode 100644 index 0000000..b4aa1f2 --- /dev/null +++ b/pypi/dependency-solver.scm @@ -0,0 +1,475 @@ +(define-module (pypi dependency-solver) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 hash-table) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (logging logger) + #:use-module (pyguile) + #:use-module (pypi requirement) + #:use-module (pypi sdist) + #:use-module (pypi sdist-store) + #:use-module (pypi build-configuration-graph) + #:use-module (pypi package) + #:export (generate-solver-hash-tables + solve-build-configuration-graph + get-scoped-releases-to-versions + + release + release? + release-name + release-version + + root-scope + + scope + scope? + scope-release + scope-parent + + scoped-release + scoped-release? + scoped-release-release + scoped-release-scope + + scoped-requirement + scoped-requirement? + scopred-requirement-requirement + scopred-requirement-scope)) + +(define root-scope '()) + +(define-record-type <release> + (release name version) + release? + (name release-name) + (version release-version)) + +(define (release->string r) + (string-join + (list + (normalise-requirement-name (release-name r)) + "@" + (release-version r)) + "")) + +(define-record-type <scope> + (scope release parent) + scope? + (release scope-release) + (parent scope-parent)) + +(define (scope->string s) + (if (null? s) + "" + (string-join + (list + "(" + (release->string (scope-release s)) + (if (null? (scope-parent s)) + "" + (string-join + (list + " -> " + (scope->string + (scope-parent s))) + "")) + ")") + ""))) + +(define (scope-tree-contains-release? r s) + (if (null? s) + #f + (or + (equal? + (scope-release s) + r) + (scope-tree-contains-release? + r + (scope-parent s))))) + +(define-record-type <scoped-release> + (scoped-release release scope) + scoped-release? + (release scoped-release-release) + (scope scoped-release-scope)) + +(define-record-type <scoped-build-configuration> + (scoped-release release scope) + scoped-release? + (release scoped-release-release) + (scope scoped-release-scope)) + +(define (scoped-release->string sr) + (string-join + (list + (release->string + (scoped-release-release sr)) + (if (null? (scoped-release-scope sr)) + "" + (string-join + (list + " " + (scope->string + (scoped-release-scope sr))) + ""))) + "")) + +(define-record-type <scoped-requirement> + (scoped-requirement requirement scope) + scoped-requirement? + (requirement scoped-requirement-requirement) + (scope scoped-requirement-scope)) + +(define (scoped-requirement->solver-package-name sr) + (string-append + (normalise-requirement-name + (requirement-name + (scoped-requirement-requirement sr))) + (if (null? (scoped-requirement-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-requirement-scope sr)))))) + +(define (scoped-release->solver-package-name sr) + (string-append + (normalise-requirement-name + (release-name (scoped-release-release sr))) + (if (null? (scoped-release-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-release-scope sr)))))) + +(define (scoped-build-configuration->solver-name sr) + (string-append + (normalise-requirement-name + (release-name (scoped-release-release sr))) + (if (null? (scoped-release-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-release-scope sr)))))) + +(define (scoped-requirement->solver-output-string sr) + (string-append + (normalise-requirement-name + (requirement-name + (scoped-requirement-requirement sr))) + (if (null? (scoped-requirement-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-requirement-scope sr)))))) + +(define (scoped-requirement->string sr) + (string-append + (requirement->string + (scoped-requirement-requirement sr)) + (if (null? (scoped-requirement-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-requirement-scope sr)))))) + +(define (build-configuration->release build-configuration) + (let* + ((sdist + (build-configuration-sdist build-configuration)) + (info (sdist-info sdist))) + (release + (pkg-info-name info) + (pkg-info-version info)))) + +(define (process-build-configuration! + build-configuration-graph + scoped-releases-to-scoped-requirements + result-string-to-requirement-options + current-scope build-configuration) + (let* + ((requirement-options-list + (hash-ref + (build-configuration-graph-edges build-configuration-graph) + build-configuration)) + (build-configuration-release + (build-configuration->release build-configuration)) + (build-configuration-scoped-release + (scoped-release + build-configuration-release + current-scope)) + (inner-scope + (scope + build-configuration-release + current-scope)) + (requirement-options-and-scopes + (map + (lambda (requirement-options) + (let* + ((type + (requirement-options-type requirement-options)) + (scope-for-requirement-options + (cond + ((member type '(() install)) + current-scope) + ((member type '(test build)) + inner-scope) + (else + (error "Unrecognised requirement type " type))))) + (cons requirement-options scope-for-requirement-options))) + requirement-options-list)) + (scoped-requirements + (map + (match-lambda + ((requirement-options . scope) + (let + ((sr + (scoped-requirement + (requirement-options-requirement + requirement-options) + scope))) + (hash-set! + result-string-to-requirement-options + (scoped-requirement->solver-output-string sr) + (cons + requirement-options + (or + (hash-ref + result-string-to-requirement-options + (scoped-requirement->solver-output-string sr)) + '()))) + sr))) + requirement-options-and-scopes))) + (if (hash-ref + scoped-releases-to-scoped-requirements + build-configuration-scoped-release) + (begin + (log-msg 'DEBUG "Duplicate scoped-release " build-configuration-scoped-release) + (log-msg 'DEBUG "existing: " (hash-ref scoped-releases-to-scoped-requirements build-configuration-scoped-release)) + (log-msg 'DEBUG "new: " scoped-requirements) + ;(error "Duplicate scoped-release") TODO: Check this + )) + (if (not (hash-ref scoped-releases-to-scoped-requirements + build-configuration-scoped-release)) + (hash-set! + scoped-releases-to-scoped-requirements + build-configuration-scoped-release + scoped-requirements)) + (for-each + (match-lambda + ((requirement-options . scope) + (for-each + (lambda (build-configuration) + (process-build-configuration! + build-configuration-graph + scoped-releases-to-scoped-requirements + result-string-to-requirement-options + scope + build-configuration)) + (requirement-options-options requirement-options)))) + requirement-options-and-scopes))) + +(define (generate-solver-hash-tables + build-configuration-graph) + (let + ((scoped-releases-to-scoped-requirements (make-hash-table)) + (result-string-to-requirement-options (make-hash-table))) + (for-each + (lambda (requirement-options) + (let + ((solver-name + (normalise-requirement-name + (requirement-name (requirement-options-requirement requirement-options))))) + (hash-set! + result-string-to-requirement-options + solver-name + (cons + requirement-options + (or + (hash-ref + result-string-to-requirement-options + solver-name) + '()))) + (for-each + (lambda (build-configuration) + (process-build-configuration! + build-configuration-graph + scoped-releases-to-scoped-requirements + result-string-to-requirement-options + root-scope + build-configuration)) + (requirement-options-options requirement-options)))) + (build-configuration-graph-roots build-configuration-graph)) + (log-msg 'DEBUG + "generate-solver-hash-tables result \n" + (string-join + (hash-map->list + (lambda (k v) + (string-join + (cons + (scoped-release->string k) + (map + (lambda (sr) + (string-append + " " + (scoped-requirement->string sr) + "\n")) + v)) + "\n")) + scoped-releases-to-scoped-requirements)) + "\n") + (values + scoped-releases-to-scoped-requirements + result-string-to-requirement-options))) + +(define (scoped-releases-to-scoped-requirements->string-to-scoped-releases + ht) + (hash-map->list + (lambda (scoped-release scoped-requirements) + (cons + (scoped-release->solver-package-name scoped-release) + scoped-release)) + ht)) + +(define (solve-build-configuration-graph + build-configuration-graph) + (receive (scoped-releases-to-scoped-requirements + result-string-to-requirement-options) + (generate-solver-hash-tables + build-configuration-graph) + (let* + ((requirements + (map + (lambda (requirement-options) + (requirement-options-requirement requirement-options)) + (build-configuration-graph-roots build-configuration-graph))) + (result + (get-versions-or-error + (hash-map->list + (lambda (scoped-release scoped-requirements) + (list + (scoped-release->solver-package-name scoped-release) + (release-version + (scoped-release-release scoped-release)) + (map + (lambda (sr) + (list + (scoped-requirement->solver-package-name sr) + (filter + (lambda (s) + (not (equal? s ""))) + (string-split + (requirement-specifiers + (scoped-requirement-requirement sr)) + #\,)))) + scoped-requirements))) + scoped-releases-to-scoped-requirements) + (concatenate + (map + (lambda (r) + (map + (lambda (s) + (string-append + (normalise-requirement-name (requirement-name r)) + s)) + (string-split + (requirement-specifiers r) + #\,))) + requirements))))) + (if (string? result) + (begin + (log-msg 'ERROR "Error during dependency resolution") + (hash-for-each + (lambda (s-release s-requirements) + (log-msg 'ERROR + (scoped-release->string s-release) ":") + (for-each + (lambda (s-requirement) + (log-msg 'ERROR " " (scoped-requirement->string s-requirement))) + s-requirements)) + scoped-releases-to-scoped-requirements) + (log-msg 'ERROR "Requirements:") + (for-each + (lambda (r) + (log-msg 'ERROR " " (requirement->string r))) + requirements) + (error result)) + (alist->hash-table + (concatenate + (map + (match-lambda + ((result-string version) + (log-msg 'DEBUG result-string " - " version) + (map + (lambda (requirement-options) + (cons requirement-options version)) + (or + (hash-ref + result-string-to-requirement-options + result-string) + (begin + (log-msg 'ERROR "|" result-string "| not found") + #f))))) + result))))))) + +(define (select-build-configuration-from-requirement-options + requirement-options + version) + (find + (lambda (build-configuration) + (equal? + version + (pkg-info-version + (sdist-info + (build-configuration-sdist build-configuration))))) + (requirement-options-options requirement-options))) + +(define (filter-build-configuration-graph + graph + requirement-options-to-version) + (build-configuration-graph + (map + (lambda (requirement-options) + (select-build-configuration-from-requirement-options + requirement-options + (hash-ref + requirement-options-to-version + requirement-options))) + (build-configuration-graph-roots graph)) + (alist->hash-table + (hash-map->list + (lambda (build-configuration requirement-options-list) + (cons + build-configuration + (map + (lambda (requirement-options) + (select-build-configuration-from-requirement-options + requirement-options + (hash-ref + requirement-options-to-version + requirement-options))) + requirement-options-list))) + (build-configuration-graph-edges graph))))) + +(define %solver-location "") + +(define (get-versions-or-error name-version-requirements overall-requirements) + (log-msg 'DEBUG "get-versions-or-error\n") + (if (not (string-null? %solver-location)) + (python-eval (string-append "import sys; sys.path.append(\"" %solver-location "\");"))) + (python-eval "from solver import get_versions_or_error") + (log-msg 'DEBUG "name-version-requirements\n") + (log-msg 'DEBUG name-version-requirements) + (log-msg 'DEBUG "\n") + (log-msg 'DEBUG "overall-requirements\n") + (log-msg 'DEBUG overall-requirements) + (log-msg 'DEBUG "\n") + (python-apply + '(solver get_versions_or_error) + (list name-version-requirements overall-requirements) + '())) diff --git a/pypi/logging.scm b/pypi/logging.scm new file mode 100644 index 0000000..bd02eb9 --- /dev/null +++ b/pypi/logging.scm @@ -0,0 +1,24 @@ +(define-module (pypi logging) + #:use-module (logging logger) + #:use-module (logging port-log) + #:use-module (oop goops) + #:export (setup-logging + shutdown-logging)) + +(define (setup-logging) + (let ((lgr (make <logger>)) + (err (make <port-log> #:port (current-error-port)))) + + (disable-log-level! err 'DEBUG) + ;(disable-log-level! err 'WARN) + ;(disable-log-level! err 'INFO) + + (add-handler! lgr err) + + (set-default-logger! lgr) + (open-log! lgr))) + +(define (shutdown-logging) + (flush-log) ;; since no args, it uses the default + (close-log!) ;; since no args, it uses the default + (set-default-logger! #f)) diff --git a/pypi/package.scm b/pypi/package.scm new file mode 100644 index 0000000..8cae990 --- /dev/null +++ b/pypi/package.scm @@ -0,0 +1,524 @@ +(define-module (pypi package) + #:use-module (logging logger) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-13) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 hash-table) + #:use-module (ice-9 pretty-print) + #:use-module (guix ui) + #:use-module (guix records) + #:use-module (guix combinators) + #:use-module (guix packages) + #:use-module (gnu packages zip) + #:use-module (guix build-system python) + #:use-module (guix download) + #:use-module (pypi sdist) + #:use-module (pypi sdist-store) + #:use-module (pypi requirement) + #:use-module (pypi dependency-solver) + #:use-module (pypi build-configuration-graph) + #:use-module (guix utils) + #:export (<package-configuration> + package-configuration + package-configuration? + package-configuration-fix-function + package-configuration-python + + requirement->package + requirements->package + + build-configuration-graph->packages + + unsatisfiable-requirements + unsatisfiable-requirements? + get-unsatisfiable-requirements)) + +(define-record-type <package-configuration> + (package-configuration python fix-function) + package-configuration? + (python package-configuration-python) + (fix-function package-configuration-fix-function)) + +(define-record-type <unsatisfiable-requirements> + (unsatisfiable-requirements requirements) + unsatisfiable-requirements? + (requirements get-unsatisfiable-requirements)) + +(define (requirement-options->package + graph + package-configuration + requirement-options-to-versions + requirement-options) + (let + ((build-configuration + (select-build-configuration-from-requirement-options + requirement-options + (or + (hash-ref + requirement-options-to-versions + requirement-options) + (begin + (log-build-configuration-graph 'ERROR graph) + (error "Missing version error for " requirement-options)))))) + (receive (native-inputs inputs propagated-inputs) + (get-inputs + graph + package-configuration + requirement-options-to-versions + (hash-ref + (build-configuration-graph-edges graph) + build-configuration)) + (build-configuration->package + package-configuration + (if (string-contains + (origin-uri + (sdist-source + (build-configuration-sdist build-configuration))) + ".zip") + (cons + `("unzip" ,unzip) + native-inputs) + native-inputs) + inputs + propagated-inputs + build-configuration)))) + +(define (debug-package package) + (log-msg 'DEBUG (package-name package) "@" (package-version package)) + (log-msg 'DEBUG (package-native-inputs package)) + (log-msg 'DEBUG (package-inputs package)) + (log-msg 'DEBUG (package-propagated-inputs package)) + (if (null? (origin-patch-guile (package-source package))) + (error "null patch-guile in own package")) + package) + +(define build-configuration->package + (memoize + (lambda (package-configuration + native-inputs + inputs + propagated-inputs + build-configuration) + (let* + ((sdist (build-configuration-sdist build-configuration)) + (info (sdist-info sdist))) + ((package-configuration-fix-function package-configuration) + sdist + (package + (name (generate-package-name build-configuration)) + (version (pkg-info-version info)) + (source (sdist-source sdist)) + (build-system python-build-system) + (native-inputs native-inputs) + (inputs inputs) + (propagated-inputs propagated-inputs) + (arguments + (append + `(#:python ,(package-configuration-python + package-configuration)) + (if (build-configuration-tests? build-configuration) + '() + `(#:tests? #f)))) + (home-page "") + (synopsis "") + (description (pkg-info-name info)) + (license "") + (properties + `((sdist . ,sdist) + (build-configuration . ,build-configuration))))))))) + +(define (select-build-configuration-from-requirement-options + requirement-options + version) + (or + (find + (lambda (build-configuration) + (equal? + version + (pkg-info-version + (sdist-info + (build-configuration-sdist build-configuration))))) + (requirement-options-options requirement-options)) + (begin + (log-msg 'ERROR "select-build-configuration-from-requirement-options") + (log-msg 'ERROR "version: " version) + (for-each + (lambda (build-configuration) + (let + ((info (sdist-info (build-configuration-sdist build-configuration)))) + (log-msg 'ERROR " " (pkg-info-name info) "@" (pkg-info-version info)))) + (requirement-options-options requirement-options)) + (error "Could not find build-configuration matching version")))) + +(define (get-inputs + graph + package-configuration + requirement-options-to-versions + input-requirement-options) + (apply + values + (map + (lambda (type) + (packages->input-list + (map + (lambda (requirement-options) + (requirement-options->package + graph + package-configuration + requirement-options-to-versions + requirement-options)) + (filter + (lambda (requirement-options) + (eq? type (requirement-options-type requirement-options))) + input-requirement-options)))) + '(build test install)))) + +(define (build-configuration-graph->packages + graph + package-configuration + requirement-options-to-versions) + (map + (lambda (requirement-options) + (requirement-options->package + graph + package-configuration + requirement-options-to-versions + requirement-options)) + (build-configuration-graph-roots graph))) + +(define (requirements->packages + package-configuration + sdist-store + requirements) + (let + ((build-configuration-graph + (requirements->build-configuration-graph + sdist-store + requirements))) + (log-build-configuration-graph 'DEBUG build-configuration-graph) + (let + ((requirement-options-to-versions + (solve-build-configuration-graph + build-configuration-graph))) + (build-configuration-graph->packages + build-configuration-graph + package-configuration + requirement-options-to-versions)))) + +(define (requirement->package + package-configuration + sdist-store + requirement) + (first + (requirements->packages + package-configuration + sdist-store + (list requirement)))) + +(define (memorise-input->package f) + (lambda args + (let* + ((key (list-head args 4)) + (store (second key)) + (store-list (get-sdist-list store))) + + (list-set! key 1 store-list) + (let + ((results (hash-ref input->package-cache key))) + (if results + (apply values results) + (let ((results (call-with-values (lambda () + (apply f args)) + list))) + (hash-set! input->package-cache key results) + (apply values results))))))) + +(define (get-inputs-for-input-requirements ipt dependants dependant-requirements store) + (receive (native-input-requirements + input-requirements + propagated-input-requirements) + (partition-requirements ipt) + (let* + ((new-dependant-requirements + (apply + lset-adjoin + (append + (list equal? propagated-input-requirements) + dependant-requirements))) + (native-input-sdists-and-extras + (get-inputs-for-requirements + store + native-input-requirements + new-dependant-requirements)) + (input-sdists-and-extras + (get-inputs-for-requirements + store + input-requirements + new-dependant-requirements)) + (propagated-input-sdists-and-extras + (get-inputs-for-requirements + store + propagated-input-requirements + new-dependant-requirements)) + (unsatisfied-requirements + (filter + requirement? + (append native-input-sdists-and-extras + input-sdists-and-extras + propagated-input-sdists-and-extras)))) + (values + native-input-sdists-and-extras + input-sdists-and-extras + propagated-input-sdists-and-extras + unsatisfied-requirements + new-dependant-requirements)))) + +(define (get-input-inputs ipt fix-function python dependants dependant-requirements store) + (receive (native-input-inputs + input-inputs + propagated-input-inputs + unsatisfied-requirements + new-dependant-requirements) + (get-inputs-for-input-requirements ipt dependants dependant-requirements store) + (if (not (null? unsatisfied-requirements)) + (throw + unsatisfied-requirements-error + unsatisfied-requirements) + (values + ; native-inputs + (append + (packages->input-list + (input-requirements->packages + ipt + fix-function + python + dependants + new-dependant-requirements + native-input-inputs + store + #f)) + (if (string-contains + (origin-uri (sdist-source (input-sdist ipt))) + ".zip") + `(("unzip" ,unzip)) + '())) + ; inputs + (packages->input-list + (input-requirements->packages + ipt + fix-function + python + dependants + new-dependant-requirements + input-inputs + store + #t)) + ; propagated-inputs + (packages->input-list + (input-requirements->packages + ipt + fix-function + python + dependants + new-dependant-requirements + propagated-input-inputs + store + #t)))))) + +(define (generate-package-name build-configuration) + (let* ((sd (build-configuration-sdist build-configuration)) + (info (sdist-info sd))) + (string-append + (pkg-info-name info) + (if (null? (build-configuration-extras build-configuration)) + "" + (string-append + "+" + (string-join + (stable-sort + (build-configuration-extras build-configuration) + string<?) + "+"))) + (if (build-configuration-tests? build-configuration) + "" + "-no-tests")))) + +(define input->package + (memorise-input->package + ; A package is a function of an sdist, and a list of extras + ; dependants is used to detect dependency loops + (lambda (ipt store fix-function python dependants dependant-requirements) + (let* ((sd (input-sdist ipt)) + (info (sdist-info sd))) + (receive (native-inputs + inputs + propagated-inputs) + (get-input-inputs ipt fix-function python dependants dependant-requirements store) + (fix-function + sd + (package + (name (generate-package-name ipt)) + (version (pkg-info-version info)) + (source (sdist-source sd)) + (build-system python-build-system) + (native-inputs native-inputs) + (inputs inputs) + (propagated-inputs propagated-inputs) + (arguments + (append + `(#:python ,python) + (if (input-run-tests ipt) + '() + `(#:tests? #f)))) + (home-page "") + (synopsis "") + (description (pkg-info-name info)) + (license "") + (properties + `((sdist . ,sd)))))))))) + +(define (input-requirement->package ipt req-input fix-function python dependants dependant-requirements store) + (if (not (dependency-loop? req-input dependants)) + ; no dependency loop detected, so just continue + (input->package + req-input + store + fix-function + python + (cons + ipt + dependants) + dependant-requirements) + ; this package is a dependency on req-input already, so try + ; building it without tests + (let + ((req-input-no-tests + (input + (inherit req-input) + (run-tests #f)))) + (if (not (dependency-loop? req-input-no-tests dependants)) + (input->package + req-input-no-tests + store + fix-function + python + (cons + ipt + dependants) + dependant-requirements) + ; Building without tests has been tried already, and the loop is + ; still present, so try omitting the dependency entirely + (let + ((req-input-no-tests-no-prop + (input + (inherit req-input) + (run-tests #f) + (allow-missing-dependencies + ; Add the current input, but without the allow-missing-dependencies + ; as this is not relevant when deciding what to ignore + (cons (input + (inherit ipt) + (allow-missing-dependencies '())) + (input-allow-missing-dependencies ipt)))))) + (if (and + (not (dependency-loop? + req-input-no-tests-no-prop dependants)) + (not (> (length (input-allow-missing-dependencies ipt)) 4))) + (input->package + req-input-no-tests-no-prop + store + fix-function + python + (cons + ipt + dependants) + dependant-requirements) + (begin + (explain-dependency-loop ipt dependants req-input) + (error "dependency loop detected\n")))))))) + +(define (inputs-equivalent? ipt1 ipt2) + (let* + ((sd1 (input-sdist ipt1)) + (sd2 (input-sdist ipt2)) + (info1 (sdist-info sd1)) + (info2 (sdist-info sd2))) + (and + (equal? (pkg-info-name info1) + (pkg-info-name info2)) + (equal? (pkg-info-version info1) + (pkg-info-version info2))))) + +(define (input-requirements->packages ipt fix-function python dependants dependant-requirements inputs store do-filter) + (log-msg 'DEBUG "input-requirements->packages " (input-short-description ipt)) + (map + (lambda (requirement-ipt) + (input-requirement->package ipt + requirement-ipt + fix-function + python + dependants + dependant-requirements + store)) + ; Filter out any dependencies that are being ignored for this input. + ; If this happens, this is a partial package, being used to break a dependency + ; loop. + (if do-filter + (filter + (lambda (requirement-ipt) + (let* + ((allow-missing (input-allow-missing-dependencies ipt)) + (result + (not + (find + (lambda (ipt2) + (inputs-equivalent? requirement-ipt ipt2)) + allow-missing)))) + (log-msg 'DEBUG + "considering " + (input-short-description requirement-ipt) + " in " (map input-short-description allow-missing) " " result) + result)) + inputs) + inputs))) + +(define input->package-cache (make-hash-table)) + +(define (packages->input-list packages) + (map (lambda (package) + (list (package-name package) package)) + packages)) + +(define (dependency-loop? ipt dependants) + (member ipt dependants)) + +(define (partition-requirements ipt) + ; propagated-inputs-requirements is the install_requirements + ; native-inputs is the + ; (differece + ; (union + ; build requirements + ; test requirements) + ; install_requirements) + (let* + ((sd (input-sdist ipt)) + (propagated-input-requirements + (filter-requirements-by-extras + (sdist-install-requires sd) + (input-extras ipt))) + (native-input-requirements + (lset-difference + equal? + (lset-union + equal? + (sdist-build-requires sd) + (if (input-run-tests ipt) + (sdist-tests-require sd) + '())) + propagated-input-requirements))) + (values + native-input-requirements + '() + propagated-input-requirements))) diff --git a/pypi/requirement.scm b/pypi/requirement.scm new file mode 100644 index 0000000..fc1bb87 --- /dev/null +++ b/pypi/requirement.scm @@ -0,0 +1,210 @@ +(define-module (pypi requirement) + #:use-module (pyguile) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-13) + #:use-module (ice-9 pretty-print) + #:use-module (guix records) + #:use-module (guix combinators) + #:use-module (pypi version) + #:export (requirement + requirement? + requirement-name + requirement-specifiers + requirement-extras + requirement-markers + requirement-run-tests + + unsatisfied-requirements-error + normalise-requirement-name + requirement-satisfied-by? + + requirement->string + + get-quoted-requirement + version-meets-requirement + get-version-best-matching-requirement + + requirement-string->requirement + requirement-tuple->quoted-requirement + requirement-tuple->requirement + requirement-string->quoted-requirement + filter-requirements-by-extras)) + +(define unsatisfied-requirements-error 'unsatisfied-requirements-error) + +(define-record-type* <requirement> + requirement make-requirement + requirement? + (name requirement-name) + (specifiers requirement-specifiers (default "")) + (extras requirement-extras (default '())) + (markers requirement-markers (default '())) + (run-tests requirement-run-tests (default #t))) + +(set-record-type-printer! <requirement> + (lambda (record port) + (display (requirement->string record) port))) + +(define (get-quoted-requirement r) + (fold + (lambda (f d) (f d)) + `(requirement + (name ,(requirement-name r))) + `(,(lambda + (d) + (if (string-null? (requirement-specifiers r)) + d + (append d `((specifiers ,(requirement-specifiers r)))))) + ,(lambda + (d) + (if (null? (requirement-extras r)) + d + (append d `((extras (quote ,(requirement-extras r))))))) + ,(lambda + (d) + (if (null? (requirement-markers r)) + d + (append d `((markers (quote ,(requirement-markers r)))))))))) + +(define (requirement-satisfied-by? r name version) + (and + (equal? + (normalise-requirement-name name) + (normalise-requirement-name (requirement-name r))) + (version-meets-requirement r version))) + +(define (version-meets-requirement r version) + (begin + (python-import "packaging.requirements") + (python-import "packaging.version") + (let* ((contains (python-eval "lambda r, v: r.specifier.contains(v)" #t)) + (pyr (python-apply '(packaging requirements Requirement) + (list + (string-append + (requirement-name r) + (requirement-specifiers r))) + '())) + (pyv (python-apply '(packaging version parse) + (list version) + '())) + (result + (python-apply (list contains) (list pyr pyv) '()))) + result))) + +(define (get-version-best-matching-requirement r versions) + (find + (lambda (v) (version-meets-requirement r v)) + (sort-versions versions))) + +(define (filter-versions-by-requirement r versions) + (filter + (lambda (v) (version-meets-requirement r v)) + versions)) + +(define (filter-requirements-by-extras reqs extras) + (filter (lambda (r) + (if (> (length (requirement-extras r)) 0) + ; If an extra is specified in the requirement, only + ; include the dependency if a matching extra is given + (> (length (lset-intersection equal? + extras + (requirement-extras r))) + 0) + #t)) ; If the requirement does not specify extras, it is valid regardless + reqs)) + +(define (requirement-tuple->quoted-requirement t) + (requirement->quoted-requirement + (requirement-tuple->requirement t))) + +(define (validate-requirement r) + (or + (string? (requirement-name r)) + (error "requirement name is not a string " (requirement-name r))) + (or + (list? (requirement-markers r)) + (error "requirement markers are not a list " (requirement-markers r))) + (or + (list? (requirement-extras r)) + (error "requirement extras are not a list " (requirement-extras r))) + r) + +(define (requirement-tuple->requirement t) + (validate-requirement + (requirement + (name (first t)) + (specifiers (second t)) + (extras (third t)) + (markers (fourth t))))) + +(define (requirement->string r) + (string-append + (requirement-name r) + (if (null? (requirement-extras r)) + "" + (apply + string-append + (list + "[" + (string-join + (requirement-extras r) + ",") + "]"))) + (requirement-specifiers r))) + +(define (requirement-string->quoted-requirement requirement-string) + (requirement->quoted-requirement + (requirement-string->requirement + requirement-string))) + +(define (requirement->quoted-requirement r) + `(requirement + (name ,(requirement-name r)) + (specifiers ,(requirement-specifiers r)) + (extras ,(requirement-extras r)) + (markers ,(requirement-markers r)))) + +(define (requirement-string->requirement requirement-string) + (begin + (python-import "packaging.requirements") + (python-import "packaging.version") + (let* ((pyr (python-apply '(packaging requirements Requirement) + (list requirement-string) + '())) + (name (python-apply '("__builtin__" "getattr") + (list pyr "name") + '())) + (specifier (python-apply '("__builtin__" "getattr") + (list pyr "specifier") + '())) + (specifiers (python-apply '("__builtin__" "str") + (list specifier) + '())) + (extras (let + ((f (python-eval "lambda pyr: list(pyr.extras)" #t))) + (python-apply + f + (list pyr) + '()))) + (markers (python-apply '("__builtin__" "getattr") + (list pyr "marker") + '()))) + (validate-requirement + (requirement + (name name) + (specifiers specifiers) + (extras extras) + (markers markers)))))) + +(define normalise-requirement-name + (memoize + (lambda (name) + (python-eval "from pkg_resources import to_filename, safe_name") + (let* + ((f (python-eval + "lambda n: to_filename(safe_name(n))" + #t))) + (string-downcase + (python-apply f (list name) '())))))) diff --git a/pypi/sdist-store.scm b/pypi/sdist-store.scm new file mode 100644 index 0000000..f1e0277 --- /dev/null +++ b/pypi/sdist-store.scm @@ -0,0 +1,190 @@ +(define-module (pypi sdist-store) + #:use-module (logging logger) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (ice-9 hash-table) + #:use-module (ice-9 pretty-print) + #:use-module (guix ui) + #:use-module (guix packages) + #:use-module (guix build utils) + #:use-module (guix download) + #:use-module (pypi sdist) + #:use-module (pypi version) + #:use-module (pypi requirement) + #:export (make-sdist-store + add-sdist + add-sdists + get-sdist + get-sdists + get-sdist-list + get-sdists-by-version-meeting-requirement + get-sdist-best-matching-requirement + get-sdist-best-matching-requirements + store-can-satisfy-requirement? + log-sdist-store + create-sdists-module)) + +(define (vhash-set key value vhash) + (vhash-cons + key + value + (vhash-delete + key + vhash))) + +(define (make-sdist-store) + vlist-null) + +(define (add-sdist store sd) + (let* + ((info (sdist-info sd)) + (name (normalise-requirement-name (pkg-info-name info))) + (version (pkg-info-version info)) + (versions + (vhash-assoc + (normalise-requirement-name name) + store))) + (vhash-set + name + (vhash-set + version + sd + (if versions + (cdr versions) + vlist-null)) + store))) + +(define (log-sdist-store level sdist-store) + (for-each + (match-lambda + ((name . versions) + (log-msg level name ":") + (for-each + (match-lambda + ((version . sdist) + (log-msg level " " version))) + (vlist->list versions)))) + (vlist->list sdist-store))) + +(define (add-sdists store sds) + (fold + (lambda (sd store) + (add-sdist store sd)) + store + sds)) + +(define (get-sdists store name) ; TODO: Change this, as it does not get sdists (instead it gets an alist) + (let + ((p + (vhash-assoc (normalise-requirement-name name) store))) + (if p + (vlist->list (cdr p)) + '()))) + +(define (get-sdists-by-version-meeting-requirement sdist-store requirement) + (filter + (match-lambda + ((version . sd) + (sdist-meets-requirement sd requirement))) + (get-sdists sdist-store (requirement-name requirement)))) + +(define (get-sdist store name version) + (assoc-ref + (get-sdists store name) + version)) + +(define (sort-version-alist al) + (let* + ((versions (map car al)) + (sorted-versions (sort-versions versions))) + (map + (lambda (version) + (cons version (assoc-ref al version))) + sorted-versions))) + + +(define (get-sdist-list store) + (apply + append + (map + cdr + (stable-sort + (vlist->list + (vlist-map + (match-lambda + ((name . versions) + (cons + name + (map cdr + (sort-version-alist + (vlist->list versions)))))) + store)) + (lambda (x y) + (string<? (car x) (car y))))))) + + +(define (create-sdists-module store module path) + (call-with-output-file + path + (lambda (port) + (pretty-print + `(define-module ,module + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build utils) + #:use-module (pypi sdist) + #:use-module (pypi requirement)) + port) + (pretty-print + `(define-public + sdists + ,(append + '(list) + (map get-quoted-sdist (get-sdist-list store)))) + port)))) + +(define (store-can-satisfy-requirement? store r) + (get-sdist-best-matching-requirement store r)) + +(define (get-sdist-best-matching-requirement store r) + (get-sdist-best-matching-requirements store (list r))) + +(define (get-sdist-best-matching-requirements store requirements) + (let* + ((unique-names + (apply + lset-adjoin + (append + (list equal? '()) + (map (lambda (r) (normalise-requirement-name + (requirement-name r))) + requirements)))) + (normalised-name (first unique-names))) + (if (not (eq? 1 (length unique-names))) + (error "Not all requirements are for the name package" + requirements)) + (let ((sorted-suitable-versions + (let* + ((sdists (filter + (lambda (sd) + (every + (lambda (r) + (sdist-meets-requirement sd r)) + requirements)) + (map cdr (get-sdists store normalised-name)))) + (sdists-and-versions + (map + (lambda (sd) (cons (pkg-info-version (sdist-info sd)) sd)) + sdists)) + (sorted-versions + (sort-versions (map car sdists-and-versions)))) + (map + (lambda (v) (assoc-ref sdists-and-versions v)) + sorted-versions)))) + (if (> (length sorted-suitable-versions) 0) + (first sorted-suitable-versions) + #f)))) diff --git a/pypi/sdist-store/dependency-sets.scm b/pypi/sdist-store/dependency-sets.scm new file mode 100644 index 0000000..d8fb920 --- /dev/null +++ b/pypi/sdist-store/dependency-sets.scm @@ -0,0 +1,66 @@ +(define-module (pypi sdist-store dependency-sets) + #:use-module (srfi srfi-9) + #:use-module (ice-9 vlist) + #:export (make-dependency-sets-record + add-dependency-set + remove-dependency-set + dependency-sets->list + get-dependency-set-keys-matching + get-dependency-set-keys + get-dependency-set)) + +(define-record-type <dependency-sets> + (new-dependency-sets-record vhash next-key) + dependency-sets-record? + (vhash dependency-sets-vhash) + (next-key dependency-sets-next-key)) + +(define (make-dependency-sets-record) + (new-dependency-sets-record + vlist-null + 0)) + +(define (add-dependency-set dependency-sets entry) + (let ((key (dependency-sets-next-key dependency-sets))) + (new-dependency-sets-record + (vhash-consq + key + entry + (dependency-sets-vhash dependency-sets)) + (+ key 1)))) + +(define (remove-dependency-set dependency-sets key) + (new-dependency-sets-record + (vhash-delq + key + (dependency-sets-vhash dependency-sets)) + (dependency-sets-next-key dependency-sets))) + +(define (dependency-sets->list proc dependency-sets) + (vhash-fold + (lambda (key value result) + (cons + (proc key value) + result)) + '() + (dependency-sets-vhash dependency-sets))) + +(define (get-dependency-set-keys-matching dependency-sets proc) + (vhash-fold + (lambda (key value result) + (if (proc value) + (cons key result) + result)) + '() + (dependency-sets-vhash dependency-sets))) + +(define (get-dependency-set-keys dependency-sets) + (vhash-fold + (lambda (key value result) + (cons key result)) + '() + (dependency-sets-vhash dependency-sets))) + +(define (get-dependency-set dependency-sets key) + (cdr + (vhash-assq key (dependency-sets-vhash dependency-sets)))) diff --git a/pypi/sdist-store/import-master.scm b/pypi/sdist-store/import-master.scm new file mode 100644 index 0000000..b55e415 --- /dev/null +++ b/pypi/sdist-store/import-master.scm @@ -0,0 +1,401 @@ +(define-module (pypi sdist-store import-master) + #:use-module (pyguile) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 ftw) + #:use-module (ice-9 vlist) + #:use-module (ice-9 hash-table) + #:use-module (ice-9 regex) + #:use-module ((ice-9 rdelim) #:select (read-line)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-13) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) + #:use-module (logging logger) + #:use-module (json) + #:use-module (web uri) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import utils) + #:use-module ((guix download) #:prefix download:) + #:use-module (guix import json) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix licenses) + #:use-module (guix build-system python) + #:use-module (pypi api) + #:use-module (pypi sdist) + #:use-module (pypi package) + #:use-module (pypi sdist-store) + #:use-module (pypi requirement) + #:use-module (pypi sdist-store dependency-sets) + #:use-module (pypi sdist-store utils) + #:use-module (pypi sdist-store import) + #:export (create-sdist-and-missing-dependencies)) + +(define (vhash-set key value vhash) + (vhash-cons + key + value + (vhash-delete + key + vhash))) + +(define (create-sdist-and-missing-dependencies + api-root + sdist-store + fix-function + python-pkg + name + version + intermediate-result-callback) + (process-dependency-sets + (import-context + (python python-pkg) + (fix-function fix-function) + (pypi-api-root api-root)) + sdist-store + (add-dependency-set + (make-dependency-sets-record) + (list (cons name version))) + vlist-null + intermediate-result-callback)) + +(define (dependency-set-ready-for-processing? key sdist-store import-states) + (log-msg 'DEBUG "dependency-set-ready-for-processing?") + (log-msg 'DEBUG sdist-store) + (let ((import-state (vhash-assq key import-states))) + (if (eq? import-state #f) + #t ; accept if this has not been tried before + (let + ((status (get-import-state-status (cdr import-state)))) + (if (bad-status? status) + (let + ((reason (get-bad-status-reason status))) + (cond + ((unsatisfiable-requirements? reason) + (every + (lambda (r) + (store-can-satisfy-requirement? sdist-store r)) + (get-unsatisfiable-requirements reason))) + (else (error "unknown failure reason")))) + ; only continue if there are remaining steps + (not (null? (get-import-state-remaining-steps (cdr import-state))))))))) + +(define (get-dependency-sets-for-processing + sdist-store dependency-sets import-states) + (filter + (lambda (key) + (dependency-set-ready-for-processing? key sdist-store import-states)) + (get-dependency-set-keys dependency-sets))) + +(define (add-result-to-log key results-log result) + (let ((existing-results (hash-ref results-log key))) + (hash-set! + results-log + key + (if existing-results + (cons result existing-results) + (list result))))) + +(define (get-latest-results-for-dependency-sets dependency-sets results-log) + (map + (lambda (key) + (let + ((entries (hash-ref results-log key))) + (if entries + (car entries) + #f))) + (get-dependency-set-keys dependency-sets))) + +(define (update-sdist-store master dest) + ; Not quite sure what this is doing, as it only acts at the package (and not + ; version) level + (vhash-fold + (lambda (k v result) + (vhash-set k v result)) + dest + master)) + +(define (get-graph-handle-for-dependency-set + key dependency-sets import-states-unsatisfiable-requirements) + (let + ((unsatisfiable-requirements + (hash-ref import-states-unsatisfiable-requirements key))) + (if (eq? #f unsatisfiable-requirements) + (cons key '()) + (begin + (cons + key + (map + (lambda (r) + (get-dependency-set-key-for-requirement dependency-sets r)) + unsatisfiable-requirements)))))) + +(define (get-dependency-set-dependency-graph + dependency-sets import-states-unsatisfiable-requirements) + (alist->hash-table + (dependency-sets->list + (lambda (key dependency-set) + (get-graph-handle-for-dependency-set + key dependency-sets import-states-unsatisfiable-requirements)) + dependency-sets))) + +(define (merge-cycles-in-dependency-sets + dependency-sets import-states-unsatisfiable-requirements) + (log-msg 'DEBUG "merge-cycles-in-dependency-sets") + (log-msg 'DEBUG (hash-map->list cons import-states-unsatisfiable-requirements)) + (let* + ((dependency-graph + (get-dependency-set-dependency-graph + dependency-sets import-states-unsatisfiable-requirements)) + (cycle (find-cycle-in-graph dependency-graph))) + (if cycle + (merge-cycles-in-dependency-sets + (fold + (lambda (key dependency-sets) + (remove-dependency-set dependency-sets key)) + (add-dependency-set + dependency-sets + (concatenate + (map + (lambda (key) + (get-dependency-set dependency-sets key)) + cycle))) + cycle) + import-states-unsatisfiable-requirements) + dependency-sets))) + +(define (process-dependency-set + import-context + sdist-store + dependency-sets + import-states + intermediate-result-callback + key) + (let + ((state + (process-import + import-context + (let + ((existing (vhash-assoc key import-states))) + (if existing + (import-state + (inherit (cdr existing)) + (sdist-store + (update-sdist-store + sdist-store + (get-import-state-sdist-store (cdr existing)))) + (status good-status)) + (import-state + (packages + (get-dependency-set dependency-sets key)) + (sdist-store + sdist-store) + (remaining-steps + steps) + (status good-status)))) + intermediate-result-callback))) + (let + ((status (get-import-state-status state)) + (updated-import-states + (vhash-set + key + state + import-states))) + (log-msg 'DEBUG "in process-dependency-set") + (log-msg 'DEBUG import-states) + (log-msg 'DEBUG status (good-status? status)) + (values + ; sdist-store + (if (good-status? status) + (add-sdists + sdist-store + (map + (match-lambda + ((name . version) + (log-msg 'INFO "Adding " name "@" version " to the store") + (get-sdist + (get-import-state-sdist-store + state) + name + version))) + (get-import-state-packages state))) + sdist-store) + ; dependency-sets + (cond + ((good-status? status) + (remove-dependency-set dependency-sets key)) + ((bad-status? status) + (log-msg 'DEBUG "bad status") + (let + ((reason (get-bad-status-reason status))) + (cond + ((unsatisfiable-requirements? reason) + (log-msg 'DEBUG "FOO") + (log-msg 'DEBUG updated-import-states) + (log-msg 'DEBUG (vlist->list updated-import-states)) + (merge-cycles-in-dependency-sets + (add-missing-dependency-sets + dependency-sets + (get-unsatisfiable-requirements reason) + import-context) + (get-import-states-unsatisfiable-requirements + sdist-store + updated-import-states))) + (else + (error "Unknown bad status reason" reason))))) + (else + (error "Unknown worker result" state))) + + ; import-states + updated-import-states)))) + +(define (get-import-states-unsatisfiable-requirements sdist-store import-states) + (log-msg 'DEBUG "get-import-states-unsatisfiable-requirements") + (log-msg 'DEBUG import-states) + (log-msg 'DEBUG (vlist->list import-states)) + (alist->hash-table + (map + (match-lambda + ((key . state) + (log-msg 'DEBUG state) + (cons + key + (if (bad-status? (get-import-state-status state)) + (filter + (lambda (r) + (not (store-can-satisfy-requirement? sdist-store r))) + (get-unsatisfiable-requirements + (get-bad-status-reason + (get-import-state-status state)))) + '())))) + (vlist->list import-states)))) + +(define (process-dependency-set-keys + import-context + sdist-store + dependency-sets + import-states + intermediate-result-callback + keys) + (if (null? keys) + (values + sdist-store + dependency-sets + import-states) + (let-values + (((sdist-store dependency-sets import-states) + (process-dependency-set + import-context + sdist-store + dependency-sets + import-states + intermediate-result-callback + (car keys)))) + (process-dependency-set-keys + import-context + sdist-store + dependency-sets + import-states + intermediate-result-callback + (cdr keys))))) + +(define (process-dependency-sets + import-context + sdist-store + dependency-sets + import-states + intermediate-result-callback) + (let + ((dependency-sets-for-processing + (get-dependency-sets-for-processing + sdist-store + dependency-sets + import-states))) + (log-msg 'DEBUG "dependency-sets-for-processing") + (log-msg 'DEBUG dependency-sets-for-processing) + (log-msg 'DEBUG "dependency-sets") + (log-msg 'DEBUG (dependency-sets->list cons dependency-sets)) + (if (null? dependency-sets-for-processing) + sdist-store + (let-values + (((sdist-store dependency-sets import-states) + (process-dependency-set-keys + import-context + sdist-store + dependency-sets + import-states + intermediate-result-callback + dependency-sets-for-processing))) + (process-dependency-sets + import-context + sdist-store + dependency-sets + import-states + intermediate-result-callback))))) + +(define (get-dependency-set-key-for-requirement dependency-sets r) + (or + (any + (match-lambda + ((key . name-version-pairs) + (any + (match-lambda + ((name . version) + (if (requirement-satisfied-by? r name version) + key + #f))) + name-version-pairs))) + (dependency-sets->list cons dependency-sets)) + (error "Could not find dependency set meeting requirement" r))) + +(define (add-missing-dependency-sets + dependency-sets + requirements + import-context) + (log-msg 'DEBUG "add-missing-dependency-sets") + (log-msg 'DEBUG requirements) + (fold + (lambda (r dependency-sets) + (log-msg 'DEBUG "Adding dependnecy set for " r) + (add-dependency-set + dependency-sets + (list + (cons + (requirement-name r) + (get-version-best-matching-requirement + r + (available-versions + (requirement-name r) + (get-import-context-pypi-api-root import-context))))))) + dependency-sets + (filter + (lambda (r) + (log-msg 'DEBUG r) + (not + (any + (lambda (name-version-pairs) + (any + (match-lambda + ((name . version) + (requirement-satisfied-by? r name version))) + name-version-pairs)) + (dependency-sets->list + (lambda (k v) v) + dependency-sets)))) + requirements))) + +(define (package-meets-requirement package requirement) + (let* ((package-name (car package)) + (package-version (cdr package))) + (if (equal? (requirement-name requirement) + package-name) + (begin + (version-meets-requirement requirement package-version)) + #f))) diff --git a/pypi/sdist-store/import.scm b/pypi/sdist-store/import.scm new file mode 100644 index 0000000..b00afd0 --- /dev/null +++ b/pypi/sdist-store/import.scm @@ -0,0 +1,720 @@ +(define-module (pypi sdist-store import) + #:use-module (pyguile) + #:use-module (logging logger) + #:use-module (rnrs io ports) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 vlist) + #:use-module (ice-9 ftw) + #:use-module (ice-9 regex) + #:use-module ((ice-9 rdelim) #:select (read-line)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) + #:use-module (json) + #:use-module (web uri) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix import utils) + #:use-module ((guix download) #:prefix download:) + #:use-module (guix import json) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix licenses) + #:use-module (guix build-system python) + #:use-module ((guix derivations) #:select (derivation-file-name + built-derivations + derivation->output-path)) + #:use-module (pypi package) + #:use-module (pypi requirement) + #:use-module (pypi api) + #:use-module (pypi sdist) + #:use-module (pypi sdist-store) + #:use-module (pypi requirement) + #:use-module (pypi dependency-solver) + #:use-module (pypi build-configuration-graph) + #:use-module (pypi sdist-store utils) + #:use-module (gnu packages python) + #:export (process-import + + recursive-package-inputs + + import-state + get-import-state-status + get-import-state-sdist-store + get-import-state-packages + + import-context + make-import-context + get-import-context-python + get-import-context-fix-function + get-import-context-pypi-api-root + + steps + + good-status + good-status? + bad-status + bad-status? + get-bad-status-reason)) + +(define-record-type* <import-state> + import-state make-import-state + import-state? + (packages get-import-state-packages) + (sdist-store get-import-state-sdist-store) + (remaining-steps get-import-state-remaining-steps) + (status get-import-state-status)) + +(define-record-type* <import-context> + import-context make-import-context + import-context? + (python get-import-context-python) + (pypi-api-root get-import-context-pypi-api-root) + (fix-function get-import-context-fix-function)) + +(define good-status 'good-status) + +(define (good-status? s) (eq? good-status s)) + +(define-record-type <bad-status> + (bad-status reason) + bad-status? + (reason get-bad-status-reason)) + +(define (check-packages-for-duplicates packages) + (if (not (= + (length packages) + (length (delete-duplicates packages equal?)))) + (error "packages contains duplicate entries" packages))) + +(define (process-import import-context import-state intermediate-result-callback) + (check-packages-for-duplicates + (get-import-state-packages import-state)) + (let + ((remaining-steps (get-import-state-remaining-steps import-state))) + (if (null? remaining-steps) + import-state + (let + ((next-step (car remaining-steps))) + (let* + ((new-state (next-step import-context import-state)) + (new-status (get-import-state-status new-state))) + (intermediate-result-callback (get-import-state-sdist-store new-state)) + (cond + ((good-status? new-status) + (process-import import-context new-state intermediate-result-callback)) + ((bad-status? new-status) + new-state) + (else + (error "Unknown import status" new-status)))))))) + +(define (create-initial-sdist-record-from-sdist name version import-context) + (ensure-unpacked-sdist-exists + name version (get-import-context-pypi-api-root import-context)) + (let + ((requires (parse-requires name version))) + (sdist + (info (get-pkg-info name version)) + (build-requires (get-sdist-build-requires name version)) + (tests-require (get-sdist-tests-require name version)) + (install-requires (get-sdist-install-requires requires)) + (extras-require (get-sdist-extras-require requires)) + (source (get-sdist-origin name version import-context))))) + +(define (create-initial-sdists import-context state) + "create-initial-sdists" + (log-msg 'DEBUG "create-initial-sdists") + (log-msg 'DEBUG (vlist->list (get-import-state-sdist-store state))) + (import-state + (inherit state) + (remaining-steps (cdr (get-import-state-remaining-steps state))) + (sdist-store + (let ((previous-store + (get-import-state-sdist-store state))) + (add-sdists + previous-store + (map + (match-lambda + ((name . version) + (create-initial-sdist-record-from-sdist name version import-context))) + (filter + (match-lambda + ((name . version) + (log-msg 'DEBUG "Checking that " name "@" version " is not already in the store") + (log-msg 'DEBUG (not (get-sdist previous-store name version))) + (not (get-sdist previous-store name version)))) + (get-import-state-packages state)))))))) + +(define (get-package-processor f) + (letrec + ((fn + (lambda (import-context state) + (check-steps state fn) + (letrec + ((processor + (lambda (import-context state packages) + (if (null? packages) + (import-state + (inherit state) + (remaining-steps (cdr (get-import-state-remaining-steps state)))) + (let* + ((pkg (car packages)) + (name (car pkg)) + (version (cdr pkg)) + (new-import-state + (f import-context state name version)) + (new-status (get-import-state-status new-import-state))) + (cond + ((good-status? new-status) + (processor import-context new-import-state (cdr packages))) + ((bad-status? new-status) + new-import-state) + (else + (error "Unknown import status" new-status)))))))) + (processor + import-context + state + (get-import-state-packages state)))))) + fn)) + +(define build-package-to-determine-build-requirements + (get-package-processor + (lambda (import-context import-state name version) + (log-msg 'INFO "Building " name "@" version " without tests") + (build-package-to-determine-requirements + import-context + import-state + name + version + #f + '())))) + +(define build-package-to-determine-test-requirements + (get-package-processor + (lambda (import-context import-state name version) + (log-msg 'INFO "Building " name "@" version " with tests") + (build-package-to-determine-requirements + import-context + import-state + name + version + #t + '())))) + +(define steps (list + create-initial-sdists + build-package-to-determine-build-requirements + build-package-to-determine-test-requirements)) + +(define (get-sdist-coresponding-to-package store pkg) + (let* + ((sd (assoc-ref (package-properties pkg) 'sdist)) + (pkginfo (sdist-info sd)) + (name (pkg-info-name pkginfo)) + (version (pkg-info-version pkginfo))) + (get-sdist + store + name + version))) + +(define (get-build-configuration-from-package pkg) + (let + ((bc + (assoc-ref (package-properties pkg) 'build-configuration))) + (if (not (build-configuration? bc)) + (begin + (log-msg 'ERROR "get-build-configuration-from-package is not a build configuration" + bc) + (error))) + bc)) + +(define (build-and-report-log-on-failures pkg) + (letrec* + ((inputs-plus-pkg + (reverse (cons pkg (reverse (recursive-package-inputs pkg))))) + (build-all + (lambda (remaining-packages) + (if (null? remaining-packages) + #t + (let + ((pkg (car remaining-packages))) + (let + ((result (build-and-return-log-on-failure pkg))) + (if (eq? result #t) + (build-all (cdr remaining-packages)) + result))))))) + (build-all inputs-plus-pkg))) + +(define (check-steps state current-step) + (if + (not (eq? (car (get-import-state-remaining-steps state)) current-step)) + (error "Actual step " current-step " does not equal " (car (get-import-state-remaining-steps state))))) + +(define (build-package-to-determine-requirements + import-context state name version run-tests extras) + (let* + ((sdist-store + (get-import-state-sdist-store state)) + (sd + (get-sdist + sdist-store + name + version)) + (build-configuration-graph-or-error + (catch + unsatisfied-requirements-error + (lambda () + (requirements->build-configuration-graph + sdist-store + (list + (requirement + (name name) + (specifiers + (string-append "==" version)) + (extras extras) + (run-tests run-tests))))) + (lambda (err unsatisfied-requirements) + (unsatisfiable-requirements unsatisfied-requirements))))) + (if (not (build-configuration-graph? build-configuration-graph-or-error)) + (import-state + (inherit state) + (status (bad-status + build-configuration-graph-or-error))) + (let* + ((build-configuration-graph + build-configuration-graph-or-error) + (requirement-options-to-versions + (solve-build-configuration-graph + build-configuration-graph)) + (pkg-or-error + (catch + unsatisfied-requirements-error + (lambda () + (first + (build-configuration-graph->packages + build-configuration-graph + (package-configuration + (get-import-context-python import-context) + (get-import-context-fix-function import-context)) + requirement-options-to-versions))) + (lambda (err unsatisfied-requirements) + (unsatisfiable-requirements unsatisfied-requirements))))) + (if (not (package? pkg-or-error)) + (import-state + (inherit state) + (status (bad-status + pkg-or-error))) + (begin + (log-msg 'DEBUG "sdist information " (sdist-short-description sd)) + (log-msg 'DEBUG "build-requires " (sdist-build-requires sd)) + (log-msg 'DEBUG "test-requires " (sdist-tests-require sd)) + (log-msg 'DEBUG "install-requires " (sdist-install-requires sd)) + (log-msg 'DEBUG "dependencies for " (package-name pkg-or-error)) + (log-msg 'DEBUG "native-inputs " (map car (package-native-inputs pkg-or-error))) + (log-msg 'DEBUG "inputs " (map car (package-inputs pkg-or-error))) + (log-msg 'DEBUG "propagated-inputs " (map car (package-propagated-inputs pkg-or-error))) + (let* + ((build-result (build-and-report-log-on-failures pkg-or-error))) + (if (eq? build-result #t) + state + (let* + ((pkg (car build-result)) + (log-contents (cdr build-result)) + (parsed-result (parse-build-log log-contents)) + (sdist (get-sdist-coresponding-to-package + sdist-store + pkg))) + (if (eq? parsed-result #f) + (begin + (display "\n") + (display log-contents) + (display "\n") + (log-msg 'ERROR "Unable to determine build problem") + (error))) + (log-msg 'INFO "Finished building " (package-name pkg) " " (package-version pkg)) + (log-msg 'INFO "Missing requirements: " parsed-result) + (if + (not + (member + (normalise-requirement-name + (pkg-info-name (sdist-info sdist))) + (map (match-lambda + ((name . version) + (normalise-requirement-name name))) + (get-import-state-packages state)))) + (begin + (display "\n") + (display log-contents) + (display "\n") + (log-msg 'ERROR + "Build problem in package outside of packages that this worker is trying to build:\n" + " packages: " (get-import-state-packages state) "\n" + " build failed for: " (normalise-requirement-name (pkg-info-name (sdist-info sdist))) "\n") + (error))) + (let* + ((missing-requirement parsed-result)) + (log-msg 'DEBUG "missing requirement " missing-requirement) + (if (member + (requirement-name missing-requirement) + (build-configuration-omitted-dependencies + (get-build-configuration-from-package pkg))) + (begin + (display "\n") + (display log-contents) + (display "\n") + (log-build-configuration-graph + '() build-configuration-graph) + (log-msg 'ERROR "Build configuration: " + (get-build-configuration-from-package pkg)) + (error "Package has failed to build due to omitted dependency"))) + (if (store-can-satisfy-requirement? sdist-store missing-requirement) + (begin + (log-msg 'DEBUG "missing requirement is in the store") + (if (member + missing-requirement + (if (package-has-tests-enabled pkg) + (sdist-tests-require sdist) + (sdist-build-requires sdist))) + (begin + (display "\n") + (display log-contents) + (display "\n") + (log-msg 'ERROR "Problem building package") + (log-build-configuration-graph + '() build-configuration-graph) + (log-msg 'ERROR "Build configuration: " + (get-build-configuration-from-package pkg)) + (error "Cannot add duplicate requirement " missing-requirement))) + (let + ((new-state + (import-state + (inherit state) + (sdist-store + (add-sdist + sdist-store + ((if (package-has-tests-enabled pkg) + add-test-requirements-to-sdist + add-build-requirements-to-sdist) + sdist + (list missing-requirement))))))) + (log-msg 'DEBUG "about to call build-package-to-determine-requirements") + (log-msg 'DEBUG state) + (log-msg 'DEBUG new-state) + (build-package-to-determine-requirements + import-context + new-state + name + version + run-tests + extras))) + ; Store can't satisfy requirements, so report failure + (begin + (log-msg 'DEBUG "missing requirement is not in the store") + (import-state + (inherit state) + (status + (bad-status + (unsatisfiable-requirements + (list missing-requirement))))))))))))))))) + +(define (readable-package p) + (string-append (package-name p) "@" (package-version p))) + +(define (check-and-fix-dependency-ordering package-and-dependencies) + (if (null? package-and-dependencies) + '() + (let* + ((first-pair (car package-and-dependencies)) + (pkg (car first-pair)) + (dependencies (cdr first-pair)) + (remaining-packages (map car (cdr package-and-dependencies)))) + (if + (every + (lambda (dependency) + (not (member dependency remaining-packages))) + dependencies) + (cons + first-pair + (check-and-fix-dependency-ordering (cdr package-and-dependencies))) + (check-and-fix-dependency-ordering + (append + (check-and-fix-dependency-ordering (cdr package-and-dependencies)) + (list first-pair))))))) + +(define (recursive-package-inputs pkg) + (apply + lset-adjoin + (append + (list eq? '()) + (apply + append + (reverse + (check-and-fix-dependency-ordering + (map + (lambda (p) + (cons p (reverse (recursive-package-inputs p)))) + (filter + (lambda (p) + (assoc-ref + (package-properties p) + 'sdist)) + (map cadr (package-direct-inputs pkg)))))))))) + +(define (get-pkg-info name version) + (let* ((possible-egg-info-paths + (search-for-egg-info (get-sdist-directory name version) 2)) + (pkg-info-path + (if (> (length possible-egg-info-paths) 0) + (string-append (first possible-egg-info-paths) + "/PKG-INFO") + (let ((p (string-append (get-sdist-directory name version) + "/PKG-INFO"))) + (if (file-exists? p) + p + #f))))) + (if pkg-info-path + (let ((data ((call-with-input-file + pkg-info-path + read-rfc822) 'headers))) + (pkg-info + (name (string-trim-both (assq-ref data 'Name))) + (version (string-trim-both (assq-ref data 'Version))) + (home-page (assq-ref data 'Home-page)) + (synopsis (assq-ref data 'Synopsis)) + (description "") ; TODO: Possibly use (assq-ref data 'Description)) + (license (assq-ref data 'License)))) + (pkg-info + (name name) + (version version) + (home-page "") + (synopsis "") + (description "") + (license ""))))) + +(define (get-sdist-build-requires name version) + (if (equal? name "setuptools") + '() + `(,(requirement + (name "setuptools"))))) + +(define (get-sdist-tests-require name version) + '()) + +(define (get-sdist-install-requires requires) + (let ((install-requires + (assoc-ref requires '()))) + (if install-requires + install-requires + '()))) + +(define (get-sdist-extras-require requires) + (map + (match-lambda + ((name . deps) + (extra name deps))) + (filter + (match-lambda + ((name . deps) + (not (null? name)))) + requires))) + +(define (parse-requires name version) + (log-msg 'DEBUG "parse-requires " name "@" version) + (python-import "pkg_resources") + (let* + ((possible-egg-info-directories + (search-for-egg-info (get-sdist-directory name version) 2))) + (if (= (length possible-egg-info-directories) 0) + '() + (let* + ((sdist-directory (get-sdist-directory name version)) + (egg-info (first possible-egg-info-directories)) + (path-metadata (python-apply + '(pkg_resources PathMetadata) + (list + sdist-directory + egg-info) + '())) + (distribution (python-apply + '(pkg_resources Distribution) + (list + sdist-directory + path-metadata) + '())) + (output-dep-map + (python-eval "lambda d: [(extra, [(d.name, str(d.specifier), list(d.extras), d.marker) for d in deps]) for extra, deps in d._dep_map.items()]" #t)) + (dep-map (python-apply output-dep-map + (list + distribution) + '()))) + (map + (match-lambda + ((extra deps) + (log-msg 'DEBUG extra) + (log-msg 'DEBUG deps) + (cons + extra + (let + ((r (map + requirement-tuple->requirement + deps))) + (log-msg 'DEBUG r) + r)))) + dep-map))))) + +(define (get-sdist-origin name version import-context) + (let* ((data + (source-release + (pypi-fetch + name + (get-import-context-pypi-api-root import-context)) + version)) + (filename (assoc-ref* data "filename")) + (full-path (string-append (get-tmpdir) "/" filename)) + (source-url (assoc-ref* data "url"))) + (origin + (method download:url-fetch) + (uri source-url) + (sha256 + (base32 (guix-hash-url full-path)))))) + +(define-condition-type &missing-source-error &error + missing-source-error? + (package missing-source-error-package)) + +(define (source-release pypi-package version) + (let ((releases (assoc-ref* pypi-package "releases" version))) + (or (find (lambda (release) + (string=? "sdist" (assoc-ref release "packagetype"))) + releases) + (raise (condition (&missing-source-error + (package pypi-package))))))) + +; error: Could not find suitable distribution for Requirement.parse('cryptography_vectors==1.4') +(define requirement-regex + (make-regexp + ".*Could not find suitable distribution for Requirement\\.parse\\('(.*)'\\)")) + +(define import-error-regex-1 + (make-regexp + "ImportError: No module named '?([^'.]+)")) + +(define import-error-regex-2 + (make-regexp + "ImportError: cannot import name '?([^'.]+)")) + +(define no-matching-distribution + (make-regexp + "No matching distribution found for (.*)")) + +; 'No module named 'hypothesis'' +(define no-module-named + (make-regexp + "'No module named '(.*)''")) + +(define (list->pairs lst) + (if (null? lst) + '() + (cons + (cons (car lst) (cadr lst)) + (list->pairs (cddr lst))))) + +(define (package-has-tests-enabled pkg) + (let + ((argument (find + (match-lambda + ((key . value) + (equal? #:tests? key))) + (list->pairs (package-arguments pkg))))) + (if argument + (cdr argument) + #t))) ; tests are on by default + +(define (parse-build-log l) + (let* + ((lines (string-split l #\newline)) + (matches + (any + (lambda (rgx) + (let + ((matches + (filter + regexp-match? + (map + (lambda (line) + (regexp-exec rgx line)) + lines)))) + (if (null? matches) + #f + matches))) + (list + requirement-regex + import-error-regex-1 + no-matching-distribution + no-module-named))) + (requirements + (if (eq? matches #f) + '() + (map + (lambda (m) (match:substring m 1)) + matches)))) + (if (null? requirements) + #f + (catch + #t + (lambda () + (requirement-string->requirement (car requirements))) + (lambda args + (display "\n") + (display l) + (display "\n") + (log-msg 'ERROR args) + (log-msg 'ERROR "Error parsing requirement from build log")))))) + +(define (build-and-return-log-on-failure pkg) + (let* + ((derivation + (with-store store + (package-derivation store pkg #:graft? #f))) + (built-already + (with-store store + (valid-path? + store (derivation->output-path derivation))))) + (if built-already + #t + (begin + (log-msg 'DEBUG derivation) + (catch + #t + (lambda () + (parameterize ((current-build-output-port (if #f + (%make-void-port "w") + (current-error-port)))) + (with-store store + (run-with-store store + (mbegin %store-monad + (built-derivations (list derivation)))))) + #t) + (lambda args + (log-msg 'DEBUG args) + (log-msg 'DEBUG (derivation-file-name derivation)) + (let* ((logf + (with-store store + (log-file store (derivation-file-name derivation)))) + (contents + (begin + (log-msg 'DEBUG "logf " logf) + (call-with-input-file logf + (lambda (port) + (call-with-decompressed-port 'bzip2 port + (lambda (port) + (get-string-all port)))))))) + (cons pkg contents)))))))) diff --git a/pypi/sdist-store/utils.scm b/pypi/sdist-store/utils.scm new file mode 100644 index 0000000..483e730 --- /dev/null +++ b/pypi/sdist-store/utils.scm @@ -0,0 +1,233 @@ +(define-module (pypi sdist-store utils) + #:use-module (pyguile) + #:use-module (logging logger) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 ftw) + #:use-module (ice-9 regex) + #:use-module ((ice-9 rdelim) #:select (read-line)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) + #:use-module (json) + #:use-module (web uri) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import utils) + #:use-module ((guix download) #:prefix download:) + #:use-module (guix import json) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix licenses) + #:use-module (guix build-system python) + #:use-module (pypi api) + #:use-module (pypi sdist) + #:use-module (pypi sdist-store) + #:use-module (pypi requirement) + #:use-module (gnu packages python) + #:export (ensure-unpacked-sdist-exists + search-for-egg-info + find-cycle-in-graph + get-sdist-directory + read-rfc822 + get-tmpdir)) + +(define (get-tmpdir) + "/tmp/guix-pypi") + +(define (ensure-unpacked-sdist-exists name version api-root) + (let ((tmpdir (get-tmpdir)) + (sdist-directory (get-sdist-directory name version))) + (begin + (unless (file-exists? tmpdir) + (mkdir tmpdir)) + (unless (file-exists? sdist-directory) + (let* ((data (source-release (pypi-fetch name api-root) version)) + (filename (assoc-ref* data "filename")) + (full-path (string-append tmpdir "/" filename)) + (source-url (assoc-ref* data "url"))) + (begin + (if (not (file-exists? full-path)) + (url-fetch source-url full-path)) + (if + (string-contains filename ".zip") + (let + ((exit-code + (system* "unzip" "-qq" full-path "-d" tmpdir))) + (if (not (zero? exit-code)) + (begin + (log-msg 'ERROR "Attempted to unzip " full-path) + (error (_ "'unzip' failed with exit code ~a\n") + exit-code)) + #f)) + (let* ((compression-type + (cond + ((string-contains filename "gz") "z") + ((string-contains filename "bz2") "j") + ((begin + (error "unknown compression type") + #f)))) + (exit-code + (system* "tar" (string-append compression-type "xf") full-path "--directory" tmpdir "--no-same-owner"))) + (if (not (zero? exit-code)) + (begin + (error (_ "'tar' failed with exit code ~a\n") + exit-code) + #f)))) + (rename-file + (string-append tmpdir "/" (tarball-directory source-url)) + sdist-directory))))))) + +(define (get-expected-sdist-name name version) + (string-append (string-downcase name) "-" version)) + +(define (get-sdist-directory name version) + (string-append (get-tmpdir) "/" (get-expected-sdist-name name version))) + +(define (tarball-directory url) + ;; Given the URL of the package's tarball, return the name of the directory + ;; that will be created upon decompressing it. If the filetype is not + ;; supported, return #f. + ;; TODO: Support more archive formats. + (let ((basename (substring url (+ 1 (string-rindex url #\/))))) + (cond + ((string-suffix? ".tar.gz" basename) + (string-drop-right basename 7)) + ((string-suffix? ".tar.bz2" basename) + (string-drop-right basename 8)) + ((string-suffix? ".zip" basename) + (string-drop-right basename 4)) + (else + (begin + (warning (_ "Unsupported archive format: \ +nnot determine package dependencies")) + #f))))) + +(define (search-for-egg-info startname depth) + (if (= depth 0) + '() + (let ((possibles (scandir + startname + (lambda (name) (string-contains name ".egg-info"))))) + (if (> (length possibles) 0) + (map + (lambda (p) (string-append startname "/" p)) + possibles) + (apply + append + (map + (lambda (sn) (search-for-egg-info + (string-append startname "/" sn) (- depth 1))) + (scandir + startname + (lambda (d) (eq? + 'directory + (stat:type + (stat (string-append startname "/" d)))))))))))) + +(define-condition-type &missing-source-error &error + missing-source-error? + (package missing-source-error-package)) + +(define (get-archive-suffix name) + (find + (lambda (suffix) + (string-suffix? suffix name)) + archive-preference)) + +(define archive-preference '(".tar.gz" ".tar.bz2" ".zip")) + +(define (source-release pypi-package version) + (let ((releases (assoc-ref* pypi-package "releases" version))) + (or (and + releases + (find (lambda (release) + (string=? "sdist" (assoc-ref release "packagetype"))) + releases)) + (raise (condition (&missing-source-error + (package pypi-package))))))) + +;;; RFC822 Parsing + +(define header-name-rx (make-regexp "^([^:]+):[ \t]*")) +(define header-cont-rx (make-regexp "^[ \t]+")) + +(define (drain-message port) + (let loop ((line (read-line port)) (acc '())) + (cond ((eof-object? line) + (reverse acc)) + (else + (loop (read-line port) (cons line acc)))))) + +(define (parse-message port) + (let* ((body-lines #f) + (body #f) + (headers '()) + (add-header! (lambda (reversed-hlines) + (let* ((hlines (reverse reversed-hlines)) + (first (car hlines))) + (if (not (= (string-length first) 0)) + (let* ((m (regexp-exec header-name-rx first)) + (name (string->symbol (match:substring m 1))) + (data (string-join + (cons (substring first (match:end m)) + (cdr hlines)) + " "))) + (set! headers (acons name data headers)))))))) + ;; "From " is only one line + (let loop ((line (read-line port)) (current-header #f)) + (cond ((eof-object? line) + (and current-header (add-header! current-header)) + (set! body-lines (drain-message port))) + ((regexp-exec header-cont-rx line) + => (lambda (m) + (loop (read-line port) + (cons (match:suffix m) current-header)))) + (else + (and current-header (add-header! current-header)) + (loop (read-line port) (list line))))) + (set! headers (reverse headers)) + (lambda (component) + (case component + ((body-lines) body-lines) + ((headers) headers) + ((body) (or body + (begin (set! body (string-join body-lines "\n" 'suffix)) + body))) + (else (error "bad component:" component)))))) + +(define (read-rfc822 port) + (parse-message port)) + +(define (display-rfc822 parse) + (cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from)))) + (for-each (lambda (header) + (format #t "~A: ~A\n" (car header) (cdr header))) + (parse 'headers)) + (format #t "\n~A" (parse 'body))) + +;; Graph utils + +(define (find-cycle-in-graph graph) + (recurse-and-return-cycle-if-found + graph + (car (hash-map->list + (lambda (k v) k) + graph)) + '())) + +(define (recurse-and-return-cycle-if-found graph node visited-nodes) + (if (member node visited-nodes) + (memq node (reverse visited-nodes)) + (let + ((links (hash-ref graph node))) + (if links + (any + (lambda (next-node) + (recurse-and-return-cycle-if-found + graph next-node (cons node visited-nodes))) + links) + #f)))) diff --git a/pypi/sdist.scm b/pypi/sdist.scm new file mode 100644 index 0000000..e0e5233 --- /dev/null +++ b/pypi/sdist.scm @@ -0,0 +1,192 @@ +(define-module (pypi sdist) + #:use-module (logging logger) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-13) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (guix ui) + #:use-module (guix base32) + #:use-module (guix records) + #:use-module (guix download) + #:use-module (guix packages) + #:use-module (pypi requirement) + #:use-module (pypi utils) + #:export (sdist + sdist? + sdist-info + sdist-build-requires + sdist-tests-require + sdist-install-requires + sdist-extras-require + sdist-source + + sdist-short-description + + get-quoted-sdist + sdist-meets-requirement + add-build-requirements-to-sdist + add-test-requirements-to-sdist + + pkg-info + pkg-info? + pkg-info-name + pkg-info-version + pkg-info-home-page + pkg-info-synopsis + pkg-info-description + pkg-info-license + + get-quoted-pkg-info + + get-extra-combinations + get-requirements-for-extras + + extra + extra? + extra-name + extra-requires)) + +(define-record-type* <sdist> + sdist make-sdist + sdist? + (info sdist-info) + (build-requires sdist-build-requires + (default '())) + (tests-require sdist-tests-require + (default '())) + (install-requires sdist-install-requires + (default '())) + (extras-require sdist-extras-require + (default '())) + (source sdist-source)) + +(define (get-quoted-sdist sdist) + `(sdist + (info ,(get-quoted-pkg-info (sdist-info sdist))) + (build-requires ,(append '(list) + (map get-quoted-requirement + (sdist-build-requires sdist)))) + (tests-require ,(append '(list) + (map get-quoted-requirement + (sdist-tests-require sdist)))) + (install-requires ,(append '(list) + (map get-quoted-requirement + (sdist-install-requires sdist)))) + (extras-require ,(append '(list) + (map + get-quoted-extra + (sdist-extras-require sdist)))) + (source ,(get-quoted-origin (sdist-source sdist))))) + +(define (add-build-requirements-to-sdist sd reqs) + (let + ((duplicate + (any + (lambda (r) + (member r (sdist-build-requires sd))) + reqs))) + (if duplicate + (error "Cannot add duplicate build requirement " duplicate))) + (log-msg 'INFO + "Adding build requirements to " + (sdist-short-description sd) + " " reqs) + (sdist + (inherit sd) + (build-requires + (append + (sdist-build-requires sd) + reqs)))) + +(define (add-test-requirements-to-sdist sd reqs) + (log-msg 'INFO + "Adding test requirements to " + (sdist-short-description sd) + " " reqs) + (let + ((duplicate + (any + (lambda (r) + (member r (sdist-tests-require sd))) + reqs))) + (if duplicate + (error "Cannot add duplicate test requirement " duplicate))) + (sdist + (inherit sd) + (tests-require + (append + (sdist-tests-require sd) + reqs)))) + +(define (get-quoted-origin o) + `(origin + (method ,(let + ((m (origin-method o))) + (cond + ((eqv? url-fetch m) + 'url-fetch) + (else + (report-error (_ "unknown method ") m "\n"))))) + (uri ,(origin-uri o)) + (sha256 + (base32 + ,(bytevector->nix-base32-string (origin-sha256 o)))))) + +(define-record-type* <pkg-info> + pkg-info make-pkg-info + pkg-info? + (name pkg-info-name) + (version pkg-info-version) + (home-page pkg-info-home-page) + (synopsis pkg-info-synopsis) + (description pkg-info-description) + (license pkg-info-license)) + +(define (get-quoted-pkg-info pi) + `(pkg-info + (name ,(pkg-info-name pi)) + (version ,(pkg-info-version pi)) + (home-page ,(pkg-info-home-page pi)) + (synopsis ,(pkg-info-synopsis pi)) + (description ,(pkg-info-description pi)) + (license ,(pkg-info-license pi)))) + +(define (get-extra-combinations sdist) + (all-combinations + (sdist-extras-require sdist))) + +(define (get-requirements-for-extras sd extras) + (apply + append + (map + (lambda (extra) + (assoc-ref extra (sdist-extras-require sd))) + extras))) + + +(define (sdist-meets-requirement sd r) + (version-meets-requirement r + (pkg-info-version (sdist-info sd)))) + +(define-record-type <extra> + (extra name requirements) + extra? + (name extra-name) + (requirements extra-requires)) + +(define (get-quoted-extra e) + `(extra + ,(extra-name e) + ,(append '(list) + (map get-quoted-requirement + (extra-requires e))))) + +(define (sdist-short-description sd) + (let + ((info (sdist-info sd))) + (string-append + (pkg-info-name info) + "@" + (pkg-info-version info)))) diff --git a/pypi/utils.scm b/pypi/utils.scm new file mode 100644 index 0000000..88ec879 --- /dev/null +++ b/pypi/utils.scm @@ -0,0 +1,24 @@ +(define-module (pypi utils) + #:use-module (ice-9 match) + #:use-module (srfi srfi-69) + #:use-module (guix packages) + #:export (all-combinations)) + +; Combinatorics + +(define (combinations lst len) + (cond ((= len 0) + '(())) + ((null? lst) + '()) + (else (append (map (lambda (rest) (cons (car lst) rest)) + (combinations (cdr lst) (- len 1))) + (combinations (cdr lst) len))))) + +(define (all-combinations lst) + (apply + append + (map + (lambda (len) + (combinations lst len)) + (cdr (iota (+ 1 (length lst))))))) diff --git a/pypi/version.scm b/pypi/version.scm new file mode 100644 index 0000000..e4d0b35 --- /dev/null +++ b/pypi/version.scm @@ -0,0 +1,18 @@ +(define-module (pypi version) + #:use-module (pyguile) + #:export (sort-versions)) + +(define (sort-versions versions) + (if (null? versions) + versions + (begin + (python-eval "from packaging.version import parse") + (let + ((sort + (python-eval + "lambda vs: [s for s, v in sorted([(s, parse(s)) for s in vs], key=lambda x: x[1], reverse=True)]" + #t))) + (python-apply + sort + (list versions) + '()))))) diff --git a/solver/__init__.py b/solver/__init__.py new file mode 100644 index 0000000..0b8160a --- /dev/null +++ b/solver/__init__.py @@ -0,0 +1,184 @@ +import solv + +OPERATOR_TO_FLAGS = { + "=": solv.REL_EQ, + "<": solv.REL_LT, + ">": solv.REL_GT, + "<=": solv.REL_EQ | solv.REL_LT, + ">=": solv.REL_EQ | solv.REL_GT, +} + +def get_operator_and_version(spec): + spec.strip() + for operator in OPERATOR_TO_FLAGS.keys(): + if spec.startswith(operator): + version = spec[len(operator):].strip() + + return operator, version + + raise Exception("Could not parse %s" % spec) + +def get_versions_or_error(sdists, overall_requirements, debug=False): + def log(*args): + if debug: + print(args) + + if sdists is None or (len(sdists) == 1 and sdists[0] is None): + sdists = [] + + if overall_requirements is None or ( + len(overall_requirements) == 1 and overall_requirements[0] is None + ): + overall_requirements = [] + + if len(overall_requirements) == 0: + log("overall_requirements", overall_requirements) + return [] + + log(sdists) + log(overall_requirements) + + pool = solv.Pool() + pool.setarch() + + sysrepo = pool.add_repo("@System") + + repo = pool.add_repo("test") + repo.create_stubs() + + solvables = {} + + log("Creating solvables") + for name, version, requirements in sdists: + solvable = repo.add_solvable() + + solvable.name = name + solvable.evr = version + solvable.arch = "noarch" + + log(solvable.name, solvable.id) + + solvables[(name, version)] = solvable + + rel_id = pool.rel2id( + solvable.nameid, + solvable.evrid, + OPERATOR_TO_FLAGS["="], + True, + ) + + solvable.add_deparray(solv.SOLVABLE_PROVIDES, rel_id) + + log("Adding requirements") + for name, version, requirements in sdists: + if requirements is None: + requirements = [] + + solvable = solvables[(name, version)] + + log("requirements for", name, version) + + for requirement_name, requirement_specifiers in requirements: + log("requirement name ", requirement_name) + requirement_name_id = pool.str2id(requirement_name, False) + + if requirement_name_id == 0: + return "Could not find package for requirement %s" % requirement_name + + if requirement_specifiers is None: + requirement_specifiers = [] + + log("specifiers ", requirement_specifiers) + if len(requirement_specifiers) == 0: + solvable.add_deparray(solv.SOLVABLE_REQUIRES, requirement_name_id) + else: + for spec in requirement_specifiers: + if "!=" in spec: + # TODO: Support this + continue + + try: + spec_operator, spec_version = get_operator_and_version(spec) + except Exception as e: + return str(e) + + requirement_evr_id = pool.str2id(spec_version, True) + + log(requirement_name_id, requirement_evr_id) + rel_id = pool.rel2id( + requirement_name_id, + requirement_evr_id, + OPERATOR_TO_FLAGS[spec_operator], + True, + ) + + log("rel_id", rel_id, requirement_name, spec_operator, spec_version) + + solvable.add_deparray(solv.SOLVABLE_REQUIRES, rel_id) + + addedprovides = pool.addfileprovides_queue() + if addedprovides: + sysrepo.updateaddedprovides(addedprovides) + repo.updateaddedprovides(addedprovides) + + pool.createwhatprovides() + + jobs = [] + + for arg in overall_requirements: + flags = ( + solv.Selection.SELECTION_REL | + solv.Selection.SELECTION_NAME | + solv.Selection.SELECTION_WITH_SOURCE + ) + + sel = pool.select(arg, flags) + + if sel.isempty(): + error = "nothing matches '%s'" % arg + log(error) + return error + + if sel.flags() & solv.Selection.SELECTION_FILELIST: + log("[using file list match for '%s']" % arg) + if sel.flags() & solv.Selection.SELECTION_PROVIDES: + log("[using capability match for '%s']" % arg) + + jobs += sel.jobs(solv.Job.SOLVER_INSTALL) + + for job in jobs: + for solvable in job.solvables(): + solvable_url = solvable.lookup_str(solv.SOLVABLE_URL) + if solvable_url: + log("Url: %s" % solvable_url) + solvable_license = solvable.lookup_str(solv.SOLVABLE_LICENSE) + if solvable_license: + log("License: %s" % solvable_license) + + pool.set_debuglevel(0) + solver = pool.Solver() + + while True: + problems = solver.solve(jobs) + if not problems: + break + + return str([str(p) for p in problems]) + + # no problems, show transaction + trans = solver.transaction() + del solver + if trans.isempty(): + return "transaction is empty" + + for cl in trans.classify( + solv.Transaction.SOLVER_TRANSACTION_SHOW_OBSOLETES | + solv.Transaction.SOLVER_TRANSACTION_OBSOLETE_IS_UPGRADE, + ): + if cl.type == solv.Transaction.SOLVER_TRANSACTION_INSTALL: + versions = [] + for p in cl.solvables(): + log(" - %s" % p) + versions.append((p.name, p.evr)) + return versions + return "unknown error" |