code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.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 cran)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 popen)
  #:use-module ((ice-9 rdelim) #:select (read-string read-line))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (ice-9 receive)
  #:use-module (web uri)
  #:use-module (guix memoization)
  #:use-module (guix http-client)
  #:use-module (gcrypt hash)
  #:use-module (guix store)
  #:use-module ((guix serialization) #:select (write-file))
  #:use-module (guix base32)
  #:use-module ((guix download) #:select (download-to-store))
  #:use-module (guix import utils)
  #:use-module ((guix build utils)
                #:select (find-files
                          delete-file-recursively
                          with-directory-excursion))
  #:use-module (guix utils)
  #:use-module (guix git)
  #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
  #:use-module (guix ui)
  #:use-module (guix upstream)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:export (cran->guix-package
            bioconductor->guix-package
            cran-recursive-import
            %cran-updater
            %bioconductor-updater
            %bioconductor-version

            cran-package?
            bioconductor-package?
            bioconductor-data-package?
            bioconductor-experiment-package?

            description->alist
            description->package))

;;; Commentary:
;;;
;;; Generate a package declaration template for the latest version of an R
;;; package on CRAN, using the DESCRIPTION file downloaded from
;;; cran.r-project.org.
;;;
;;; Code:

(define string->license
  (match-lambda
   ("AGPL-3" 'agpl3+)
   ("Artistic-2.0" 'artistic2.0)
   ("Apache License 2.0" 'asl2.0)
   ("BSD_2_clause" 'bsd-2)
   ("BSD_2_clause + file LICENSE" 'bsd-2)
   ("BSD_3_clause" 'bsd-3)
   ("BSD_3_clause + file LICENSE" 'bsd-3)
   ("GPL" '(list gpl2+ gpl3+))
   ("GPL (>= 2)" 'gpl2+)
   ("GPL (>= 3)" 'gpl3+)
   ("GPL-2" 'gpl2)
   ("GPL-3" 'gpl3)
   ("LGPL-2" 'lgpl2.0)
   ("LGPL-2.1" 'lgpl2.1)
   ("LGPL-3" 'lgpl3)
   ("LGPL (>= 2)" 'lgpl2.0+)
   ("LGPL (>= 2.1)" 'lgpl2.1+)
   ("LGPL (>= 3)" 'lgpl3+)
   ("MIT" 'expat)
   ("MIT + file LICENSE" 'expat)
   ((x) (string->license x))
   ((lst ...) `(list ,@(map string->license lst)))
   (_ #f)))

(define (description->alist description)
  "Convert a DESCRIPTION string into an alist."
  (let ((lines (string-split description #\newline))
        (parse (lambda (line acc)
                 (if (string-null? line) acc
                     ;; Keys usually start with a capital letter and end with
                     ;; ":".  There are some exceptions, unfortunately (such
                     ;; as "biocViews").  There are no blanks in a key.
                     (if (string-match "^[A-Za-z][^ :]+:( |\n|$)" line)
                         ;; New key/value pair
                         (let* ((pos   (string-index line #\:))
                                (key   (string-take line pos))
                                (value (string-drop line (+ 1 pos))))
                           (cons (cons key
                                       (string-trim-both value))
                                 acc))
                         ;; This is a continuation of the previous pair
                         (match-let ((((key . value) . rest) acc))
                           (cons (cons key (string-join
                                            (list value
                                                  (string-trim-both line))))
                                 rest)))))))
    (fold parse '() lines)))

(define (format-inputs names)
  "Generate a sorted list of package inputs from a list of package NAMES."
  (map (lambda (name)
         (list name (list 'unquote (string->symbol name))))
       (sort names string-ci<?)))

(define* (maybe-inputs package-inputs #:optional (type 'inputs))
  "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a
package definition."
  (match package-inputs
    (()
     '())
    ((package-inputs ...)
     `((,type (,'quasiquote ,(format-inputs package-inputs)))))))

(define %cran-url "https://cran.r-project.org/web/packages/")
(define %bioconductor-url "https://bioconductor.org/packages/")

;; The latest Bioconductor release is 3.11.  Bioconductor packages should be
;; updated together.
(define %bioconductor-version "3.11")

(define* (bioconductor-packages-list-url #:optional type)
  (string-append "https://bioconductor.org/packages/"
                 %bioconductor-version
                 (match type
                   ('annotation "/data/annotation")
                   ('experiment "/data/experiment")
                   (_ "/bioc"))
                 "/src/contrib/PACKAGES"))

(define* (bioconductor-packages-list #:optional type)
  "Return the latest version of package NAME for the current bioconductor
release."
  (let ((url (string->uri (bioconductor-packages-list-url type))))
    (guard (c ((http-get-error? c)
               (format (current-error-port)
                       "error: failed to retrieve list of packages from ~s: ~a (~s)~%"
                       (uri->string (http-get-error-uri c))
                       (http-get-error-code c)
                       (http-get-error-reason c))
               #f))
      ;; Split the big list on empty lines, then turn each chunk into an
      ;; alist of attributes.
      (map (lambda (chunk)
             (description->alist (string-join chunk "\n")))
           (let* ((port  (http-fetch/cached url))
                  (lines (read-lines port)))
             (close-port port)
             (chunk-lines lines))))))

(define* (latest-bioconductor-package-version name #:optional type)
  "Return the version string corresponding to the latest release of the
bioconductor package NAME, or #F if the package is unknown."
  (and=> (find (lambda (meta)
                 (string=? (assoc-ref meta "Package") name))
               (bioconductor-packages-list type))
         (cut assoc-ref <> "Version")))

;; XXX taken from (guix scripts hash)
(define (vcs-file? file stat)
  (case (stat:type stat)
    ((directory)
     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
    ((regular)
     ;; Git sub-modules have a '.git' file that is a regular text file.
     (string=? (basename file) ".git"))
    (else
     #f)))

;; Little helper to download URLs only once.
(define download
  (memoize
   (lambda* (url #:key method)
     (with-store store
       (cond
        ((eq? method 'git)
         (latest-repository-commit store url))
        ((eq? method 'hg)
         (call-with-temporary-directory
          (lambda (dir)
            (unless (zero? (system* "hg" "clone" url dir))
              (leave (G_ "~A: hg download failed~%") url))
            (with-directory-excursion dir
              (let* ((port (open-pipe* OPEN_READ "hg" "id" "--id"))
                     (changeset (string-trim-right (read-string port))))
                (close-pipe port)
                (for-each delete-file-recursively
                          (find-files dir "^\\.hg$" #:directories? #t))
                (let ((store-directory
                       (add-to-store store (basename url) #t "sha256" dir)))
                  (values store-directory changeset)))))))
        (else (download-to-store store url)))))))

(define (fetch-description repository name)
  "Return an alist of the contents of the DESCRIPTION file for the R package
NAME in the given REPOSITORY, or #f in case of failure.  NAME is
case-sensitive."
  (case repository
    ((cran)
     (let ((url (string-append %cran-url name "/DESCRIPTION")))
       (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))
         (let* ((port   (http-fetch url))
                (result (description->alist (read-string port))))
           (close-port port)
           result))))
    ((bioconductor)
     ;; Currently, the bioconductor project does not offer a way to access a
     ;; package's DESCRIPTION file over HTTP, so we determine the version,
     ;; download the source tarball, and then extract the DESCRIPTION file.
     (and-let* ((type    (or
                          (and (latest-bioconductor-package-version name) #t)
                          (and (latest-bioconductor-package-version name 'annotation) 'annotation)
                          (and (latest-bioconductor-package-version name 'experiment) 'experiment)))
                (version (latest-bioconductor-package-version name type))
                (url     (car (bioconductor-uri name version type)))
                (tarball (download url)))
       (call-with-temporary-directory
        (lambda (dir)
          (parameterize ((current-error-port (%make-void-port "rw+"))
                         (current-output-port (%make-void-port "rw+")))
            (and (zero? (system* "tar" "--wildcards" "-x"
                                 "--strip-components=1"
                                 "-C" dir
                                 "-f" tarball "*/DESCRIPTION"))
                 (and=> (description->alist (with-input-from-file
                                                (string-append dir "/DESCRIPTION") read-string))
                        (lambda (meta)
                          (if (boolean? type) meta
                              (cons `(bioconductor-type . ,type) meta))))))))))
    ((git)
     (and (string-prefix? "http" name)
          ;; Download the git repository at "NAME"
          (call-with-values
              (lambda () (download name #:method 'git))
            (lambda (dir commit)
              (and=> (description->alist (with-input-from-file
                                             (string-append dir "/DESCRIPTION") read-string))
                     (lambda (meta)
                       (cons* `(git . ,name)
                              `(git-commit . ,commit)
                              meta)))))))
    ((hg)
     (and (string-prefix? "http" name)
          ;; Download the mercurial repository at "NAME"
          (call-with-values
              (lambda () (download name #:method 'hg))
            (lambda (dir changeset)
              (and=> (description->alist (with-input-from-file
                                             (string-append dir "/DESCRIPTION") read-string))
                     (lambda (meta)
                       (cons* `(hg . ,name)
                              `(hg-changeset . ,changeset)
                              meta)))))))))

(define (listify meta field)
  "Look up FIELD in the alist META.  If FIELD contains a comma-separated
string, turn it into a list and strip off parenthetic expressions.  Return the
empty list when the FIELD cannot be found."
  (let ((value (assoc-ref meta field)))
    (if (not value)
        '()
        ;; Strip off parentheses
        (let ((items (string-split (regexp-substitute/global
                                    #f "( *\\([^\\)]+\\)) *"
                                    value 'pre 'post)
                                   #\,)))
          (remove (lambda (item)
                    (or (string-null? item)
                        ;; When there is whitespace inside of items it is
                        ;; probably because this was not an actual list to
                        ;; begin with.
                        (string-any char-set:whitespace item)))
                  (map string-trim-both items))))))

;; Trick Guile 3 so that it keeps the 'listify' binding accessible *and*
;; private even though this module is declarative.
(set! listify listify)

(define default-r-packages
  (list "base"
        "compiler"
        "datasets"
        "grDevices"
        "graphics"
        "grid"
        "methods"
        "parallel"
        "splines"
        "stats"
        "stats4"
        "tcltk"
        "tools"
        "translations"
        "utils"))

;; The field for system dependencies is often abused to specify non-package
;; dependencies (such as c++11).  This list is used to ignore them.
(define invalid-packages
  (list "c++11"))

(define cran-guix-name (cut guix-name "r-" <>))

(define (tarball-needs-fortran? tarball)
  "Check if the TARBALL contains Fortran source files."
  (define (check pattern)
    (parameterize ((current-error-port (%make-void-port "rw+"))
                   (current-output-port (%make-void-port "rw+")))
      (zero? (system* "tar" "--wildcards" "--list" pattern "-f" tarball))))
  (or (check "*.f90")
      (check "*.f95")
      (check "*.f")))

(define (directory-needs-fortran? dir)
  "Check if the directory DIR contains Fortran source files."
  (match (find-files dir "\\.f(90|95)?")
    (() #f)
    (_ #t)))

(define (needs-fortran? thing tarball?)
  "Check if the THING contains Fortran source files."
  (if tarball?
      (tarball-needs-fortran? thing)
      (directory-needs-fortran? thing)))

(define (files-match-pattern? directory regexp . file-patterns)
  "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match
the given REGEXP."
  (let ((pattern (make-regexp regexp)))
    (any (lambda (file)
           (call-with-input-file file
             (lambda (port)
               (let loop ()
                 (let ((line (read-line port)))
                   (cond
                    ((eof-object? line) #f)
                    ((regexp-exec pattern line) #t)
                    (else (loop))))))))
         (apply find-files directory file-patterns))))

(define (tarball-files-match-pattern? tarball regexp . file-patterns)
  "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL
match the given REGEXP."
  (call-with-temporary-directory
   (lambda (dir)
     (parameterize ((current-error-port (%make-void-port "rw+")))
       (apply system* "tar"
              "xf" tarball "-C" dir
              `("--wildcards" ,@file-patterns)))
     (files-match-pattern? dir regexp))))

(define (directory-needs-zlib? dir)
  "Return #T if any of the Makevars files in the src directory DIR contain a
zlib linker flag."
  (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)"))

(define (tarball-needs-zlib? tarball)
  "Return #T if any of the Makevars files in the src directory of the TARBALL
contain a zlib linker flag."
  (tarball-files-match-pattern?
   tarball "-lz"
   "*/src/Makevars*" "*/src/configure*" "*/configure*"))

(define (needs-zlib? thing tarball?)
  "Check if the THING contains files indicating a dependency on zlib."
  (if tarball?
      (tarball-needs-zlib? thing)
      (directory-needs-zlib? thing)))

(define (directory-needs-pkg-config? dir)
  "Return #T if any of the Makevars files in the src directory DIR reference
the pkg-config tool."
  (files-match-pattern? dir "pkg-config"
                        "(Makevars.*|configure.*)"))

(define (tarball-needs-pkg-config? tarball)
  "Return #T if any of the Makevars files in the src directory of the TARBALL
reference the pkg-config tool."
  (tarball-files-match-pattern?
   tarball "pkg-config"
   "*/src/Makevars*" "*/src/configure*" "*/configure*"))

(define (needs-pkg-config? thing tarball?)
  "Check if the THING contains files indicating a dependency on pkg-config."
  (if tarball?
      (tarball-needs-pkg-config? thing)
      (directory-needs-pkg-config? thing)))

(define (needs-knitr? meta)
  (member "knitr" (listify meta "VignetteBuilder")))

;; XXX adapted from (guix scripts hash)
(define (file-hash file select? recursive?)
  ;; Compute the hash of FILE.
  (if recursive?
      (let-values (((port get-hash) (open-sha256-port)))
        (write-file file port #:select? select?)
        (force-output port)
        (get-hash))
      (call-with-input-file file port-sha256)))

(define (description->package repository meta)
  "Return the `package' s-expression for an R package published on REPOSITORY
from the alist META, which was derived from the R package's DESCRIPTION file."
  (let* ((base-url   (case repository
                       ((cran)         %cran-url)
                       ((bioconductor) %bioconductor-url)
                       ((git)          #f)
                       ((hg)           #f)))
         (uri-helper (case repository
                       ((cran)         cran-uri)
                       ((bioconductor) bioconductor-uri)
                       ((git)          #f)
                       ((hg)           #f)))
         (name       (assoc-ref meta "Package"))
         (synopsis   (assoc-ref meta "Title"))
         (version    (assoc-ref meta "Version"))
         (license    (string->license (assoc-ref meta "License")))
         ;; Some packages have multiple home pages.  Some have none.
         (home-page  (case repository
                       ((git) (assoc-ref meta 'git))
                       ((hg)  (assoc-ref meta 'hg))
                       (else (match (listify meta "URL")
                               ((url rest ...) url)
                               (_ (string-append base-url name))))))
         (source-url (case repository
                       ((git) (assoc-ref meta 'git))
                       ((hg)  (assoc-ref meta 'hg))
                       (else
                        (match (apply uri-helper name version
                                      (case repository
                                        ((bioconductor)
                                         (list (assoc-ref meta 'bioconductor-type)))
                                        (else '())))
                          ((url rest ...) url)
                          ((? string? url) url)
                          (_ #f)))))
         (git?       (assoc-ref meta 'git))
         (hg?        (assoc-ref meta 'hg))
         (source     (download source-url #:method (cond
                                                    (git? 'git)
                                                    (hg? 'hg)
                                                    (else #f))))
         (sysdepends (append
                      (if (needs-zlib? source (not (or git? hg?))) '("zlib") '())
                      (filter (lambda (name)
                                (not (member name invalid-packages)))
                              (map string-downcase (listify meta "SystemRequirements")))))
         (propagate  (filter (lambda (name)
                               (not (member name (append default-r-packages
                                                         invalid-packages))))
                             (lset-union equal?
                                         (listify meta "Imports")
                                         (listify meta "LinkingTo")
                                         (delete "R"
                                                 (listify meta "Depends")))))
         (package
           `(package
              (name ,(cran-guix-name name))
              (version ,(case repository
                          ((git)
                           `(git-version ,version revision commit))
                          ((hg)
                           `(string-append ,version "-" revision "." changeset))
                          (else version)))
              (source (origin
                        (method ,(cond
                                  (git? 'git-fetch)
                                  (hg?  'hg-fetch)
                                  (else 'url-fetch)))
                        (uri ,(case repository
                                ((git)
                                 `(git-reference
                                   (url ,(assoc-ref meta 'git))
                                   (commit commit)))
                                ((hg)
                                 `(hg-reference
                                   (url ,(assoc-ref meta 'hg))
                                   (changeset changeset)))
                                (else
                                 `(,(procedure-name uri-helper) ,name version
                                   ,@(or (and=> (assoc-ref meta 'bioconductor-type)
                                                (lambda (type)
                                                  (list (list 'quote type))))
                                         '())))))
                        ,@(cond
                           (git?
                            '((file-name (git-file-name name version))))
                           (hg?
                            '((file-name (string-append name "-" version "-checkout"))))
                           (else '()))
                        (sha256
                         (base32
                          ,(bytevector->nix-base32-string
                            (case repository
                              ((git)
                               (file-hash source (negate vcs-file?) #t))
                              ((hg)
                               (file-hash source (negate vcs-file?) #t))
                              (else (file-sha256 source))))))))
              ,@(if (not (and git? hg?
                              (equal? (string-append "r-" name)
                                      (cran-guix-name name))))
                    `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
                    '())
              (build-system r-build-system)
              ,@(maybe-inputs sysdepends)
              ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
              ,@(maybe-inputs
                 `(,@(if (needs-fortran? source (not (or git? hg?)))
                         '("gfortran") '())
                   ,@(if (needs-pkg-config? source (not (or git? hg?)))
                         '("pkg-config") '())
                   ,@(if (needs-knitr? meta)
                         '("r-knitr") '()))
                 'native-inputs)
              (home-page ,(if (string-null? home-page)
                              (string-append base-url name)
                              home-page))
              (synopsis ,synopsis)
              (description ,(beautify-description (or (assoc-ref meta "Description")
                                                      "")))
              (license ,license))))
    (values
     (case repository
       ((git)
        `(let ((commit ,(assoc-ref meta 'git-commit))
               (revision "1"))
           ,package))
       ((hg)
        `(let ((changeset ,(assoc-ref meta 'hg-changeset))
               (revision "1"))
           ,package))
       (else package))
     propagate)))

(define cran->guix-package
  (memoize
   (lambda* (package-name #:optional (repo 'cran))
     "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
s-expression corresponding to that package, or #f on failure."
     (let ((description (fetch-description repo package-name)))
       (if description
           (description->package repo description)
           (case repo
             ((git)
              ;; Retry import from Bioconductor
              (cran->guix-package package-name 'bioconductor))
             ((hg)
              ;; Retry import from Bioconductor
              (cran->guix-package package-name 'bioconductor))
             ((bioconductor)
              ;; Retry import from CRAN
              (cran->guix-package package-name 'cran))
             (else (values #f '()))))))))

(define* (cran-recursive-import package-name #:optional (repo 'cran))
  (recursive-import package-name repo
                    #:repo->guix-package cran->guix-package
                    #:guix-name cran-guix-name))

;;;
;;; Updater.
;;;

(define (package->upstream-name package)
  "Return the upstream name of the PACKAGE."
  (let* ((properties (package-properties package))
         (upstream-name (and=> properties
                               (cut assoc-ref <> 'upstream-name))))
    (if upstream-name
        upstream-name
        (match (package-source package)
          ((? origin? origin)
           (match (origin-uri origin)
             ((or (? string? url) (url _ ...))
              (let ((end   (string-rindex url #\_))
                    (start (string-rindex url #\/)))
                ;; The URL ends on
                ;; (string-append "/" name "_" version ".tar.gz")
                (and start end (substring url (+ start 1) end))))
             (_ #f)))
          (_ #f)))))

(define (latest-cran-release pkg)
  "Return an <upstream-source> for the latest release of the package PKG."

  (define upstream-name
    (package->upstream-name pkg))

  (define meta
    (fetch-description 'cran upstream-name))

  (and meta
       (let ((version (assoc-ref meta "Version")))
         ;; CRAN does not provide signatures.
         (upstream-source
          (package (package-name pkg))
          (version version)
          (urls (cran-uri upstream-name version))
          (input-changes
           (changed-inputs pkg
                           (description->package 'cran meta)))))))

(define (latest-bioconductor-release pkg)
  "Return an <upstream-source> for the latest release of the package PKG."

  (define upstream-name
    (package->upstream-name pkg))

  (define version
    (latest-bioconductor-package-version upstream-name))

  (and version
       ;; Bioconductor does not provide signatures.
       (upstream-source
        (package (package-name pkg))
        (version version)
        (urls (bioconductor-uri upstream-name version))
        (input-changes
         (changed-inputs
          pkg
          (cran->guix-package upstream-name 'bioconductor))))))

(define (cran-package? package)
  "Return true if PACKAGE is an R package from CRAN."
  (and (string-prefix? "r-" (package-name package))
       ;; Check if the upstream name can be extracted from package uri.
       (package->upstream-name package)
       ;; Check if package uri(s) are prefixed by "mirror://cran".
       ((url-predicate (cut string-prefix? "mirror://cran" <>)) package)))

(define (bioconductor-package? package)
  "Return true if PACKAGE is an R package from Bioconductor."
  (let ((predicate (lambda (uri)
                     (and (string-prefix? "https://bioconductor.org" uri)
                          ;; Data packages are neither listed in SVN nor on
                          ;; the Github mirror, so we have to exclude them
                          ;; from the set of bioconductor packages that can be
                          ;; updated automatically.
                          (not (string-contains uri "/data/annotation/"))
                          ;; Experiment packages are in a separate repository.
                          (not (string-contains uri "/data/experiment/"))))))
    (and (string-prefix? "r-" (package-name package))
         ((url-predicate predicate) package))))

(define (bioconductor-data-package? package)
  "Return true if PACKAGE is an R data package from Bioconductor."
  (let ((predicate (lambda (uri)
                     (and (string-prefix? "https://bioconductor.org" uri)
                          (string-contains uri "/data/annotation/")))))
    (and (string-prefix? "r-" (package-name package))
         ((url-predicate predicate) package))))

(define (bioconductor-experiment-package? package)
  "Return true if PACKAGE is an R experiment package from Bioconductor."
  (let ((predicate (lambda (uri)
                     (and (string-prefix? "https://bioconductor.org" uri)
                          (string-contains uri "/data/experiment/")))))
    (and (string-prefix? "r-" (package-name package))
         ((url-predicate predicate) package))))

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

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

;;; cran.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Martin Becze <mjbecze@riseup.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 crate)
  #:use-module (guix base32)
  #:use-module (guix build-system cargo)
  #:use-module ((guix download) #:prefix download:)
  #:use-module (gcrypt hash)
  #:use-module (guix http-client)
  #:use-module (guix import json)
  #:use-module (guix import utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-26)
  #:export (crate->guix-package
            guix-package->crate-name
            string->license
            crate-recursive-import
            %crate-updater))

;;;
;;; Interface to https://crates.io/api/v1.
;;;

;; Crates.  A crate is essentially a "package".  It can have several
;; "versions", each of which has its own set of dependencies, license,
;; etc.--see <crate-version> below.
(define-json-mapping <crate> make-crate crate?
  json->crate
  (name          crate-name)                      ;string
  (latest-version crate-latest-version "max_version") ;string
  (home-page     crate-home-page "homepage")      ;string | #nil
  (repository    crate-repository)                ;string
  (description   crate-description)               ;string
  (keywords      crate-keywords                   ;list of strings
                 "keywords" vector->list)
  (categories    crate-categories                 ;list of strings
                 "categories" vector->list)
  (versions      crate-versions "actual_versions" ;list of <crate-version>
                 (lambda (vector)
                   (map json->crate-version
                        (vector->list vector))))
  (links         crate-links))                    ;alist

;; Crate version.
(define-json-mapping <crate-version> make-crate-version crate-version?
  json->crate-version
  (id            crate-version-id)                ;integer
  (number        crate-version-number "num")      ;string
  (download-path crate-version-download-path "dl_path") ;string
  (readme-path   crate-version-readme-path "readme_path") ;string
  (license       crate-version-license "license") ;string
  (links         crate-version-links))            ;alist

;; Crate dependency.  Each dependency (each edge in the graph) is annotated as
;; being a "normal" dependency or a development dependency.  There also
;; information about the minimum required version, such as "^0.0.41".
(define-json-mapping <crate-dependency> make-crate-dependency
  crate-dependency?
  json->crate-dependency
  (id            crate-dependency-id "crate_id")  ;string
  (kind          crate-dependency-kind "kind"     ;'normal | 'dev
                 string->symbol)
  (requirement   crate-dependency-requirement "req")) ;string

(define (lookup-crate name)
  "Look up NAME on https://crates.io and return the corresopnding <crate>
record or #f if it was not found."
  (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/"
                                         name))))
    (and=> (and json (assoc-ref json "crate"))
           (lambda (alist)
             ;; The "versions" field of ALIST is simply a list of version IDs
             ;; (integers).  Here, we squeeze in the actual version
             ;; dictionaries that are not part of ALIST but are just more
             ;; convenient handled this way.
             (let ((versions (or (assoc-ref json "versions") '#())))
               (json->crate `(,@alist
                              ("actual_versions" . ,versions))))))))

(define (crate-version-dependencies version)
  "Return the list of <crate-dependency> records of VERSION, a
<crate-version>."
  (let* ((path (assoc-ref (crate-version-links version) "dependencies"))
         (url  (string-append (%crate-base-url) path)))
    (match (assoc-ref (or (json-fetch url) '()) "dependencies")
      ((? vector? vector)
       (delete-duplicates (map json->crate-dependency (vector->list vector))))
      (_
       '()))))

;;;
;;; Converting crates to Guix packages.
;;;

(define (maybe-cargo-inputs package-names)
  (match (package-names->package-inputs package-names)
    (()
     '())
    ((package-inputs ...)
     `(#:cargo-inputs ,package-inputs))))

(define (maybe-cargo-development-inputs package-names)
  (match (package-names->package-inputs package-names)
    (()
     '())
    ((package-inputs ...)
     `(#:cargo-development-inputs ,package-inputs))))

(define (maybe-arguments arguments)
  (match arguments
    (()
     '())
    ((args ...)
     `((arguments (,'quasiquote ,args))))))

(define* (make-crate-sexp #:key name version cargo-inputs cargo-development-inputs
                          home-page synopsis description license
                          #:allow-other-keys)
  "Return the `package' s-expression for a rust package with the given NAME,
VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
and LICENSE."
  (let* ((port (http-fetch (crate-uri name version)))
         (guix-name (crate-name->package-name name))
         (cargo-inputs (map crate-name->package-name cargo-inputs))
         (cargo-development-inputs (map crate-name->package-name
                                        cargo-development-inputs))
         (pkg `(package
                   (name ,guix-name)
                   (version ,version)
                   (source (origin
                             (method url-fetch)
                             (uri (crate-uri ,name version))
                             (file-name (string-append name "-" version ".tar.gz"))
                             (sha256
                              (base32
                               ,(bytevector->nix-base32-string (port-sha256 port))))))
                   (build-system cargo-build-system)
                   ,@(maybe-arguments (append (maybe-cargo-inputs cargo-inputs)
                                              (maybe-cargo-development-inputs
                                                cargo-development-inputs)))
                   (home-page ,(match home-page
                                 (() "")
                                 (_ home-page)))
                   (synopsis ,synopsis)
                   (description ,(beautify-description description))
                   (license ,(match license
                               (() #f)
                               ((license) license)
                               (_ `(list ,@license)))))))
         (close-port port)
         pkg))

(define (string->license string)
  (filter-map (lambda (license)
                (and (not (string-null? license))
                     (not (any (lambda (elem) (string=? elem license))
                               '("AND" "OR" "WITH")))
                     (or (spdx-string->license license)
                         'unknown-license!)))
              (string-split string (string->char-set " /"))))

(define* (crate->guix-package crate-name #:optional version)
  "Fetch the metadata for CRATE-NAME from crates.io, and return the
`package' s-expression corresponding to that package, or #f on failure.
When VERSION is specified, attempt to fetch that version; otherwise fetch the
latest version of CRATE-NAME."

  (define (normal-dependency? dependency)
    (eq? (crate-dependency-kind dependency) 'normal))

  (define crate
    (lookup-crate crate-name))

  (define version-number
    (and crate
         (or version
             (crate-latest-version crate))))

  (define version*
    (and crate
         (find (lambda (version)
                 (string=? (crate-version-number version)
                           version-number))
               (crate-versions crate))))

  (and crate version*
       (let* ((dependencies   (crate-version-dependencies version*))
              (dep-crates     (filter normal-dependency? dependencies))
              (dev-dep-crates (remove normal-dependency? dependencies))
              (cargo-inputs   (sort (map crate-dependency-id dep-crates)
                                    string-ci<?))
              (cargo-development-inputs
               (sort (map crate-dependency-id dev-dep-crates)
                     string-ci<?)))
         (values
          (make-crate-sexp #:name crate-name
                           #:version (crate-version-number version*)
                           #:cargo-inputs cargo-inputs
                           #:cargo-development-inputs cargo-development-inputs
                           #:home-page (or (crate-home-page crate)
                                           (crate-repository crate))
                           #:synopsis (crate-description crate)
                           #:description (crate-description crate)
                           #:license (and=> (crate-version-license version*)
                                            string->license))
          (append cargo-inputs cargo-development-inputs)))))

(define* (crate-recursive-import crate-name #:optional version)
  (recursive-import crate-name #f
                    #:repo->guix-package
                    (lambda (name repo)
                      (let ((version (and (string=? name crate-name)
                                          version)))
                        (crate->guix-package name version)))
                    #:guix-name crate-name->package-name))

(define (guix-package->crate-name package)
  "Return the crate name of PACKAGE."
  (and-let* ((origin (package-source package))
             (uri (origin-uri origin))
             (crate-url? uri)
             (len (string-length crate-url))
             (path (xsubstring uri len))
             (parts (string-split path #\/)))
    (match parts
      ((name _ ...) name))))

(define (crate-name->package-name name)
  (string-append "rust-" (string-join (string-split name #\_) "-")))

;;;
;;; Updater
;;;

(define crate-package?
  (url-predicate crate-url?))

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (let* ((crate-name (guix-package->crate-name package))
         (crate      (lookup-crate crate-name))
         (version    (crate-latest-version crate))
         (url        (crate-uri crate-name version)))
    (upstream-source
     (package (package-name package))
     (version version)
     (urls (list url)))))

(define %crate-updater
  (upstream-updater
   (name 'crates)
   (description "Updater for crates.io packages")
   (pred crate-package?)
   (latest latest-release)))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.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 elpa)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (web uri)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module ((guix download) #:select (download-to-store))
  #:use-module (guix import utils)
  #:use-module (guix http-client)
  #:use-module (guix store)
  #:use-module (guix ui)
  #:use-module (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix upstream)
  #:use-module (guix packages)
  #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  #:export (elpa->guix-package
            %elpa-updater
            elpa-recursive-import))

(define (elpa-dependencies->names deps)
  "Convert DEPS, a list of symbol/version pairs à la ELPA, to a list of
package names as strings"
  (match deps
    (((names _ ...) ...)
     (map symbol->string names))))

(define emacs-standard-library?
  (let ((libs '("emacs" "cl-lib")))
    (lambda (lib)
      "Return true if LIB is part of Emacs itself.  The check is not
exhaustive and only attempts to recognize a subset of packages which in the
past were distributed separately from Emacs."
      (member lib libs))))

(define (filter-dependencies names)
  "Remove the package names included with Emacs from the list of
NAMES (strings)."
  (remove emacs-standard-library? names))

(define (elpa-name->package-name name)
  "Given the NAME of an Emacs package, return the corresponding Guix name."
  (let ((package-name-prefix "emacs-"))
    (if (string-prefix? package-name-prefix name)
        (string-downcase name)
        (string-append package-name-prefix (string-downcase name)))))

(define* (elpa-url #:optional (repo 'gnu))
  "Retrieve the URL of REPO."
  (let ((elpa-archives
         '((gnu . "https://elpa.gnu.org/packages")
           (gnu/http . "http://elpa.gnu.org/packages") ;for testing
           (melpa-stable . "https://stable.melpa.org/packages")
           (melpa . "https://melpa.org/packages"))))
    (assq-ref elpa-archives repo)))

(define* (elpa-fetch-archive #:optional (repo 'gnu))
  "Retrieve the archive with the list of packages available from REPO."
  (let ((url (and=> (elpa-url repo)
                    (cut string-append <> "/archive-contents"))))
    (if url
        ;; Use a relatively small TTL for the archive itself.
        (let* ((port (http-fetch/cached (string->uri url)
                                        #:ttl (* 6 3600)))
               (data (read port)))
          (close-port port)
          data)
        (leave (G_ "~A: currently not supported~%") repo))))

(define* (call-with-downloaded-file url proc #:optional (error-thunk #f))
  "Fetch URL, store the content in a temporary file and call PROC with that
file.  Returns the value returned by PROC.  On error call ERROR-THUNK and
return its value or leave if it's false."
  (catch #t
    (lambda ()
      (proc (http-fetch/cached (string->uri url))))
    (lambda (key . args)
      (if error-thunk
          (error-thunk)
          (leave (G_ "~A: download failed~%") url)))))

(define (is-elpa-package? name elpa-pkg-spec)
  "Return true if the string NAME corresponds to the name of the package
defined by ELPA-PKG-SPEC, a package specification as in an archive
'archive-contents' file."
  (eq? (first elpa-pkg-spec) (string->symbol name)))

(define* (elpa-package-info name #:optional (repo 'gnu))
  "Extract the information about the package NAME from the package archieve of
REPO."
  (let* ((archive (elpa-fetch-archive repo))
         (pkgs (match archive ((version pkg-spec ...) pkg-spec)))
         (info (filter (cut is-elpa-package? name <>) pkgs)))
    (if (pair? info) (first info) #f)))

;; Object to store information about an ELPA package.
(define-record-type <elpa-package>
  (make-elpa-package name version inputs synopsis kind home-page description
                     source-url)
  elpa-package?
  (name elpa-package-name)
  (version elpa-package-version)
  (inputs elpa-package-inputs)
  (synopsis elpa-package-synopsis)
  (kind elpa-package-kind)
  (home-page elpa-package-home-page)
  (description elpa-package-description)
  (source-url elpa-package-source-url))

(set-record-type-printer! <elpa-package>
                          (lambda (package port)
                            (format port "#<elpa-package ~a@~a>"
                                      (elpa-package-name package)
                                      (elpa-package-version package))))

(define (elpa-version->string elpa-version)
  "Convert the package version as used in Emacs package files into a string."
  (if (pair? elpa-version)
      (let-values (((ms rest) (match elpa-version
                                ((ms . rest)
                                 (values ms rest)))))
        (fold (lambda (n s) (string-append s "." (number->string n)))
              (number->string ms) rest))
      #f))

(define (package-home-page alist)
  "Extract the package home-page from ALIST."
  (or (assq-ref alist ':url) "unspecified"))

(define (ensure-list alist)
  "If ALIST is the symbol 'nil return the empty list.  Otherwise, return ALIST."
  (if (eq? alist 'nil)
      '()
      alist))

(define (package-source-url kind name version repo)
  "Return the source URL of the package described the the strings NAME and
VERSION at REPO.  KIND is either the symbol 'single or 'tar."
  (case kind
    ((single) (full-url repo name ".el" version))
    ((tar) (full-url repo name ".tar" version))
    (else
     #f)))

(define* (full-url repo name suffix #:optional (version #f))
  "Return the full URL of the package NAME at REPO and the SUFFIX.  Maybe
include VERSION."
  (if version
      (string-append (elpa-url repo) "/" name "-" version suffix)
      (string-append (elpa-url repo) "/" name suffix)))

(define (fetch-package-description kind name repo)
  "Fetch the description of package NAME of type KIND from REPO."
  (let ((url (full-url repo name "-readme.txt"))
        (error-thunk (lambda () "No description available.")))
    (call-with-downloaded-file url read-string error-thunk)))

(define* (fetch-elpa-package name #:optional (repo 'gnu))
  "Fetch package NAME from REPO."
  (let ((pkg (elpa-package-info name repo)))
    (match pkg
      ((name version reqs synopsis kind . rest)
       (let* ((name (symbol->string name))
             (ver (elpa-version->string version))
             (url (package-source-url kind name ver repo)))
         (make-elpa-package name ver
                            (ensure-list reqs) synopsis kind
                            (package-home-page (match rest
                                                 (() #f)
                                                 ((one) one)))
                            (fetch-package-description kind name repo)
                            url)))
      (_ #f))))

(define* (elpa-package->sexp pkg #:optional license)
  "Return the `package' S-expression for the Emacs package PKG, a record of
type '<elpa-package>'."

  (define name (elpa-package-name pkg))

  (define version (elpa-package-version pkg))

  (define source-url (elpa-package-source-url pkg))

  (define dependencies-names
    (filter-dependencies (elpa-dependencies->names
                          (elpa-package-inputs pkg))))

  (define dependencies
    (map (lambda (n)
           (let ((new-n (elpa-name->package-name n)))
             (list new-n (list 'unquote (string->symbol new-n)))))
         dependencies-names))

  (define (maybe-inputs input-type inputs)
    (match inputs
      (()
       '())
      ((inputs ...)
       (list (list input-type
                   (list 'quasiquote inputs))))))

  (let ((tarball (with-store store
                   (download-to-store store source-url))))
    (values
     `(package
        (name ,(elpa-name->package-name name))
        (version ,version)
        (source (origin
                  (method url-fetch)
                  (uri (string-append ,@(factorize-uri source-url version)))
                  (sha256
                   (base32
                    ,(if tarball
                         (bytevector->nix-base32-string (file-sha256 tarball))
                         "failed to download package")))))
        (build-system emacs-build-system)
        ,@(maybe-inputs 'propagated-inputs dependencies)
        (home-page ,(elpa-package-home-page pkg))
        (synopsis ,(elpa-package-synopsis pkg))
        (description ,(elpa-package-description pkg))
        (license ,license))
     dependencies-names)))

(define* (elpa->guix-package name #:optional (repo 'gnu))
  "Fetch the package NAME from REPO and produce a Guix package S-expression."
  (match (fetch-elpa-package name repo)
    (#f #f)
    (package
      ;; ELPA is known to contain only GPLv3+ code.  Other repos may contain
      ;; code under other license but there's no license metadata.
      (let ((license (and (memq repo '(gnu gnu/http)) 'license:gpl3+)))
        (elpa-package->sexp package license)))))

;;;
;;; Updates.
;;;

(define (latest-release package)
  "Return an <upstream-release> for the latest release of PACKAGE."
  (define name
    (if (string-prefix? "emacs-" (package-name package))
        (string-drop (package-name package) 6)
        (package-name package)))

  (let* ((repo    'gnu)
         (info    (elpa-package-info name repo))
         (version (match info
                    ((name raw-version . _)
                     (elpa-version->string raw-version))))
         (url     (match info
                    ((_ raw-version reqs synopsis kind . rest)
                     (package-source-url kind name version repo)))))
    (upstream-source
     (package (package-name package))
     (version version)
     (urls (list url))
     (signature-urls (list (string-append url ".sig"))))))

(define package-from-gnu.org?
  (url-predicate (lambda (url)
                   (let ((uri (string->uri url)))
                     (and uri
                          (string=? (uri-host uri) "elpa.gnu.org"))))))

(define %elpa-updater
  ;; The ELPA updater.  We restrict it to packages hosted on elpa.gnu.org
  ;; because for other repositories, we typically grab the source elsewhere.
  (upstream-updater
   (name 'elpa)
   (description "Updater for ELPA packages")
   (pred package-from-gnu.org?)
   (latest latest-release)))

(define elpa-guix-name (cut guix-name "emacs-" <>))

(define* (elpa-recursive-import package-name #:optional (repo 'gnu))
  (recursive-import package-name repo
                    #:repo->guix-package elpa->guix-package
                    #:guix-name elpa-guix-name))

;;; elpa.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 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 gem)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (json)
  #:use-module ((guix download) #:prefix download:)
  #:use-module (guix import utils)
  #:use-module (guix import json)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix base16)
  #:use-module (guix base32)
  #:use-module ((guix build-system ruby) #:select (rubygems-uri))
  #:export (gem->guix-package
            %gem-updater
            gem-recursive-import))

;; Gems as defined by the API at <https://rubygems.org/api/v1/gems>.
(define-json-mapping <gem> make-gem gem?
  json->gem
  (name          gem-name)                        ;string
  (platform      gem-platform)                    ;string
  (version       gem-version)                     ;string
  (authors       gem-authors)                     ;string
  (licenses      gem-licenses "licenses"          ;list of strings
                 (lambda (licenses)
                   ;; This is sometimes #nil (the JSON 'null' value).  Arrange
                   ;; to always return a list.
                   (cond ((not licenses) '())
                         ((vector? licenses) (vector->list licenses))
                         (else '()))))
  (info          gem-info)
  (sha256        gem-sha256 "sha"                 ;bytevector
                 base16-string->bytevector)
  (home-page     gem-home-page "homepage_uri")    ;string
  (dependencies  gem-dependencies "dependencies"  ;<gem-dependencies>
                 json->gem-dependencies))

(define-json-mapping <gem-dependencies> make-gem-dependencies
  gem-dependencies?
  json->gem-dependencies
  (development   gem-dependencies-development     ;list of <gem-dependency>
                 "development"
                 json->gem-dependency-list)
  (runtime       gem-dependencies-runtime         ;list of <gem-dependency>
                 "runtime"
                 json->gem-dependency-list))

(define (json->gem-dependency-list vector)
  (if vector
      (map json->gem-dependency (vector->list vector))
      '()))

(define-json-mapping <gem-dependency> make-gem-dependency gem-dependency?
  json->gem-dependency
  (name          gem-dependency-name)             ;string
  (requirements  gem-dependency-requirements))    ;string

(define (rubygems-fetch name)
  "Return a <gem> record for the package NAME, or #f on failure."
  (and=> (json-fetch
          (string-append "https://rubygems.org/api/v1/gems/" name ".json"))
         json->gem))

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

(define (make-gem-sexp name version hash home-page synopsis description
                       dependencies licenses)
  "Return the `package' s-expression for a Ruby package with the given NAME,
VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES."
  `(package
     (name ,(ruby-package-name name))
     (version ,version)
     (source (origin
               (method url-fetch)
               (uri (rubygems-uri ,name version))
               (sha256
                (base32
                 ,(bytevector->nix-base32-string hash)))))
     (build-system ruby-build-system)
     ,@(if (null? dependencies)
           '()
           `((propagated-inputs
              (,'quasiquote
               ,(map (lambda (name)
                       `(,name
                         (,'unquote
                          ,(string->symbol name))))
                     dependencies)))))
     (synopsis ,synopsis)
     (description ,description)
     (home-page ,home-page)
     (license ,(match licenses
                 (() #f)
                 ((license) (license->symbol license))
                 (_ `(list ,@(map license->symbol licenses)))))))

(define* (gem->guix-package package-name #:optional (repo 'rubygems) version)
  "Fetch the metadata for PACKAGE-NAME from rubygems.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
  (let ((gem (rubygems-fetch package-name)))
    (if gem
        (let* ((dependencies-names (map gem-dependency-name
                                        (gem-dependencies-runtime
                                         (gem-dependencies gem))))
               (dependencies (map (lambda (dep)
                                    (if (string=? dep "bundler")
                                        "bundler" ; special case, no prefix
                                        (ruby-package-name dep)))
                                  dependencies-names))
               (licenses     (map string->license (gem-licenses gem))))
          (values (make-gem-sexp (gem-name gem) (gem-version gem)
                                 (gem-sha256 gem) (gem-home-page gem)
                                 (gem-info gem)
                                 (beautify-description (gem-info gem))
                                 dependencies
                                 licenses)
                  dependencies-names))
        (values #f '()))))

(define (guix-package->gem-name package)
  "Given a PACKAGE built from rubygems.org, return the name of the
package on RubyGems."
  (let ((source-url (and=> (package-source package) origin-uri)))
    ;; The URL has the form:
    ;; 'https://rubygems.org/downloads/' +
    ;; package name + '-' + version + '.gem'
    ;; e.g. "https://rubygems.org/downloads/hashery-2.1.1.gem"
    (substring source-url 31 (string-rindex source-url #\-))))

(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 License") license:bsd-3)
    ((or "MIT" "MIT license" "Expat license") license:expat)
    ("Public domain" license:public-domain)
    ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0)
    (_ #f)))

(define gem-package?
  (url-prefix-predicate "https://rubygems.org/downloads/"))

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (let* ((gem-name (guix-package->gem-name package))
         (gem      (rubygems-fetch gem-name))
         (version  (gem-version gem))
         (url      (rubygems-uri gem-name version)))
    (upstream-source
     (package (package-name package))
     (version version)
     (urls (list url)))))

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

(define* (gem-recursive-import package-name #:optional version)
  (recursive-import package-name '()
                    #:repo->guix-package gem->guix-package
                    #:guix-name ruby-package-name))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 github)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (guix utils)
  #:use-module (guix i18n)
  #:use-module (guix diagnostics)
  #:use-module ((guix download) #:prefix download:)
  #:use-module ((guix git-download) #:prefix download:)
  #:use-module (guix import utils)
  #:use-module (guix import json)
  #:use-module (json)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix http-client)
  #:use-module (web uri)
  #:export (%github-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 ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar"
              ".tgz" ".tbz" ".love")))

(define (updated-github-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 GitHub url, then return false.

  (define (updated-url url)
    (if (string-prefix? "https://github.com/" url)
        (let ((ext     (or (find-extension url) ""))
              (name    (package-upstream-name old-package))
              (version (package-version old-package))
              (prefix  (string-append "https://github.com/"
                                      (github-user-slash-repository url)))
              (repo    (github-repository url)))
          (cond
           ((string-suffix? (string-append "/tarball/v" version) url)
            (string-append prefix "/tarball/v" new-version))
           ((string-suffix? (string-append "/tarball/" version) url)
            (string-append prefix "/tarball/" new-version))
           ((string-suffix? (string-append "/archive/v" version ext) url)
            (string-append prefix "/archive/v" new-version ext))
           ((string-suffix? (string-append "/archive/" version ext) url)
            (string-append prefix "/archive/" new-version ext))
           ((string-suffix? (string-append "/archive/" name "-" version ext)
                            url)
            (string-append prefix "/archive/" name "-" new-version ext))
           ((string-suffix? (string-append "/releases/download/v" version "/"
                                           name "-" version ext)
                            url)
            (string-append prefix "/releases/download/v" new-version "/" name
                           "-" new-version ext))
           ((string-suffix? (string-append "/releases/download/" version "/"
                                           name "-" version ext)
                            url)
            (string-append prefix "/releases/download/" new-version "/" name
                           "-" new-version ext))
           ((string-suffix? (string-append "/releases/download/" version "/"
                                           repo "-" version ext)
                            url)
            (string-append prefix "/releases/download/" new-version "/" repo
                           "-" new-version ext))
           ((string-suffix? (string-append "/releases/download/" repo "-"
                                           version "/" repo "-" version ext)
                            url)
            (string-append "/releases/download/" repo "-" version "/" repo "-"
                           version ext))
           (#t #f))) ; Some URLs are not recognised.
        #f))

  (match (package-source old-package)
    ((? origin? origin)
     (let ((source-uri   (origin-uri origin))
           (fetch-method (origin-method origin)))
       (cond
        ((eq? fetch-method download:url-fetch)
         (match source-uri
           ((? string?)
            (updated-url source-uri))
           ((source-uri ...)
            (find updated-url source-uri))))
        ((and (eq? fetch-method download:git-fetch)
              (string-prefix? "https://github.com/"
                              (download:git-reference-url source-uri)))
         (download:git-reference-url source-uri))
        (else #f))))
    (_ #f)))

(define (github-package? package)
  "Return true if PACKAGE is a package from GitHub, else false."
  (->bool (updated-github-url package "dummy")))

(define (github-repository url)
  "Return a string e.g. bedtools2 of the name of the repository, from a string
URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
  (match (string-split (uri-path (string->uri url)) #\/)
    ((_ owner project . rest)
     (string-append (basename project ".git")))))

(define (github-user-slash-repository url)
  "Return a string e.g. arq5x/bedtools2 of the owner and the name of the
repository separated by a forward slash, from a string URL of the form
'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
  (match (string-split (uri-path (string->uri url)) #\/)
    ((_ owner project . rest)
     (string-append owner "/" (basename project ".git")))))

(define %github-token
  ;; Token to be passed to Github.com to avoid the 60-request per hour
  ;; limit, or #f.
  (make-parameter (getenv "GUIX_GITHUB_TOKEN")))

(define (fetch-releases-or-tags url)
  "Fetch the list of \"releases\" or, if it's empty, the list of tags for the
repository at URL.  Return the corresponding JSON dictionaries (alists),
or #f if the information could not be retrieved.

We look at both /releases and /tags because the \"release\" feature of GitHub
is little used; often, people simply provide a tag.  What's confusing is that
tags show up in the \"Releases\" tab of the web UI.  For instance,
'https://github.com/aconchillo/guile-json/releases' shows a number of
\"releases\" (really: tags), whereas
'https://api.github.com/repos/aconchillo/guile-json/releases' returns the
empty list."
  (define release-url
    (string-append "https://api.github.com/repos/"
                   (github-user-slash-repository url)
                   "/releases"))
  (define tag-url
    (string-append "https://api.github.com/repos/"
                   (github-user-slash-repository url)
                   "/tags"))

  (define headers
    ;; Ask for version 3 of the API as suggested at
    ;; <https://developer.github.com/v3/>.
    `((Accept . "application/vnd.github.v3+json")
      (user-agent . "GNU Guile")
      ,@(if (%github-token)
            `((Authorization . ,(string-append "token " (%github-token))))
            '())))

  (guard (c ((and (http-get-error? c)
                  (= 404 (http-get-error-code c)))
             (warning (G_ "~a is unreachable (~a)~%")
                      release-url (http-get-error-code c))
             '#()))                               ;return an empty release set
    (let* ((port   (http-fetch release-url #:headers headers))
           (result (json->scm port)))
      (close-port port)
      (match result
        (#()
         ;; We got the empty list, presumably because the user didn't use GitHub's
         ;; "release" mechanism, but hopefully they did use Git tags.
         (json-fetch tag-url #:headers headers))
        (x x)))))

(define (latest-released-version url package-name)
  "Return a string of the newest released version name given a string URL like
'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
the package e.g. 'bedtools2'.  Return #f if there is no releases"
  (define (pre-release? x)
    (assoc-ref x "prerelease"))

  (define (release->version release)
    (let ((tag (or (assoc-ref release "tag_name") ;a "release"
                   (assoc-ref release "name")))   ;a tag
          (name-length (string-length package-name)))
      (cond
       ;; some tags include the name of the package e.g. "fdupes-1.51"
       ;; so remove these
       ((and (< name-length (string-length tag))
             (string=? (string-append package-name "-")
                       (substring tag 0 (+ name-length 1))))
        (substring tag (+ name-length 1)))
       ;; some tags start with a "v" e.g. "v0.25.0"
       ;; or with the word "version" e.g. "version.2.1"
       ;; where some are just the version number
       ((string-prefix? "version" tag)
        (if (char-set-contains? char-set:digit (string-ref tag 7))
            (substring tag 7)
            (substring tag 8)))
       ((string-prefix? "v" tag)
        (substring tag 1))
       ;; Finally, reject tags that don't start with a digit:
       ;; they may not represent a release.
       ((and (not (string-null? tag))
             (char-set-contains? char-set:digit
                                 (string-ref tag 0)))
        tag)
       (else #f))))

  (let* ((json (and=> (fetch-releases-or-tags url)
                      vector->list)))
    (if (eq? json #f)
        (if (%github-token)
            (error "Error downloading release information through the GitHub
API when using a GitHub token")
            (error "Error downloading release information through the GitHub
API. This may be fixed by using an access token and setting the environment
variable GUIX_GITHUB_TOKEN, for instance one procured from
https://github.com/settings/tokens"))
        (match (sort (filter-map release->version
                                 (match (remove pre-release? json)
                                   (() json) ; keep everything
                                   (releases releases)))
                     version>?)
          ((latest-release . _) latest-release)
          (() #f)))))

(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 github.com URL
      ((? download:git-reference? ref)
       (download:git-reference-url ref))
      ((urls ...)
       (find (cut string-contains <> "github.com") urls))))

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

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2019 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 gnome)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix http-client)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (web uri)
  #:use-module (ice-9 match)
  #:export (%gnome-updater))

;;; Commentary:
;;;
;;; This package provides not an actual importer but simply an updater for
;;; GNOME packages.  It grabs package meta-data from 'cache.json' files
;;; available on ftp.gnome.org.
;;;
;;; Code:

(define (jsonish->upstream-source name jsonish)
  "Return an <upstream-source> object for package NAME, using JSONISH as the
source for metadata."
  (match jsonish
    ((version . dictionary)
     (upstream-source
      (package name)
      (version version)
      (urls (filter-map (lambda (extension)
                          (match (assoc-ref dictionary extension)
                            (#f
                             #f)
                            ((? string? relative-url)
                             (string-append "mirror://gnome/sources/"
                                            name "/" relative-url))))
                        '("tar.lz" "tar.xz" "tar.bz2" "tar.gz")))))))

(define (latest-gnome-release package)
  "Return the latest release of PACKAGE, a GNOME package, or #f if it could
not be determined."
  (define %not-dot
    (char-set-complement (char-set #\.)))

  (define (even-minor-version? version)
    (match (string-tokenize version %not-dot)
      (((= string->number major) (= string->number minor) . rest)
       (and minor (even? minor)))
      (_
       #t)))                                      ;cross fingers

  (define upstream-name
    ;; Some packages like "NetworkManager" have camel-case names.
    (package-upstream-name package))

  (guard (c ((http-get-error? c)
             (if (= 404 (http-get-error-code c))
                 #f
                 (raise c))))
    (let* ((port (http-fetch/cached
                  (string->uri (string-append
                                "https://ftp.gnome.org/pub/gnome/sources/"
                                upstream-name "/cache.json"))

                  ;; ftp.gnome.org supports 'if-Modified-Since', so the local
                  ;; cache can expire early.
                  #:ttl (* 60 10)))
           (json (json->scm port)))
      (close-port port)
      (match json
        (#(4 releases _ ...)
         (let* ((releases (assoc-ref releases upstream-name))
                (latest   (fold (match-lambda*
                                  (((key . value) result)
                                   (cond ((even-minor-version? key)
                                          (match result
                                            (#f
                                             (cons key value))
                                            ((newest . _)
                                             (if (version>? key newest)
                                                 (cons key value)
                                                 result))))
                                         (else
                                          result))))
                                #f
                                releases)))
           (and latest
                (jsonish->upstream-source upstream-name latest))))))))

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 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 gnu)
  #:use-module (guix gnu-maintenance)
  #:use-module (guix import utils)
  #:use-module (guix utils)
  #:use-module (guix store)
  #:use-module (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix upstream)
  #: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 (web uri)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (gnu->guix-package))

;;; Commentary:
;;;
;;; Generate a package declaration template for the latest version of a GNU
;;; package, using meta-data available upstream for the package.
;;;
;;; Code:

(define (qualified-url url)
  "Return a fully-qualified URL based on URL."
  (if (string-prefix? "/" url)
      (string-append "http://www.gnu.org" url)
      url))

(define (preferred-archive-type release)
  "Return the preferred type of archive for downloading RELEASE."
  (find (cute member <> (upstream-source-archive-types release))
        '("xz" "lz" "bz2" "tbz2" "gz" "tgz" "Z")))

(define* (gnu-package->sexp package release
                            #:key (key-download 'interactive))
  "Return the 'package' sexp for the RELEASE (a <gnu-release>) of PACKAGE (a
<gnu-package>), or #f upon failure.  Use KEY-DOWNLOAD as the OpenPGP key
download policy (see 'download-tarball' for details.)"
  (define name
    (gnu-package-name package))

  (define url-base
    ;; XXX: We assume that RELEASE's directory starts with "/gnu".
    (string-append "mirror:/"
                   (match (upstream-source-urls release)
                     ((url rest ...)
                      (dirname (uri-path (string->uri url)))))
                   "/" name "-"))

  (define archive-type
    (preferred-archive-type release))

  (define url
    (find (cut string-suffix? archive-type <>)
          (upstream-source-urls release)))

  (define sig-url
    (find (cute string-suffix? (string-append archive-type ".sig") <>)
          (upstream-source-signature-urls release)))

  (with-store store
    (match (download-tarball store url sig-url
                             #:key-download key-download)
      ((? string? tarball)
       `(package
          (name ,name)
          (version ,(upstream-source-version release))
          (source (origin
                    (method url-fetch)
                    (uri (string-append ,url-base version
                                        ,(string-append ".tar." archive-type)))
                    (sha256
                     (base32
                      ,(bytevector->nix-base32-string
                        (file-sha256 tarball))))))
          (build-system gnu-build-system)
          (synopsis ,(gnu-package-doc-summary package))
          (description ,(gnu-package-doc-description package))
          (home-page ,(match (gnu-package-doc-urls package)
                        ((head . tail) (qualified-url head))))
          (license find-by-yourself!)))
      (#f                     ;failure to download or authenticate the tarball
       #f))))

(define* (gnu->guix-package name
                            #:key (key-download 'interactive))
  "Return the package declaration for NAME as an s-expression.  Use
KEY-DOWNLOAD as the OpenPGP key download policy (see 'download-tarball' for
details.)"
  (match (latest-release name)
    ((? upstream-source? release)
     (let ((version (upstream-source-version release)))
       (match (find-package name)
         (#f
          (raise (condition
                  (&message
                   (message "couldn't find meta-data for GNU package")))))
         (info
          (gnu-package->sexp info release #:key-download key-download)))))
    (_
     (raise (condition
             (&message
              (message
               "failed to determine latest release of GNU package")))))))

;;; gnu.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Nikita <nikita@n0.is>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.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 hackage)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-1)
  #:use-module ((guix download) #:select (download-to-store url-fetch))
  #:use-module ((guix utils) #:select (package-name->name+version
                                       canonical-newline-port))
  #:use-module (guix http-client)
  #:use-module ((guix import utils) #:select (factorize-uri recursive-import))
  #:use-module (guix import cabal)
  #:use-module (guix store)
  #:use-module (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix memoization)
  #:use-module (guix upstream)
  #:use-module (guix packages)
  #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  #:export (hackage->guix-package
            hackage-recursive-import
            %hackage-updater

            guix-package->hackage-name
            hackage-name->package-name
            hackage-fetch
            hackage-source-url
            hackage-cabal-url
            hackage-package?))

(define ghc-standard-libraries
  ;; List of libraries distributed with ghc (8.6.5).
  ;; Contents of ...-ghc-8.6.5/lib/ghc-8.6.5.
  '("ghc"
    "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but
            ;; hackage-name->package-name takes this into account.
    "win32" ;; similarly uppercased
    "array"
    "base"
    "binary"
    "bytestring"
    "containers"
    "deepseq"
    "directory"
    "filepath"
    "ghc"
    "ghc-boot"
    "ghc-boot-th"
    "ghc-compact"
    "ghc-heap"
    "ghc-prim"
    "ghci"
    "haskeline"
    "hpc"
    "integer-gmp"
    "libiserv"
    "mtl"
    "parsec"
    "pretty"
    "process"
    "stm"
    "template-haskell"
    "terminfo"
    "text"
    "time"
    "transformers"
    "unix"
    "xhtml"))

(define package-name-prefix "ghc-")

(define (hackage-source-url name version)
  "Given a Hackage package NAME and VERSION, return a url to the source
tarball."
  (string-append "https://hackage.haskell.org/package/" name
                 "/" name "-" version ".tar.gz"))

(define* (hackage-cabal-url name #:optional version)
  "Given a Hackage package NAME and VERSION, return a url to the corresponding
.cabal file on Hackage.  If VERSION is #f or missing, the url for the latest
version is returned."
  (if version
      (string-append "https://hackage.haskell.org/package/"
                     name "-" version "/" name ".cabal")
      (string-append "https://hackage.haskell.org/package/"
                     name "/" name ".cabal")))

(define (hackage-name->package-name name)
  "Given the NAME of a Cabal package, return the corresponding Guix name."
  (if (string-prefix? package-name-prefix name)
      (string-downcase name)
      (string-append package-name-prefix (string-downcase name))))

(define guix-package->hackage-name
  (let ((uri-rx (make-regexp "https?://hackage.haskell.org/package/([^/]+)/.*"))
        (name-rx (make-regexp "(.*)-[0-9\\.]+")))
    (lambda (package)
      "Given a Guix package name, return the corresponding Hackage name."
      (let* ((source-url (and=> (package-source package) origin-uri))
             (name (match:substring (regexp-exec uri-rx source-url) 1)))
        (match (regexp-exec name-rx name)
          (#f name)
          (m (match:substring m 1)))))))

(define (read-cabal-and-hash port)
  "Read a Cabal file from PORT and return it and its hash in nix-base32
format as two values."
  (let-values (((port get-hash) (open-sha256-input-port port)))
    (values (read-cabal (canonical-newline-port port))
            (bytevector->nix-base32-string (get-hash)))))

(define (hackage-fetch-and-hash name-version)
  "Fetch the latest Cabal revision for the package NAME-VERSION, and return
two values: the parsed Cabal file and its hash in nix-base32 format.  If the
version part is omitted from the package name, then fetch the latest
version.  On failure, both return values will be #f."
  (guard (c ((and (http-get-error? c)
                  (= 404 (http-get-error-code c)))
             (values #f #f)))           ;"expected" if package is unknown
    (let*-values (((name version) (package-name->name+version name-version))
                  ((url)          (hackage-cabal-url name version))
                  ((port _)       (http-fetch url))
                  ((cabal hash)   (read-cabal-and-hash port)))
      (close-port port)
      (values cabal hash))))

(define (hackage-fetch name-version)
  "Return the Cabal file for the package NAME-VERSION, or #f on failure.  If
the version part is omitted from the package name, then return the latest
version."
  (let-values (((cabal hash) (hackage-fetch-and-hash name-version)))
    cabal))

(define string->license
  ;; List of valid values from
  ;; https://www.haskell.org
  ;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html.
  (match-lambda
   ("GPL-2" 'gpl2)
   ("GPL-3" 'gpl3)
   ("GPL" "'gpl??")
   ("AGPL-3" 'agpl3)
   ("AGPL" "'agpl??")
   ("LGPL-2.1" 'lgpl2.1)
   ("LGPL-3" 'lgpl3)
   ("LGPL" "'lgpl??")
   ("BSD2" 'bsd-2)
   ("BSD3" 'bsd-3)
   ("BSD-3-Clause" 'bsd-3)
   ("MIT" 'expat)
   ("ISC" 'isc)
   ("MPL" 'mpl2.0)
   ("Apache-2.0" 'asl2.0)
   ("PublicDomain" 'public-domain)
   ((x) (string->license x))
   ((lst ...) `(list ,@(map string->license lst)))
   (_ #f)))

(define (cabal-dependencies->names cabal)
  "Return the list of dependencies names from the CABAL package object,
not including test suite dependencies or custom-setup dependencies."
  (let* ((lib (cabal-package-library cabal))
         (lib-deps (if (pair? lib)
                       (map cabal-dependency-name
                            (append-map cabal-library-dependencies lib))
                       '()))
         (exe (cabal-package-executables cabal))
         (exe-deps (if (pair? exe)
                       (map cabal-dependency-name
                            (append-map cabal-executable-dependencies exe))
                       '())))
    (delete-duplicates (append lib-deps exe-deps))))

(define (cabal-test-dependencies->names cabal)
  "Return the list of test suite dependencies from the CABAL package
object."
  (let* ((ts (cabal-package-test-suites cabal))
         (ts-deps (if (pair? ts)
                      (map cabal-dependency-name
                           (append-map cabal-test-suite-dependencies ts))
                      '())))
    ts-deps))

(define (cabal-custom-setup-dependencies->names cabal)
  "Return the list of custom-setup dependencies from the CABAL package
object."
  (let* ((custom-setup-dependencies (or (and=> (cabal-package-custom-setup cabal)
                                               cabal-custom-setup-dependencies)
                                        '())))
    (map cabal-dependency-name custom-setup-dependencies)))

(define (filter-dependencies dependencies own-name)
  "Filter the dependencies included with the GHC compiler from DEPENDENCIES, a
list with the names of dependencies.  OWN-NAME is the name of the Cabal
package being processed and is used to filter references to itself."
  (filter (lambda (d) (not (member (string-downcase d)
                                   (cons own-name ghc-standard-libraries))))
          dependencies))

(define* (hackage-module->sexp cabal cabal-hash
                               #:key (include-test-dependencies? #t))
  "Return the `package' S-expression for a Cabal package.  CABAL is the
representation of a Cabal file as produced by 'read-cabal'.  CABAL-HASH is
the hash of the Cabal file."

  (define name
    (cabal-package-name cabal))

  (define version
    (cabal-package-version cabal))

  (define revision
    (cabal-package-revision cabal))

  (define source-url
    (hackage-source-url name version))

  (define hackage-dependencies
    ((compose (cut filter-dependencies <>
                   (cabal-package-name cabal))
              (cut cabal-dependencies->names <>))
     cabal))

  (define hackage-native-dependencies
    (lset-difference
     equal?
     ((compose (cut filter-dependencies <>
                    (cabal-package-name cabal))
               ;; FIXME: Check include-test-dependencies?
               (lambda (cabal)
                 (append (if include-test-dependencies?
                             (cabal-test-dependencies->names cabal)
                             '())
                         (cabal-custom-setup-dependencies->names cabal))))
      cabal)
     hackage-dependencies))

  (define dependencies
    (map (lambda (name)
           (list name (list 'unquote (string->symbol name))))
         (map hackage-name->package-name
              hackage-dependencies)))

  (define native-dependencies
    (map (lambda (name)
           (list name (list 'unquote (string->symbol name))))
         (map hackage-name->package-name
              hackage-native-dependencies)))

  (define (maybe-inputs input-type inputs)
    (match inputs
      (()
       '())
      ((inputs ...)
       (list (list input-type
                   (list 'quasiquote inputs))))))

  (define (maybe-arguments)
    (match (append (if (not include-test-dependencies?)
                       '(#:tests? #f)
                       '())
                   (if (not (string-null? revision))
                       `(#:cabal-revision (,revision ,cabal-hash))
                       '()))
      (() '())
      (args `((arguments (,'quasiquote ,args))))))

  (let ((tarball (with-store store
                   (download-to-store store source-url))))
    (values
     `(package
        (name ,(hackage-name->package-name name))
        (version ,version)
        (source (origin
                  (method url-fetch)
                  (uri (string-append ,@(factorize-uri source-url version)))
                  (sha256
                   (base32
                    ,(if tarball
                         (bytevector->nix-base32-string (file-sha256 tarball))
                         "failed to download tar archive")))))
        (build-system haskell-build-system)
        ,@(maybe-inputs 'inputs dependencies)
        ,@(maybe-inputs 'native-inputs native-dependencies)
        ,@(maybe-arguments)
        (home-page ,(cabal-package-home-page cabal))
        (synopsis ,(cabal-package-synopsis cabal))
        (description ,(cabal-package-description cabal))
        (license ,(string->license (cabal-package-license cabal))))
     (append hackage-dependencies hackage-native-dependencies))))

(define* (hackage->guix-package package-name #:key
                                (include-test-dependencies? #t)
                                (port #f)
                                (cabal-environment '()))
  "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the
called with keyword parameter PORT, from PORT.  Return the `package'
S-expression corresponding to that package, or #f on failure.
CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal
conditionals are evaluated.  The accepted keys are: \"os\", \"arch\", \"impl\"
and the name of a flag.  The value associated with a flag has to be either the
symbol 'true' or 'false'.  The value associated with other keys has to conform
to the Cabal file format definition.  The default value associated with the
keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\"
respectively."
  (let-values (((cabal-meta cabal-hash)
                (if port
                    (read-cabal-and-hash port)
                    (hackage-fetch-and-hash package-name))))
    (and=> cabal-meta (compose (cut hackage-module->sexp <> cabal-hash
                                    #:include-test-dependencies?
                                    include-test-dependencies?)
                               (cut eval-cabal <> cabal-environment)))))

(define hackage->guix-package/m                   ;memoized variant
  (memoize hackage->guix-package))

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

(define hackage-package?
  (let ((hackage-rx (make-regexp "https?://hackage.haskell.org")))
    (url-predicate (cut regexp-exec hackage-rx <>))))

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (let* ((hackage-name (guix-package->hackage-name package))
         (cabal-meta (hackage-fetch hackage-name)))
    (match cabal-meta
      (#f
       (format (current-error-port)
               "warning: failed to parse ~a~%"
               (hackage-cabal-url hackage-name))
       #f)
      ((_ *** ("version" (version)))
       (let ((url (hackage-source-url hackage-name version)))
         (upstream-source
          (package (package-name package))
          (version version)
          (urls (list url))))))))

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

;;; cabal.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 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 json)
  #:use-module (json)
  #:use-module (guix http-client)
  #:use-module (guix import utils)
  #:use-module (guix import print)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:export (json-fetch
            json->code
            json->scheme-file))

(define* (json-fetch url
                     ;; Note: many websites returns 403 if we omit a
                     ;; 'User-Agent' header.
                     #:key (headers `((user-agent . "GNU Guile")
                                      (Accept . "application/json"))))
  "Return a representation of the JSON resource URL (a list or hash table), or
#f if URL returns 403 or 404.  HEADERS is a list of HTTP headers to pass in
the query."
  (guard (c ((and (http-get-error? c)
                  (let ((error (http-get-error-code c)))
                    (or (= 403 error)
                        (= 404 error))))
             #f))
    (let* ((port   (http-fetch url #:headers headers))
           (result (json->scm port)))
      (close-port port)
      result)))

(define (json->code file-name)
  "Read FILE-NAME containing one ore more JSON package definitions and return
a list of S-expressions, or return #F when the JSON is invalid."
  (catch 'json-invalid
    (lambda ()
      (let ((json (json-string->scm
                   (with-input-from-file file-name read-string))))
        (match json
          (#(packages ...)
           ;; To allow definitions to refer to one another, collect references
           ;; to local definitions and tell alist->package to ignore them.
           (second
            (memq #:result
                  (fold
                   (lambda (pkg names+result)
                     (match names+result
                       ((#:names names #:result result)
                        (list #:names
                              (cons (assoc-ref pkg "name") names)
                              #:result
                              (append result
                                      (list
                                       (package->code (alist->package pkg names))
                                       (string->symbol (assoc-ref pkg "name"))))))))
                        (list #:names '()
                              #:result '())
                        packages))))
          (package
            (list (package->code (alist->package json))
                  (string->symbol (assoc-ref json "name")))))))
    (const #f)))

(define (json->scheme-file file)
  "Convert the FILE containing a JSON package definition to a Scheme
representation and return the new file name (or #F on error)."
  (and-let* ((sexprs (json->code file))
             (file* (let* ((tempdir (or (getenv "TMPDIR") "/tmp"))
                           (template (string-append tempdir "/guix-XXXXXX"))
                           (port     (mkstemp! template)))
                      (close-port port)
                      template)))
    (call-with-output-file file*
      (lambda (port)
        (write '(use-modules (gnu)
                             (guix)
                             ((guix licenses) #:prefix license:))
               port)
        (for-each (cut write <> port) sexprs)))
    file*))