summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2019-11-02 22:03:09 +0000
committerChristopher Baines <mail@cbaines.net>2019-11-03 08:26:19 +0000
commit897c2747b30a6e52434891520467a0d80029a178 (patch)
tree025f49d3ec9c6ea60639a172fa30a2a7b897a8a9 /src
parenta643f9a12779494ed35813b7906229728cf282e2 (diff)
downloadweekly-news-897c2747b30a6e52434891520467a0d80029a178.tar
weekly-news-897c2747b30a6e52434891520467a0d80029a178.tar.gz
Add the initial implementation of the code
Diffstat (limited to 'src')
-rw-r--r--src/date-utils.scm133
-rw-r--r--src/reader.scm119
-rw-r--r--src/theme.scm152
-rw-r--r--src/urls.scm51
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)))