guix-gnunet/guix/import/contentdb.scm

;;; 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 contentdb)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #: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 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)
  #:use-module ((guix licenses) #:prefix license:)
  #:export (%contentdb-api
            contentdb->guix-package
            contentdb-recursive-import))

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

;; 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) ; natural | #f
  (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) ; string | #f
  (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)) ; string | #f

(define-json-mapping <release> make-release release?
  json->release
  (commit               release-commit "commit" string-or-false) ; string | #f
  (downloads            release-downloads) ; integer
  (id                   release-id) ; integer
  (max-minetest-version release-max-minetest-version) ; string | #f
  (min-minetest-version release-min-minetest-version) ; string | #f
  (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") ; #t | #f
  (name dependency-name) ; string
  (packages dependency-packages "packages" vector->list)) ; list of strings

(define (contentdb-fetch author name)
  "Return a <package> record for package NAME by AUTHOR, 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->package-name name)
  "Given the 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 name)))

;; 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 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 likewise.
(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 (make-minetest-sexp name version repository commit
                            inputs home-page synopsis
                            description media-license license)
  "Return a S-expression for the minetest package with the given NAME,
VERSION, REPOSITORY, COMMIT, INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
MEDIA-LICENSE and LICENSE."
  `(package
     (name ,(contentdb->package-name name))
     (version ,version)
     (source
       (origin
         (method git-fetch)
         (uri (git-reference
                (url ,repository)
                (commit ,commit)))
         (sha256
          (base32
           ;; The commit id is not always available.
           ,(and commit
                 (bytevector->nix-base32-string
                  (file-hash
                   (download-git-repository repository `(commit . ,commit))
                   (negate vcs-file?) #t)))))
         (file-name (git-file-name name version))))
     (build-system minetest-mod-build-system)
     ,@(maybe-propagated-inputs
        (map (compose contentdb->package-name cdr) inputs))
     (home-page ,home-page)
     (synopsis ,(delete-cr synopsis))
     (description ,(delete-cr description))
     (license ,(if (eq? media-license license)
                   (license->symbol license)
                   `(list ,(license->symbol media-license)
                          ,(license->symbol license))))))

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

(define (important-dependencies dependencies author name)
  (define dependency-list
    (assoc-ref dependencies (string-append author "/" name)))
  (filter-map
   (lambda (dependency)
     (and (not (dependency-optional? dependency))
          ;; "default" must be provided by the 'subgame' in use
          ;; and does not refer to a specific minetest mod.
          ;; "doors", "bucket" ... are provided by the default minetest
          ;; subgame.
          (not (member (dependency-name dependency)
                       '("default" "doors" "beds" "bucket" "doors" "farming"
                         "flowers" "stairs" "xpanes")))
          ;; Dependencies often have only one implementation.
          (let* ((/name (string-append "/" (dependency-name dependency)))
                 (likewise-named-implementations
                  (filter (cut string-suffix? /name <>)
                          (dependency-packages dependency)))
                 (implementation
                  (and (not (null? likewise-named-implementations))
                       (first likewise-named-implementations))))
            (and implementation
                 (apply cons (string-split implementation #\/))))))
   dependency-list))

(define* (%contentdb->guix-package author name)
  "Fetch the metadata for NAME by AUTHOR from https://content.minetest.net, and
return the 'package' S-expression corresponding to that package, or #f on failure.
On success, also return the upstream dependencies as a list of
(AUTHOR . NAME) pairs."
  (and-let* ((package (contentdb-fetch author name))
             (dependencies (contentdb-fetch-dependencies author name))
             (release (latest-release author name)))
    (let ((important-upstream-dependencies
           (important-dependencies dependencies author name)))
      (values (make-minetest-sexp 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)
                                  (string->license
                                   (package-media-license package))
                                  (string->license
                                   (package-license package)))
              important-upstream-dependencies))))

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

(define (contentdb-recursive-import author name)
  ;; recursive-import expects upstream package names to be strings,
  ;; so do some conversions.
  (define (split-author/name author/name)
    (string-split author/name #\/))
  (define (author+name->author/name author+name)
    (string-append (car author+name) "/" (cdr author+name)))
  (define* (contentdb->guix-package* author/name #:key repo version)
    (receive (package . maybe-dependencies)
        (apply contentdb->guix-package (split-author/name author/name))
      (and package
           (receive (dependencies)
               (apply values maybe-dependencies)
             (values package
                     (map author+name->author/name dependencies))))))
  (recursive-import (author+name->author/name (cons author name))
                    #:repo->guix-package contentdb->guix-package*
                    #:guix-name
                    (lambda (author/name)
                      (contentdb->package-name
                       (second (split-author/name author/name))))))

;; A list of license names is available at
;; <https://content.minetest.net/api/licenses/>.
(define (string->license str)
  "Convert the string STR into a license object."
  (match str
    ("GPLv3"        license:gpl3)
    ("GPLv2"        license:gpl2)
    ("ISC"          license:isc)
    ;; "MIT" means the Expat license on ContentDB,
    ;; see <https://github.com/minetest/contentdb/issues/326#issuecomment-890143784>.
    ("MIT"          license:expat)
    ("CC BY-SA 3.0" license:cc-by-sa3.0)
    ("CC BY-SA 4.0" license:cc-by-sa4.0)
    ("LGPLv2.1"     license:lgpl2.1)
    ("LGPLv3"       license:lgpl3)
    ("MPL 2.0"      license:mpl2.0)
    ("ZLib"         license:zlib)
    ("Unlicense"    license:unlicense)
    (_ #f)))