2019-03-05 22:43:56 +01:00
|
|
|
;;; GNU Guix web site
|
2021-08-10 10:38:40 +02:00
|
|
|
;;; Copyright © 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
|
2023-06-10 13:26:55 +02:00
|
|
|
;;; Copyright © 2023 Florian Pelz <pelzflorian@pelzflorian.de>
|
2016-10-26 01:16:53 +02:00
|
|
|
;;;
|
2019-03-05 22:43:56 +01:00
|
|
|
;;; This file is part of the GNU Guix web site.
|
2016-10-26 01:16:53 +02:00
|
|
|
;;;
|
2019-03-05 22:43:56 +01:00
|
|
|
;;; The GNU Guix web site is free software; you can redistribute it and/or modify it
|
2016-10-26 01:16:53 +02:00
|
|
|
;;; under the terms of the GNU Affero General Public License as published by
|
|
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
|
|
;;; your option) any later version.
|
|
|
|
;;;
|
2019-03-05 22:43:56 +01:00
|
|
|
;;; The GNU Guix web site is distributed in the hope that it will be useful, but
|
2016-10-26 01:16:53 +02:00
|
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
;;; GNU Affero General Public License for more details.
|
|
|
|
;;;
|
|
|
|
;;; You should have received a copy of the GNU Affero General Public License
|
2019-03-05 22:43:56 +01:00
|
|
|
;;; along with the GNU Guix web site. If not, see <http://www.gnu.org/licenses/>.
|
2016-10-26 01:16:53 +02:00
|
|
|
|
2017-07-29 15:18:59 +02:00
|
|
|
(define-module (apps blog utils)
|
|
|
|
#:use-module (apps aux lists)
|
|
|
|
#:use-module (apps aux web)
|
website: apps: Mark all files for translation.
* website/po/guix-website.pot: New file.
* website/apps/base/utils.scm (manual-url-with-language): New
procedure.
(locale-display-name): New procedure.
(guix-url): Use localized URLs by default.
* website/apps/base/templates/components.scm (manual-href,
manual-link-yellow): New procedures.
(breadcrumbs, contact->shtml, navbar): Mark for translation.
* website/apps/base/data.scm (contact-media): Mark for
translation.
* website/apps/base/templates/about.scm (about-t): Mark for
translation.
* website/apps/base/templates/contact.scm (contact-t): Mark for
translation.
* website/apps/base/templates/contribute.scm (contribute-t): Mark for
translation.
* website/apps/base/templates/donate.scm (donate-t): Mark for
translation.
* website/apps/base/templates/graphics.scm (graphics-t): Mark for
translation.
* website/apps/base/templates/help.scm (help-t): Mark for translation.
* website/apps/base/templates/home.scm (home-t): Mark for translation.
* website/apps/base/templates/irc.scm (irc-t): Mark for translation.
* website/apps/base/templates/menu.scm (menu-t): Mark for translation.
* website/apps/base/templates/security.scm (security-t): Mark for
translation.
* website/apps/base/templates/theme.scm (theme): Mark for translation.
* website/apps/blog/templates/components.scm (post-preview, sidebar):
Mark for translation.
* website/apps/blog/templates/feed.scm (atom-feed-t): Mark for
translation.
* website/apps/blog/templates/post-list.scm (post-list-t): Mark for
translation.
* website/apps/blog/templates/post.scm (post-t): Mark for translation.
* website/apps/blog/templates/tag.scm (tag-t): Mark for translation.
* website/apps/download/data.scm (home-t): Mark for translation.
* website/apps/download/templates/components.scm (system-downloads):
Mark for translation.
* website/apps/download/templates/download.scm (download-t): Mark for
translation.
* website/apps/download/templates/download-latest.scm (images,
image-download, download-latest-t): Mark for
translation.
* website/apps/media/data.scm (playlists, screenshots):
Mark for translation.
* website/apps/media/templates/components.scm (video->shtml,
video-content): Mark for translation.
* website/apps/base/templates/screenshot.scm (screenshot-t):
Mark for translation.
* website/apps/media/templates/screenshots-overview.scm
(screenshots-overview-t): Mark for translation.
* website/apps/media/templates/video.scm (video-t): Mark for translation.
* website/apps/media/templates/video-list.scm (video-list-t):
Mark for translation.
* website/apps/packages/templates/components.scm (detailed-package-preview,
letter-selector, sidebar, supported-systems->shtml): Mark for translation.
* website/apps/packages/templates/detailed-index.scm (detailed-index-t):
Mark for translation.
* website/apps/packages/templates/detailed-package-list.scm
(detailed-package-list-t): Mark for translation.
* website/apps/packages/templates/index.scm (index-t): Mark for translation.
* website/apps/packages/templates/package-list.scm (package-list-t):
Mark for translation.
* website/apps/packages/templates/package.scm (package-t): Mark for
translation.
2020-07-15 08:15:58 +02:00
|
|
|
#:use-module (apps i18n)
|
2016-10-26 01:16:53 +02:00
|
|
|
#:use-module (haunt post)
|
2017-07-29 15:18:59 +02:00
|
|
|
#:use-module (ice-9 match)
|
|
|
|
#:use-module (srfi srfi-1)
|
|
|
|
#:use-module (srfi srfi-19)
|
2017-04-14 11:34:47 +02:00
|
|
|
#:use-module (syntax-highlight)
|
|
|
|
#:use-module (syntax-highlight scheme)
|
|
|
|
#:use-module (syntax-highlight lexers)
|
2017-07-29 15:18:59 +02:00
|
|
|
#:export (post-groups->tag-list
|
|
|
|
post-url-path
|
|
|
|
posts/latest
|
|
|
|
syntax-highlight
|
2020-04-15 13:03:26 +02:00
|
|
|
change-image-to-video
|
2017-07-29 15:18:59 +02:00
|
|
|
tag-first?
|
|
|
|
tag-system-path
|
|
|
|
tag-url-path))
|
|
|
|
|
|
|
|
|
|
|
|
(define (post-groups->tag-list groups)
|
|
|
|
"Return a list of Haunt tags from the list of grouped posts.
|
|
|
|
|
|
|
|
GROUPS (association list)
|
|
|
|
An association list of tags mapped to posts, as returned by the
|
|
|
|
posts/group-by-tag procedure from (haunt post) module."
|
|
|
|
(cond ((null? groups) '())
|
|
|
|
(else
|
|
|
|
(cons (car (first groups))
|
|
|
|
(post-groups->tag-list (rest groups))))))
|
|
|
|
|
|
|
|
|
|
|
|
(define (post-url-path post)
|
|
|
|
"Return a URL path for the POST in the form blog/YYYY/POST-SLUG.
|
|
|
|
|
|
|
|
POST (<post>)
|
|
|
|
A post object as defined in (haunt post) module."
|
2023-06-10 13:26:55 +02:00
|
|
|
;; Note: End the path with a slash so 'localized-root-path' down the road
|
|
|
|
;; prepends the language tag.
|
2017-07-29 15:18:59 +02:00
|
|
|
(url-path-join "blog"
|
|
|
|
(date->string (post-date post) "~Y")
|
2023-06-10 13:26:55 +02:00
|
|
|
(post-slug post)
|
|
|
|
""))
|
2017-07-29 15:18:59 +02:00
|
|
|
|
|
|
|
|
|
|
|
(define (posts/latest posts n)
|
|
|
|
"Return the latest N posts from the given list of posts."
|
|
|
|
(let ((latest-posts (posts/reverse-chronological posts)))
|
|
|
|
(cond
|
|
|
|
((null? posts) '())
|
|
|
|
((<= (length posts) n) latest-posts)
|
|
|
|
(else (list-head latest-posts n)))))
|
|
|
|
|
|
|
|
|
|
|
|
(define (tag-first? tag-a tag-b)
|
|
|
|
"Return true if TAG-A goes first than TAG-B alphabetically.
|
2016-10-26 01:16:53 +02:00
|
|
|
|
2017-07-29 15:18:59 +02:00
|
|
|
This predicate is used for sorting tags.
|
|
|
|
|
|
|
|
TAG-A, TAG-B (string)
|
|
|
|
A tag as used by Haunt posts. For example: 'User interface'."
|
|
|
|
(string<? (string-downcase tag-a) (string-downcase tag-b)))
|
|
|
|
|
|
|
|
|
|
|
|
(define (tag-system-path tag)
|
|
|
|
"Return a system path for the TAG in the form blog/tags/TAG-SLUG.
|
|
|
|
|
|
|
|
The path is relative to the website directory.
|
|
|
|
|
|
|
|
TAG (string)
|
|
|
|
A tag as used by Haunt posts. For example: 'Scheme API'."
|
|
|
|
(string-append "blog/tags/" (slugify tag)))
|
|
|
|
|
|
|
|
|
|
|
|
(define (tag-url-path tag)
|
|
|
|
"Return a URL path for the TAG in the form blog/tags/TAG-SLUG.
|
|
|
|
|
|
|
|
TAG (string)
|
|
|
|
A tag as used by Haunt posts. For example: 'Scheme API'."
|
2021-08-10 10:38:40 +02:00
|
|
|
;; Note: End the path with a slash so 'localized-root-path' down the road
|
|
|
|
;; prepends the language tag.
|
|
|
|
(url-path-join "blog" "tags" (slugify tag) ""))
|
2017-07-29 15:18:59 +02:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
;;; Syntax highlighting.
|
|
|
|
;;;
|
2016-10-26 01:16:53 +02:00
|
|
|
|
2017-04-14 11:34:47 +02:00
|
|
|
(define %default-special-prefixes
|
|
|
|
'("define" "syntax"))
|
|
|
|
|
|
|
|
(define lex-scheme/guix
|
|
|
|
;; Specialized lexer for the Scheme we use in Guix.
|
|
|
|
;; TODO: Add #~, #$, etc.
|
|
|
|
(make-scheme-lexer (cons* "with-imported-modules"
|
|
|
|
"gexp" "ungexp"
|
|
|
|
"ungexp-native" "ungexp-splicing"
|
|
|
|
"ungexp-native-splicing"
|
|
|
|
"mlet" "mlet*"
|
|
|
|
"match"
|
|
|
|
%default-special-symbols)
|
|
|
|
%default-special-prefixes))
|
|
|
|
|
|
|
|
(define (syntax-highlight sxml)
|
|
|
|
"Recurse over SXML and syntax-highlight code snippets."
|
|
|
|
(match sxml
|
|
|
|
(('code ('@ ('class "language-scheme")) code-snippet)
|
|
|
|
`(code ,(highlights->sxml
|
|
|
|
(highlight lex-scheme/guix code-snippet))))
|
|
|
|
((tag ('@ attributes ...) body ...)
|
|
|
|
`(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
|
|
|
|
((tag body ...)
|
|
|
|
`(,tag ,@(map syntax-highlight body)))
|
|
|
|
((? string? str)
|
|
|
|
str)))
|
2020-04-15 13:03:26 +02:00
|
|
|
|
|
|
|
(define (change-image-to-video sxml)
|
|
|
|
"Replace <img> tags in SXML that refer to WebM videos with proper <video>
|
|
|
|
tags. This hack allows one to refer to a video from a Markdown document."
|
|
|
|
(match sxml
|
|
|
|
(('img ('@ attributes ...) body ...)
|
|
|
|
(let ((src (match (assoc 'src attributes)
|
|
|
|
((_ url) url)))
|
|
|
|
(alt (match (assoc 'alt attributes)
|
|
|
|
((_ text) text))))
|
|
|
|
(if (string-suffix? ".webm" src)
|
2020-04-15 16:01:28 +02:00
|
|
|
`(video (@ (src ,src)
|
|
|
|
(poster ,(string-append src ".poster.png"))
|
|
|
|
(controls "controls"))
|
website: apps: Mark all files for translation.
* website/po/guix-website.pot: New file.
* website/apps/base/utils.scm (manual-url-with-language): New
procedure.
(locale-display-name): New procedure.
(guix-url): Use localized URLs by default.
* website/apps/base/templates/components.scm (manual-href,
manual-link-yellow): New procedures.
(breadcrumbs, contact->shtml, navbar): Mark for translation.
* website/apps/base/data.scm (contact-media): Mark for
translation.
* website/apps/base/templates/about.scm (about-t): Mark for
translation.
* website/apps/base/templates/contact.scm (contact-t): Mark for
translation.
* website/apps/base/templates/contribute.scm (contribute-t): Mark for
translation.
* website/apps/base/templates/donate.scm (donate-t): Mark for
translation.
* website/apps/base/templates/graphics.scm (graphics-t): Mark for
translation.
* website/apps/base/templates/help.scm (help-t): Mark for translation.
* website/apps/base/templates/home.scm (home-t): Mark for translation.
* website/apps/base/templates/irc.scm (irc-t): Mark for translation.
* website/apps/base/templates/menu.scm (menu-t): Mark for translation.
* website/apps/base/templates/security.scm (security-t): Mark for
translation.
* website/apps/base/templates/theme.scm (theme): Mark for translation.
* website/apps/blog/templates/components.scm (post-preview, sidebar):
Mark for translation.
* website/apps/blog/templates/feed.scm (atom-feed-t): Mark for
translation.
* website/apps/blog/templates/post-list.scm (post-list-t): Mark for
translation.
* website/apps/blog/templates/post.scm (post-t): Mark for translation.
* website/apps/blog/templates/tag.scm (tag-t): Mark for translation.
* website/apps/download/data.scm (home-t): Mark for translation.
* website/apps/download/templates/components.scm (system-downloads):
Mark for translation.
* website/apps/download/templates/download.scm (download-t): Mark for
translation.
* website/apps/download/templates/download-latest.scm (images,
image-download, download-latest-t): Mark for
translation.
* website/apps/media/data.scm (playlists, screenshots):
Mark for translation.
* website/apps/media/templates/components.scm (video->shtml,
video-content): Mark for translation.
* website/apps/base/templates/screenshot.scm (screenshot-t):
Mark for translation.
* website/apps/media/templates/screenshots-overview.scm
(screenshots-overview-t): Mark for translation.
* website/apps/media/templates/video.scm (video-t): Mark for translation.
* website/apps/media/templates/video-list.scm (video-list-t):
Mark for translation.
* website/apps/packages/templates/components.scm (detailed-package-preview,
letter-selector, sidebar, supported-systems->shtml): Mark for translation.
* website/apps/packages/templates/detailed-index.scm (detailed-index-t):
Mark for translation.
* website/apps/packages/templates/detailed-package-list.scm
(detailed-package-list-t): Mark for translation.
* website/apps/packages/templates/index.scm (index-t): Mark for translation.
* website/apps/packages/templates/package-list.scm (package-list-t):
Mark for translation.
* website/apps/packages/templates/package.scm (package-t): Mark for
translation.
2020-07-15 08:15:58 +02:00
|
|
|
(p ,(G_ `(a (@ (href ,src) (class "link-subtle"))
|
|
|
|
"Download video."))))
|
2020-04-15 13:03:26 +02:00
|
|
|
sxml)))
|
|
|
|
((tag ('@ attributes ...) body ...)
|
|
|
|
`(,tag (@ ,@attributes) ,@(map change-image-to-video body)))
|
|
|
|
((tag body ...)
|
|
|
|
`(,tag ,@(map change-image-to-video body)))
|
|
|
|
((? string? str)
|
|
|
|
str)))
|