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>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; 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-url
            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-url
  (make-parameter "https://hackage.haskell.org"))

(define (hackage-source-url name version)
  "Given a Hackage package NAME and VERSION, return a url to the source
tarball."
  (string-append (%hackage-url) "/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 (%hackage-url) "/package/"
                     name "-" version "/" name ".cabal")
      (string-append (%hackage-url) "/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" 'license:gpl2)
   ("GPL-3" 'license:gpl3)
   ("GPL" "'gpl??")
   ("AGPL-3" 'license:agpl3)
   ("AGPL" "'agpl??")
   ("LGPL-2.1" 'license:lgpl2.1)
   ("LGPL-3" 'license:lgpl3)
   ("LGPL" "'lgpl??")
   ("BSD2" 'license:bsd-2)
   ("BSD3" 'license:bsd-3)
   ("BSD-3-Clause" 'license:bsd-3)
   ("MIT" 'license:expat)
   ("ISC" 'license:isc)
   ("MPL" 'license:mpl2.0)
   ("Apache-2.0" 'license:asl2.0)
   ("PublicDomain" 'license: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
                    #:repo->guix-package (lambda* (name #:key repo version)
                                           (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*))

repo_name: maximed/guix

license: mit


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

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

  #:export (%kde-updater))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

  (match (json-fetch
          (string-append "https://api.launchpad.net/1.0/"
                         repository "/releases"))
    (#f #f)                                       ;404 or similar
    (json
     (assoc-ref
      (last (remove pre-release? (vector->list (assoc-ref json "entries"))))
      "version"))))

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

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

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; 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 minetest)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 hash-table)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (guix utils)
  #:use-module (guix ui)
  #:use-module (guix i18n)
  #:use-module (guix memoization)
  #:use-module (guix serialization)
  #:use-module (guix import utils)
  #:use-module (guix import json)
  #:use-module ((gcrypt hash) #:select (open-sha256-port port-sha256))
  #:use-module (json)
  #:use-module (guix base32)
  #:use-module (guix git)
  #:use-module (guix store)
  #:export (%default-sort-key
            %contentdb-api
            json->package
            contentdb-fetch
            elaborate-contentdb-name
            minetest->guix-package
            minetest-recursive-import
            sort-packages))

;; The ContentDB API is documented at
;; <https://content.minetest.net>.

(define %contentdb-api
  (make-parameter "https://content.minetest.net/api/"))

(define (string-or-false x)
  (and (string? x) x))

(define (natural-or-false x)
  (and (exact-integer? x) (>= x 0) x))

;; Descriptions on ContentDB use carriage returns, but Guix doesn't.
(define (delete-cr text)
  (string-delete #\cr text))

;;;
;;; JSON mappings
;;;

;; Minetest package.
;;
;; API endpoint: /packages/AUTHOR/NAME/
(define-json-mapping <package> make-package package?
  json->package
  (author            package-author) ; string
  (creation-date     package-creation-date ; string
                     "created_at")
  (downloads         package-downloads) ; integer
  (forums            package-forums "forums" natural-or-false)
  (issue-tracker     package-issue-tracker "issue_tracker") ; string
  (license           package-license) ; string
  (long-description  package-long-description "long_description") ; string
  (maintainers       package-maintainers ; list of strings
                     "maintainers" vector->list)
  (media-license     package-media-license "media_license") ; string
  (name              package-name) ; string
  (provides          package-provides ; list of strings
                     "provides" vector->list)
  (release           package-release) ; integer
  (repository        package-repository "repo" string-or-false)
  (score             package-score) ; flonum
  (screenshots       package-screenshots "screenshots" vector->list) ; list of strings
  (short-description package-short-description "short_description") ; string
  (state             package-state) ; string
  (tags              package-tags "tags" vector->list) ; list of strings
  (thumbnail         package-thumbnail) ; string
  (title             package-title) ; string
  (type              package-type) ; string
  (url               package-url) ; string
  (website           package-website "website" string-or-false))

(define-json-mapping <release> make-release release?
  json->release
  ;; If present, a git commit identified by its hash
  (commit               release-commit "commit" string-or-false)
  (downloads            release-downloads) ; integer
  (id                   release-id) ; integer
  (max-minetest-version release-max-minetest-version string-or-false)
  (min-minetest-version release-min-minetest-version string-or-false)
  (release-date         release-data) ; string
  (title                release-title) ; string
  (url                  release-url)) ; string

(define-json-mapping <dependency> make-dependency dependency?
  json->dependency
  (optional? dependency-optional? "is_optional") ; bool
  (name dependency-name) ; string
  (packages dependency-packages "packages" vector->list)) ; list of strings

;; A structure returned by the /api/packages/?fmt=keys endpoint
(define-json-mapping <package-keys> make-package-keys package-keys?
  json->package-keys
  (author package-keys-author) ; string
  (name package-keys-name)     ; string
  (type package-keys-type))    ; string

(define (package-mod? package)
  "Is the ContentDB package PACKAGE a mod?"
  ;; ContentDB also has ‘games’ and ‘texture packs’.
  (string=? (package-type package) "mod"))

;;;
;;; Manipulating names of packages
;;;
;;; There are three kind of names:
;;;
;;;   * names of guix packages, e.g. minetest-basic-materials.
;;;   * names of mods on ContentDB, e.g. basic_materials
;;;   * a combination of author and mod name on ContentDB, e.g. VanessaE/basic_materials
;;;

(define (%construct-full-name author name)
  (string-append author "/" name))

(define (package-full-name package)
  "Given a <package> object, return the corresponding AUTHOR/NAME string."
  (%construct-full-name (package-author package) (package-name package)))

(define (package-keys-full-name package)
  "Given a <package-keys> object, return the corresponding AUTHOR/NAME string."
  (%construct-full-name (package-keys-author package)
                        (package-keys-name package)))

(define (contentdb->package-name author/name)
  "Given the AUTHOR/NAME of a package on ContentDB, return a Guix-compliant
name for the package."
  ;; The author is not included, as the names of popular mods
  ;; tend to be unique.
  (string-append "minetest-" (snake-case (author/name->name author/name))))

(define (author/name->name author/name)
  "Extract NAME from the AUTHOR/NAME string, or raise an error if AUTHOR/NAME
is ill-formatted."
  (match (string-split author/name #\/)
    ((author name)
     (when (string-null? author)
       (leave
        (G_ "In ~a: author names must consist of at least a single character.~%")
        author/name))
     (when (string-null? name)
       (leave
        (G_ "In ~a: mod names must consist of at least a single character.~%")
        author/name))
     name)
    ((too many . components)
     (leave
      (G_ "In ~a: author names and mod names may not contain forward slashes.~%")
      author/name))
    ((name)
     (if (string-null? name)
         (leave (G_ "mod names may not be empty.~%"))
         (leave (G_ "The name of the author is missing in ~a.~%")
                author/name)))))

(define* (elaborate-contentdb-name name #:key (sort %default-sort-key))
  "If NAME is an AUTHOR/NAME string, return it.  Otherwise, try to determine
the author and return an appropriate AUTHOR/NAME string.  If that fails,
raise an exception."
  (if (or (string-contains name "/") (string-null? name))
      ;; Call 'author/name->name' to verify that NAME seems reasonable
      ;; and raise an appropriate exception if it isn't.
      (begin
        (author/name->name name)
        name)
      (let* ((package-keys (contentdb-query-packages name #:sort sort))
             (correctly-named
              (filter (lambda (package-key)
                        (string=? name (package-keys-name package-key)))
                      package-keys)))
        (match correctly-named
          ((one) (package-keys-full-name one))
          ((too . many)
           (warning (G_ "~a is ambigious, presuming ~a (other options include: ~a)~%")
                    name (package-keys-full-name too)
                    (map package-keys-full-name many))
           (package-keys-full-name too))
          (()
           (leave (G_ "No mods with name ~a were found.~%") name))))))

;;;
;;; API endpoints
;;;

(define contentdb-fetch
  (mlambda (author/name)
    "Return a <package> record for package AUTHOR/NAME, or #f on failure."
    (and=> (json-fetch
            (string-append (%contentdb-api) "packages/" author/name "/"))
           json->package)))

(define (contentdb-fetch-releases author/name)
  "Return a list of <release> records for package NAME by AUTHOR, or #f
on failure."
  (and=> (json-fetch (string-append (%contentdb-api) "packages/" author/name
                                    "/releases/"))
         (lambda (json)
           (map json->release (vector->list json)))))

(define (latest-release author/name)
  "Return the latest source release for package NAME by AUTHOR,
or #f if this package does not exist."
  (and=> (contentdb-fetch-releases author/name)
         car))

(define (contentdb-fetch-dependencies author/name)
  "Return an alist of lists of <dependency> records for package NAME by AUTHOR
and possibly some other packages as well, or #f on failure."
  (define url (string-append (%contentdb-api) "packages/" author/name
                             "/dependencies/"))
  (and=> (json-fetch url)
         (lambda (json)
           (map (match-lambda
                  ((key . value)
                   (cons key (map json->dependency (vector->list value)))))
                json))))

(define* (contentdb-query-packages q #:key
                                   (type "mod")
                                   (limit 50)
                                   (sort %default-sort-key)
                                   (order "desc"))
  "Search ContentDB for Q (a string).  Sort by SORT, in ascending order
if ORDER is \"asc\" or descending order if ORDER is \"desc\".  TYPE must
be \"mod\", \"game\" or \"txp\", restricting thes search results to
respectively mods, games and texture packs.  Limit to at most LIMIT
results.  The return value is a list of <package-keys> records."
  ;; XXX does Guile have something for constructing (and, when necessary,
  ;; escaping) query strings?
  (define url (string-append (%contentdb-api) "packages/?type=" type
                             "&q=" q "&fmt=keys"
                             "&limit=" (number->string limit)
                             "&order=" order
                             "&sort=" sort))
  (let ((json (json-fetch url)))
    (if json
        (map json->package-keys (vector->list json))
        (leave
         (G_ "The package search API doesn't exist anymore.~%")))))

;; XXX copied from (guix import elpa)
(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)))

;; XXX adapted from (guix scripts hash)
(define (file-hash file)
  "Compute the hash of FILE."
  (let-values (((port get-hash) (open-sha256-port)))
    (write-file file port)
    (force-output port)
    (get-hash)))

(define (make-minetest-sexp author/name version repository commit
                            inputs home-page synopsis
                            description media-license license)
  "Return a S-expression for the minetest package with the given author/NAME,
VERSION, REPOSITORY, COMMIT, INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
MEDIA-LICENSE and LICENSE."
  `(package
     (name ,(contentdb->package-name author/name))
     (version ,version)
     (source
       (origin
         (method git-fetch)
         (uri (git-reference
                (url ,repository)
                (commit ,commit)))
         (sha256
          (base32
           ;; The git commit is not always available.
           ,(and commit
                 (bytevector->nix-base32-string
                  (file-hash
                   (download-git-repository repository
                                            `(commit . ,commit)))))))
         (file-name (git-file-name name version))))
     (build-system minetest-mod-build-system)
     ,@(maybe-propagated-inputs (map contentdb->package-name inputs))
     (home-page ,home-page)
     (synopsis ,(delete-cr synopsis))
     (description ,(delete-cr description))
     (license ,(if (eq? media-license license)
                   license
                   `(list ,media-license ,license)))
     ;; The Minetest updater (not yet in Guix; it requires not-yet-submitted
     ;; patches to (guix upstream) that require some work) needs to know both
     ;; the author name and mod name for efficiency.
     (properties ,(list 'quasiquote `((upstream-name . ,author/name))))))

(define (package-home-page package)
  "Guess the home page of the ContentDB package PACKAGE.

In order of preference, try the 'website', the forum topic on the
official Minetest forum and the Git repository (if any)."
  (define (topic->url-sexp topic)
    ;; 'minetest-topic' is a procedure defined in (gnu packages minetest)
    `(minetest-topic ,topic))
  (or (package-website package)
      (and=> (package-forums package) topic->url-sexp)
      (package-repository package)))

;; If the default sort key is changed, make sure to modify 'show-help'
;; in (guix scripts import minetest) appropriately as well.
(define %default-sort-key "score")

(define* (sort-packages packages #:key (sort %default-sort-key))
  "Sort PACKAGES by SORT, in descending order."
  (define package->key
    (match sort
      ("score" package-score)
      ("downloads" package-downloads)))
  (define (greater x y)
    (> (package->key x) (package->key y)))
  (sort-list packages greater))

(define builtin-mod?
  (let ((%builtin-mods
         (alist->hash-table
          (map (lambda (x) (cons x #t))
               '("beds" "binoculars" "boats" "bones" "bucket" "butterflies"
                 "carts" "creative" "default" "doors" "dungeon_loot" "dye"
                 "env_sounds" "farming" "fire" "fireflies" "flowers"
                 "game_commands" "give_initial_stuff" "map" "mtg_craftguide"
                 "player_api" "screwdriver" "sethome" "sfinv" "spawn" "stairs"
                 "tnt" "vessels" "walls" "weather" "wool" "xpanes")))))
    (lambda (mod)
      "Is MOD provided by the default minetest subgame?"
      (hash-ref %builtin-mods mod))))

(define* (important-dependencies dependencies author/name
                                 #:key (sort %default-sort-key))
  "Return the hard dependencies of AUTHOR/NAME in the association list
DEPENDENCIES as a list of AUTHOR/NAME strings."
  (define dependency-list
    (assoc-ref dependencies author/name))
  (filter-map
   (lambda (dependency)
     (and (not (dependency-optional? dependency))
          (not (builtin-mod? (dependency-name dependency)))
          ;; The dependency information contains symbolic names
          ;; that can be ‘provided’ by multiple mods, so we need to choose one
          ;; of the implementations.
          (let* ((implementations
                  (par-map contentdb-fetch (dependency-packages dependency)))
                 ;; Fetching package information about the packages is racy:
                 ;; some packages might be removed from ContentDB between the
                 ;; construction of DEPENDENCIES and the call to
                 ;; 'contentdb-fetch'.  So filter out #f.
                 ;;
                 ;; Filter out ‘games’ that include the requested mod -- it's
                 ;; the mod itself we want.
                 (mods (filter (lambda (p) (and=> p package-mod?))
                               implementations))
                 (sorted-mods (sort-packages mods #:sort sort)))
            (match sorted-mods
              ((package) (package-full-name package))
              ((too . many)
               (warning
                (G_ "The dependency ~a of ~a has multiple different implementations ~a.~%")
                (dependency-name dependency)
                author/name
                (map package-full-name sorted-mods))
               (match sort
                 ("score"
                  (warning
                   (G_ "The implementation with the highest score will be choosen!~%")))
                 ("downloads"
                  (warning
                   (G_ "The implementation that has been downloaded the most will be choosen!~%"))))
               (package-full-name too))
              (()
               (warning
                (G_ "The dependency ~a of ~a does not have any implementation.  It will be ignored!~%")
                (dependency-name dependency) author/name)
               #f)))))
   dependency-list))

(define* (%minetest->guix-package author/name #:key (sort %default-sort-key))
  "Fetch the metadata for AUTHOR/NAME from https://content.minetest.net, and
return the 'package' S-expression corresponding to that package, or raise an
exception on failure.  On success, also return the upstream dependencies as a
list of AUTHOR/NAME strings."
  ;; Call 'author/name->name' to verify that AUTHOR/NAME seems reasonable.
  (author/name->name author/name)
  (define package (contentdb-fetch author/name))
  (unless package
    (leave (G_ "no package metadata for ~a on ContentDB~%") author/name))
  (define dependencies (contentdb-fetch-dependencies author/name))
  (unless dependencies
    (leave (G_ "no dependency information for ~a on ContentDB~%") author/name))
  (define release (latest-release author/name))
  (unless release
    (leave (G_ "no release of ~a on ContentDB~%") author/name))
  (define important-upstream-dependencies
    (important-dependencies dependencies author/name #:sort sort))
  (values (make-minetest-sexp author/name
                              (release-title release) ; version
                              (package-repository package)
                              (release-commit release)
                              important-upstream-dependencies
                              (package-home-page package)
                              (package-short-description package)
                              (package-long-description package)
                              (spdx-string->license
                               (package-media-license package))
                              (spdx-string->license
                               (package-license package)))
          important-upstream-dependencies))

(define minetest->guix-package
  (memoize %minetest->guix-package))

(define* (minetest-recursive-import author/name #:key (sort %default-sort-key))
  (define* (minetest->guix-package* author/name #:key repo version)
    (minetest->guix-package author/name #:sort sort))
  (recursive-import author/name
                    #:repo->guix-package minetest->guix-package*
                    #:guix-name contentdb->package-name))


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

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

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

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

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

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

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

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

(define* (get-opam-repository #:optional repo)
  "Update or fetch the latest version of the opam repository and return the
path to the repository."
  (let ((url (cond
               ((or (not repo) (equal? repo 'opam))
                "https://github.com/ocaml/opam-repository")
               ((string-prefix? "coq-" (symbol->string repo))
                "https://github.com/coq/opam-coq-archive")
               ((equal? repo 'coq) "https://github.com/coq/opam-coq-archive")
               (else (throw 'unknown-repository repo)))))
    (receive (location commit _)
      (update-cached-checkout url)
      (cond
        ((or (not repo) (equal? repo 'opam))
         location)
        ((equal? repo 'coq)
         (string-append location "/released"))
        ((string-prefix? "coq-" (symbol->string repo))
         (string-append location "/" (substring (symbol->string repo) 4)))
        (else location)))))

;; Prevent Guile 3 from inlining this procedure so we can mock it in tests.
(set! get-opam-repository get-opam-repository)

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

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

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

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

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

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

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

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

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

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

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

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

(define (filter-dependencies depends)
  "Remove implicit dependencies from the list of dependencies in @var{depends}."
  (filter (lambda (name)
            (and (not (member name '("" "ocaml" "ocamlfind" "dune" "jbuilder")))
                 (not (string-prefix? "base-" name))))
          depends))

(define (depends->inputs depends)
  (filter-dependencies (map dependency->input depends)))

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

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

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

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

(define* (opam-recursive-import package-name #:key repo)
  (recursive-import package-name
                    #:repo->guix-package opam->guix-package
                    #:guix-name ocaml-name->guix-name
                    #:repo repo))

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

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

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

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

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


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

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

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

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

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

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

  (define (source->code source version)
    (let ((uri       (origin-uri source))
          (method    (origin-method source))
          (hash      (origin-hash source))
          (file-name (origin-file-name source))
          (patches   (origin-patches source)))
      `(origin
         ;; Since 'procedure-name' returns the procedure name within the
         ;; module where it's defined, not its public name.  Thus, try hard to
         ;; find its public name and use 'procedure-name' as a last resort.
         (method ,(or (any (lambda (module)
                             (variable-name method module))
                           '((guix download)
                             (guix git-download)
                             (guix hg-download)
                             (guix svn-download)))
                      (procedure-name method)))
         (uri (string-append ,@(match (factorize-uri uri version)
                                 ((? string? uri) (list uri))
                                 (factorized factorized))))
         ,(if (equal? (content-hash-algorithm hash) 'sha256)
              `(sha256 (base32 ,(bytevector->nix-base32-string
                                 (content-hash-value hash))))
              `(hash (content-hash ,(bytevector->nix-base32-string
                                     (content-hash-value hash))
                                   ,(content-hash-algorithm hash))))
         ;; FIXME: in order to be able to throw away the directory prefix,
         ;; we just assume that the patch files can be found with
         ;; "search-patches".
         ,@(if (null? patches) '()
               `((patches (search-patches ,@(map basename patches))))))))

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

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