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