summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-05-13 09:13:49 +0200
committerLudovic Courtès <ludo@gnu.org>2015-05-13 09:13:49 +0200
commit8bbccb95f84ae21c8d97a22bb5a2d3ef3059cdfd (patch)
tree7222621a954147f2d3f192e3177051c3e091b12b
parent0e0a5a9a0c9488e47900bb4be1f1d79672c0a3bc (diff)
downloadguix-artwork-8bbccb95f84ae21c8d97a22bb5a2d3ef3059cdfd.tar
guix-artwork-8bbccb95f84ae21c8d97a22bb5a2d3ef3059cdfd.tar.gz
website: Download news entries from the Atom feed.
* website/www.scm (%atom-url): New variable. (fetch-news): New procedure. (<news-entry>): New record type. (news-items, sxml->string*, summarize-string, news-entry->sxml): New procedures. (main-page): Use 'news-items' and 'news-entry->sxml' instead of hard-coded news entries.
-rw-r--r--website/www.scm124
1 files changed, 97 insertions, 27 deletions
diff --git a/website/www.scm b/website/www.scm
index 95cd7bf..50bb4a2 100644
--- a/website/www.scm
+++ b/website/www.scm
@@ -8,6 +8,12 @@
#:use-module (www contribute)
#:use-module (www help)
#:use-module (sxml simple)
+ #:use-module (sxml match)
+ #:use-module (web client)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (main-page
@@ -15,6 +21,90 @@
export-web-page
export-web-site))
+(define %atom-url
+ ;; The web site's news feed.
+ "http://savannah.gnu.org/news/atom.php?group=guix")
+
+(define (fetch-news)
+ "Return the SXML tree of the Atom news feed."
+ (call-with-values
+ (lambda ()
+ (http-get %atom-url))
+ (lambda (response contents)
+ (call-with-input-string contents
+ (lambda (port)
+ (xml->sxml port
+ #:namespaces '((atom . "http://www.w3.org/2005/Atom")
+ (x . "http://www.w3.org/1999/xhtml"))
+ #:trim-whitespace? #t))))))
+
+(define-record-type <news-entry>
+ (news-entry url title date author content)
+ news-entry?
+ (url news-entry-url) ;string
+ (title news-entry-title) ;string
+ (date news-entry-date) ;SRFI-19 date
+ (author news-entry-author) ;sxml
+ (content news-entry-content)) ;sxml
+
+(define (news-items)
+ "Return the list of <news-entry> taken from the web site's RSS feed."
+ (sxml-match (fetch-news)
+ ((*TOP* (*PI* ,pi ...)
+ (atom:feed
+ (atom:id ,feed-id)
+ (atom:link)
+ (atom:title ,feed-title)
+ (atom:updated ,feed-updated)
+ (atom:entry
+ (atom:id ,id)
+ (atom:link (@ (href ,link)))
+ (atom:title ,title)
+ (atom:updated ,updated)
+ (atom:author ,author)
+ (atom:content ,content)
+ ,rest ...)
+ ...
+ ))
+ (map news-entry
+ link title
+ (map (cut string->date <> "~Y-~m-~d") updated)
+ author content))))
+
+(define (sxml->string* tree)
+ "Flatten tree by dismissing tags and attributes, and return the resulting
+string."
+ (define (sxml->strings tree)
+ (match tree
+ (((? symbol?) ('@ _ ...) body ...)
+ (append-map sxml->strings body))
+ (((? symbol?) body ...)
+ (append-map sxml->strings body))
+ ((? string?)
+ (list tree))))
+
+ (string-concatenate (sxml->strings tree)))
+
+(define (summarize-string str n)
+ "Truncate STR at the first space encountered starting from the Nth
+character."
+ (if (<= (string-length str) n)
+ str
+ (let ((space (string-index str #\space n)))
+ (string-take str (or space n)))))
+
+(define (news-entry->sxml entry)
+ "Return the an SXML tree representing ENTRY, a <news-entry>."
+ `(a (@ (href ,(news-entry-url entry))
+ (class "news-entry"))
+ (h4 ,(news-entry-title entry))
+ (p (@ (class "news-date"))
+ ,(date->string (news-entry-date entry) "~B ~e, ~Y"))
+ (p (@ (class "news-summary"))
+ ,(summarize-string (sxml->string* (news-entry-content entry))
+ 230)
+ "…")))
+
(define (main-page)
`(html (@ (lang "en"))
,(html-page-header "Home" #:css "index.css")
@@ -128,38 +218,14 @@ packaging API. ")
(p (a (@ (href ,(base-url "contribute") )
(class "hlink-yellow-boxed"))
"Help us package more software →")))
+
(div (@ (id "news-box"))
(h2 "News")
- (a (@ (href "http://www.fsf.org/news/fsf-adds-guix-system-distribution-to-list-of-endorsed-distributions")
- (class "news-entry"))
- (h4 "FSF adds Guix System Distribution to list of
-endorsed distributions")
- (p (@ (class "news-date")) "February 3, 2015")
- (p (@ (class "news-summary"))
- "The Guix System Distribution is a new and growing
-distro that currently ships with just over 1000 packages, already including
-almost all of the programs available from the GNU Project..."))
- (a (@ (href "https://savannah.gnu.org/forum/forum.php?forum_id=8193")
- (class "news-entry"))
- (h4 "GNU Guix 0.8.1 Released")
- (p (@ (class "news-date")) "January 29, 2015")
- (p (@ (class "news-summary"))
- "We are pleased to announce the next alpha release of
-GNU Guix, version 0.8.1. The release comes both with a source tarball, which
-allows you to install it on top of a running GNU/Linux system, and a USB
-installation image to install the standalone Guix System..."))
- (a (@ (href "https://savannah.gnu.org/forum/forum.php?forum_id=8191")
- (class "news-entry"))
- (h4 "GNU Guix at FOSDEM")
- (p (@ (class "news-date")) "January 27, 2015")
- (p (@ (class "news-summary"))
- "Guix will be present at FOSDEM in Brussels, Belgium,
-with a talk entitled \"The Emacs of Distros\" this Saturday, at 3PM, in room
-H.1302. The talk will give an update on developments in Guix and the Guix System
-Distribution since last year..."))
+ ,@(map news-entry->sxml (take (news-items) 3))
(p (a (@ (href "https://savannah.gnu.org/news/?group=guix")
(class "hlink-more-dark"))
"More news")))
+
(div (@ (id "contact-box"))
(h2 "Contact")
(div (@ (class "info-box text-justify"))
@@ -267,3 +333,7 @@ the broader GNU system.")
file-name-separator-string
filename))))
%web-pages))
+
+;; Local Variables:
+;; eval: (put 'sxml-match 'scheme-indent-function 1)
+;; End: