path: root/pypi/sdist-store/import-master.scm

(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)))