blob: 2d9081051aa82b314e57712be1520a4e9c873044 (
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
|
(define-module (rss-filter)
:export (handle-feed)
:use-module (ice-9 curried-definitions)
:use-module (ice-9 match)
:use-module (rss-filter feed-handler)
:use-module (web client)
:use-module (web response)
:use-module (sxml simple)
:use-module (sxml xpath)
:use-module (sxml namespace)
:use-module ((hnh util path) :select (path-append))
:use-module (datetime)
)
(define (make-debug-item call-stack)
`(item
(title "RSS-FILTER ERROR")
(link "https://git.hornquist.se/rss-filter/")
(guid "RSS-FILTER-ERROR")
(description
,(with-output-to-string
(lambda ()
(sxml->xml
`(div
(div (@ (style "background-color: pink"))
"Something went wrong when filtering this item")
(pre
,(with-output-to-string
(lambda ()
((@ (system repl debug) terminal-width) #e1e10)
(display-backtrace
call-stack (current-output-port))))))))))
(author "rss-filter VERSION HERE")
(pubDate ,(datetime->string (current-datetime)))))
(define ((handle-feed output-directory quiet?) feed)
(define response
(begin
(when (not quiet?)
(format (current-error-port) "Fetching ~a~%" (feed-url feed)))
;; TODO follow redirects
(http-get (feed-url feed)
#:streaming? #t)))
(unless (= 200 (response-code response))
(format (current-error-port) "HTTP error ~a"
(response-code response))
(exit 1))
(let* ((feed-content (move-to-namespace (parse-rss (response-body-port response))
'((#f . rss))))
(feed-title (car ((sxpath '(// rss:channel rss:title *text*)) feed-content)))
(safe-title (string-map (lambda (c) (if (char-set-contains? char-set:letter+digit c)
c #\_))
feed-title)))
(let ((output
(let ((call-stack #f))
(catch
#t (lambda () (filter-tree (feed-transformer feed)
feed-content))
;; error handler
(lambda _
(filter-tree
`((rss:channel . ,(match-lambda*
((tag . (('@ args ...) body ...))
`(,tag (@ ,@args)
,(make-debug-item call-stack)
,@body))
((tag body ...)
`(,tag ,(make-debug-item call-stack)
,@body)))))
feed-content))
;; pre unwind hadler
(lambda _ (set! call-stack (make-stack #t))))))
(filename (string-append
(path-append output-directory safe-title)
".rss")))
(with-output-to-file filename
(lambda ()
(sxml->xml
;; Removing the rss prefix should be fine, but at least NewNewsWire
;; (for iPad) expects all rss elements to be un-namespaced.
(move-to-namespace output '((rss . #f)))))))))
|
