[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
05/05: website: main-page: Show posts provided by Haunt.
|
From: |
Ludovic Courtès |
|
Subject: |
05/05: website: main-page: Show posts provided by Haunt. |
|
Date: |
Wed, 26 Oct 2016 22:26:09 +0000 (UTC) |
civodul pushed a commit to branch wip-haunt
in repository guix-artwork.
commit 864ff90859459615872d3d3b5e1574ac08c3839a
Author: Ludovic Courtès <address@hidden>
Date: Wed Oct 26 22:51:05 2016 +0200
website: main-page: Show posts provided by Haunt.
* website/www.scm (%atom-url, fetch-news, <news-entry>)
(news-items, news-entry->sxml): Remove.
(post->summary-sxml): New procedure.
(main-page): Add 'site' and 'posts' parameters. Use them to create the
"news-box".
* website/haunt.scm <site>: Add separate builder for guix.html.
---
website/haunt.scm | 19 ++++++++----
website/www.scm | 84 ++++++++++++-----------------------------------------
2 files changed, 31 insertions(+), 72 deletions(-)
diff --git a/website/haunt.scm b/website/haunt.scm
index 7e694d2..761d488 100644
--- a/website/haunt.scm
+++ b/website/haunt.scm
@@ -28,6 +28,7 @@
(haunt builder blog)
(haunt builder atom)
(ice-9 match)
+ (srfi srfi-1)
(www)
(www utils)
(www news))
@@ -71,12 +72,18 @@
(email . "address@hidden"))
#:readers (list sxml-reader)
#:builders
- `(,@(map (match-lambda
- ((file-name contents)
- (lambda (site posts)
- (with-url-parameters
- (make-page file-name (contents) sxml->html)))))
- %web-pages)
+ `(,(lambda (site posts) ;the main page
+ (with-url-parameters
+ (make-page "guix.html" (main-page site posts)
+ sxml->html)))
+ ,@(filter-map (match-lambda
+ (("guix.html" _) ;handled above
+ #f)
+ ((file-name contents)
+ (lambda (site posts)
+ (with-url-parameters
+ (make-page file-name (contents) sxml->html)))))
+ %web-pages)
,(blog #:theme (parameterized-theme %news-haunt-theme)
#:prefix "news")
,(atom-feed #:file-name "news/feed.xml"
diff --git a/website/www.scm b/website/www.scm
index 01e6a93..459629f 100644
--- a/website/www.scm
+++ b/website/www.scm
@@ -22,16 +22,15 @@
(define-module (www)
#:use-module (www utils)
#:use-module (www shared)
- #:use-module (www packages)
#:use-module (www download)
#:use-module (www donate)
#:use-module (www about)
#:use-module (www contribute)
#:use-module (www help)
#:use-module (www security)
+ #:use-module (www news)
+ #:use-module (haunt post)
#: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)
@@ -43,56 +42,6 @@
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";)
- (xhtml . "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 (atom:name ,author))
- (atom:content ,content)
- ,rest ...)
- ...
- ))
- (map news-entry
- link title
- (map (cut string->date <> "~Y-~m-~d") updated)
- author content))))
-
(define %video-url
;; Note: No "http:" so that people viewing the parent page via HTTPS get
;; the video via HTTPS as well (otherwise some browsers complain.)
@@ -120,15 +69,16 @@ character."
(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))
+(define (post->summary-sxml post url)
+ "Return the an SXML tree representing POST, a Haunt blog post, with a link
+to URL."
+ `(a (@ (href ,url)
(class "news-entry"))
- (h4 ,(news-entry-title entry))
+ (h4 ,(post-ref post 'title))
(p (@ (class "news-date"))
- ,(date->string (news-entry-date entry) "~B ~e, ~Y"))
+ ,(date->string (post-date post) "~B ~e, ~Y"))
(p (@ (class "news-summary"))
- ,(summarize-string (sxml->string* (news-entry-content entry))
+ ,(summarize-string (sxml->string* (post-sxml post))
170)
"…")))
@@ -141,7 +91,9 @@ character."
(class "screenshot-thumb")
(alt ,alt)))))
-(define (main-page)
+(define* (main-page #:optional site (posts '()))
+ "Produce the main page showing a subset of POSTS, a list of Haunt blog
+posts."
`(html (@ (lang "en"))
,(html-page-header
"GNU's advanced distro and transactional package manager"
@@ -260,8 +212,12 @@ packaging API. ")
(div (@ (id "news-box"))
(h2 "News")
- ,@(map news-entry->sxml (take (news-items) 3))
- (p (a (@ (href "https://savannah.gnu.org/news/?group=guix";)
+ ,@(map (lambda (post)
+ (post->summary-sxml post
+ (post-url post site)))
+ (take (posts/reverse-chronological posts)
+ (min 3 (length posts))))
+ (p (a (@ (href ,(base-url "news"))
(class "hlink-more-dark"))
"More news")))
@@ -368,7 +324,3 @@ Distribution.")
file-name-separator-string
filename))))
%web-pages))
-
-;; Local Variables:
-;; eval: (put 'sxml-match 'scheme-indent-function 1)
-;; End: