code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import kde)
  #:use-module (guix http-client)
  #:use-module (guix memoization)
  #:use-module (guix gnu-maintenance)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-11)
  #:use-module (web uri)

  #:export (%kde-updater))

;;; Commentary:
;;;
;;; This package provides not an actual importer but simply an updater for
;;; KDE packages.  It grabs available files from the 'ls-lR.bz2' file
;;; available on download.kde.org.
;;;
;;; Code:

(define (tarball->version tarball)
  "Return the version TARBALL corresponds to.  TARBALL is a file name like
\"coreutils-8.23.tar.xz\"."
  (let-values (((name version)
                (gnu-package-name->name+version
                 (tarball-sans-extension tarball))))
    version))

(define %kde-file-list-uri
  ;; URI of the file list (ls -lR format) for download.kde.org.
  (string->uri "https://download.kde.org/ls-lR.bz2"))

(define (download.kde.org-files)
  ;;"Return the list of files available at download.kde.org."

    (define (ls-lR-line->filename path line)
      ;; Remove mode, blocks, user, group, size, date, time and one space,
      ;; then prepend PATH
      (regexp-substitute
       #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post))

    (define (canonicalize path)
      (let* ((path (if (string-prefix? "/srv/archives/ftp/" path)
                       (string-drop path (string-length "/srv/archives/ftp"))
                       path))
             (path (if (string-suffix? ":" path)
                       (string-drop-right path 1)
                       path))
             (path (if (not (string-suffix? "/" path))
                       (string-append path "/")
                       path)))
        path))

    (define (write-cache input cache)
      "Read bzipped ls-lR from INPUT, and write it as a list of file paths to
CACHE."
      (call-with-decompressed-port 'bzip2 input
        (lambda (input)
          (let loop_dirs ((files '()))
            ;; process a new directory block
            (let ((path (read-line input)))
              (if
               (or (eof-object? path) (string= path ""))
               (write (reverse files) cache)
               (let loop_entries ((path (canonicalize path))
                                  (files files))
                 ;; process entries within the directory block
                 (let ((line (read-line input)))
                   (cond
                    ((eof-object? line)
                     (write (reverse files) cache))
                    ((string-prefix? "-" line)
                     ;; this is a file entry: prepend to FILES, then re-enter
                     ;; the loop for remaining entries
                     (loop_entries path
                                   (cons (ls-lR-line->filename path line) files)
                                   ))
                    ((not (string= line ""))
                     ;; this is a non-file entry: ignore it, just re-enter the
                     ;; loop for remaining entries
                     (loop_entries path files))
                    ;; empty line: directory block end, re-enter the outer
                    ;; loop for the next block
                    (#t (loop_dirs files)))))))))))

  (define (cache-miss uri)
    (format (current-error-port) "fetching ~a...~%" (uri->string uri)))

  (let* ((port (http-fetch/cached %kde-file-list-uri
                                  #:ttl 3600
                                  #:write-cache write-cache
                                  #:cache-miss cache-miss))
         (files (read port)))
    (close-port port)
    files))

(define (uri->kde-path-pattern uri)
  "Build a regexp from the package's URI suitable for matching the package
path version-agnostic.

Example:
Input:
   mirror://kde//stable/frameworks/5.55/portingAids/kross-5.55.0.zip
Output:
   //stable/frameworks/[^/]+/portingAids/
"

  (define version-regexp
    ;; regexp for matching versions as used in the ld-lR file
    (make-regexp
     (string-join '("^([0-9]+\\.)+[0-9]+-?"   ;; 5.12.90, 4.2.0-preview
                    "^[0-9]+$"                ;; 20031002
                    ".*-([0-9]+\\.)+[0-9]+$") ;; kdepim-4.6.1
                    "|")))

  (define (version->pattern part)
    ;; If a path element might be a version, replace it by a catch-all part
    (if (regexp-exec version-regexp part)
        "[^/]+"
        part))

  (let* ((path (uri-path uri))
         (directory-parts (string-split (dirname path) #\/)))
    (make-regexp
     (string-append
      (string-join (map version->pattern directory-parts) "/")
      "/"))))

(define (latest-kde-release package)
  "Return the latest release of PACKAGE, a KDE package, or #f if it could
not be determined."
  (let* ((uri      (string->uri (origin-uri (package-source package))))
         (path-rx  (uri->kde-path-pattern uri))
         (name     (package-upstream-name package))
         (files    (download.kde.org-files))
         (relevant (filter (lambda (file)
                             (and (regexp-exec path-rx file)
                                  (release-file? name (basename file))))
                           files)))
    (match (sort relevant (lambda (file1 file2)
                            (version>? (tarball-sans-extension
                                        (basename file1))
                                       (tarball-sans-extension
                                        (basename file2)))))
           ((and tarballs (reference _ ...))
            (let* ((version  (tarball->version reference))
                   (tarballs (filter (lambda (file)
                                       (string=? (tarball-sans-extension
                                                  (basename file))
                                                 (tarball-sans-extension
                                                  (basename reference))))
                                     tarballs)))
              (upstream-source
               (package name)
               (version version)
               (urls (map (lambda (file)
                            (string-append "mirror://kde/" file))
                          tarballs)))))
           (()
            #f))))

(define %kde-updater
  (upstream-updater
    (name 'kde)
    (description "Updater for KDE packages")
    (pred (url-prefix-predicate "mirror://kde/"))
    (latest latest-kde-release)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import launchpad)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (web uri)
  #:use-module ((guix download) #:prefix download:)
  #:use-module (guix import json)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:export (%launchpad-updater))

(define (find-extension url)
  "Return the extension of the archive e.g. '.tar.gz' given a URL, or
false if none is recognized"
  (find (lambda (x) (string-suffix? x url))
        (list ".orig.tar.gz" ".tar.gz" ".tar.bz2" ".tar.xz"
              ".zip" ".tar" ".tgz" ".tbz" ".love")))

(define (updated-launchpad-url old-package new-version)
  ;; Return a url for the OLD-PACKAGE with NEW-VERSION.  If no source url in
  ;; the OLD-PACKAGE is a Launchpad url, then return false.

  (define (updated-url url)
    (and (string-prefix? "https://launchpad.net/" url)
         (let ((ext (or (find-extension url) ""))
               (name (package-name old-package))
               (version (package-version old-package))
               (repo (launchpad-repository url)))
           (cond
            ((< (length (string-split version #\.)) 2) #f)
            ((string=? (string-append "https://launchpad.net/"
                                      repo "/" (version-major+minor version)
                                      "/" version "/+download/" repo "-" version ext)
                       url)
             (string-append "https://launchpad.net/"
                            repo "/" (version-major+minor new-version)
                            "/" new-version "/+download/" repo "-" new-version ext))
            ((string=? (string-append "https://launchpad.net/"
                                      repo "/" (version-major+minor version)
                                      "/" version "/+download/" repo "_" version ext)
                       url)
             (string-append "https://launchpad.net/"
                            repo "/" (version-major+minor new-version)
                            "/" new-version "/+download/" repo "-" new-version ext))
            ((string=? (string-append "https://launchpad.net/"
                                      repo "/trunk/" version "/+download/"
                                      repo "-" version ext)
                       url)
             (string-append "https://launchpad.net/"
                            repo "/trunk/" new-version
                            "/+download/" repo "-" new-version ext))
            ((string=? (string-append "https://launchpad.net/"
                                      repo "/trunk/" version "/+download/"
                                      repo "_" version ext)
                       url)
             (string-append "https://launchpad.net/"
                            repo "/trunk/" new-version
                            "/+download/" repo "_" new-version ext))
            (#t #f))))) ; Some URLs are not recognised.

  (match (package-source old-package)
    ((? origin? origin)
     (let ((source-uri   (origin-uri origin))
           (fetch-method (origin-method origin)))
       (and (eq? fetch-method download:url-fetch)
            (match source-uri
              ((? string?)
               (updated-url source-uri))
              ((source-uri ...)
               (any updated-url source-uri))))))
    (_ #f)))

(define (launchpad-package? package)
  "Return true if PACKAGE is a package from Launchpad, else false."
  (->bool (updated-launchpad-url package "1.0.0")))

(define (launchpad-repository url)
  "Return a string e.g. linuxdcpp of the name of the repository, from a string
URL of the form
'https://launchpad.net/linuxdcpp/1.1/1.1.0/+download/linuxdcpp-1.1.0.tar.bz2'"
  (match (string-split (uri-path (string->uri url)) #\/)
    ((_ repo . rest) repo)))

(define (latest-released-version package-name)
  "Return a string of the newest released version name given the PACKAGE-NAME,
for example, 'linuxdcpp'. Return #f if there is no releases."
  (define (pre-release? x)
    ;; Versions containing anything other than digit characters and "." (for
    ;; example, "5.1.0-rc1") are assumed to be pre-releases.
    (not (string-every (char-set-union (char-set #\.)
                                       char-set:digit)
                       (assoc-ref x "version"))))

  (assoc-ref
   (last (remove
          pre-release?
          (vector->list
           (assoc-ref (json-fetch
                       (string-append "https://api.launchpad.net/1.0/"
                                      package-name "/releases"))
                      "entries"))))
   "version"))

(define (latest-release pkg)
  "Return an <upstream-source> for the latest release of PKG."
  (define (origin-github-uri origin)
    (match (origin-uri origin)
      ((? string? url) url) ; surely a Launchpad URL
      ((urls ...)
       (find (cut string-contains <> "launchpad.net") urls))))

  (let* ((source-uri (origin-github-uri (package-source pkg)))
         (name (package-name pkg))
         (newest-version (latest-released-version name)))
    (if newest-version
        (upstream-source
         (package name)
         (version newest-version)
         (urls (list (updated-launchpad-url pkg newest-version))))
        #f))) ; On Launchpad but no proper releases

(define %launchpad-updater
  (upstream-updater
   (name 'launchpad)
   (description "Updater for Launchpad packages")
   (pred launchpad-package?)
   (latest latest-release)))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import opam)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 peg)
  #:use-module (ice-9 receive)
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (web uri)
  #:use-module (guix build-system)
  #:use-module (guix build-system ocaml)
  #:use-module (guix http-client)
  #:use-module (guix git)
  #:use-module (guix ui)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:use-module (guix import utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:export (opam->guix-package
            opam-recursive-import
            %opam-updater

            ;; The following patterns are exported for testing purposes.
            string-pat
            multiline-string
            list-pat
            dict
            condition))

;; Define a PEG parser for the opam format
(define-peg-pattern comment none (and "#" (* STRCHR) "\n"))
(define-peg-pattern SP none (or " " "\n" comment))
(define-peg-pattern SP2 body (or " " "\n"))
(define-peg-pattern QUOTE none "\"")
(define-peg-pattern QUOTE2 body "\"")
(define-peg-pattern COLON none ":")
;; A string character is any character that is not a quote, or a quote preceded by a backslash.
(define-peg-pattern STRCHR body
                    (or " " "!" "\n" (and (ignore "\\") "\"")
                        (and (ignore "\\") "\\") (range #\# #\頋)))
(define-peg-pattern operator all (or "=" "!" "<" ">"))

(define-peg-pattern records body (* (and (or record weird-record) (* SP))))
(define-peg-pattern record all (and key COLON (* SP) value))
(define-peg-pattern weird-record all (and key (* SP) dict))
(define-peg-pattern key body (+ (or (range #\a #\z) "-")))
(define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP)))
(define-peg-pattern choice-pat all (and (ignore "(") (* SP) choice (* SP)  (ignore ")")))
(define-peg-pattern choice body
  (or (and (or conditional-value ground-value) (* SP) (ignore "|") (* SP) choice)
      conditional-value
      ground-value))
(define-peg-pattern ground-value body (and (or multiline-string string-pat choice-pat list-pat var) (* SP)))
(define-peg-pattern conditional-value all (and ground-value (* SP) condition))
(define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE))
(define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]")))
(define-peg-pattern var all (+ (or (range #\a #\z) "-")))
(define-peg-pattern multiline-string all
                    (and QUOTE QUOTE QUOTE (* SP)
                         (* (or SP2 STRCHR (and QUOTE2 (not-followed-by QUOTE))
                                (and QUOTE2 QUOTE2 (not-followed-by QUOTE))))
                         QUOTE QUOTE QUOTE))
(define-peg-pattern dict all (and (ignore "{") (* SP) records (* SP) (ignore "}")))

(define-peg-pattern condition body (and (ignore "{") condition-form (ignore "}")))

(define-peg-pattern condition-form body
                    (and
                      (* SP)
                      (or condition-and condition-or condition-form2)
                      (* SP)))
(define-peg-pattern condition-form2 body
                    (and (* SP) (or condition-greater-or-equal condition-greater
                                    condition-lower-or-equal condition-lower
                                    condition-neq condition-eq condition-not
                                    condition-content) (* SP)))

;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string))
(define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string))
(define-peg-pattern condition-greater all (and (ignore ">") (* SP) condition-string))
(define-peg-pattern condition-lower-or-equal all (and (ignore (and "<" "=")) (* SP) condition-string))
(define-peg-pattern condition-lower all (and (ignore "<") (* SP) condition-string))
(define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&")) (* SP) condition-form))
(define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form))
(define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content))
(define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content))
(define-peg-pattern condition-not all (and (ignore (and "!")) (* SP) condition-content))
(define-peg-pattern condition-content body (or condition-paren condition-string condition-var))
(define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!"))))
(define-peg-pattern condition-paren body (and "(" condition-form ")"))
(define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE))
(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":")))

(define (get-opam-repository)
  "Update or fetch the latest version of the opam repository and return the
path to the repository."
  (receive (location commit _)
    (update-cached-checkout "https://github.com/ocaml/opam-repository")
    location))

(define (latest-version versions)
  "Find the most recent version from a list of versions."
  (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))

(define (find-latest-version package repository)
  "Get the latest version of a package as described in the given repository."
  (let* ((dir (string-append repository "/packages/" package))
         (versions (scandir dir (lambda (name) (not (string-prefix? "." name))))))
    (if versions
      (let ((versions (map
                        (lambda (dir)
                          (string-join (cdr (string-split dir #\.)) "."))
                        versions)))
        ;; Workaround for janestreet re-versionning
        (let ((v-versions (filter (lambda (version) (string-prefix? "v" version)) versions)))
          (if (null? v-versions)
            (latest-version versions)
            (string-append "v" (latest-version (map (lambda (version) (substring version 1)) v-versions))))))
      (begin
        (format #t (G_ "Package not found in opam repository: ~a~%") package)
        #f))))

(define (get-metadata opam-file)
  (with-input-from-file opam-file
    (lambda _
      (peg:tree (match-pattern records (get-string-all (current-input-port)))))))

(define (substitute-char str what with)
  (string-join (string-split str what) with))

(define (ocaml-name->guix-name name)
  (substitute-char
    (cond
      ((equal? name "ocamlfind") "ocaml-findlib")
      ((string-prefix? "ocaml" name) name)
      ((string-prefix? "conf-" name) (substring name 5))
      (else (string-append "ocaml-" name)))
    #\_ "-"))

(define (metadata-ref file lookup)
  (fold (lambda (record acc)
          (match record
            ((record key val)
             (if (equal? key lookup)
               (match val
                 (('list-pat . stuff) stuff)
                 (('string-pat stuff) stuff)
                 (('multiline-string stuff) stuff)
                 (('dict records ...) records))
               acc))))
        #f file))

(define (native? condition)
  (match condition
    (('condition-var var)
     (match var
       ("with-test" #t)
       ("test" #t)
       ("build" #t)
       (_ #f)))
    ((or ('condition-or cond-left cond-right) ('condition-and cond-left cond-right))
     (or (native? cond-left)
         (native? cond-right)))
    (_ #f)))

(define (dependency->input dependency)
  (match dependency
    (('string-pat str) str)
    ;; Arbitrary select the first dependency
    (('choice-pat choice ...) (dependency->input (car choice)))
    (('conditional-value val condition)
     (if (native? condition) "" (dependency->input val)))))

(define (dependency->native-input dependency)
  (match dependency
    (('string-pat str) "")
    ;; Arbitrary select the first dependency
    (('choice-pat choice ...) (dependency->input (car choice)))
    (('conditional-value val condition)
     (if (native? condition) (dependency->input val) ""))))

(define (dependency->name dependency)
  (match dependency
    (('string-pat str) str)
    ;; Arbitrary select the first dependency
    (('choice-pat choice ...) (dependency->input (car choice)))
    (('conditional-value val condition)
     (dependency->name val))))

(define (dependency-list->names lst)
  (filter
    (lambda (name)
      (not (or
             (string-prefix? "conf-" name)
             (equal? name "ocaml")
             (equal? name "findlib"))))
    (map dependency->name lst)))

(define (ocaml-names->guix-names names)
  (map ocaml-name->guix-name
       (remove (lambda (name)
                 (or (equal? "" name))
                     (equal? "ocaml" name))
               names)))

(define (depends->inputs depends)
  (filter (lambda (name)
            (and (not (equal? "" name))
                 (not (equal? "ocaml" name))
                 (not (equal? "ocamlfind" name))))
    (map dependency->input depends)))

(define (depends->native-inputs depends)
  (filter (lambda (name) (not (equal? "" name)))
    (map dependency->native-input depends)))

(define (dependency-list->inputs lst)
  (map
    (lambda (dependency)
      (list dependency (list 'unquote (string->symbol dependency))))
    (ocaml-names->guix-names lst)))

(define* (opam-fetch name #:optional (repository (get-opam-repository)))
  (and-let* ((repository repository)
             (version (find-latest-version name repository))
             (file (string-append repository "/packages/" name "/" name "." version "/opam")))
    `(("metadata" ,@(get-metadata file))
      ("version" . ,(if (string-prefix? "v" version)
                        (substring version 1)
                        version)))))

(define* (opam->guix-package name #:key (repository (get-opam-repository)))
  "Import OPAM package NAME from REPOSITORY (a directory name) or, if
REPOSITORY is #f, from the official OPAM repository.  Return a 'package' sexp
or #f on failure."
  (and-let* ((opam-file (opam-fetch name repository))
             (version (assoc-ref opam-file "version"))
             (opam-content (assoc-ref opam-file "metadata"))
             (url-dict (metadata-ref opam-content "url"))
             (source-url (metadata-ref url-dict "src"))
             (requirements (metadata-ref opam-content "depends"))
             (dependencies (dependency-list->names requirements))
             (native-dependencies (depends->native-inputs requirements))
             (inputs (dependency-list->inputs (depends->inputs requirements)))
             (native-inputs (dependency-list->inputs
                              ;; Do not add dune nor jbuilder since they are
                              ;; implicit inputs of the dune-build-system.
                              (filter
                                (lambda (name)
                                  (not (member name '("dune" "jbuilder"))))
                                native-dependencies))))
        ;; If one of these are required at build time, it means we
        ;; can use the much nicer dune-build-system.
        (let ((use-dune? (or (member "dune" (append dependencies native-dependencies))
                        (member "jbuilder" (append dependencies native-dependencies)))))
          (call-with-temporary-output-file
            (lambda (temp port)
              (and (url-fetch source-url temp)
                   (values
                    `(package
                       (name ,(ocaml-name->guix-name name))
                       (version ,(if (string-prefix? "v" version)
                                   (substring version 1)
                                   version))
                       (source
                         (origin
                           (method url-fetch)
                           (uri ,source-url)
                           (sha256 (base32 ,(guix-hash-url temp)))))
                       (build-system ,(if use-dune?
                                          'dune-build-system
                                          'ocaml-build-system))
                       ,@(if (null? inputs)
                           '()
                           `((propagated-inputs ,(list 'quasiquote inputs))))
                       ,@(if (null? native-inputs)
                           '()
                           `((native-inputs ,(list 'quasiquote native-inputs))))
                       ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name)))
                           '()
                           `((properties
                               ,(list 'quasiquote `((upstream-name . ,name))))))
                       (home-page ,(metadata-ref opam-content "homepage"))
                       (synopsis ,(metadata-ref opam-content "synopsis"))
                       (description ,(metadata-ref opam-content "description"))
                       (license #f))
                    (filter
                      (lambda (name)
                        (not (member name '("dune" "jbuilder"))))
		      dependencies))))))))

(define (opam-recursive-import package-name)
  (recursive-import package-name #f
                    #:repo->guix-package (lambda (name repo)
                                           (opam->guix-package name))
                    #:guix-name ocaml-name->guix-name))

(define (guix-name->opam-name name)
  (if (string-prefix? "ocaml-" name)
    (substring name 6)
    name))

(define (guix-package->opam-name package)
  "Given an OCaml PACKAGE built from OPAM, return the name of the
package in OPAM."
  (let ((upstream-name (assoc-ref
                         (package-properties package)
                         'upstream-name))
        (name (package-name package)))
    (if upstream-name
      upstream-name
      (guix-name->opam-name name))))

(define (opam-package? package)
  "Return true if PACKAGE is an OCaml package from OPAM"
  (and
    (member (build-system-name (package-build-system package)) '(dune ocaml))
    (not (string-prefix? "ocaml4" (package-name package)))))

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (and-let* ((opam-name (guix-package->opam-name package))
             (opam-file (opam-fetch opam-name))
             (version (assoc-ref opam-file "version"))
             (opam-content (assoc-ref opam-file "metadata"))
             (url-dict (metadata-ref opam-content "url"))
             (source-url (metadata-ref url-dict "src")))
    (upstream-source
      (package (package-name package))
      (version version)
      (urls (list source-url)))))

(define %opam-updater
  (upstream-updater
    (name 'opam)
    (description "Updater for OPAM packages")
    (pred opam-package?)
    (latest latest-release)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2020 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import print)
  #:use-module (guix base32)
  #:use-module (guix utils)
  #:use-module (guix licenses)
  #:use-module (guix packages)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (gnu packages)
  #:use-module (srfi srfi-1)
  #:use-module (guix import utils)
  #:use-module (ice-9 control)
  #:use-module (ice-9 match)
  #:export (package->code))

;; FIXME: the quasiquoted arguments field may contain embedded package
;; objects, e.g. in #:disallowed-references; they will just be printed with
;; their usual #<package ...> representation, not as variable names.
(define (package->code package)
  "Return an S-expression representing the source code that produces PACKAGE
when evaluated."
  ;; The module in which the package PKG is defined
  (define (package-module-name pkg)
    (map string->symbol
         (string-split (string-drop-right
                        (location-file (package-location pkg)) 4)
                       #\/)))

  ;; Return the first candidate variable name that is bound to VAL.
  (define (variable-name val mod)
    (match (let/ec return
             (module-for-each (lambda (sym var)
                                (if (eq? val (variable-ref var))
                                    (return sym)
                                    #f))
                              (resolve-interface mod)))
      ((? symbol? sym) sym)
      (_ #f)))

  ;; Print either license variable name or the code for a license object
  (define (license->code lic)
    (let ((var (variable-name lic '(guix licenses))))
      (or (symbol-append 'license: var)
          `(license
            (name ,(license-name lic))
            (uri ,(license-uri lic))
            (comment ,(license-comment lic))))))

  (define (search-path-specification->code spec)
    `(search-path-specification
      (variable ,(search-path-specification-variable spec))
      (files (list ,@(search-path-specification-files spec)))
      (separator ,(search-path-specification-separator spec))
      (file-type (quote ,(search-path-specification-file-type spec)))
      (file-pattern ,(search-path-specification-file-pattern spec))))

  (define (source->code source version)
    (let ((uri       (origin-uri source))
          (method    (origin-method source))
          (sha256    (origin-sha256 source))
          (file-name (origin-file-name source))
          (patches   (origin-patches source)))
      `(origin
         (method ,(procedure-name method))
         (uri (string-append ,@(match (factorize-uri uri version)
                                 ((? string? uri) (list uri))
                                 (factorized factorized))))
         (sha256
          (base32
           ,(format #f "~a" (bytevector->nix-base32-string sha256))))
         ;; FIXME: in order to be able to throw away the directory prefix,
         ;; we just assume that the patch files can be found with
         ;; "search-patches".
         ,@(if (null? patches) '()
               `((patches (search-patches ,@(map basename patches))))))))

  (define (package-lists->code lsts)
    (list 'quasiquote
          (map (match-lambda
                 ((? symbol? s)
                  (list (symbol->string s) (list 'unquote s)))
                 ((label pkg . out)
                  (let ((mod (package-module-name pkg)))
                    (cons* label
                           ;; FIXME: using '@ certainly isn't pretty, but it
                           ;; avoids having to import the individual package
                           ;; modules.
                           (list 'unquote
                                 (list '@ mod (variable-name pkg mod)))
                           out))))
               lsts)))

  (let ((name                (package-name package))
        (version             (package-version package))
        (source              (package-source package))
        (build-system        (package-build-system package))
        (arguments           (package-arguments package))
        (inputs              (package-inputs package))
        (propagated-inputs   (package-propagated-inputs package))
        (native-inputs       (package-native-inputs package))
        (outputs             (package-outputs package))
        (native-search-paths (package-native-search-paths package))
        (search-paths        (package-search-paths package))
        (replacement         (package-replacement package))
        (synopsis            (package-synopsis package))
        (description         (package-description package))
        (license             (package-license package))
        (home-page           (package-home-page package))
        (supported-systems   (package-supported-systems package))
        (properties          (package-properties package)))
    `(define-public ,(string->symbol name)
       (package
         (name ,name)
         (version ,version)
         (source ,(source->code source version))
         ,@(match properties
             (() '())
             (_  `((properties ,properties))))
         ,@(if replacement
               `((replacement ,replacement))
               '())
         (build-system (@ (guix build-system ,(build-system-name build-system))
                          ,(symbol-append (build-system-name build-system)
                                          '-build-system)))
         ,@(match arguments
             (() '())
             (args `((arguments ,(list 'quasiquote args)))))
         ,@(match outputs
             (("out") '())
             (outs `((outputs (list ,@outs)))))
         ,@(match native-inputs
             (() '())
             (pkgs `((native-inputs ,(package-lists->code pkgs)))))
         ,@(match inputs
             (() '())
             (pkgs `((inputs ,(package-lists->code pkgs)))))
         ,@(match propagated-inputs
             (() '())
             (pkgs `((propagated-inputs ,(package-lists->code pkgs)))))
         ,@(if (lset= string=? supported-systems %supported-systems)
               '()
               `((supported-systems (list ,@supported-systems))))
         ,@(match (map search-path-specification->code native-search-paths)
             (() '())
             (paths `((native-search-paths (list ,@paths)))))
         ,@(match (map search-path-specification->code search-paths)
             (() '())
             (paths `((search-paths (list ,@paths)))))
         (home-page ,home-page)
         (synopsis ,synopsis)
         (description ,description)
         (license ,(if (list? license)
                       `(list ,@(map license->code license))
                       (license->code license)))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org>
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import pypi)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 receive)
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (guix utils)
  #:use-module (guix memoization)
  #:use-module (guix diagnostics)
  #:use-module (guix i18n)
  #:use-module ((guix build utils)
                #:select ((package-name->name+version
                           . hyphen-package-name->name+version)
                          find-files
                          invoke))
  #:use-module (guix import utils)
  #:use-module ((guix download) #:prefix download:)
  #:use-module (guix import json)
  #:use-module (json)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix build-system python)
  #:export (parse-requires.txt
            parse-wheel-metadata
            specification->requirement-name
            guix-package->pypi-name
            pypi-recursive-import
            pypi->guix-package
            %pypi-updater))

;; The PyPI API (notice the rhyme) is "documented" at:
;; <https://warehouse.readthedocs.io/api-reference/json/>.

(define non-empty-string-or-false
  (match-lambda
    ("" #f)
    ((? string? str) str)
    ((or 'null #f) #f)))

;; PyPI project.
(define-json-mapping <pypi-project> make-pypi-project pypi-project?
  json->pypi-project
  (info          pypi-project-info "info" json->project-info) ;<project-info>
  (last-serial   pypi-project-last-serial "last_serial")      ;integer
  (releases      pypi-project-releases "releases" ;string/<distribution>* pairs
                 (match-lambda
                   (((versions . dictionaries) ...)
                    (map (lambda (version vector)
                           (cons version
                                 (map json->distribution
                                      (vector->list vector))))
                         versions dictionaries))))
  (distributions pypi-project-distributions "urls" ;<distribution>*
                 (lambda (vector)
                   (map json->distribution (vector->list vector)))))

;; Project metadata.
(define-json-mapping <project-info> make-project-info project-info?
  json->project-info
  (name         project-info-name)                ;string
  (author       project-info-author)              ;string
  (maintainer   project-info-maintainer)          ;string
  (classifiers  project-info-classifiers          ;list of strings
                "classifiers" vector->list)
  (description  project-info-description)         ;string
  (summary      project-info-summary)             ;string
  (keywords     project-info-keywords)            ;string
  (license      project-info-license)             ;string
  (download-url project-info-download-url         ;string | #f
                "download_url" non-empty-string-or-false)
  (home-page    project-info-home-page            ;string
                "home_page")
  (url          project-info-url "project_url")   ;string
  (release-url  project-info-release-url "release_url") ;string
  (version      project-info-version))            ;string

;; Distribution: a URL along with cryptographic hashes and metadata.
(define-json-mapping <distribution> make-distribution distribution?
  json->distribution
  (url          distribution-url)                  ;string
  (digests      distribution-digests)              ;list of string pairs
  (file-name    distribution-file-name "filename") ;string
  (has-signature? distribution-has-signature? "hash_sig") ;Boolean
  (package-type distribution-package-type "packagetype") ;"bdist_wheel" | ...
  (python-version distribution-package-python-version
                  "python_version"))

(define (pypi-fetch name)
  "Return a <pypi-project> record for package NAME, or #f on failure."
  (and=> (json-fetch (string-append "https://pypi.org/pypi/" name "/json"))
         json->pypi-project))

;; For packages found on PyPI that lack a source distribution.
(define-condition-type &missing-source-error &error
  missing-source-error?
  (package  missing-source-error-package))

(define (latest-source-release pypi-package)
  "Return the latest source release for PYPI-PACKAGE."
  (let ((releases (assoc-ref (pypi-project-releases pypi-package)
                             (project-info-version
                              (pypi-project-info pypi-package)))))
    (or (find (lambda (release)
                (string=? "sdist" (distribution-package-type release)))
              releases)
        (raise (condition (&missing-source-error
                           (package pypi-package)))))))

(define (latest-wheel-release pypi-package)
  "Return the url of the wheel for the latest release of pypi-package,
or #f if there isn't any."
  (let ((releases (assoc-ref (pypi-project-releases pypi-package)
                             (project-info-version
                              (pypi-project-info pypi-package)))))
    (or (find (lambda (release)
                (string=? "bdist_wheel" (distribution-package-type release)))
              releases)
        #f)))

(define (python->package-name name)
  "Given the NAME of a package on PyPI, return a Guix-compliant name for the
package."
  (if (string-prefix? "python-" name)
      (snake-case name)
      (string-append "python-" (snake-case name))))

(define (guix-package->pypi-name package)
  "Given a Python PACKAGE built from pypi.org, return the name of the
package on PyPI."
  (define (url->pypi-name url)
    (hyphen-package-name->name+version
     (basename (file-sans-extension url))))

  (match (and=> (package-source package) origin-uri)
    ((? string? url)
     (url->pypi-name url))
    ((lst ...)
     (any url->pypi-name lst))
    (#f #f)))

(define (wheel-url->extracted-directory wheel-url)
  (match (string-split (basename wheel-url) #\-)
    ((name version _ ...)
     (string-append name "-" version ".dist-info"))))

(define (maybe-inputs package-inputs input-type)
  "Given a list of PACKAGE-INPUTS, tries to generate the 'inputs' field of a
package definition.  INPUT-TYPE, a symbol, is used to populate the name of
the input field."
  (match package-inputs
    (()
     '())
    ((package-inputs ...)
     `((,input-type (,'quasiquote ,package-inputs))))))

(define %requirement-name-regexp
  ;; Regexp to match the requirement name in a requirement specification.

  ;; Some grammar, taken from PEP-0508 (see:
  ;; https://www.python.org/dev/peps/pep-0508/).

  ;; Using this grammar makes the PEP-0508 regexp easier to understand for
  ;; humans.  The use of a regexp is preferred to more primitive string
  ;; manipulations because we can more directly match what upstream uses
  ;; (again, per PEP-0508).  The regexp approach is also easier to extend,
  ;; should we want to implement more completely the grammar of PEP-0508.

  ;; The unified rule can be expressed as:
  ;; specification = wsp* ( url_req | name_req ) wsp*

  ;; where url_req is:
  ;; url_req = name wsp* extras? wsp* urlspec wsp+ quoted_marker?

  ;; and where name_req is:
  ;; name_req = name wsp* extras? wsp* versionspec? wsp* quoted_marker?

  ;; Thus, we need only matching NAME, which is expressed as:
  ;; identifer_end = letterOrDigit | (('-' | '_' | '.' )* letterOrDigit)
  ;; identifier    = letterOrDigit identifier_end*
  ;; name          = identifier
  (let* ((letter-or-digit "[A-Za-z0-9]")
         (identifier-end (string-append "(" letter-or-digit "|"
                                        "[-_.]*" letter-or-digit ")"))
         (identifier (string-append "^" letter-or-digit identifier-end "*"))
         (name identifier))
    (make-regexp name)))

(define (specification->requirement-name spec)
  "Given a specification SPEC, return the requirement name."
  (match:substring
   (or (regexp-exec %requirement-name-regexp spec)
       (error (G_ "Could not extract requirement name in spec:") spec))))

(define (test-section? name)
  "Return #t if the section name contains 'test' or 'dev'."
  (any (cut string-contains-ci name <>)
       '("test" "dev")))

(define (parse-requires.txt requires.txt)
  "Given REQUIRES.TXT, a Setuptools requires.txt file, return a list of lists
of requirements.

The first list contains the required dependencies while the second the
optional test dependencies.  Note that currently, optional, non-test
dependencies are omitted since these can be difficult or expensive to
satisfy."

  (define (comment? line)
    ;; Return #t if the given LINE is a comment, #f otherwise.
    (string-prefix? "#" (string-trim line)))

  (define (section-header? line)
    ;; Return #t if the given LINE is a section header, #f otherwise.
    (string-prefix? "[" (string-trim line)))

  (call-with-input-file requires.txt
    (lambda (port)
      (let loop ((required-deps '())
                 (test-deps '())
                 (inside-test-section? #f)
                 (optional? #f))
        (let ((line (read-line port)))
          (cond
           ((eof-object? line)
            ;; Duplicates can occur, since the same requirement can be
            ;; listed multiple times with different conditional markers, e.g.
            ;; pytest >= 3 ; python_version >= "3.3"
            ;; pytest < 3 ; python_version < "3.3"
            (map (compose reverse delete-duplicates)
                 (list required-deps test-deps)))
           ((or (string-null? line) (comment? line))
            (loop required-deps test-deps inside-test-section? optional?))
           ((section-header? line)
            ;; Encountering a section means that all the requirements
            ;; listed below are optional. Since we want to pick only the
            ;; test dependencies from the optional dependencies, we must
            ;; track those separately.
            (loop required-deps test-deps (test-section? line) #t))
           (inside-test-section?
            (loop required-deps
                  (cons (specification->requirement-name line)
                        test-deps)
                  inside-test-section? optional?))
           ((not optional?)
            (loop (cons (specification->requirement-name line)
                        required-deps)
                  test-deps inside-test-section? optional?))
           (optional?
            ;; Skip optional items.
            (loop required-deps test-deps inside-test-section? optional?))
           (else
            (warning (G_ "parse-requires.txt reached an unexpected \
condition on line ~a~%") line))))))))

(define (parse-wheel-metadata metadata)
  "Given METADATA, a Wheel metadata file, return a list of lists of
requirements.

Refer to the documentation of PARSE-REQUIRES.TXT for a description of the
returned value."
  ;; METADATA is a RFC-2822-like, header based file.

  (define (requires-dist-header? line)
    ;; Return #t if the given LINE is a Requires-Dist header.
    (string-match "^Requires-Dist: " line))

  (define (requires-dist-value line)
    (string-drop line (string-length "Requires-Dist: ")))

  (define (extra? line)
    ;; Return #t if the given LINE is an "extra" requirement.
    (string-match "extra == '(.*)'" line))

  (define (test-requirement? line)
    (and=> (match:substring (extra? line) 1) test-section?))

  (call-with-input-file metadata
    (lambda (port)
      (let loop ((required-deps '())
                 (test-deps '()))
        (let ((line (read-line port)))
          (cond
           ((eof-object? line)
            (map (compose reverse delete-duplicates)
                 (list required-deps test-deps)))
           ((and (requires-dist-header? line) (not (extra? line)))
            (loop (cons (specification->requirement-name
                         (requires-dist-value line))
                        required-deps)
                  test-deps))
           ((and (requires-dist-header? line) (test-requirement? line))
            (loop required-deps
                  (cons (specification->requirement-name (requires-dist-value line))
                        test-deps)))
           (else
            (loop required-deps test-deps)))))))) ;skip line

(define (guess-requirements source-url wheel-url archive)
  "Given SOURCE-URL, WHEEL-URL and an ARCHIVE of the package, return a list
of the required packages specified in the requirements.txt file.  ARCHIVE will
be extracted in a temporary directory."

  (define (read-wheel-metadata wheel-archive)
    ;; Given WHEEL-ARCHIVE, a ZIP Python wheel archive, return the package's
    ;; requirements, or #f if the metadata file contained therein couldn't be
    ;; extracted.
    (let* ((dirname (wheel-url->extracted-directory wheel-url))
           (metadata (string-append dirname "/METADATA")))
      (call-with-temporary-directory
       (lambda (dir)
         (if (zero?
              (parameterize ((current-error-port (%make-void-port "rw+"))
                             (current-output-port (%make-void-port "rw+")))
                (system* "unzip" wheel-archive "-d" dir metadata)))
             (parse-wheel-metadata (string-append dir "/" metadata))
             (begin
               (warning
                (G_ "Failed to extract file: ~a from wheel.~%") metadata)
               #f))))))

  (define (guess-requirements-from-wheel)
    ;; Return the package's requirements using the wheel, or #f if an error
    ;; occurs.
    (call-with-temporary-output-file
     (lambda (temp port)
       (if wheel-url
           (and (url-fetch wheel-url temp)
                (read-wheel-metadata temp))
           #f))))

  (define (guess-requirements-from-source)
    ;; Return the package's requirements by guessing them from the source.
    (if (compressed-file? source-url)
        (call-with-temporary-directory
         (lambda (dir)
           (parameterize ((current-error-port (%make-void-port "rw+"))
                          (current-output-port (%make-void-port "rw+")))
             (if (string=? "zip" (file-extension source-url))
                 (invoke "unzip" archive "-d" dir)
                 (invoke "tar" "xf" archive "-C" dir)))
           (let ((requires.txt-files
                  (find-files dir (lambda (abs-file-name _)
		                    (string-match "\\.egg-info/requires.txt$"
                                                  abs-file-name)))))
             (match requires.txt-files
               (()
                (warning (G_ "Cannot guess requirements from source archive:\
 no requires.txt file found.~%"))
                (list '() '()))
               (else (parse-requires.txt (first requires.txt-files)))))))
        (begin
          (warning (G_ "Unsupported archive format; \
cannot determine package dependencies from source archive: ~a~%")
                   (basename source-url))
          (list '() '()))))

  ;; First, try to compute the requirements using the wheel, else, fallback to
  ;; reading the "requires.txt" from the egg-info directory from the source
  ;; archive.
  (or (guess-requirements-from-wheel)
      (guess-requirements-from-source)))

(define (compute-inputs source-url wheel-url archive)
  "Given the SOURCE-URL and WHEEL-URL of an already downloaded ARCHIVE, return
a pair of lists, each consisting of a list of name/variable pairs, for the
propagated inputs and the native inputs, respectively.  Also
return the unaltered list of upstream dependency names."

  (define (strip-argparse deps)
    (remove (cut string=? "argparse" <>) deps))

  (define (requirement->package-name/sort deps)
    (sort
     (map (lambda (input)
            (let ((guix-name (python->package-name input)))
              (list guix-name (list 'unquote (string->symbol guix-name)))))
          deps)
     (lambda args
       (match args
         (((a _ ...) (b _ ...))
          (string-ci<? a b))))))

  (define process-requirements
    (compose requirement->package-name/sort strip-argparse))

  (let ((dependencies (guess-requirements source-url wheel-url archive)))
    (values (map process-requirements dependencies)
            (concatenate dependencies))))

(define (make-pypi-sexp name version source-url wheel-url home-page synopsis
                        description license)
  "Return the `package' s-expression for a python package with the given NAME,
VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
  (call-with-temporary-output-file
   (lambda (temp port)
     (and (url-fetch source-url temp)
          (receive (guix-dependencies upstream-dependencies)
              (compute-inputs source-url wheel-url temp)
            (match guix-dependencies
              ((required-inputs native-inputs)
               (when (string-suffix? ".zip" source-url)
                 (set! native-inputs (cons
                                     '("unzip" ,unzip)
                                     native-inputs)))
               (values
                `(package
                   (name ,(python->package-name name))
                   (version ,version)
                   (source
                    (origin
                      (method url-fetch)
                      (uri (pypi-uri
                             ;; PyPI URL are case sensitive, but sometimes
                             ;; a project named using mixed case has a URL
                             ;; using lower case, so we must work around this
                             ;; inconsistency.  For actual examples, compare
                             ;; the URLs of the "Deprecated" and "uWSGI" PyPI
                             ;; packages.
                             ,(if (string-contains source-url name)
                                  name
                                  (string-downcase name))
                             version
                             ;; Some packages have been released as `.zip`
                             ;; instead of the more common `.tar.gz`. For
                             ;; example, see "path-and-address".
                             ,@(if (string-suffix? ".zip" source-url)
                                   '(".zip")
                                   '())))
                      (sha256
                       (base32
                        ,(guix-hash-url temp)))))
                   (build-system python-build-system)
                   ,@(maybe-inputs required-inputs 'propagated-inputs)
                   ,@(maybe-inputs native-inputs 'native-inputs)
                   (home-page ,home-page)
                   (synopsis ,synopsis)
                   (description ,description)
                   (license ,(license->symbol license)))
                upstream-dependencies))))))))

(define pypi->guix-package
  (memoize
   (lambda* (package-name)
     "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
     (let* ((project (pypi-fetch package-name))
            (info    (and project (pypi-project-info project))))
       (and project
            (guard (c ((missing-source-error? c)
                       (let ((package (missing-source-error-package c)))
                         (leave (G_ "no source release for pypi package ~a ~a~%")
                                (project-info-name info)
                                (project-info-version info)))))
              (make-pypi-sexp (project-info-name info)
                              (project-info-version info)
                              (and=> (latest-source-release project)
                                     distribution-url)
                              (and=> (latest-wheel-release project)
                                     distribution-url)
                              (project-info-home-page info)
                              (project-info-summary info)
                              (project-info-summary info)
                              (string->license
                               (project-info-license info)))))))))

(define (pypi-recursive-import package-name)
  (recursive-import package-name #f
                    #:repo->guix-package (lambda (name repo)
                                           (pypi->guix-package name))
                    #:guix-name python->package-name))

(define (string->license str)
  "Convert the string STR into a license object."
  (match str
    ("GNU LGPL" license:lgpl2.0)
    ("GPL" license:gpl3)
    ((or "BSD" "BSD-3" "BSD License") license:bsd-3)
    ("BSD-2-Clause" license:bsd-2)
    ((or "MIT" "MIT license" "MIT License" "Expat license") license:expat)
    ("Public domain" license:public-domain)
    ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0)
    ("MPL 2.0" license:mpl2.0)
    (_ #f)))

(define pypi-package?
  (url-predicate
   (lambda (url)
     (or (string-prefix? "https://pypi.org/" url)
         (string-prefix? "https://pypi.python.org/" url)
         (string-prefix? "https://pypi.org/packages" url)
         (string-prefix? "https://files.pythonhosted.org/packages" url)))))

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (let* ((pypi-name    (guix-package->pypi-name package))
         (pypi-package (pypi-fetch pypi-name)))
    (and pypi-package
         (guard (c ((missing-source-error? c) #f))
           (let* ((info    (pypi-project-info pypi-package))
                  (version (project-info-version info))
                  (url     (distribution-url
                            (latest-source-release pypi-package))))
             (upstream-source
              (package (package-name package))
              (version version)
              (urls (list url))))))))

(define %pypi-updater
  (upstream-updater
   (name 'pypi)
   (description "Updater for PyPI packages")
   (pred pypi-package?)
   (latest latest-release)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import snix)
  #:use-module (sxml ssax)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 format)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)

  ;; Use the 'package-name->name+version' procedure that works with
  ;; hyphen-separate name/version, not the one that works with '@'-separated
  ;; name/version.  Subtle!
  #:use-module ((guix utils) #:hide (package-name->name+version))
  #:use-module ((guix build utils) #:select (package-name->name+version))

  #:use-module (guix import utils)
  #:use-module (guix base16)
  #:use-module (guix base32)
  #:use-module (guix config)
  #:use-module (guix gnu-maintenance)
  #:export (open-nixpkgs
            xml->snix
            nixpkgs->guix-package))

;;; Commentary:
;;;
;;; Converting Nix code to s-expressions, and then to Guix `package'
;;; declarations, using the XML output of `nix-instantiate'.
;;;
;;; Code:

;;;
;;; SNix.
;;;

;; Nix object types visible in the XML output of `nix-instantiate' and
;; mapping to S-expressions (we map to sexps, not records, so that we
;; can do pattern matching):
;;
;;   at               (at varpat attrspat)
;;   attr             (attribute loc name value)
;;   attrs            (attribute-set attributes)
;;   attrspat         (attribute-set-pattern patterns)
;;   bool             #f|#t
;;   derivation       (derivation drv-path out-path attributes)
;;   ellipsis         '...
;;   expr             (snix loc body ...)
;;   function         (function loc at|attrspat|varpat)
;;   int              int
;;   list             list
;;   null             'null
;;   path             string
;;   string           string
;;   unevaluated      'unevaluated
;;   varpat           (varpat name)
;;
;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise;
;; however, handling `repeated' nodes makes it impossible to do anything
;; lazily because the whole SXML tree has to be traversed to maintain the
;; list of known derivations.

(define (xml-element->snix elem attributes body derivations)
  "Return an SNix element corresponding to XML element ELEM."

  (define (loc)
    (location (assq-ref attributes 'path)
              (assq-ref attributes 'line)
              (assq-ref attributes 'column)))

  (case elem
    ((at)
     (values `(at ,(car body) ,(cadr body)) derivations))
    ((attr)
     (let ((name (assq-ref attributes 'name)))
       (cond ((null? body)
              (values `(attribute-pattern ,name) derivations))
             ((and (pair? body) (null? (cdr body)))
              (values `(attribute ,(loc) ,name ,(car body))
                      derivations))
             (else
              (error "invalid attribute body" name (loc) body)))))
    ((attrs)
     (values `(attribute-set ,(reverse body)) derivations))
    ((attrspat)
     (values `(attribute-set-pattern ,body) derivations))
    ((bool)
     (values (string-ci=? "true" (assq-ref attributes 'value))
             derivations))
    ((derivation)
     (let ((drv-path (assq-ref attributes 'drvPath))
           (out-path (assq-ref attributes 'outPath)))
       (if (equal? body '(repeated))
           (let ((body (vhash-assoc drv-path derivations)))
             (if (pair? body)
                 (values `(derivation ,drv-path ,out-path ,(cdr body))
                         derivations)

                 ;; DRV-PATH hasn't been encountered yet but may be later
                 ;; (see <http://article.gmane.org/gmane.linux.distributions.nixos/5946>.)
                 ;; Return an `unresolved' node.
                 (values `(unresolved
                           ,(lambda (derivations)
                              (let ((body (vhash-assoc drv-path derivations)))
                                (if (pair? body)
                                    `(derivation ,drv-path ,out-path
                                                 ,(cdr body))
                                    (error "no previous occurrence of derivation"
                                           drv-path)))))
                         derivations)))
           (values `(derivation ,drv-path ,out-path ,body)
                   (vhash-cons drv-path body derivations)))))
    ((ellipsis)
     (values '... derivations))
    ((expr)
     (values `(snix ,(loc) ,@body) derivations))
    ((function)
     (values `(function ,(loc) ,body) derivations))
    ((int)
     (values (string->number (assq-ref attributes 'value))
             derivations))
    ((list)
     (values body derivations))
    ((null)
     (values 'null derivations))
    ((path)
     (values (assq-ref attributes 'value) derivations))
    ((repeated)
     (values 'repeated derivations))
    ((string)
     (values (assq-ref attributes 'value) derivations))
    ((unevaluated)
     (values 'unevaluated derivations))
    ((varpat)
     (values `(varpat ,(assq-ref attributes 'name)) derivations))
    (else (error "unhandled Nix XML element" elem))))

(define (resolve snix derivations)
  "Return a new SNix tree where `unresolved' nodes from SNIX have been
replaced by the result of their application to DERIVATIONS, a vhash."
  (let loop ((node snix)
             (seen vlist-null))
    (if (vhash-assq node seen)
        (values node seen)
        (match node
          (('unresolved proc)
           (let ((n (proc derivations)))
             (values n seen)))
          ((tag body ...)
           (let ((body+seen (fold (lambda (n body+seen)
                                    (call-with-values
                                        (lambda ()
                                          (loop n (cdr body+seen)))
                                      (lambda (n* seen)
                                        (cons (cons n* (car body+seen))
                                              (vhash-consq n #t seen)))))
                                  (cons '() (vhash-consq node #t seen))
                                  body)))
             (values (cons tag (reverse (car body+seen)))
                     (vhash-consq node #t (cdr body+seen)))))
          (anything
           (values anything seen))))))

(define xml->snix
  (let ((parse
         (ssax:make-parser NEW-LEVEL-SEED
                           (lambda (elem-gi attributes namespaces expected-content
                                    seed)
                             (cons '() (cdr seed)))

                           FINISH-ELEMENT
                           (lambda (elem-gi attributes namespaces parent-seed
                                            seed)
                             (let ((snix        (car seed))
                                   (derivations (cdr seed)))
                               (let-values (((snix derivations)
                                             (xml-element->snix elem-gi
                                                                attributes
                                                                snix
                                                                derivations)))
                                 (cons (cons snix (car parent-seed))
                                       derivations))))

                           CHAR-DATA-HANDLER
                           (lambda (string1 string2 seed)
                             ;; Discard inter-node strings, which are blanks.
                             seed))))
    (lambda (port)
      "Return the SNix represention of TREE, an SXML tree as returned by
parsing the XML output of `nix-instantiate' on Nixpkgs."
      (match (parse port (cons '() vlist-null))
        (((snix) . derivations)
         (resolve snix derivations))))))

(define (attribute-value attribute)
  "Return the value of ATTRIBUTE."
  (match attribute
    (('attribute _ _ value) value)))

(define (derivation-source derivation)
  "Return the \"src\" attribute of DERIVATION or #f if not found."
  (match derivation
    (('derivation _ _ (attributes ...))
     (find-attribute-by-name "src" attributes))))

(define (derivation-output-path derivation)
  "Return the output path of DERIVATION."
  (match derivation
    (('derivation _ out-path _)
     out-path)
    (_ #f)))

(define (source-output-path src)
  "Return the output path of SRC, the \"src\" attribute of a derivation."
  (derivation-output-path (attribute-value src)))

(define (source-urls src)
  "Return the URLs of SRC, the \"src\" attribute of a derivation."
  (match src
    (('attribute _ _ ('derivation _ _ (attributes ...)))
     (match (find-attribute-by-name "urls" attributes)
       (('attribute _ _ value)
        value)))
    (_ #f)))

(define (source-sha256 src)
  "Return the sha256 of SRC, the \"src\" attribute of a derivation, as a
bytevector."
  (match src
    (('attribute _ _ ('derivation _ _ (attributes ...)))
     (match (find-attribute-by-name "outputHash" attributes)
       (('attribute _ _ value)
        (match value
          ((= string-length 52)
           (nix-base32-string->bytevector value))
          ((= string-length 64)
           (base16-string->bytevector value))
          (_
           (error "unsupported hash format" value))))))
    (_ #f)))

(define (derivation-source-output-path derivation)
  "Return the output path of the \"src\" attribute of DERIVATION or #f
if DERIVATION lacks an \"src\" attribute."
  (and=> (derivation-source derivation) source-output-path))

(define* (open-nixpkgs nixpkgs #:optional attribute)
  "Return an input pipe to the XML representation of Nixpkgs.  When
ATTRIBUTE is true, only that attribute is considered."
  (with-fluids ((%default-port-encoding "UTF-8"))
    (let ((cross-system (format #f "{
  config = \"i686-guix-linux-gnu\";
  libc = \"glibc\";
  arch = \"guix\";
  withTLS = true;
  float = \"hard\";
  openssl.system = \"linux-generic32\";
  platform = (import ~a/pkgs/top-level/platforms.nix).sheevaplug;
}" nixpkgs)))
      (apply open-pipe* OPEN_READ
             "nix-instantiate" "--strict" "--eval-only" "--xml"

             ;; Pass a dummy `crossSystem' argument so that `buildInputs' and
             ;; `nativeBuildInputs' are not coalesced.
             ;; XXX: This is hacky and has other problems.
             ;"--arg" "crossSystem" cross-system

             `(,@(if attribute
                     `("-A" ,attribute)
                     '())
               ,nixpkgs)))))

(define (pipe-failed? pipe)
  "Close pipe and return its status if it failed."
  (let ((status (close-pipe pipe)))
    (if (or (status:term-sig status)
            (not (= (status:exit-val status) 0)))
        status
        #f)))

(define (find-attribute-by-name name attributes)
  "Return attribute NAME in ATTRIBUTES, an attribute set or list of SNix
attributes, or #f if NAME cannot be found."
  (find (lambda (a)
          (match a
            (('attribute _ (? (cut string=? <> name)) _)
             a)
            (_ #f)))
        (match attributes
          (('attribute-set (attributes ...))
           attributes)
          (_
           attributes))))

(define (license-variable license)
  "Return the name of the (guix licenses) variable for LICENSE."
  (match license
    ("GPLv2+"    'gpl2+)
    ("GPLv3+"    'gpl3+)
    ("LGPLv2+"   'lgpl2.1+)
    ("LGPLv2.1+" 'lgpl2.1+)
    ("LGPLv3+"   'lgpl3+)
    (('attribute-set _ ...)
     ;; At some point in 2013, Nixpkgs switched to attribute sets to represent
     ;; licenses.  These are listed in lib/licenses.nix.
     (match (and=> (find-attribute-by-name "shortName" license)
                   attribute-value)
       ("agpl3Plus"  'agpl3+)
       ("gpl2Plus"   'gpl2+)
       ("gpl3Plus"   'gpl3+)
       ("lgpl2Plus"  'lgpl2.0+)
       ("lgpl21Plus" 'lgpl2.1+)
       ("lgpl3Plus"  'lgpl3+)
       ((? string? x) x)
       (_             license)))
    (_           license)))

(define (package-source-output-path package)
  "Return the output path of the \"src\" derivation of PACKAGE."
  (derivation-source-output-path (attribute-value package)))

;;;
;;; Conversion of "Nix expressions" to "Guix expressions".
;;;

(define (snix-derivation->guix-package derivation)
  "Return the `package' s-expression corresponding to SNix DERIVATION, a
Nixpkgs `stdenv.mkDerivation'-style derivation, and the original source
location of DERIVATION."
  (match derivation
    (('derivation _ _ (attributes ...))
     (let*-values (((full-name loc)
                    (match (find-attribute-by-name "name" attributes)
                      (('attribute loc _ value)
                       (values value loc))
                      (_
                       (values #f #f))))
                   ((name version)
                    (package-name->name+version full-name)))
       (define (convert-inputs type)
         ;; Convert the derivation's input from a list of SNix derivations to
         ;; a list of name/variable pairs.
         (match (and=> (find-attribute-by-name type attributes)
                       attribute-value)
           (#f
            '())
           ((inputs ...)
            ;; Inputs can be either derivations or the null value.
            (filter-map (match-lambda
                         (('derivation _ _ (attributes ...))
                          (let* ((full-name
                                  (attribute-value
                                   (find-attribute-by-name "name" attributes)))
                                 (name (package-name->name+version full-name)))
                            (list name
                                  (list 'unquote (string->symbol name)))))
                         ('null #f))
                        inputs))))

       (define (maybe-inputs guix-name inputs)
         (match inputs
           (()
            '())
           ((inputs ...)
            (list (list guix-name
                        (list 'quasiquote inputs))))))

       (define (pretty-uri uri version)
         (if version
             (match (factorize-uri uri version)
               ((items ...)
                `(string-append ,@items))
               (x x))
             uri))

       (let* ((source  (find-attribute-by-name "src" attributes))
              (urls    (source-urls source))
              (sha256  (source-sha256 source))
              (meta    (and=> (find-attribute-by-name "meta" attributes)
                              attribute-value)))
         (values
          `(package
             (name ,name)
             (version ,version)
             (source (origin
                      (method url-fetch)
                      (uri ,(pretty-uri (car urls) version))
                      (sha256
                       (base32
                        ,(bytevector->nix-base32-string sha256)))))
             (build-system gnu-build-system)

             ;; When doing a native Nixpkgs build, `buildInputs' is empty and
             ;; everything is in `nativeBuildInputs'.  So we can't distinguish
             ;; between both, here.
             ;;
             ;; Note that `nativeBuildInputs' was renamed from
             ;; `buildNativeInputs' in Nixpkgs sometime around March 2013.
             ,@(maybe-inputs 'inputs
                             (convert-inputs "nativeBuildInputs"))
             ,@(maybe-inputs 'propagated-inputs
                             (convert-inputs "propagatedNativeBuildInputs"))

             (home-page ,(and=> (find-attribute-by-name "homepage" meta)
                                attribute-value))
             (synopsis
              ;; For GNU packages, prefer the official synopsis.
              ,(or (false-if-exception
                    (and=> (find (lambda (gnu-package)
                                   (equal? (gnu-package-name gnu-package)
                                           name))
                                 (official-gnu-packages))
                           gnu-package-doc-summary))
                   (and=> (find-attribute-by-name "description" meta)
                          attribute-value)))
             (description
              ;; Likewise, prefer the official description of GNU packages.
              ,(or (false-if-exception
                    (and=> (find (lambda (gnu-package)
                                   (equal? (gnu-package-name gnu-package)
                                           name))
                                 (official-gnu-packages))
                           gnu-package-doc-description))
                   (and=> (find-attribute-by-name "longDescription" meta)
                          attribute-value)))
             (license ,(and=> (find-attribute-by-name "license" meta)
                              (compose license-variable attribute-value))))
          loc))))))

(define (nixpkgs->guix-package nixpkgs attribute)
  "Evaluate ATTRIBUTE in NIXPKGS, the file name of a Nixpkgs checkout,
and return the `package' s-expression corresponding to that package."
  (let ((port (open-nixpkgs nixpkgs attribute)))
    (match (xml->snix port)
      (('snix loc (and drv ('derivation _ ...)))
       (and (not (pipe-failed? port))
            (snix-derivation->guix-package drv)))
      (_
       (not (pipe-failed? port))))))

;;; snix.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import stackage)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (guix import json)
  #:use-module (guix import hackage)
  #:use-module (guix import utils)
  #:use-module (guix memoization)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:export (stackage->guix-package
            stackage-recursive-import
            %stackage-updater))

;;;
;;; Stackage info fetcher and access functions
;;;

(define %stackage-url "http://www.stackage.org")

(define (lts-info-ghc-version lts-info)
  "Retruns the version of the GHC compiler contained in LTS-INFO."
  (and=> (assoc-ref lts-info "snapshot")
         (cut assoc-ref <> "ghc")))

(define (lts-info-packages lts-info)
  "Retruns the alist of packages contained in LTS-INFO."
  (or (assoc-ref lts-info "packages") '()))

(define (leave-with-message fmt . args)
  (raise (condition (&message (message (apply format #f fmt args))))))

(define stackage-lts-info-fetch
  ;; "Retrieve the information about the LTS Stackage release VERSION."
  (memoize
   (lambda* (#:optional (version ""))
     (let* ((url (if (string=? "" version)
                     (string-append %stackage-url "/lts")
                     (string-append %stackage-url "/lts-" version)))
            (lts-info (json-fetch url)))
       (if lts-info
           (reverse lts-info)
           (leave-with-message "LTS release version not found: ~a" version))))))

(define (stackage-package-name pkg-info)
  (assoc-ref pkg-info "name"))

(define (stackage-package-version pkg-info)
  (assoc-ref pkg-info "version"))

(define (lts-package-version pkgs-info name)
  "Return the version of the package with upstream NAME included in PKGS-INFO."
  (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name))
                   (vector->list pkgs-info))))
    (stackage-package-version pkg)))

;;;
;;; Importer entry point
;;;

(define (hackage-name-version name version)
  (and version (string-append  name "@" version)))

(define stackage->guix-package
  (memoize
   (lambda* (package-name ; upstream name
             #:key
             (include-test-dependencies? #t)
             (lts-version "")
             (packages-info
              (lts-info-packages
               (stackage-lts-info-fetch lts-version))))
     "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org.  The retrieved
version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION
release at stackage.org.  Return the `package' S-expression corresponding to
that package, or #f on failure.  PACKAGES-INFO is the alist with the packages
included in the Stackage LTS release."
     (let* ((version (lts-package-version packages-info package-name))
            (name-version (hackage-name-version package-name version)))
       (if name-version
           (hackage->guix-package name-version
                                  #:include-test-dependencies?
                                  include-test-dependencies?)
           (leave-with-message "~a: Stackage package not found" package-name))))))

(define (stackage-recursive-import package-name . args)
  (recursive-import package-name #f
                    #:repo->guix-package (lambda (name repo)
                                           (apply stackage->guix-package (cons name args)))
                    #:guix-name hackage-name->package-name))

;;;
;;; Updater
;;;

(define latest-lts-release
  (let ((pkgs-info (mlambda () (lts-info-packages (stackage-lts-info-fetch)))))
    (lambda* (package)
      "Return an <upstream-source> for the latest Stackage LTS release of
PACKAGE or #f if the package is not included in the Stackage LTS release."
      (let* ((hackage-name (guix-package->hackage-name package))
             (version (lts-package-version (pkgs-info) hackage-name))
             (name-version (hackage-name-version hackage-name version)))
        (match (and=> name-version hackage-fetch)
          (#f (format (current-error-port)
                      "warning: failed to parse ~a~%"
                      (hackage-cabal-url hackage-name))
              #f)
          (_ (let ((url (hackage-source-url hackage-name version)))
               (upstream-source
                (package (package-name package))
                (version version)
                (urls (list url))))))))))

(define %stackage-updater
  (upstream-updater
   (name 'stackage)
   (description "Updater for Stackage LTS packages")
   (pred hackage-package?)
   (latest latest-lts-release)))

;;; stackage.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import texlive)
  #:use-module (ice-9 match)
  #:use-module (sxml simple)
  #:use-module (sxml xpath)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (web uri)
  #:use-module (guix http-client)
  #:use-module (gcrypt hash)
  #:use-module (guix memoization)
  #:use-module (guix store)
  #:use-module (guix base32)
  #:use-module (guix serialization)
  #:use-module (guix svn-download)
  #:use-module (guix import utils)
  #:use-module (guix utils)
  #:use-module (guix upstream)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:use-module (guix build-system texlive)
  #:export (texlive->guix-package

            fetch-sxml
            sxml->package))

;;; Commentary:
;;;
;;; Generate a package declaration template for the latest version of a
;;; package on CTAN, using the XML output produced by the XML API to the CTAN
;;; database at http://www.ctan.org/xml/1.2/
;;;
;;; Instead of taking the packages from CTAN, however, we fetch the sources
;;; from the SVN repository of the Texlive project.  We do this because CTAN
;;; only keeps a single version of each package whereas we can access any
;;; version via SVN.  Unfortunately, this means that the importer is really
;;; just a Texlive importer, not a generic CTAN importer.
;;;
;;; Code:

(define string->license
  (match-lambda
    ("artistic2" 'gpl3+)
    ("gpl" 'gpl3+)
    ("gpl1" 'gpl1)
    ("gpl1+" 'gpl1+)
    ("gpl2" 'gpl2)
    ("gpl2+" 'gpl2+)
    ("gpl3" 'gpl3)
    ("gpl3+" 'gpl3+)
    ("lgpl2.1" 'lgpl2.1)
    ("lgpl3" 'lgpl3)
    ("knuth" 'knuth)
    ("pd" 'public-domain)
    ("bsd2" 'bsd-2)
    ("bsd3" 'bsd-3)
    ("bsd4" 'bsd-4)
    ("opl" 'opl1.0+)
    ("ofl" 'silofl1.1)
    ("lppl" 'lppl)
    ("lppl1" 'lppl1.0+) ; usually means "or later"
    ("lppl1.2" 'lppl1.2+) ; usually means "or later"
    ("lppl1.3" 'lppl1.3+) ; usually means "or later"
    ("lppl1.3a" 'lppl1.3a)
    ("lppl1.3b" 'lppl1.3b)
    ("lppl1.3c" 'lppl1.3c)
    ("cc-by-2" 'cc-by-2.0)
    ("cc-by-3" 'cc-by-3.0)
    ("cc-by-sa-2" 'cc-by-sa2.0)
    ("cc-by-sa-3" 'cc-by-sa3.0)
    ("mit" 'expat)
    ("fdl" 'fdl1.3+)
    ("gfl" 'gfl1.0)

    ;; These are known non-free licenses
    ("noinfo" 'unknown)
    ("nosell" 'non-free)
    ("shareware" 'non-free)
    ("nosource" 'non-free)
    ("nocommercial" 'non-free)
    ("cc-by-nc-nd-1" 'non-free)
    ("cc-by-nc-nd-2" 'non-free)
    ("cc-by-nc-nd-2.5" 'non-free)
    ("cc-by-nc-nd-3" 'non-free)
    ("cc-by-nc-nd-4" 'non-free)
    ((x) (string->license x))
    ((lst ...) `(list ,@(map string->license lst)))
    (_ #f)))

(define (fetch-sxml name)
  "Return an sxml representation of the package information contained in the
XML description of the CTAN package or #f in case of failure."
  ;; This API always returns the latest release of the module.
  (let ((url (string-append "http://www.ctan.org/xml/1.2/pkg/" name)))
    (guard (c ((http-get-error? c)
               (format (current-error-port)
                       "error: failed to retrieve package information \
from ~s: ~a (~s)~%"
                       (uri->string (http-get-error-uri c))
                       (http-get-error-code c)
                       (http-get-error-reason c))
               #f))
      (xml->sxml (http-fetch url)
                 #:trim-whitespace? #t))))

(define (guix-name component name)
  "Return a Guix package name for a given Texlive package NAME."
  (string-append "texlive-" component "-"
                 (string-map (match-lambda
                               (#\_ #\-)
                               (#\. #\-)
                               (chr (char-downcase chr)))
                             name)))

(define* (sxml->package sxml #:optional (component "latex"))
  "Return the `package' s-expression for a Texlive package from the SXML
expression describing it."
  (define (sxml-value path)
    (match ((sxpath path) sxml)
      (() #f)
      ((val) val)))
  (with-store store
    (let* ((id         (sxml-value '(entry @ id *text*)))
           (synopsis   (sxml-value '(entry caption *text*)))
           (version    (or (sxml-value '(entry version @ number *text*))
                           (sxml-value '(entry version @ date *text*))))
           (license    (match ((sxpath '(entry license @ type *text*)) sxml)
                         ((license) (string->license license))
                         ((lst ...) (map string->license lst))))
           (home-page  (string-append "http://www.ctan.org/pkg/" id))
           (ref        (texlive-ref component id))
           (checkout   (download-svn-to-store store ref)))
      `(package
         (name ,(guix-name component id))
         (version ,version)
         (source (origin
                   (method svn-fetch)
                   (uri (texlive-ref ,component ,id))
                   (sha256
                    (base32
                     ,(bytevector->nix-base32-string
                       (let-values (((port get-hash) (open-sha256-port)))
                         (write-file checkout port)
                         (force-output port)
                         (get-hash)))))))
         (build-system texlive-build-system)
         (arguments ,`(,'quote (#:tex-directory ,(string-join (list component id) "/"))))
         (home-page ,home-page)
         (synopsis ,synopsis)
         (description ,(string-trim-both
                        (string-join
                         (map string-trim-both
                              (string-split
                               (beautify-description
                                (sxml->string (or (sxml-value '(entry description))
                                                  '())))
                               #\newline)))))
         (license ,(match license
                     ((lst ...) `(list ,@lst))
                     (license license)))))))

(define texlive->guix-package
  (memoize
   (lambda* (package-name #:optional (component "latex"))
     "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
s-expression corresponding to that package, or #f on failure."
     (and=> (fetch-sxml package-name)
            (cut sxml->package <> component)))))

;;; ctan.scm ends here