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

(use-modules
 (srfi srfi-1)           ;dedup lists
 (srfi srfi-19)           ;date
 (sxml simple))

(define (update-gitlab-rss url alias)
  "Download and cache to disk a paginated rss feed until a cached entry is detected."
  (define filename (string-append alias ".new.rss.sxml.tmp"))
  (define acc-filename (string-append alias ".rss.sxml"))
  (define acc-filename-tmp (string-append alias ".rss.sxml.tmp"))
  (define old-entries
    (if (file-exists? acc-filename)
        (let ()
          (define contents (call-with-input-file acc-filename read))
          (get-entries-old contents))
        '()))
  (define new-entries (get-more-entries url filename old-entries 0))
  (define merged-entries (delete-duplicates
                          (append old-entries new-entries)
                          (lambda (a b)
                            (equal? (car (assoc-ref a 'http://www.w3.org/2005/Atom:id))
                                    (car (assoc-ref b 'http://www.w3.org/2005/Atom:id))))))
  (call-with-output-file acc-filename-tmp
    (lambda (port) (write merged-entries port)))
  (rename-file acc-filename-tmp acc-filename)
  (delete-file filename))


(define (get-more-entries url filename old-entries offset)
  (system* "wget" (string-append url "?offset=" (number->string offset)) "-q" "-O" filename)
  (let ()
    (define new-entries
      (let ()
        (define contents (call-with-input-file filename xml->sxml))
        (get-entries contents)))
    (define found-old-entry?
      (find (lambda (e)
              (define id (car (assoc-ref e 'http://www.w3.org/2005/Atom:id)))
              (find (lambda (o)
                      (equal? id
                              (car (assoc-ref o 'http://www.w3.org/2005/Atom:id))))
                    old-entries))
            new-entries))
    (define result (append new-entries old-entries))
    (if found-old-entry?
        result
        (if (null? new-entries)
            result
            (begin
              (sleep 2)
              (get-more-entries url filename result (+ offset (length new-entries))))))))

(define (get-entries sxml)
  (define feed (assoc-ref sxml 'http://www.w3.org/2005/Atom:feed))
  (define entries (filter
                    (lambda (e)
                      (and (list? e)
                           (eq? (car e) 'http://www.w3.org/2005/Atom:entry)))
                    feed))
  entries)

(define (get-entries-old feed)
  (define entries (filter
                    (lambda (e)
                      (and (list? e)
                           (eq? (car e) 'http://www.w3.org/2005/Atom:entry)))
                    feed))
  entries)

(define (string-substitute str search substitute start-recursive)
  (define found (string-contains str search))
  (define result
    (if found
        (cons #t (string-replace str
                                 substitute
                                 found (+ found (string-length search))))
        (cons #f str)))
  (if (and (car result) start-recursive)
      (string-substitute (cdr result) search substitute start-recursive)
      (cdr result)))

(define (main args)
  (define url (car (cdr args)))
  (define alias (car (cdr (cdr args))))
  (update-gitlab-rss  url alias))