diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/date-utils.scm | 133 | ||||
| -rw-r--r-- | src/reader.scm | 119 | ||||
| -rw-r--r-- | src/theme.scm | 152 | ||||
| -rw-r--r-- | src/urls.scm | 51 |
4 files changed, 455 insertions, 0 deletions
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))) |