code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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 egg)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-71)
  #:use-module (gcrypt hash)
  #:use-module (guix git)
  #:use-module (guix i18n)
  #:use-module (guix base32)
  #:use-module (guix diagnostics)
  #:use-module (guix memoization)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix build-system)
  #:use-module (guix build-system chicken)
  #:use-module (guix store)
  #:use-module ((guix download) #:select (download-to-store url-fetch))
  #:use-module (guix import utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:export (egg->guix-package
            egg-recursive-import
            %egg-updater

            ;; For tests.
            guix-package->egg-name))

;;; Commentary:
;;;
;;; (guix import egg) provides package importer for CHICKEN eggs.  See the
;;; official specification format for eggs
;;; <https://wiki.call-cc.org/man/5/Egg%20specification%20format>.
;;;
;;; The following happens under the hood:
;;;
;;; * <git://code.call-cc.org/eggs-5-latest> is a Git repository that contains
;;;   the latest version of all CHICKEN eggs.  We look clone this repository
;;;   and retrieve the latest version number, and the PACKAGE.egg file, which
;;;   contains a list of lists containing metadata about the egg.
;;;
;;; * All the eggs are stored as tarballs at
;;;   <https://code.call-cc.org/egg-tarballs/5>, so we grab the tarball for
;;;   the egg from there.
;;;
;;; * The rest of the package fields will be parsed from the PACKAGE.egg file.
;;;
;;; Todos:
;;;
;;; * Support for CHICKEN 4?
;;;
;;; * Some packages will specify a specific version of a depencency in the
;;;   PACKAGE.egg file, how should we handle this?
;;;
;;; Code:

;;;
;;; Egg metadata fetcher and helper functions.
;;;

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

(define %eggs-url
  (make-parameter "https://code.call-cc.org/egg-tarballs/5"))

(define %eggs-home-page
  (make-parameter "https://wiki.call-cc.org/egg"))

(define (egg-source-url name version)
  "Return the URL to the source tarball for version VERSION of the CHICKEN egg
NAME."
  (string-append (%eggs-url) "/" name "/" name "-" version ".tar.gz"))

(define (egg-name->guix-name name)
  "Return the package name for CHICKEN egg NAME."
  (string-append package-name-prefix name))

(define (eggs-repository)
  "Update or fetch the latest version of the eggs repository and return the path
to the repository."
  (let* ((url "git://code.call-cc.org/eggs-5-latest")
         (directory commit _ (update-cached-checkout url)))
    directory))

(define (egg-directory name)
  "Return the directory containing the source code for the egg NAME."
  (let ((eggs-directory (eggs-repository)))
    (string-append eggs-directory "/" name)))

(define (find-latest-version name)
  "Get the latest version of the egg NAME."
  (let ((directory (scandir (egg-directory name))))
    (if directory
        (last directory)
        #f)))

(define* (egg-metadata name #:optional file)
  "Return the package metadata file for the egg NAME, or if FILE is specified,
return the package metadata in FILE."
  (call-with-input-file (or file
                            (string-append (egg-directory name) "/"
                                           (find-latest-version name)
                                           "/" name ".egg"))
    read))

(define (guix-name->egg-name name)
  "Return the CHICKEN egg name corresponding to the Guix package NAME."
  (if (string-prefix? package-name-prefix name)
      (string-drop name (string-length package-name-prefix))
      name))

(define (guix-package->egg-name package)
  "Return the CHICKEN egg name of the Guix CHICKEN PACKAGE."
  (or (assq-ref (package-properties package) 'upstream-name)
      (guix-name->egg-name (package-name package))))

(define (egg-package? package)
  "Check if PACKAGE is an CHICKEN egg package."
  (and (eq? (package-build-system package) chicken-build-system)
       (string-prefix? package-name-prefix (package-name package))))

(define string->license
  ;; Doesn't seem to use a specific format.
  ;; <https://wiki.call-cc.org/eggs-licensing>
  (match-lambda
   ("GPL-2" 'license:gpl2)
   ("GPL-2+" 'license:gpl2+)
   ("GPL-3" 'license:gpl3)
   ("GPL-3+" 'license:gpl3+)
   ("GPL" 'license:gpl?)
   ("AGPL-3" 'license:agpl3)
   ("AGPL" 'license:agpl?)
   ("LGPL-2.0" 'license:lgpl2.0)
   ("LGPL-2.0+" 'license:lgpl2.0+)
   ("LGPL-2.1" 'license:lgpl2.1)
   ("LGPL-2.1+" 'license:lgpl2.1+)
   ("LGPL-3" 'license:lgpl3)
   ("LGPL-3" 'license:lgpl3+)
   ("LGPL" 'license:lgpl?)
   ("BSD-1-Clause" 'license:bsd-1)
   ("BSD-2-Clause" 'license:bsd-2)
   ("BSD-3-Clause" 'license:bsd-3)
   ("BSD" 'license:bsd?)
   ("MIT" 'license:expat)
   ("ISC" 'license:isc)
   ("Artistic-2" 'license:artistic2.0)
   ("Apache-2.0" 'license:asl2.0)
   ("Public Domain" 'license:public-domain)
   ((x) (string->license x))
   ((lst ...) `(list ,@(map string->license lst)))
   (_ #f)))

;;;
;;; Egg importer.
;;;

(define* (egg->guix-package name #:key (file #f) (source #f))
  "Import a CHICKEN egg called NAME from either the given .egg FILE, or from
the latest NAME metadata downloaded from the official repository if FILE is #f.
Return a <package> record or #f on failure.

SOURCE is a ``file-like'' object containing the source code corresponding to
the egg.  If SOURCE is not specified, the latest tarball for egg NAME will be
downloaded.

Specifying the SOURCE argument is mainly useful for developing a CHICKEN egg
locally.  Note that if FILE and SOURCE are specified, recursive import will
not work."
  (define egg-content (if file
                          (egg-metadata name file)
                          (egg-metadata name)))
  (if (not egg-content)
      (values #f '())                    ; egg doesn't exist
      (let* ((version* (or (assoc-ref egg-content 'version)
                           (find-latest-version name)))
             (version (if (list? version*) (first version*) version*))
             (source-url (if source #f (egg-source-url name version)))
             (tarball (if source
                          #f
                          (with-store store
                            (download-to-store store source-url)))))

        (define egg-home-page
          (string-append (%eggs-home-page) "/" name))

        (define egg-synopsis
          (match (assoc-ref egg-content 'synopsis)
            ((synopsis) synopsis)
            (_ #f)))

        (define egg-licenses
          (let ((licenses*
                 (match (assoc-ref egg-content 'license)
                   ((license)
                    (map string->license (string-split license #\/)))
                   (#f
                    '()))))
            (match licenses*
              ((license) license)
              ((license1 license2 ...) `(list ,@licenses*)))))

        (define (maybe-symbol->string sym)
          (if (symbol? sym) (symbol->string sym) sym))

        (define (prettify-system-dependency name)
          ;; System dependencies sometimes have spaces and/or upper case
          ;; letters in them.
          ;;
          ;; There will probably still be some weird edge cases.
          (string-map (lambda (char)
                        (case char
                          ((#\space) #\-)
                          (else char)))
                      (maybe-symbol->string name)))

        (define* (egg-parse-dependency name #:key (system? #f))
          (define extract-name
            (match-lambda
              ((name version) name)
              (name name)))

          (define (prettify-name name)
            (if system?
                (prettify-system-dependency name)
                (maybe-symbol->string name)))

          (let ((name (prettify-name (extract-name name))))
            ;; Dependencies are sometimes specified as symbols and sometimes
            ;; as strings
            (list (string-append (if system? "" package-name-prefix)
                                 name)
                  (list 'unquote
                        (string->symbol (string-append
                                         (if system? "" package-name-prefix)
                                         name))))))

        (define egg-propagated-inputs
          (let ((dependencies (assoc-ref egg-content 'dependencies)))
            (if (list? dependencies)
                (map egg-parse-dependency
                     dependencies)
                '())))

        ;; TODO: Or should these be propagated?
        (define egg-inputs
          (let ((dependencies (assoc-ref egg-content 'foreign-dependencies)))
            (if (list? dependencies)
                (map (lambda (name)
                       (egg-parse-dependency name #:system? #t))
                     dependencies)
                '())))

        (define egg-native-inputs
          (let* ((test-dependencies (or (assoc-ref egg-content
                                                   'test-dependencies)
                                        '()))
                 (build-dependencies (or (assoc-ref egg-content
                                                    'build-dependencies)
                                         '()))
                 (test+build-dependencies (append test-dependencies
                                                  build-dependencies)))
            (match test+build-dependencies
              ((_ _ ...) (map egg-parse-dependency
                              test+build-dependencies))
              (() '()))))

        ;; Copied from (guix import hackage).
        (define (maybe-inputs input-type inputs)
          (match inputs
            (()
             '())
            ((inputs ...)
             (list (list input-type
                         (list 'quasiquote inputs))))))

        (values
         `(package
            (name ,(egg-name->guix-name name))
            (version ,version)
            (source
             ,(if source
                  source
                  `(origin
                     (method url-fetch)
                     (uri ,source-url)
                     (sha256
                      (base32 ,(if tarball
                                   (bytevector->nix-base32-string
                                    (file-sha256 tarball))
                                   "failed to download tar archive"))))))
            (build-system chicken-build-system)
            (arguments ,(list 'quasiquote (list #:egg-name name)))
            ,@(maybe-inputs 'native-inputs egg-native-inputs)
            ,@(maybe-inputs 'inputs egg-inputs)
            ,@(maybe-inputs 'propagated-inputs egg-propagated-inputs)
            (home-page ,egg-home-page)
            (synopsis ,egg-synopsis)
            (description #f)
            (license ,egg-licenses))
         (filter (lambda (name)
                   (not (member name '("srfi-4"))))
                 (map (compose guix-name->egg-name first)
                      (append egg-propagated-inputs
                              egg-native-inputs)))))))

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

(define (egg-recursive-import package-name)
  (recursive-import package-name
                    #:repo->guix-package (lambda* (name #:key version repo)
                                           (egg->guix-package/m name))
                    #:guix-name egg-name->guix-name))

;;;
;;; Updater.
;;;

(define (latest-release package)
  "Return an @code{<upstream-source>} for the latest release of PACKAGE."
  (let* ((egg-name (guix-package->egg-name package))
         (version (find-latest-version egg-name))
         (source-url (egg-source-url egg-name version)))
    (upstream-source
     (package (package-name package))
     (version version)
     (urls (list source-url)))))

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

;;; egg.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
;;; 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 elpa)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #: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 (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module ((guix download) #:select (download-to-store))
  #:use-module (guix import utils)
  #:use-module (guix http-client)
  #:use-module (guix git)
  #:use-module ((guix serialization) #:select (write-file))
  #: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* (download-git-repository url ref)
  "Fetch the given REF from the Git repository at URL."
  (with-store store
    (latest-repository-commit store url #:ref ref)))

(define (package-name->melpa-recipe package-name)
  "Fetch the MELPA recipe for PACKAGE-NAME, represented as an alist from
keywords to values."
  (define recipe-url
    (string-append "https://raw.githubusercontent.com/melpa/melpa/master/recipes/"
                   package-name))

  (define (data->recipe data)
    (match data
      (() '())
      ((key value . tail)
       (cons (cons key value) (data->recipe tail)))))

  (let* ((port (http-fetch/cached (string->uri recipe-url)
                                  #:ttl (* 6 3600)))
         (data (read port)))
    (close-port port)
    (data->recipe (cons ':name data))))

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

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

(define (git-repository->origin recipe url)
  "Fetch origin details from the Git repository at URL for the provided MELPA
RECIPE."
  (define ref
    (cond
     ((assoc-ref recipe #:branch)
      => (lambda (branch) (cons 'branch branch)))
     ((assoc-ref recipe #:commit)
      => (lambda (commit) (cons 'commit commit)))
     (else
      '(branch . "master"))))

  (let-values (((directory commit) (download-git-repository url ref)))
    `(origin
       (method git-fetch)
       (uri (git-reference
             (url ,url)
             (commit ,commit)))
       (sha256
        (base32
         ,(bytevector->nix-base32-string
           (file-hash directory (negate vcs-file?) #t)))))))

(define* (melpa-recipe->origin recipe)
  "Fetch origin details from the MELPA recipe and associated repository for
the package named PACKAGE-NAME."
  (define (github-repo->url repo)
    (string-append "https://github.com/" repo ".git"))
  (define (gitlab-repo->url repo)
    (string-append "https://gitlab.com/" repo ".git"))

  (match (assq-ref recipe ':fetcher)
    ('github (git-repository->origin recipe (github-repo->url (assq-ref recipe ':repo))))
    ('gitlab (git-repository->origin recipe (gitlab-repo->url (assq-ref recipe ':repo))))
    ('git    (git-repository->origin recipe (assq-ref recipe ':url)))
    (#f #f)   ; if we're not using melpa then this stops us printing a warning
    (_ (warning (G_ "Unsupported MELPA fetcher: ~a, falling back to unstable MELPA source.~%")
                (assq-ref recipe ':fetcher))
       #f)))

(define default-files-spec
  ;; This contains more than just the things contained in %default-include and
  ;; %default-exclude, presumably because this includes source files (*.in,
  ;; *.texi, etc.) which have already been processed for releases.
  ;;
  ;; Taken from:
  ;; https://github.com/melpa/melpa/blob/e8dc709d0ab2b4a68c59315f42858bcb86095f11/package-build/package-build.el#L580-L585
  '("*.el" "*.el.in" "dir"
    "*.info" "*.texi" "*.texinfo"
    "doc/dir" "doc/*.info" "doc/*.texi" "doc/*.texinfo"
    (:exclude ".dir-locals.el" "test.el" "tests.el" "*-test.el" "*-tests.el")))

(define* (melpa-recipe->maybe-arguments melpa-recipe)
  "Extract arguments for the build system from MELPA-RECIPE."
  (define (glob->regexp glob)
    (string-append
     "^"
     (regexp-substitute/global #f "\\*\\*?" glob
                               'pre
                               (lambda (m)
                                 (if (string= (match:substring m 0) "**")
                                     ".*"
                                     "[^/]+"))
                               'post)
     "$"))

  (let ((files (assq-ref melpa-recipe ':files)))
    (if files
        (let* ((with-default (apply append (map (lambda (entry)
                                                  (if (eq? ':defaults entry)
                                                      default-files-spec
                                                      (list entry)))
                                                files)))
               (inclusions (remove pair? with-default))
               (exclusions (apply append (map (match-lambda
                                                ((':exclude . values)
                                                 values)
                                                (_ '()))
                                              with-default))))
          `((arguments '(#:include ',(map glob->regexp inclusions)
                         #:exclude ',(map glob->regexp exclusions)))))
        '())))

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

  (define melpa-recipe
    (if (eq? repo 'melpa)
        (package-name->melpa-recipe (elpa-package-name pkg))
        #f))

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

  (define melpa-source
    (melpa-recipe->origin melpa-recipe))

  (values
   `(package
      (name ,(elpa-name->package-name name))
      (version ,version)
      (source ,(or melpa-source
                   (let ((tarball (with-store store
                                    (download-to-store store source-url))))
                     `(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)
      ,@(if melpa-source
            (melpa-recipe->maybe-arguments melpa-recipe)
            '())
      (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 #:key (repo 'gnu) version)
  "Fetch the package NAME from REPO and produce a Guix package S-expression."
  (match (fetch-elpa-package name repo)
    (#false
     (raise (condition
             (&message
              (message (format #false
                               "couldn't find meta-data for ELPA package `~a'."
                               name))))))
    (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 repo)))))

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

  (define repo 'gnu)

  (match (elpa-package-info name repo)
    (#f
     ;; No info, perhaps because PACKAGE is not truly an ELPA package.
     #f)
    (info
     (let* ((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
                    #:repo->guix-package elpa->guix-package
                    #:guix-name elpa-guix-name))

;;; elpa.scm ends here

repo_name: maximed/guix

license: mit


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, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 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 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) '())
                         ((unspecified? 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 (and vector (not (unspecified? 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 #:key (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 '()
                    #: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, 2021 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)))
      (((= string->number major) . _)
       ;; It should at last start with a digit.
       major)))

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

                  ;; Hide messages about URL redirects.
                  #:log-port (%make-void-port "w")))
           (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>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@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 gnu)
  #:use-module ((guix diagnostics) #:select (formatted-message))
  #:use-module (guix gnu-maintenance)
  #:use-module (guix import utils)
  #:use-module (guix i18n)
  #: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.)"
  (let ((package (find-package name)))
    (unless package
      (raise (formatted-message (G_ "no GNU package found for ~a") name)))

    (match (latest-release name)
      ((? upstream-source? release)
       (let ((version (upstream-source-version release)))
         (gnu-package->sexp package release #:key-download key-download)))
      (_
       (raise (formatted-message
               (G_ "failed to determine latest release of GNU ~a")
               name))))))

;;; gnu.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com>
;;; Copyright © 2021 François Joulaud <francois.joulaud@radiofrance.com>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;;
;;; 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 go)
  #:use-module (guix build-system go)
  #:use-module (guix git)
  #:use-module (guix i18n)
  #:use-module (guix diagnostics)
  #:use-module (guix import utils)
  #:use-module (guix import json)
  #:use-module (guix packages)
  #:use-module ((guix utils) #:select (string-replace-substring))
  #:use-module (guix http-client)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix memoization)
  #:autoload   (htmlprag) (html->sxml)            ;from Guile-Lib
  #:autoload   (guix git) (update-cached-checkout)
  #:autoload   (gcrypt hash) (open-hash-port hash-algorithm sha256)
  #:autoload   (guix serialization) (write-file)
  #:autoload   (guix base32) (bytevector->nix-base32-string)
  #:autoload   (guix build utils) (mkdir-p)
  #:use-module (ice-9 match)
  #:use-module (ice-9 peg)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 textual-ports)
  #:use-module ((rnrs io ports) #:select (call-with-port))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (sxml match)
  #:use-module ((sxml xpath) #:renamer (lambda (s)
                                         (if (eq? 'filter s)
                                             'xfilter
                                             s)))
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (web uri)

  #:export (go-module->guix-package
            go-module-recursive-import))

;;; Commentary:
;;;
;;; (guix import go) attempts to make it easier to create Guix package
;;; declarations for Go modules.
;;;
;;; Modules in Go are a "collection of related Go packages" which are "the
;;; unit of source code interchange and versioning".  Modules are generally
;;; hosted in a repository.
;;;
;;; At this point it should handle correctly modules which have only Go
;;; dependencies and are accessible from proxy.golang.org (or configured via
;;; GOPROXY).
;;;
;;; We want it to work more or less this way:
;;; - get latest version for the module from GOPROXY
;;; - infer VCS root repo from which we will check-out source by
;;;   + recognising known patterns (like github.com)
;;;   + or recognizing .vcs suffix
;;;   + or parsing meta tag in HTML served at the URL
;;;   + or (TODO) if nothing else works by using zip file served by GOPROXY
;;; - get go.mod from GOPROXY (which is able to synthetize one if needed)
;;; - extract list of dependencies from this go.mod
;;;
;;; The Go module paths are translated to a Guix package name under the
;;; assumption that there will be no collision.

;;; TODO list
;;; - get correct hash in vcs->origin for Mercurial and Subversion

;;; Code:

(define http-fetch*
  ;; Like http-fetch, but memoized and returning the body as a string.
  (memoize (lambda args
             (call-with-port (apply http-fetch args) get-string-all))))

(define json-fetch*
  (memoize json-fetch))

(define (go-path-escape path)
  "Escape a module path by replacing every uppercase letter with an
exclamation mark followed with its lowercase equivalent, as per the module
Escaped Paths specification (see:
https://godoc.org/golang.org/x/mod/module#hdr-Escaped_Paths)."
  (define (escape occurrence)
    (string-append "!" (string-downcase (match:substring occurrence))))
  (regexp-substitute/global #f "[A-Z]" path 'pre escape 'post))

;; Prevent inlining of this procedure, which is accessed by unit tests.
(set! go-path-escape go-path-escape)

(define (go.pkg.dev-info name)
  (http-fetch* (string-append "https://pkg.go.dev/" name)))

(define* (go-module-version-string goproxy name #:key version)
  "Fetch the version string of the latest version for NAME from the given
GOPROXY server, or for VERSION when specified."
  (let ((file (if version
                  (string-append "@v/" version ".info")
                  "@latest")))
    (assoc-ref (json-fetch* (format #f "~a/~a/~a"
                                    goproxy (go-path-escape name) file))
               "Version")))

(define* (go-module-available-versions goproxy name)
  "Retrieve the available versions for a given module from the module proxy.
Versions are being returned **unordered** and may contain different versioning
styles for the same package."
  (let* ((url (string-append goproxy "/" (go-path-escape name) "/@v/list"))
         (body (http-fetch* url))
         (versions (remove string-null? (string-split body #\newline))))
    (if (null? versions)
        (list (go-module-version-string goproxy name)) ;latest version
        versions)))

(define (go-package-licenses name)
  "Retrieve the list of licenses that apply to NAME, a Go package or module
name (e.g. \"github.com/golang/protobuf/proto\")."
  (let* ((body (go.pkg.dev-info (string-append name "?tab=licenses")))
         ;; Extract the text contained in a h2 child node of any
         ;; element marked with a "License" class attribute.
         (select (sxpath `(// (* (@ (equal? (class "License"))))
                              h2 // div // *text*))))
    (select (html->sxml body #:strict? #t))))

(define (sxml->texi sxml-node)
  "A very basic SXML to Texinfo converter which attempts to preserve HTML
formatting and links as text."
  (sxml-match sxml-node
              ((strong ,text)
               (format #f "@strong{~a}" text))
              ((a (@ (href ,url)) ,text)
               (format #f "@url{~a,~a}" url text))
              ((code ,text)
               (format #f "@code{~a}" text))
              (,something-else something-else)))

(define (go-package-description name)
  "Retrieve a short description for NAME, a Go package name,
e.g. \"google.golang.org/protobuf/proto\"."
  (let* ((body (go.pkg.dev-info name))
         (sxml (html->sxml body #:strict? #t))
         (overview ((sxpath
                     `(//
                       (* (@ (equal? (class "Documentation-overview"))))
                       (p 1))) sxml))
         ;; Sometimes, the first paragraph just contains images/links that
         ;; has only "\n" for text.  The following filter is designed to
         ;; omit it.
         (contains-text? (lambda (node)
                           (remove string-null?
                                   (map string-trim-both
                                        (filter (node-typeof? '*text*)
                                                (cdr node))))))
         (select-content (sxpath
                          `(//
                            (* (@ (equal? (class "UnitReadme-content"))))
                            div // p ,(xfilter contains-text?))))
         ;; Fall-back to use content; this is less desirable as it is more
         ;; verbose, but not every page has an overview.
         (description (if (not (null? overview))
                          overview
                          (select-content sxml)))
         (description* (if (not (null? description))
                           (first description)
                           description)))
    (match description*
      (() #f)                           ;nothing selected
      ((p elements ...)
       (apply string-append (filter string? (map sxml->texi elements)))))))

(define (go-package-synopsis module-name)
  "Retrieve a short synopsis for a Go module named MODULE-NAME,
e.g. \"google.golang.org/protobuf\".  The data is scraped from
the https://pkg.go.dev/ web site."
  ;; Note: Only the *module* (rather than package) page has the README title
  ;; used as a synopsis on the https://pkg.go.dev web site.
  (let* ((url (string-append "https://pkg.go.dev/" module-name))
         (body (http-fetch* url))
         ;; Extract the text contained in a h2 child node of any
         ;; element marked with a "License" class attribute.
         (select-title (sxpath
                        `(// (div (@ (equal? (class "UnitReadme-content"))))
                             // h3 *text*))))
    (match (select-title (html->sxml body #:strict? #t))
      (() #f)                           ;nothing selected
      ((title more ...)                 ;title is the first string of the list
       (string-trim-both title)))))

(define (list->licenses licenses)
  "Given a list of LICENSES mostly following the SPDX conventions, return the
corresponding Guix license or 'unknown-license!"
  (filter-map (lambda (license)
                (and (not (string-null? license))
                     (not (any (cut string=? <> license)
                               '("AND" "OR" "WITH")))
                     ;; Adjust the license names scraped from
                     ;; https://pkg.go.dev to an equivalent SPDX identifier,
                     ;; if they differ (see: https://github.com/golang/pkgsite
                     ;; /internal/licenses/licenses.go#L174).
                     (or (spdx-string->license
                          (match license
                            ("BlueOak-1.0" "BlueOak-1.0.0")
                            ("BSD-0-Clause" "0BSD")
                            ("BSD-2-Clause" "BSD-2-Clause-FreeBSD")
                            ("GPL2" "GPL-2.0")
                            ("GPL3" "GPL-3.0")
                            ("NIST" "NIST-PD")
                            (_ license)))
                         'unknown-license!)))
              licenses))

(define (fetch-go.mod goproxy module-path version)
  "Fetch go.mod from the given GOPROXY server for the given MODULE-PATH
and VERSION and return an input port."
  (let ((url (format #f "~a/~a/@v/~a.mod" goproxy
                     (go-path-escape module-path)
                     (go-path-escape version))))
    (http-fetch* url)))

(define (parse-go.mod content)
  "Parse the go.mod file CONTENT, returning a list of directives, comments,
and unknown lines.  Each sublist begins with a symbol (go, module, require,
replace, exclude, retract, comment, or unknown) and is followed by one or more
sublists.  Each sublist begins with a symbol (module-path, version, file-path,
comment, or unknown) and is followed by the indicated data."
  ;; https://golang.org/ref/mod#go-mod-file-grammar
  (define-peg-pattern NL none "\n")
  (define-peg-pattern WS none (or " " "\t" "\r"))
  (define-peg-pattern => none (and (* WS) "=>"))
  (define-peg-pattern punctuation none (or "," "=>" "[" "]" "(" ")"))
  (define-peg-pattern comment all
    (and (ignore "//") (* WS) (* (and (not-followed-by NL) peg-any))))
  (define-peg-pattern EOL body (and (* WS) (? comment) NL))
  (define-peg-pattern block-start none (and (* WS) "(" EOL))
  (define-peg-pattern block-end none (and (* WS) ")" EOL))
  (define-peg-pattern any-line body
    (and (* WS) (* (and (not-followed-by NL) peg-any)) EOL))

  ;; Strings and identifiers
  (define-peg-pattern identifier body
    (+ (and (not-followed-by (or NL WS punctuation)) peg-any)))
  (define-peg-pattern string-raw body
    (and (ignore "`") (+ (and (not-followed-by "`") peg-any)) (ignore "`")))
  (define-peg-pattern string-quoted body
    (and (ignore "\"")
         (+ (or (and (ignore "\\") peg-any)
                (and (not-followed-by "\"") peg-any)))
         (ignore "\"")))
  (define-peg-pattern string-or-ident body
    (and (* WS) (or string-raw string-quoted identifier)))

  (define-peg-pattern version all string-or-ident)
  (define-peg-pattern module-path all string-or-ident)
  (define-peg-pattern file-path all string-or-ident)

  ;; Non-directive lines
  (define-peg-pattern unknown all any-line)
  (define-peg-pattern block-line body
    (or EOL (and (not-followed-by block-end) unknown)))

  ;; GoDirective = "go" GoVersion newline .
  (define-peg-pattern go all (and (ignore "go") version EOL))

  ;; ModuleDirective = "module" ( ModulePath | "(" newline ModulePath newline ")" ) newline .
  (define-peg-pattern module all
    (and (ignore "module") (or (and block-start module-path EOL block-end)
                               (and module-path EOL))))

  ;; The following directives may all be used solo or in a block
  ;; RequireSpec = ModulePath Version newline .
  (define-peg-pattern require all (and module-path version EOL))
  (define-peg-pattern require-top body
    (and (ignore "require")
         (or (and block-start (* (or require block-line)) block-end) require)))

  ;; ExcludeSpec = ModulePath Version newline .
  (define-peg-pattern exclude all (and module-path version EOL))
  (define-peg-pattern exclude-top body
    (and (ignore "exclude")
         (or (and block-start (* (or exclude block-line)) block-end) exclude)))

  ;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline
  ;;             | ModulePath [ Version ] "=>" ModulePath Version newline .
  (define-peg-pattern original all (or (and module-path version) module-path))
  (define-peg-pattern with all (or (and module-path version) file-path))
  (define-peg-pattern replace all (and original => with EOL))
  (define-peg-pattern replace-top body
    (and (ignore "replace")
         (or (and block-start (* (or replace block-line)) block-end) replace)))

  ;; RetractSpec = ( Version | "[" Version "," Version "]" ) newline .
  (define-peg-pattern range all
    (and (* WS) (ignore "[") version
         (* WS) (ignore ",") version (* WS) (ignore "]")))
  (define-peg-pattern retract all (and (or range version) EOL))
  (define-peg-pattern retract-top body
    (and (ignore "retract")
         (or (and block-start (* (or retract block-line)) block-end) retract)))

  (define-peg-pattern go-mod body
    (* (and (* WS) (or go module require-top exclude-top replace-top
                       retract-top EOL unknown))))

  (let ((tree (peg:tree (match-pattern go-mod content)))
        (keywords '(go module require replace exclude retract comment unknown)))
    (keyword-flatten keywords tree)))

;; Prevent inlining of this procedure, which is accessed by unit tests.
(set! parse-go.mod parse-go.mod)

(define (go.mod-directives go.mod directive)
  "Return the list of top-level directive bodies in GO.MOD matching the symbol
DIRECTIVE."
  (filter-map (match-lambda
                (((? (cut eq? <> directive) head) . rest) rest)
                (_ #f))
              go.mod))

(define (go.mod-requirements go.mod)
  "Compute and return the list of requirements specified by GO.MOD."
  (define (replace directive requirements)
    (define (maybe-replace module-path new-requirement)
      ;; Do not allow version updates for indirect dependencies (see:
      ;; https://golang.org/ref/mod#go-mod-file-replace).
      (if (and (equal? module-path (first new-requirement))
               (not (assoc-ref requirements module-path)))
          requirements
          (cons new-requirement (alist-delete module-path requirements))))

    (match directive
      ((('original ('module-path module-path) . _) with . _)
       (match with
         (('with ('file-path _) . _)
          (alist-delete module-path requirements))
         (('with ('module-path new-module-path) ('version new-version) . _)
          (maybe-replace module-path
                         (list new-module-path new-version)))))))

  (define (require directive requirements)
    (match directive
      ((('module-path module-path) ('version version) . _)
       (cons (list module-path version) requirements))))

  (let* ((requires (go.mod-directives go.mod 'require))
         (replaces (go.mod-directives go.mod 'replace))
         (requirements (fold require '() requires)))
    (fold replace requirements replaces)))

;; Prevent inlining of this procedure, which is accessed by unit tests.
(set! go.mod-requirements go.mod-requirements)

(define-record-type <vcs>
  (%make-vcs url-prefix root-regex type)
  vcs?
  (url-prefix vcs-url-prefix)
  (root-regex vcs-root-regex)
  (type vcs-type))

(define (make-vcs prefix regexp type)
  (%make-vcs prefix (make-regexp regexp) type))

(define known-vcs
  ;; See the following URL for the official Go equivalent:
  ;; https://github.com/golang/go/blob/846dce9d05f19a1f53465e62a304dea21b99f910/src/cmd/go/internal/vcs/vcs.go#L1026-L1087
  (list
   (make-vcs
    "github.com"
    "^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
    'git)
   (make-vcs
    "bitbucket.org"
    "^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$"
    'unknown)
   (make-vcs
    "hub.jazz.net/git/"
    "^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
    'git)
   (make-vcs
    "git.apache.org"
    "^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$"
    'git)
   (make-vcs
    "git.openstack.org"
    "^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\
(/[A-Za-z0-9_.\\-]+)*$"
    'git)))

(define (module-path->repository-root module-path)
  "Infer the repository root from a module path.  Go modules can be
defined at any level of a repository tree, but querying for the meta tag
usually can only be done from the web page at the root of the repository,
hence the need to derive this information."

  ;; For reference, see: https://golang.org/ref/mod#vcs-find.
  (define vcs-qualifiers '(".bzr" ".fossil" ".git" ".hg" ".svn"))

  (define (vcs-qualified-module-path->root-repo-url module-path)
    (let* ((vcs-qualifiers-group (string-join vcs-qualifiers "|"))
           (pattern (format #f "^(.*(~a))(/|$)" vcs-qualifiers-group))
           (m (string-match pattern module-path)))
      (and=> m (cut match:substring <> 1))))

  (or (and=> (find (lambda (vcs)
                     (string-prefix? (vcs-url-prefix vcs) module-path))
                   known-vcs)
             (lambda (vcs)
               (match:substring (regexp-exec (vcs-root-regex vcs)
                                             module-path) 1)))
      (vcs-qualified-module-path->root-repo-url module-path)
      module-path))

(define* (go-module->guix-package-name module-path #:optional version)
  "Converts a module's path to the canonical Guix format for Go packages.
Optionally include a VERSION string to append to the name."
  ;; Map dot, slash, underscore and tilde characters to hyphens.
  (let ((module-path* (string-map (lambda (c)
                                    (if (member c '(#\. #\/ #\_ #\~))
                                        #\-
                                        c))
                                  module-path)))
    (string-downcase (string-append "go-" module-path*
                                    (if version
                                        (string-append "-" version)
                                        "")))))

(define (strip-.git-suffix/maybe repo-url)
  "Strip a repository URL '.git' suffix from REPO-URL if hosted at GitHub."
  (match repo-url
    ((and (? (cut string-prefix? "https://github.com" <>))
          (? (cut string-suffix? ".git" <>)))
     (string-drop-right repo-url 4))
    (_ repo-url)))

(define-record-type <module-meta>
  (make-module-meta import-prefix vcs repo-root)
  module-meta?
  (import-prefix module-meta-import-prefix)
  (vcs module-meta-vcs)                 ;a symbol
  (repo-root module-meta-repo-root))

(define (fetch-module-meta-data module-path)
  "Retrieve the module meta-data from its landing page.  This is necessary
because goproxy servers don't currently provide all the information needed to
build a package."
  (define (go-import->module-meta content-text)
    (match (string-split content-text #\space)
      ((root-path vcs repo-url)
       (make-module-meta root-path (string->symbol vcs)
                         (strip-.git-suffix/maybe repo-url)))))
  ;; <meta name="go-import" content="import-prefix vcs repo-root">
  (let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path)))
         (select (sxpath `(// head (meta (@ (equal? (name "go-import"))))
                              // content))))
    (match (select (html->sxml meta-data #:strict? #t))
      (() #f)                           ;nothing selected
      ((('content content-text) ..1)
       (find (lambda (meta)
               (string-prefix? (module-meta-import-prefix meta) module-path))
             (map go-import->module-meta content-text))))))

(define (module-meta-data-repo-url meta-data goproxy)
  "Return the URL where the fetcher which will be used can download the
source."
  (if (member (module-meta-vcs meta-data) '(fossil mod))
      goproxy
      (module-meta-repo-root meta-data)))

;; XXX: Copied 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)))

;; XXX: Adapted from 'file-hash' in (guix scripts hash).
(define* (file-hash file #:optional (algorithm (hash-algorithm sha256)))
  ;; Compute the hash of FILE.
  (let-values (((port get-hash) (open-hash-port algorithm)))
    (write-file file port #:select? (negate vcs-file?))
    (force-output port)
    (get-hash)))

(define* (git-checkout-hash url reference algorithm)
  "Return the ALGORITHM hash of the checkout of URL at REFERENCE, a commit or
tag."
  (define cache
    (string-append (or (getenv "TMPDIR") "/tmp")
                   "/guix-import-go-"
                   (passwd:name (getpwuid (getuid)))))

  ;; Use a custom cache to avoid cluttering the default one under
  ;; ~/.cache/guix, but choose one under /tmp so that it's persistent across
  ;; subsequent "guix import" invocations.
  (mkdir-p cache)
  (chmod cache #o700)
  (let-values (((checkout commit _)
                (parameterize ((%repository-cache-directory cache))
                  (update-cached-checkout url
                                          #:ref
                                          `(tag-or-commit . ,reference)))))
    (file-hash checkout algorithm)))

(define (vcs->origin vcs-type vcs-repo-url version)
  "Generate the `origin' block of a package depending on what type of source
control system is being used."
  (case vcs-type
    ((git)
     (let ((plain-version? (string=? version (go-version->git-ref version)))
           (v-prefixed?    (string-prefix? "v" version)))
       `(origin
          (method git-fetch)
          (uri (git-reference
                (url ,vcs-repo-url)
                ;; This is done because the version field of the package,
                ;; which the generated quoted expression refers to, has been
                ;; stripped of any 'v' prefixed.
                (commit ,(if (and plain-version? v-prefixed?)
                             '(string-append "v" version)
                             '(go-version->git-ref version)))))
          (file-name (git-file-name name version))
          (sha256
           (base32
            ,(bytevector->nix-base32-string
              (git-checkout-hash vcs-repo-url (go-version->git-ref version)
                                 (hash-algorithm sha256))))))))
    ((hg)
     `(origin
        (method hg-fetch)
        (uri (hg-reference
              (url ,vcs-repo-url)
              (changeset ,version)))
        (file-name (string-append name "-" version "-checkout"))
        (sha256
         (base32
          ;; FIXME: populate hash for hg repo checkout
          "0000000000000000000000000000000000000000000000000000"))))
    ((svn)
     `(origin
        (method svn-fetch)
        (uri (svn-reference
              (url ,vcs-repo-url)
              (revision (string->number version))))
        (file-name (string-append name "-" version "-checkout"))
        (sha256
         (base32
          ;; FIXME: populate hash for svn repo checkout
          "0000000000000000000000000000000000000000000000000000"))))
    (else
     (raise
      (formatted-message (G_ "unsupported vcs type '~a' for package '~a'")
                         vcs-type vcs-repo-url)))))

(define* (go-module->guix-package module-path #:key
                                  (goproxy "https://proxy.golang.org")
                                  version
                                  pin-versions?)
  "Return the package S-expression corresponding to MODULE-PATH at VERSION, a Go package.
The meta-data is fetched from the GOPROXY server and https://pkg.go.dev/.
When VERSION is unspecified, the latest version available is used."
  (let* ((available-versions (go-module-available-versions goproxy module-path))
         (version* (or version
                       (go-module-version-string goproxy module-path))) ;latest
         ;; Elide the "v" prefix Go uses.
         (strip-v-prefix (cut string-trim <> #\v))
         ;; Pseudo-versions do not appear in the versions list; skip the
         ;; following check.
         (_ (unless (or (go-pseudo-version? version*)
                        (member version* available-versions))
              (error (format #f "error: version ~s is not available
hint: use one of the following available versions ~a\n"
                             version* available-versions))))
         (content (fetch-go.mod goproxy module-path version*))
         (dependencies+versions (go.mod-requirements (parse-go.mod content)))
         (dependencies (if pin-versions?
                           dependencies+versions
                           (map car dependencies+versions)))
         (guix-name (go-module->guix-package-name module-path))
         (root-module-path (module-path->repository-root module-path))
         ;; The VCS type and URL are not included in goproxy information. For
         ;; this we need to fetch it from the official module page.
         (meta-data (fetch-module-meta-data root-module-path))
         (vcs-type (module-meta-vcs meta-data))
         (vcs-repo-url (module-meta-data-repo-url meta-data goproxy))
         (synopsis (go-package-synopsis root-module-path))
         (description (go-package-description module-path))
         (licenses (go-package-licenses module-path)))
    (values
     `(package
        (name ,guix-name)
        (version ,(strip-v-prefix version*))
        (source
         ,(vcs->origin vcs-type vcs-repo-url version*))
        (build-system go-build-system)
        (arguments
         '(#:import-path ,root-module-path))
        ,@(maybe-propagated-inputs
           (map (match-lambda
                  ((name version)
                   (go-module->guix-package-name name (strip-v-prefix version)))
                  (name
                   (go-module->guix-package-name name)))
                dependencies))
        (home-page ,(format #f "https://~a" root-module-path))
        (synopsis ,synopsis)
        (description ,(and=> description beautify-description))
        (license ,(match (list->licenses licenses)
                    (() #f)                        ;unknown license
                    ((license)                     ;a single license
                     license)
                    ((license ...)     ;a list of licenses
                     `(list ,@license)))))
     (if pin-versions?
         dependencies+versions
         dependencies))))

(define go-module->guix-package* (memoize go-module->guix-package))

(define* (go-module-recursive-import package-name
                                     #:key (goproxy "https://proxy.golang.org")
                                     version
                                     pin-versions?)

  (recursive-import
   package-name
   #:repo->guix-package
   (lambda* (name #:key version repo)
     ;; Disable output buffering so that the following warning gets printed
     ;; consistently.
     (setvbuf (current-error-port) 'none)
     (guard (c ((http-get-error? c)
                (warning (G_ "Failed to import package ~s.
reason: ~s could not be fetched: HTTP error ~a (~s).
This package and its dependencies won't be imported.~%")
                         name
                         (uri->string (http-get-error-uri c))
                         (http-get-error-code c)
                         (http-get-error-reason c))
                (values '() '())))
       (receive (package-sexp dependencies)
           (go-module->guix-package* name #:goproxy goproxy
                                     #:version version
                                     #:pin-versions? pin-versions?)
         (values package-sexp dependencies))))
   #:guix-name go-module->guix-package-name
   #:version version))