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

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