Add the initial implementation of the code

1 files changed, 152 insertions, 0 deletions

diff --git a/src/theme.scm b/src/theme.scm
new file mode 100644
index 0000000..c1d7004
--- /dev/null
+++ b/src/theme.scm
@@ -0,0 +1,152 @@
+(define-module (src theme)
+  #:use-module (srfi srfi-19)
+  #:use-module (haunt post)
+  #:use-module (haunt site)
+  #:use-module (haunt builder blog)
+  #:use-module (src urls)
+  #:use-module (src date-utils)
+  #:export (weekly-news-theme))
+
+(define (weekly-news-layout site title body)
+  `((doctype "html")
+
+    (html
+     (@ (lang "en"))
+
+     (head
+      ,(if (null? title)
+           `(title "Guix Weekly News")
+           `(title ,(string-append title " — Guix Weekly News")))
+      (meta (@ (charset "UTF-8")))
+      (meta (@ (name "viewport")
+               (content "width=device-width, initial-scale=1.0")))
+      ;; Base CSS.
+      (link (@ (rel "stylesheet") (href "/static/css/base.css")))
+      ;; Feeds.
+      (link (@ (type "application/atom+xml") (rel "alternate")
+               (title "GNU Guix — Activity Feed")
+               (href "feeds/blog.atom")))
+      (link (@ (rel "icon") (type "image/png")
+               (href "/static/img/icon.png")))
+      (link (@ (rel "icon") (type "image/svg+xml") (sizes "any")
+               (href "/static/img/icon.svg"))))
+
+     (body
+      (header
+       (a (@ (href "/"))
+          (h2
+           (@ (style "color: white; margin: 0.4em; font-size: 2em;"))
+           (img (@ (style "height: 1.1em;")
+                   (src "/static/img/guix-logo.png")))
+           "Guix Weekly News")))
+      (main
+       (article
+        (@ (class "page centered-block limit-width"))
+        ,body))
+      (footer
+       "Made with " (span (@ (class "metta")) "♥")
+       " by humans and powered by "
+       (a (@ (class "link-yellow") (href ,(gnu-url "software/guile/")))
+          "GNU Guile") ".  "
+          (a
+           (@ (class "link-yellow")
+              (href "//git.savannah.gnu.org/cgit/guix/guix-artwork.git/tree/website"))
+           "Source code")
+          " under the "
+          (a
+           (@ (class "link-yellow")
+              (href ,(gnu-url "licenses/agpl-3.0.html")))
+           "GNU AGPL") ".")))))
+
+(define (is-year-and-week-a-draft? year week)
+  (time>? (date->time-utc
+           (lookup-end-date-for-week year week))
+          (current-time)))
+
+(define (weekly-news-post-template post)
+  (let ((year (post-ref post 'year))
+        (week (post-ref post 'week)))
+    `((div
+       ,@(or (and=>
+              (previous-week-with-year year week)
+              (lambda (previous-week-and-year)
+                `((a (@ (href ,(apply weekly-news-post-url
+                                      previous-week-and-year)))
+                     (span (@ (id "left-nav"))
+                           "Previous week")))))
+             '())
+       (h1 (@ (id "center"))
+           ,(post-ref post 'title))
+       ,@(or (and=>
+              (and (and=> (next-week-with-year year week)
+                          (lambda (next-week-and-year)
+                            (not (apply is-year-and-week-a-draft?
+                                        next-week-and-year))))
+                   (next-week-with-year year week))
+              (lambda (next-week-and-year)
+                `((a (@ (href ,(apply weekly-news-post-url
+                                      next-week-and-year)))
+                     (span (@ (id "right-nav"))
+                           "Next week")))))
+             '()))
+      (div
+       (@ (style "text-align: center;"))
+       ,(date->string (post-ref post 'start-date) "~1")
+       " to "
+       ,(date->string (post-ref post 'end-date) "~1"))
+      (br)
+      ,(post-sxml post))))
+
+(define (weekly-news-collection-template site title posts prefix)
+  (define (post-uri post)
+    (string-append (or prefix "") "/"
+                   (site-post-slug site post) ".html"))
+
+  (define (date->string* date)
+    (date->string date "~a ~d ~b"))
+
+  `((ul
+     (@ (id "post-list"))
+     ,@(map (lambda (post)
+              (let ((draft
+                     (time>? (date->time-utc
+                              (post-ref post 'end-date))
+                             (current-time))))
+                `(li
+                  (@ (class ,(if draft "draft-post" "")))
+                  ,(if draft
+                       `((time
+                          "Week " ,(post-ref post 'week)
+                          (div
+                           (@ (style "font-size: small;"))
+                           "Beginning "
+                           ,(date->string*
+                             (post-ref post 'start-date))))
+                         ,(string-append
+                           "Will be published on "
+                           (date->string (move-date-by-days
+                                          (post-ref post 'start-date)
+                                          7)
+                                         "~A (~1)")))
+                       `(a (@ (href ,(post-uri post)))
+                           (time
+                            "Week " ,(post-ref post 'week)
+                            (div
+                             (@ (style "font-size: small;"))
+                             "Beginning "
+                             ,(date->string*
+                               (post-ref post 'start-date))))
+                           ,(post-ref post 'synopsis))))))
+            posts)
+     ,@(if (string=? title "Recent posts")
+           '((li
+              (a (@ (style "margin-bottom: 1em;")
+                    (href "/all.html"))
+                 "All posts")))
+           '()))))
+
+(define weekly-news-theme
+  (theme #:name "Weekly news"
+         #:layout weekly-news-layout
+         #:post-template weekly-news-post-template
+         #:collection-template weekly-news-collection-template))