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

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