From 897c2747b30a6e52434891520467a0d80029a178 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 2 Nov 2019 22:03:09 +0000
Subject: Add the initial implementation of the code

---
 haunt.scm          |  56 +++++++++++++++-----
 src/date-utils.scm | 133 ++++++++++++++++++++++++++++++++++++++++++++++
 src/reader.scm     | 119 +++++++++++++++++++++++++++++++++++++++++
 src/theme.scm      | 152 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/urls.scm       |  51 ++++++++++++++++++
 update.scm         |  75 ++++++++++++++++++++++++++
 6 files changed, 573 insertions(+), 13 deletions(-)
 create mode 100644 src/date-utils.scm
 create mode 100644 src/reader.scm
 create mode 100644 src/theme.scm
 create mode 100644 src/urls.scm
 create mode 100644 update.scm

diff --git a/haunt.scm b/haunt.scm
index a945372..3ce7a6a 100644
--- a/haunt.scm
+++ b/haunt.scm
@@ -1,17 +1,47 @@
-(use-modules (haunt asset)
+(use-modules (srfi srfi-1)
+             (srfi srfi-19)
+             (haunt asset)
              (haunt builder blog)
              (haunt builder atom)
              (haunt builder assets)
-             (haunt reader commonmark)
-             (haunt site))
+             (haunt site)
+             (haunt post)
+             (src reader)
+             (src theme))
 
-(site #:title "Built with Guile"
-      #:domain "example.com"
-      #:default-metadata
-      '((author . "Eva Luator")
-        (email  . "eva@example.com"))
-      #:readers (list commonmark-reader)
-      #:builders (list (blog)
-                       (atom-feed)
-                       (atom-feeds-by-tag)
-                       (static-directory "images")))
+;; Set the timezone to UTC, otherwise the dates can get confused.
+(setenv "TZ" "utc")
+
+(define (filter-posts-remove-future-drafts posts)
+  (filter (lambda (post)
+            (time<? (date->time-utc
+                     (post-ref post 'start-date))
+                    (current-time)))
+          posts))
+
+(define (filter-posts-remove-drafts posts)
+  (filter (lambda (post)
+            (time<? (date->time-utc
+                     (post-ref post 'end-date))
+                    (current-time)))
+          posts))
+
+(site #:title "Guix Weekly News"
+      #:domain "prototype-guix-weekly-news.cbaines.net"
+      #:readers (list post-reader)
+      #:builders
+      (list
+       (blog #:theme weekly-news-theme
+             #:collections
+             `(("Recent posts" "index.html"
+                ,(compose (lambda (posts)
+                            (take posts 8))
+                          filter-posts-remove-future-drafts
+                          posts/reverse-chronological))
+               ("All posts" "all.html"
+                ,(compose filter-posts-remove-drafts
+                          posts/reverse-chronological))))
+       (atom-feed #:filter
+                  (compose filter-posts-remove-drafts
+                           posts/reverse-chronological))
+       (static-directory "static")))
diff --git a/src/date-utils.scm b/src/date-utils.scm
new file mode 100644
index 0000000..b977f13
--- /dev/null
+++ b/src/date-utils.scm
@@ -0,0 +1,133 @@
+(define-module (src date-utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:export (lookup-start-date-for-week
+            lookup-end-date-for-week
+
+            next-week-with-year
+            previous-week-with-year
+
+            move-date-by-days
+
+            %week-start-lookup-data))
+
+(define (move-date-by-days date days)
+  (let ((time-utc
+         (date->time-utc date))
+        (duration
+         (make-time time-duration
+                    0
+                    (* 24 60 60
+                       days))))
+    (time-utc->date
+     (add-duration time-utc duration))))
+
+(define (end-of-week-date date)
+  (let ((time-utc
+         (date->time-utc date))
+        (duration
+         (make-time time-duration
+                    0
+                    (- (* 24 60 60 7)
+                       1))))
+    (time-utc->date
+     (add-duration time-utc duration))))
+
+(define %week-start-lookup-data
+  (let* ((week-start-day 1)              ; Monday
+         (years (iota (+ 2
+                         (- (date-year (current-date))
+                            2019))
+                      2019))
+         (first-week-mondays-by-year
+          (fold (lambda (year data)
+                  (let* ((fourth-of-january
+                          ;; At least according to Wikipedia, the first week
+                          ;; of the year defined by ISO 8601 contains the
+                          ;; 4th of January
+                          ;; https://en.wikipedia.org/wiki/ISO_8601#Week_dates
+                          (make-date 0 0 0 0 4 1 year 0))
+                         (fourth-of-january-week-day
+                          ;; date-week-day starts on Sunday, so adjust the
+                          ;; numbering so that 0 is Monday, 1 is Tuesday,
+                          ;; ...
+                          (modulo (- (date-week-day fourth-of-january)
+                                     1)
+                                  7)))
+                    (cons
+                     (cons year
+                           (move-date-by-days fourth-of-january
+                                              (* fourth-of-january-week-day -1)))
+                     data)))
+                '()
+                (append years
+                        (list (+ 2 (date-year (current-date))))))))
+
+    (fold (lambda (year data)
+            (let ((first-week-monday
+                   (assoc-ref first-week-mondays-by-year
+                              year))
+                  (time-for-first-week-monday-for-next-year
+                   (date->time-utc
+                    (assoc-ref first-week-mondays-by-year
+                               (+ 1 year)))))
+              (cons (cons
+                     year
+                     (fold (lambda (week data)
+                             (let ((start-date
+                                    (move-date-by-days
+                                     first-week-monday
+                                     (* 7
+                                        (- week 1)))))
+                               (if (time>=? (date->time-utc start-date)
+                                            time-for-first-week-monday-for-next-year)
+                                   data
+                                   (cons (cons week start-date)
+                                         data))))
+                           '()
+                           (iota 53 1)))
+                    data)))
+          '()
+          years)))
+
+(define (lookup-start-date-for-week year week)
+  (assq-ref (assq-ref %week-start-lookup-data
+                      year)
+            week))
+
+(define (lookup-end-date-for-week year week)
+  (end-of-week-date
+   (assq-ref (assq-ref %week-start-lookup-data year)
+             week)))
+
+(define (next-week-with-year year week)
+  (let* ((year-weeks
+          (assoc-ref %week-start-lookup-data
+                     year))
+         (last-week
+          (apply max (map car year-weeks))))
+    (if (eq? week last-week)
+        (if (eq? year
+                 (apply max
+                        (map car %week-start-lookup-data)))
+            #f
+            (list (+ year 1)
+                  1))
+        (list year
+              (+ week 1)))))
+
+(define (previous-week-with-year year week)
+  (let* ((year-weeks
+          (assoc-ref %week-start-lookup-data
+                     year)))
+    (if (eq? week 1)
+        (let ((previous-year-weeks
+               (assoc-ref %week-start-lookup-data
+                          (- year 1))))
+          (if previous-year-weeks
+              (list (- year 1)
+                    (apply max
+                           (map car previous-year-weeks)))
+              #f))
+        (list year
+              (- week 1)))))
diff --git a/src/reader.scm b/src/reader.scm
new file mode 100644
index 0000000..90d90eb
--- /dev/null
+++ b/src/reader.scm
@@ -0,0 +1,119 @@
+(define-module (src reader)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (json)
+  #:use-module (commonmark)
+  #:use-module (haunt reader)
+  #:use-module (haunt post)
+  #:use-module (src date-utils)
+  #:use-module (src urls)
+  #:export (post-reader
+
+            compare-data-filename-for-week))
+
+(define %placeholder-content
+  '("No specific news this week, if you know of something happening \
+related to Guix, please submit it for the next issue!"))
+
+(define %filename-regexp
+  (make-regexp "^posts\\/([0-9]{4})\\/([0-9]{2})/(.*)\\.md$"))
+
+;;; Comparison function data handling
+
+(define (compare-data-filename-for-week year week)
+  (format #f "data/~d/~2'0d/compare.json" year week))
+
+(define (lookup-compare-data-for-week year week)
+  (let ((filename
+         (compare-data-filename-for-week year week)))
+    (if (file-exists? filename)
+        (call-with-input-file filename json->scm)
+        #f)))
+
+(define (get-compare-data-packages-list compare-data key)
+  (stable-sort
+   (map
+    (lambda (package-data)
+      (assoc-ref package-data "name"))
+    (vector->list
+     (or (assoc-ref compare-data key)
+         (vector))))
+   string<=?))
+
+;;; Post reader
+
+(define post-reader
+  (make-reader
+   (make-file-extension-matcher "md")
+   (lambda (file)
+     (call-with-input-file file
+       (lambda (port)
+         (let ((filename-match
+                (regexp-exec %filename-regexp file)))
+           (unless filename-match
+             (error "Unknown file " file))
+           (let* ((year (string->number
+                         (match:substring filename-match 1)))
+                  (week (string->number
+                         (match:substring filename-match 2)))
+                  (locale (match:substring filename-match 3))
+                  (start-date (lookup-start-date-for-week year week))
+                  (end-date (lookup-end-date-for-week year week)))
+             (values
+              `((slug . ,(weekly-news-post-slug year week
+                                                #:locale locale))
+                (title . ,(format #f "Week ~2'0d, ~d"
+                                  week year))
+                (year . ,year)
+                (week . ,week)
+                (date . ,end-date)
+                (start-date . ,start-date)
+                (end-date . ,end-date)
+                ,@(let ((metadata (read-metadata-headers port)))
+                    (if (assoc-ref metadata 'synopsis)
+                        metadata
+                        `(,@metadata
+                          (synopsis
+                           . ,(string-append
+                               (date->string start-date "~1")
+                               " to "
+                               (date->string end-date "~1")))))))
+              (let ((compare-data
+                     (lookup-compare-data-for-week year week)))
+                (append
+                 (let ((content (commonmark->sxml port)))
+                   (if (null? content)
+                       %placeholder-content
+                       content))
+                 `((h3 "Package changes")
+                   (h4 "New packages")
+                   ,@(match (get-compare-data-packages-list compare-data
+                                                            "new-packages")
+                       (()
+                        '("None"))
+                       ((packages ...)
+                        (list
+                         (string-join packages ", "))))
+                   (h4 "Removed packages")
+                   ,@(match (get-compare-data-packages-list compare-data
+                                                            "removed-packages")
+                       (()
+                        '("None"))
+                       ((packages ...)
+                        (list
+                         (string-join packages ", "))))
+                   (h4 "Version changes")
+                   ,@(match (get-compare-data-packages-list compare-data
+                                                            "version-changes")
+                       (()
+                        '("None"))
+                       ((packages ...)
+                        (list
+                         (string-join packages ", "))))
+                   (p
+                    (a (@ (href
+                           ,(data-guix-gnu-org-compare-by-datetime-url
+                             start-date
+                             end-date)))
+                       "View comparison data")))))))))))))
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))
diff --git a/src/urls.scm b/src/urls.scm
new file mode 100644
index 0000000..dfa83ab
--- /dev/null
+++ b/src/urls.scm
@@ -0,0 +1,51 @@
+(define-module (src urls)
+  #:use-module (srfi srfi-19)
+  #:use-module (src date-utils)
+  #:export (gnu-url
+            weekly-news-post-url
+            weekly-news-post-slug
+            data-guix-gnu-org-compare-by-datetime-url))
+
+(define* (gnu-url #:optional (path ""))
+  "Append PATH to GNU.org URL.
+
+   PATH (string)
+     An optional relative URL path to a resource. For example:
+     'software/guile/'.
+
+   RETURN VALUE (string)
+     A URL. For example: https://gnu.org/software/guile/."
+  (string-append "https://gnu.org/" path))
+
+(define* (weekly-news-post-url . args)
+  (string-append
+   "/"
+   (apply weekly-news-post-slug args)
+   ".html"))
+
+(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-slug year week #:key (locale "en_US"))
+  (string-append
+   (if (is-year-and-week-a-draft? year week)
+       "drafts/"
+       "")
+   (format #f "~a/~d/~2,'0d" locale year week)))
+
+(define* (data-guix-gnu-org-compare-by-datetime-url
+          base-datetime
+          target-datetime
+          #:key (json #f))
+  (define (date->string* date)
+    (date->string date "~1%20~T"))
+
+  (string-append
+   "http://data.guix.gnu.org/compare-by-datetime"
+   (if json ".json" "")
+   "?base_branch=master"
+   "&base_datetime=" (date->string* base-datetime)
+   "&target_branch=master"
+   "&target_datetime=" (date->string* target-datetime)))
diff --git a/update.scm b/update.scm
new file mode 100644
index 0000000..7de35e1
--- /dev/null
+++ b/update.scm
@@ -0,0 +1,75 @@
+(load "haunt.scm")
+
+(use-modules (srfi srfi-11)
+             (srfi srfi-19)
+             (ice-9 format)
+             (ice-9 match)
+             (rnrs bytevectors)
+             (web client)
+             (web response)
+             (json)
+             (src urls)
+             (src reader)
+             (src date-utils))
+
+(define (mkdir-p filename)
+  (fold (lambda (next-part done-parts)
+          (let ((filename
+                 (string-append done-parts
+                                "/"
+                                next-part)))
+            (unless (file-exists? filename)
+              (mkdir filename))
+            filename))
+        "./"
+        (string-split filename #\/)))
+
+(define (download-data-for-week year week)
+  (define (date->string* date)
+    (date->string date "~1%20~T"))
+
+  (let-values
+      (((response body)
+        (http-get
+         (data-guix-gnu-org-compare-by-datetime-url
+          (lookup-start-date-for-week year week)
+          (lookup-end-date-for-week year week)
+          #:json #t))))
+
+    (let ((output (compare-data-filename-for-week year week)))
+      (mkdir-p (dirname output))
+      (let ((data
+             (scm->json-string
+              (json-string->scm (utf8->string body))
+              #:pretty #t)))
+        (call-with-output-file output
+          (lambda (port)
+            (display data port)))
+        (simple-format #t "written ~A\n" output)))))
+
+(for-each
+ (match-lambda
+   ((year . weeks)
+    (for-each
+     (lambda (week)
+       (let ((week-string
+              (format #f "~2'0d" week)))
+         (let ((week-end-date
+                (lookup-end-date-for-week year week)))
+           (when (time>? (current-time)
+                         (date->time-utc week-end-date))
+             (unless (file-exists?
+                      (compare-data-filename-for-week year week))
+               (download-data-for-week year week)))
+           (let ((filename
+                  (format
+                   #f "posts/~d/~2'0d/en_US.md"
+                   year week)))
+             (mkdir-p (dirname filename))
+             (when (not (file-exists? filename))
+               (call-with-output-file filename
+                 (lambda (port)
+                   (display "---\n" port)))
+               (simple-format #t "written ~A\n" filename))))))
+     (map car weeks))))
+ %week-start-lookup-data)
-- 
cgit v1.2.3