build-aux/check-channel-news.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2020 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
  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'
  36 channel."
  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
  54 existent 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))))