diff options
Diffstat (limited to 'pypi/sdist-store/import.scm')
| -rw-r--r-- | pypi/sdist-store/import.scm | 720 |
1 files changed, 720 insertions, 0 deletions
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)))))))) |