projects/guix·blob master · refs

82 lines · 3.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2020 Ludovic Courtès <[email protected]>
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
19;;;
20;;; Validate 'etc/news.scm'.
21;;;
22
23(use-modules (git)
24 (guix git)
25 (guix ui)
26 (guix channels)
27 (srfi srfi-26)
28 (ice-9 match))
29
30;; XXX: These two things are currently private.
31(define read-channel-news (@@ (guix channels) read-channel-news))
32(define channel-news-entries (cut struct-ref <> 0))
33
34(define (all-the-news directory)
35 "Return the <channel-news> read from DIRECTORY, a checkout of the 'guix'
36channel."
37 (call-with-input-file (string-append directory "/etc/news.scm")
38 read-channel-news))
39
40(define (validate-texinfo str type language)
41 "Parse STR as a Texinfo fragment and raise an error if that fails."
42 (catch #t
43 (lambda ()
44 (texi->plain-text str))
45 (lambda (key . args)
46 (print-exception (current-error-port) #f key args)
47 (report-error (G_ "the Texinfo snippet below is invalid (~a, ~a):~%")
48 type language)
49 (display str (current-error-port))
50 (exit 1))))
51
52(define (validate-news-entry repository entry)
53 "Validate ENTRY, a <channel-news-entry>, making sure it refers to an
54existent commit of REPOSITORY and contains only valid Texinfo."
55 (catch 'git-error
56 (lambda ()
57 (let ((commit (commit-lookup repository
58 (string->oid
59 (channel-news-entry-commit entry)))))
60 (for-each (match-lambda
61 ((language . title)
62 (validate-texinfo title 'title language)))
63 (channel-news-entry-title entry))
64 (for-each (match-lambda
65 ((language . body)
66 (validate-texinfo body 'body language)))
67 (channel-news-entry-body entry))))
68 (lambda (key error . rest)
69 (if (= GIT_ENOTFOUND (git-error-code error))
70 (leave (G_ "commit '~a' of entry '~a' does not exist~%")
71 (channel-news-entry-commit entry)
72 (channel-news-entry-title entry))
73 (apply throw key error rest)))))
74
75(let* ((this-directory (dirname (current-filename)))
76 (top-directory (string-append this-directory "/.."))
77 (entries (channel-news-entries (all-the-news top-directory))))
78 (with-repository top-directory repository
79 (for-each (cut validate-news-entry repository <>)
80 entries)
81 (info (G_ "All ~a channel news entries are valid.~%")
82 (length entries))))