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