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