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