1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
| | ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 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 gnome)
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (guix http-client)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (web uri)
#:use-module (ice-9 match)
#:export (%gnome-updater))
;;; Commentary:
;;;
;;; This package provides not an actual importer but simply an updater for
;;; GNOME packages. It grabs package meta-data from 'cache.json' files
;;; available on ftp.gnome.org.
;;;
;;; Code:
(define (jsonish->upstream-source name jsonish)
"Return an <upstream-source> object for package NAME, using JSONISH as the
source for metadata."
(match jsonish
((version . dictionary)
(upstream-source
(package name)
(version version)
(urls (filter-map (lambda (extension)
(match (assoc-ref dictionary extension)
(#f
#f)
((? string? relative-url)
(string-append "mirror://gnome/sources/"
name "/" relative-url))))
'("tar.lz" "tar.xz" "tar.bz2" "tar.gz")))))))
(define* (import-gnome-release package #:key (version #f))
"Return the latest release of PACKAGE, a GNOME package, or #f if it could
not be determined."
(define %not-dot
(char-set-complement (char-set #\.)))
(define (even-minor-version? version)
(match (string-tokenize version %not-dot)
(((= string->number major) (= string->number minor) . rest)
(and minor (even? minor)))
(((= string->number major) . _)
;; It should at last start with a digit.
major)))
(define upstream-name
;; Some packages like "NetworkManager" have camel-case names.
(package-upstream-name package))
(define (find-latest-release releases)
(fold (match-lambda*
(((key . value) result)
(cond ((even-minor-version? key)
(match result
(#f
(cons key value))
((newest . _)
(if (version>? key newest)
(cons key value)
result))))
(else
result))))
#f
releases))
(define (find-version-release releases version)
(fold (match-lambda*
(((key . value) result)
(if (string=? key version)
(cons key value)
result)))
#f
releases))
(guard (c ((http-get-error? c)
(if (= 404 (http-get-error-code c))
#f
(raise c))))
(let* ((port (http-fetch/cached
(string->uri (string-append
"https://ftp.gnome.org/pub/gnome/sources/"
upstream-name "/cache.json"))
;; ftp.gnome.org supports 'if-Modified-Since', so the local
;; cache can expire early.
#:ttl (* 60 10)
;; Hide messages about URL redirects.
#:log-port (%make-void-port "w")))
(json (json->scm port)))
(close-port port)
(match json
(#(4 releases _ ...)
(let* ((releases (assoc-ref releases upstream-name))
(latest (if version
(find-version-release releases version)
(find-latest-release releases))))
(and latest
(jsonish->upstream-source upstream-name latest))))))))
(define %gnome-updater
(upstream-updater
(name 'gnome)
(description "Updater for GNOME packages")
(pred (url-prefix-predicate "mirror://gnome/"))
(import import-gnome-release)))
|