[bug#37413] [PATCH 4/9] channels: Add support for a news file.

[Ludovic Courtès]

* guix/channels.scm (<channel-metadata>)[news-file]: New field.
(read-channel-metadata): Set the 'news-file' field.
(read-channel-metadata-from-source): Likewise.
(<channel-news>, <channel-news-entry>): New record types.
(sexp->channel-news-entry, read-channel-news)
(channel-news-for-commit): New procedures.
* guix/tests/git.scm (populate-git-repository): For 'add', allow
CONTENTS to be a procedure.
* tests/channels.scm ("channel-news, no news")
("channel-news, one entry"): New tests.
* doc/guix.texi (Channels): Document it.
---
 doc/guix.texi      |  51 +++++++++++++++++++
 guix/channels.scm  | 121 ++++++++++++++++++++++++++++++++++++++++++---
 guix/tests/git.scm |   7 ++-
 tests/channels.scm |  96 +++++++++++++++++++++++++++++++++++
 4 files changed, 266 insertions(+), 9 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 39d4b865f6..c7fe9f3907 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3946,6 +3946,57 @@ add a meta-data file @file{.guix-channel} that contains:
   (directory "guix"))
 @end lisp
 
+@cindex news, for channels
+@subsection Writing Channel News
+
+Channel authors may occasionally want to communicate to their users
+information about important changes in the channel.  You'd send them all
+an email, but that's not convenient.
+
+Instead, channels can provide a @dfn{news file}; when the channel users
+run @command{guix pull}, that news file is automatically read and
+@command{guix pull --news} can display the announcements that correspond
+to the new commits that have been pulled, if any.
+
+To do that, channel authors must first declare the name of the news file
+in their @file{.guix-channel} file:
+
+@lisp
+(channel
+  (version 0)
+  (news-file "etc/news.txt"))
+@end lisp
+
+The news file itself, @file{etc/news.txt} in this example, must look
+something like this:
+
+@lisp
+(channel-news
+  (version 0)
+  (entry (commit "d894ab8e9bfabcefa6c49d9ba2e834dd5a73a300")
+         (title ("en" "Fixed terrible bug")
+                ("fr" "Oh la la"))
+         (body ("en" "@@emph@{Good news@}!  It's fixed!")))
+  (entry (commit "bdcabe815cd28144a2d2b4bc3c5057b051fa9906")
+         (title ("en" "Added a great package")
+                ("ca" "Què vol dir guix?"))
+         (body ("en" "Don't miss the @@code@{hello@} package!"))))
+@end lisp
+
+The file consists of a list of @dfn{news entries}.  Each entry is
+associated with a commit: it describes changes made in this commit,
+possibly in preceding commits as well.  Users see entries only the first
+time they obtain the commit the entry refers to.
+
+The @code{title} field should be a one-line summary while @code{body}
+can be arbitrary long, and both can contain Texinfo markup
+(@pxref{Overview,,, texinfo, GNU Texinfo}).  Both the title and body are
+a list of language tag/message tuples, which allows @command{guix pull}
+to display news in the language that corresponds to the user's locale.
+
+So yes, you could use your channel as a blog.  But beware, this is
+@emph{not quite} what your users might expect.
+
 @subsection Replicating Guix
 
 @cindex pinning, channels
diff --git a/guix/channels.scm b/guix/channels.scm
index ebb2cacbc7..63e3e2f49e 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -19,6 +19,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix channels)
+  #:use-module (git)
   #:use-module (guix git)
   #:use-module (guix records)
   #:use-module (guix gexp)
@@ -29,6 +30,7 @@
   #:use-module (guix derivations)
   #:use-module (guix combinators)
   #:use-module (guix diagnostics)
+  #:use-module (guix sets)
   #:use-module (guix store)
   #:use-module (guix i18n)
   #:use-module ((guix utils)
@@ -67,7 +69,14 @@
             %channel-profile-hooks
             channel-instances->derivation
 
-            profile-channels))
+            profile-channels
+
+            channel-news-entry?
+            channel-news-entry-commit
+            channel-news-entry-title
+            channel-news-entry-body
+
+            channel-news-for-commit))
 
 ;;; Commentary:
 ;;;
@@ -110,10 +119,11 @@
   (checkout  channel-instance-checkout))
 
 (define-record-type <channel-metadata>
-  (channel-metadata directory dependencies)
+  (channel-metadata directory dependencies news-file)
   channel-metadata?
   (directory     channel-metadata-directory)      ;string with leading slash
-  (dependencies  channel-metadata-dependencies))  ;list of <channel>
+  (dependencies  channel-metadata-dependencies)   ;list of <channel>
+  (news-file     channel-metadata-news-file))     ;string | #f
 
 (define (channel-reference channel)
   "Return the \"reference\" for CHANNEL, an sexp suitable for
@@ -129,12 +139,13 @@ if valid metadata could not be read from PORT."
   (match (read port)
     (('channel ('version 0) properties ...)
      (let ((directory    (and=> (assoc-ref properties 'directory) first))
-           (dependencies (or (assoc-ref properties 'dependencies) '())))
+           (dependencies (or (assoc-ref properties 'dependencies) '()))
+           (news-file    (and=> (assoc-ref properties 'news-file) first)))
        (channel-metadata
-        (cond ((not directory) "/")
+        (cond ((not directory) "/")               ;directory
               ((string-prefix? "/" directory) directory)
               (else (string-append "/" directory)))
-        (map (lambda (item)
+        (map (lambda (item)                       ;dependencies
                (let ((get (lambda* (key #:optional default)
                             (or (and=> (assoc-ref item key) first) default))))
                  (and-let* ((name (get 'name))
@@ -145,7 +156,8 @@ if valid metadata could not be read from PORT."
                     (branch branch)
                     (url url)
                     (commit (get 'commit))))))
-             dependencies))))
+             dependencies)
+        news-file)))                              ;news-file
     ((and ('channel ('version version) _ ...) sexp)
      (raise (condition
              (&message (message "unsupported '.guix-channel' version"))
@@ -169,7 +181,7 @@ doesn't exist."
         read-channel-metadata))
     (lambda args
       (if (= ENOENT (system-error-errno args))
-          (channel-metadata "/" '())
+          (channel-metadata "/" '() #f)
           (apply throw args)))))
 
 (define (channel-instance-metadata instance)
@@ -560,3 +572,96 @@ PROFILE is not a profile created by 'guix pull', return 
the empty list."
               ;; Show most recently installed packages last.
               (reverse
                (manifest-entries (profile-manifest profile)))))
+
+
+;;;
+;;; News.
+;;;
+
+;; Channel news.
+(define-record-type <channel-news>
+  (channel-news entries)
+  channel-news?
+  (entries channel-news-entries))                 ;list of <channel-news-entry>
+
+;; News entry, associated with a specific commit of the channel.
+(define-record-type <channel-news-entry>
+  (channel-news-entry commit title body)
+  channel-news-entry?
+  (commit  channel-news-entry-commit)             ;hex string
+  (title   channel-news-entry-title)              ;list of language tag/string 
pairs
+  (body    channel-news-entry-body))              ;list of language tag/string 
pairs
+
+(define (sexp->channel-news-entry entry)
+  "Return the <channel-news-entry> record corresponding to ENTRY, an sexp."
+  (match entry
+    (('entry ('commit commit)
+             ('title (title-tags titles) ...)
+             ('body (body-tags bodies) ...)
+             _ ...)
+     (channel-news-entry commit
+                         (map cons title-tags titles)
+                         (map cons body-tags bodies)))
+    (_
+     (raise (condition
+             (&message (message "invalid channel news entry"))
+             (&error-location
+              (location (source-properties->location
+                         (source-properties entry)))))))))
+
+(define (read-channel-news port)
+  "Read a channel news feed from PORT and return it as a <channel-news>
+record."
+  (match (false-if-exception (read port))
+    (('channel-news ('version 0) entries ...)
+     (channel-news (map sexp->channel-news-entry entries)))
+    ((and ('channel-news ('version version) _ ...) sexp)
+     (raise (condition
+             (&message (message "unsupported channel news file"))
+             (&error-location
+              (location (source-properties->location
+                         (source-properties sexp)))))))
+    (#f
+     (raise (condition
+             (&message (message "syntactically invalid channel news file")))))
+    (sexp
+     (raise (condition
+             (&message (message "invalid channel news file"))
+             (&error-location
+              (location (source-properties->location
+                         (source-properties sexp)))))))))
+
+(define* (channel-news-for-commit channel new #:optional old)
+  "Return a list of <channel-news-entry> for CHANNEL between commits OLD and
+NEW.  When OLD is omitted or is #f, return all the news entries of CHANNEL."
+  (catch 'git-error
+    (lambda ()
+      (let* ((checkout  (update-cached-checkout (channel-url channel)
+                                                #:ref `(commit . ,new)))
+             (metadata  (read-channel-metadata-from-source checkout))
+             (news-file (channel-metadata-news-file metadata))
+             (news-file (and news-file
+                             (string-append checkout "/" news-file))))
+        (if (and news-file (file-exists? news-file))
+            (let ((entries (channel-news-entries (call-with-input-file 
news-file
+                                                   read-channel-news))))
+              (if old
+                  (with-repository checkout repository
+                    (let* ((new     (commit-lookup repository (string->oid 
new)))
+                           (old     (commit-lookup repository (string->oid 
old)))
+                           (commits (list->set
+                                     (map (compose oid->string commit-id)
+                                          (commit-difference new old)))))
+                      (filter (lambda (entry)
+                                (set-contains? commits
+                                               (channel-news-entry-commit 
entry)))
+                              entries)))
+                  entries))
+            '())))
+    (lambda (key error . rest)
+      ;; If commit NEW or commit OLD cannot be found, then something must be
+      ;; wrong (for example, the history of CHANNEL was rewritten and these
+      ;; commits no longer exist upstream), so quietly return the empty list.
+      (if (= GIT_ENOTFOUND (git-error-code error))
+          '()
+          (apply throw key error rest)))))
diff --git a/guix/tests/git.scm b/guix/tests/git.scm
index 52abe77c83..9d5b1ae321 100644
--- a/guix/tests/git.scm
+++ b/guix/tests/git.scm
@@ -18,6 +18,7 @@
 
 (define-module (guix tests git)
   #:use-module (git)
+  #:use-module ((guix git) #:select (with-repository))
   #:use-module (guix utils)
   #:use-module (guix build utils)
   #:use-module (ice-9 match)
@@ -55,7 +56,11 @@ Return DIRECTORY on success."
          (mkdir-p (dirname file))
          (call-with-output-file file
            (lambda (port)
-             (display contents port)))
+             (display (if (string? contents)
+                          contents
+                          (with-repository directory repository
+                            (contents repository)))
+                      port)))
          (git "add" file)
          (loop rest)))
       ((('commit text) rest ...)
diff --git a/tests/channels.scm b/tests/channels.scm
index e83b5437d3..686bd3acee 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -28,6 +28,10 @@
   #:use-module (guix gexp)
   #:use-module ((guix utils)
                 #:select (error-location? error-location location-line))
+  #:use-module ((guix build utils) #:select (which))
+  #:use-module (git)
+  #:use-module (guix git)
+  #:use-module (guix tests git)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -246,4 +250,96 @@
                (depends? drv3
                          (list drv2 drv0) (list))))))))
 
+(unless (which (git-command)) (test-skip 1))
+(test-equal "channel-news, no news"
+  '()
+  (with-temporary-git-repository directory
+      '((add "a.txt" "A")
+        (commit "the commit"))
+    (with-repository directory repository
+      (let ((channel (channel (url (string-append "file://" directory))
+                              (name 'foo)))
+            (latest  (reference-name->oid repository "HEAD")))
+        (channel-news-for-commit channel (oid->string latest))))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-assert "channel-news, one entry"
+  (with-temporary-git-repository directory
+      `((add ".guix-channel"
+             ,(object->string
+               '(channel (version 0)
+                         (news-file "news.scm"))))
+        (commit "first commit")
+        (add "src/a.txt" "A")
+        (commit "second commit")
+        (add "news.scm"
+             ,(lambda (repository)
+                (let ((previous
+                       (reference-name->oid repository "HEAD")))
+                  (object->string
+                   `(channel-news
+                     (version 0)
+                     (entry (commit ,(oid->string previous))
+                            (title ("en" "New file!"))
+                            (body ("en" "Yeah, a.txt."))))))))
+        (commit "third commit")
+        (add "src/b.txt" "B")
+        (commit "fourth commit")
+        (add "news.scm"
+             ,(lambda (repository)
+                (let ((second
+                       (commit-id
+                        (find-commit repository "second commit")))
+                      (previous
+                       (reference-name->oid repository "HEAD")))
+                  (object->string
+                   `(channel-news
+                     (version 0)
+                     (entry (commit ,(oid->string previous))
+                            (title ("en" "Another file!"))
+                            (body ("en" "Yeah, b.txt.")))
+                     (entry (commit ,(oid->string second))
+                            (title ("en" "Old news."))
+                            (body ("en" "For a.txt"))))))))
+        (commit "fifth commit"))
+    (with-repository directory repository
+      (define (find-commit* message)
+        (oid->string (commit-id (find-commit repository message))))
+
+      (let ((channel (channel (url (string-append "file://" directory))
+                              (name 'foo)))
+            (commit1 (find-commit* "first commit"))
+            (commit2 (find-commit* "second commit"))
+            (commit3 (find-commit* "third commit"))
+            (commit4 (find-commit* "fourth commit"))
+            (commit5 (find-commit* "fifth commit")))
+        ;; First try fetching all the news up to a given commit.
+        (and (null? (channel-news-for-commit channel commit2))
+             (lset= string=?
+                    (map channel-news-entry-commit
+                         (channel-news-for-commit channel commit5))
+                    (list commit2 commit4))
+             (lset= equal?
+                    (map channel-news-entry-title
+                         (channel-news-for-commit channel commit5))
+                    '((("en" . "Another file!")) (("en" . "Old news."))))
+             (lset= string=?
+                    (map channel-news-entry-commit
+                         (channel-news-for-commit channel commit3))
+                    (list commit2))
+
+             ;; Now fetch news entries that apply to a commit range.
+             (lset= string=?
+                    (map channel-news-entry-commit
+                         (channel-news-for-commit channel commit3 commit1))
+                    (list commit2))
+             (lset= string=?
+                    (map channel-news-entry-commit
+                         (channel-news-for-commit channel commit5 commit3))
+                    (list commit4))
+             (lset= string=?
+                    (map channel-news-entry-commit
+                         (channel-news-for-commit channel commit5 commit1))
+                    (list commit4 commit2)))))))
+
 (test-end "channels")
-- 
2.23.0