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

---
 src/date-utils.scm | 133 ++++++++++++++++++++++++++++++++++++++++++++++
 src/reader.scm     | 119 +++++++++++++++++++++++++++++++++++++++++
 src/theme.scm      | 152 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/urls.scm       |  51 ++++++++++++++++++
 4 files changed, 455 insertions(+)
 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

(limited to 'src')

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)))
-- 
cgit v1.2.3