summaryrefslogtreecommitdiff
path: root/src/reader.scm
blob: 90d90eb814beb0865761fdeb559971615d16981c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
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")))))))))))))