guix/import/elpa.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
   3 ;;; Copyright © 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix import elpa)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 rdelim)
  24   #:use-module (web uri)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-9)
  27   #:use-module (srfi srfi-9 gnu)
  28   #:use-module (srfi srfi-11)
  29   #:use-module (srfi srfi-26)
  30   #:use-module ((guix download) #:select (download-to-store))
  31   #:use-module (guix import utils)
  32   #:use-module (guix http-client)
  33   #:use-module (guix store)
  34   #:use-module (guix ui)
  35   #:use-module (gcrypt hash)
  36   #:use-module (guix base32)
  37   #:use-module (guix upstream)
  38   #:use-module (guix packages)
  39   #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  40   #:export (elpa->guix-package
  41             %elpa-updater
  42             elpa-recursive-import))
  43
  44 (define (elpa-dependencies->names deps)
  45   "Convert DEPS, a list of symbol/version pairs à la ELPA, to a list of
  46 package names as strings"
  47   (match deps
  48     (((names _ ...) ...)
  49      (map symbol->string names))))
  50
  51 (define emacs-standard-library?
  52   (let ((libs '("emacs" "cl-lib")))
  53     (lambda (lib)
  54       "Return true if LIB is part of Emacs itself.  The check is not
  55 exhaustive and only attempts to recognize a subset of packages which in the
  56 past were distributed separately from Emacs."
  57       (member lib libs))))
  58
  59 (define (filter-dependencies names)
  60   "Remove the package names included with Emacs from the list of
  61 NAMES (strings)."
  62   (remove emacs-standard-library? names))
  63
  64 (define (elpa-name->package-name name)
  65   "Given the NAME of an Emacs package, return the corresponding Guix name."
  66   (let ((package-name-prefix "emacs-"))
  67     (if (string-prefix? package-name-prefix name)
  68         (string-downcase name)
  69         (string-append package-name-prefix (string-downcase name)))))
  70
  71 (define* (elpa-url #:optional (repo 'gnu))
  72   "Retrieve the URL of REPO."
  73   (let ((elpa-archives
  74          '((gnu . "https://elpa.gnu.org/packages")
  75            (gnu/http . "http://elpa.gnu.org/packages") ;for testing
  76            (melpa-stable . "https://stable.melpa.org/packages")
  77            (melpa . "https://melpa.org/packages"))))
  78     (assq-ref elpa-archives repo)))
  79
  80 (define* (elpa-fetch-archive #:optional (repo 'gnu))
  81   "Retrieve the archive with the list of packages available from REPO."
  82   (let ((url (and=> (elpa-url repo)
  83                     (cut string-append <> "/archive-contents"))))
  84     (if url
  85         ;; Use a relatively small TTL for the archive itself.
  86         (let* ((port (http-fetch/cached (string->uri url)
  87                                         #:ttl (* 6 3600)))
  88                (data (read port)))
  89           (close-port port)
  90           data)
  91         (leave (G_ "~A: currently not supported~%") repo))))
  92
  93 (define* (call-with-downloaded-file url proc #:optional (error-thunk #f))
  94   "Fetch URL, store the content in a temporary file and call PROC with that
  95 file.  Returns the value returned by PROC.  On error call ERROR-THUNK and
  96 return its value or leave if it's false."
  97   (catch #t
  98     (lambda ()
  99       (proc (http-fetch/cached (string->uri url))))
 100     (lambda (key . args)
 101       (if error-thunk
 102           (error-thunk)
 103           (leave (G_ "~A: download failed~%") url)))))
 104
 105 (define (is-elpa-package? name elpa-pkg-spec)
 106   "Return true if the string NAME corresponds to the name of the package
 107 defined by ELPA-PKG-SPEC, a package specification as in an archive
 108 'archive-contents' file."
 109   (eq? (first elpa-pkg-spec) (string->symbol name)))
 110
 111 (define* (elpa-package-info name #:optional (repo 'gnu))
 112   "Extract the information about the package NAME from the package archieve of
 113 REPO."
 114   (let* ((archive (elpa-fetch-archive repo))
 115          (pkgs (match archive ((version pkg-spec ...) pkg-spec)))
 116          (info (filter (cut is-elpa-package? name <>) pkgs)))
 117     (if (pair? info) (first info) #f)))
 118
 119 ;; Object to store information about an ELPA package.
 120 (define-record-type <elpa-package>
 121   (make-elpa-package name version inputs synopsis kind home-page description
 122                      source-url)
 123   elpa-package?
 124   (name elpa-package-name)
 125   (version elpa-package-version)
 126   (inputs elpa-package-inputs)
 127   (synopsis elpa-package-synopsis)
 128   (kind elpa-package-kind)
 129   (home-page elpa-package-home-page)
 130   (description elpa-package-description)
 131   (source-url elpa-package-source-url))
 132
 133 (set-record-type-printer! <elpa-package>
 134                           (lambda (package port)
 135                             (format port "#<elpa-package ~a@~a>"
 136                                       (elpa-package-name package)
 137                                       (elpa-package-version package))))
 138
 139 (define (elpa-version->string elpa-version)
 140   "Convert the package version as used in Emacs package files into a string."
 141   (if (pair? elpa-version)
 142       (let-values (((ms rest) (match elpa-version
 143                                 ((ms . rest)
 144                                  (values ms rest)))))
 145         (fold (lambda (n s) (string-append s "." (number->string n)))
 146               (number->string ms) rest))
 147       #f))
 148
 149 (define (package-home-page alist)
 150   "Extract the package home-page from ALIST."
 151   (or (assq-ref alist ':url) "unspecified"))
 152
 153 (define (ensure-list alist)
 154   "If ALIST is the symbol 'nil return the empty list.  Otherwise, return ALIST."
 155   (if (eq? alist 'nil)
 156       '()
 157       alist))
 158
 159 (define (package-source-url kind name version repo)
 160   "Return the source URL of the package described the the strings NAME and
 161 VERSION at REPO.  KIND is either the symbol 'single or 'tar."
 162   (case kind
 163     ((single) (full-url repo name ".el" version))
 164     ((tar) (full-url repo name ".tar" version))
 165     (else
 166      #f)))
 167
 168 (define* (full-url repo name suffix #:optional (version #f))
 169   "Return the full URL of the package NAME at REPO and the SUFFIX.  Maybe
 170 include VERSION."
 171   (if version
 172       (string-append (elpa-url repo) "/" name "-" version suffix)
 173       (string-append (elpa-url repo) "/" name suffix)))
 174
 175 (define (fetch-package-description kind name repo)
 176   "Fetch the description of package NAME of type KIND from REPO."
 177   (let ((url (full-url repo name "-readme.txt"))
 178         (error-thunk (lambda () "No description available.")))
 179     (call-with-downloaded-file url read-string error-thunk)))
 180
 181 (define* (fetch-elpa-package name #:optional (repo 'gnu))
 182   "Fetch package NAME from REPO."
 183   (let ((pkg (elpa-package-info name repo)))
 184     (match pkg
 185       ((name version reqs synopsis kind . rest)
 186        (let* ((name (symbol->string name))
 187              (ver (elpa-version->string version))
 188              (url (package-source-url kind name ver repo)))
 189          (make-elpa-package name ver
 190                             (ensure-list reqs) synopsis kind
 191                             (package-home-page (match rest
 192                                                  (() #f)
 193                                                  ((one) one)))
 194                             (fetch-package-description kind name repo)
 195                             url)))
 196       (_ #f))))
 197
 198 (define* (elpa-package->sexp pkg #:optional license)
 199   "Return the `package' S-expression for the Emacs package PKG, a record of
 200 type '<elpa-package>'."
 201
 202   (define name (elpa-package-name pkg))
 203
 204   (define version (elpa-package-version pkg))
 205
 206   (define source-url (elpa-package-source-url pkg))
 207
 208   (define dependencies-names
 209     (filter-dependencies (elpa-dependencies->names
 210                           (elpa-package-inputs pkg))))
 211
 212   (define dependencies
 213     (map (lambda (n)
 214            (let ((new-n (elpa-name->package-name n)))
 215              (list new-n (list 'unquote (string->symbol new-n)))))
 216          dependencies-names))
 217
 218   (define (maybe-inputs input-type inputs)
 219     (match inputs
 220       (()
 221        '())
 222       ((inputs ...)
 223        (list (list input-type
 224                    (list 'quasiquote inputs))))))
 225
 226   (let ((tarball (with-store store
 227                    (download-to-store store source-url))))
 228     (values
 229      `(package
 230         (name ,(elpa-name->package-name name))
 231         (version ,version)
 232         (source (origin
 233                   (method url-fetch)
 234                   (uri (string-append ,@(factorize-uri source-url version)))
 235                   (sha256
 236                    (base32
 237                     ,(if tarball
 238                          (bytevector->nix-base32-string (file-sha256 tarball))
 239                          "failed to download package")))))
 240         (build-system emacs-build-system)
 241         ,@(maybe-inputs 'propagated-inputs dependencies)
 242         (home-page ,(elpa-package-home-page pkg))
 243         (synopsis ,(elpa-package-synopsis pkg))
 244         (description ,(elpa-package-description pkg))
 245         (license ,license))
 246      dependencies-names)))
 247
 248 (define* (elpa->guix-package name #:optional (repo 'gnu))
 249   "Fetch the package NAME from REPO and produce a Guix package S-expression."
 250   (match (fetch-elpa-package name repo)
 251     (#f #f)
 252     (package
 253       ;; ELPA is known to contain only GPLv3+ code.  Other repos may contain
 254       ;; code under other license but there's no license metadata.
 255       (let ((license (and (memq repo '(gnu gnu/http)) 'license:gpl3+)))
 256         (elpa-package->sexp package license)))))
 257
 258 \f
 259 ;;;
 260 ;;; Updates.
 261 ;;;
 262
 263 (define (latest-release package)
 264   "Return an <upstream-release> for the latest release of PACKAGE."
 265   (define name
 266     (if (string-prefix? "emacs-" (package-name package))
 267         (string-drop (package-name package) 6)
 268         (package-name package)))
 269
 270   (let* ((repo    'gnu)
 271          (info    (elpa-package-info name repo))
 272          (version (match info
 273                     ((name raw-version . _)
 274                      (elpa-version->string raw-version))))
 275          (url     (match info
 276                     ((_ raw-version reqs synopsis kind . rest)
 277                      (package-source-url kind name version repo)))))
 278     (upstream-source
 279      (package (package-name package))
 280      (version version)
 281      (urls (list url))
 282      (signature-urls (list (string-append url ".sig"))))))
 283
 284 (define package-from-gnu.org?
 285   (url-predicate (lambda (url)
 286                    (let ((uri (string->uri url)))
 287                      (and uri
 288                           (string=? (uri-host uri) "elpa.gnu.org"))))))
 289
 290 (define %elpa-updater
 291   ;; The ELPA updater.  We restrict it to packages hosted on elpa.gnu.org
 292   ;; because for other repositories, we typically grab the source elsewhere.
 293   (upstream-updater
 294    (name 'elpa)
 295    (description "Updater for ELPA packages")
 296    (pred package-from-gnu.org?)
 297    (latest latest-release)))
 298
 299 (define elpa-guix-name (cut guix-name "emacs-" <>))
 300
 301 (define* (elpa-recursive-import package-name #:optional (repo 'gnu))
 302   (recursive-import package-name repo
 303                     #:repo->guix-package elpa->guix-package
 304                     #:guix-name elpa-guix-name))
 305
 306 ;;; elpa.scm ends here