01/02: website: post: Recognize image references to videos.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix-artwork.

commit 2c5caf18cced32cbf32fa601807516419ca906f5
Author: Ludovic Courtès <address@hidden>
AuthorDate: Wed Apr 15 13:03:26 2020 +0200

    website: post: Recognize image references to videos.
    
    * website/apps/blog/utils.scm (change-image-to-video): New procedure.
    * website/apps/blog/templates/post.scm (post-t): Use it.
---
 website/apps/blog/templates/post.scm |  3 ++-
 website/apps/blog/utils.scm          | 24 +++++++++++++++++++++++-
 2 files changed, 25 insertions(+), 2 deletions(-)

diff --git a/website/apps/blog/templates/post.scm 
b/website/apps/blog/templates/post.scm
index 39d0332..35c57a8 100644
--- a/website/apps/blog/templates/post.scm
+++ b/website/apps/blog/templates/post.scm
@@ -44,7 +44,8 @@
         ,(post-ref post 'author) " — "
         ,(date->string (post-date post) "~B ~e, ~Y"))
 
-       ,(syntax-highlight (post-sxml post))
+       ,(change-image-to-video
+          (syntax-highlight (post-sxml post)))
 
        (div
         (@ (class "tag-list"))
diff --git a/website/apps/blog/utils.scm b/website/apps/blog/utils.scm
index b161a16..b5d1368 100644
--- a/website/apps/blog/utils.scm
+++ b/website/apps/blog/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix web site
-;;; Copyright © 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016, 2017, 2020 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of the GNU Guix web site.
 ;;;
@@ -30,6 +30,7 @@
            post-url-path
            posts/latest
            syntax-highlight
+            change-image-to-video
            tag-first?
            tag-system-path
            tag-url-path))
@@ -126,3 +127,24 @@
      `(,tag ,@(map syntax-highlight body)))
     ((? string? str)
      str)))
+
+(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)
+           `(video (@ (src ,src) (controls "controls"))
+                   (p (a (@ (href ,src) (class "link-subtle"))
+                         "Download video.")))
+           sxml)))
+    ((tag ('@ attributes ...) body ...)
+     `(,tag (@ ,@attributes) ,@(map change-image-to-video body)))
+    ((tag body ...)
+     `(,tag ,@(map change-image-to-video body)))
+    ((? string? str)
+     str)))