You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

112 lines
4.3 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (guix import gnome)
  19. #:use-module (guix upstream)
  20. #:use-module (guix utils)
  21. #:use-module (guix packages)
  22. #:use-module (guix http-client)
  23. #:use-module (json)
  24. #:use-module (srfi srfi-1)
  25. #:use-module (srfi srfi-11)
  26. #:use-module (srfi srfi-34)
  27. #:use-module (web uri)
  28. #:use-module (ice-9 match)
  29. #:export (%gnome-updater))
  30. ;;; Commentary:
  31. ;;;
  32. ;;; This package provides not an actual importer but simply an updater for
  33. ;;; GNOME packages. It grabs package meta-data from 'cache.json' files
  34. ;;; available on ftp.gnome.org.
  35. ;;;
  36. ;;; Code:
  37. (define (jsonish->upstream-source name jsonish)
  38. "Return an <upstream-source> object for package NAME, using JSONISH as the
  39. source for metadata."
  40. (match jsonish
  41. ((version . dictionary)
  42. (upstream-source
  43. (package name)
  44. (version version)
  45. (urls (filter-map (lambda (extension)
  46. (match (hash-ref dictionary extension)
  47. (#f
  48. #f)
  49. ((? string? relative-url)
  50. (string-append "mirror://gnome/sources/"
  51. name "/" relative-url))))
  52. '("tar.lz" "tar.xz" "tar.bz2" "tar.gz")))))))
  53. (define (latest-gnome-release package)
  54. "Return the latest release of PACKAGE, a GNOME package, or #f if it could
  55. not be determined."
  56. (define %not-dot
  57. (char-set-complement (char-set #\.)))
  58. (define (even-minor-version? version)
  59. (match (string-tokenize version %not-dot)
  60. (((= string->number major) (= string->number minor) . rest)
  61. (and minor (even? minor)))
  62. (_
  63. #t))) ;cross fingers
  64. (define upstream-name
  65. ;; Some packages like "NetworkManager" have camel-case names.
  66. (package-upstream-name package))
  67. (guard (c ((http-get-error? c)
  68. (if (= 404 (http-get-error-code c))
  69. #f
  70. (raise c))))
  71. (let* ((port (http-fetch/cached
  72. (string->uri (string-append
  73. "https://ftp.gnome.org/pub/gnome/sources/"
  74. upstream-name "/cache.json"))
  75. ;; ftp.gnome.org supports 'if-Modified-Since', so the local
  76. ;; cache can expire early.
  77. #:ttl (* 60 10)))
  78. (json (json->scm port)))
  79. (close-port port)
  80. (match json
  81. ((4 (? hash-table? releases) _ ...)
  82. (let* ((releases (hash-ref releases upstream-name))
  83. (latest (hash-fold (lambda (key value result)
  84. (cond ((even-minor-version? key)
  85. (match result
  86. (#f
  87. (cons key value))
  88. ((newest . _)
  89. (if (version>? key newest)
  90. (cons key value)
  91. result))))
  92. (else
  93. result)))
  94. #f
  95. releases)))
  96. (and latest
  97. (jsonish->upstream-source upstream-name latest))))))))
  98. (define %gnome-updater
  99. (upstream-updater
  100. (name 'gnome)
  101. (description "Updater for GNOME packages")
  102. (pred (url-prefix-predicate "mirror://gnome/"))
  103. (latest latest-gnome-release)))