121 lines
3.1 KiB
Scheme
121 lines
3.1 KiB
Scheme
;;
|
|
;; Copyright © 2021 kitzman <kitzman @ disroot . org>
|
|
;;
|
|
|
|
(define-module (lieferhund processor)
|
|
#:use-module (lieferhund config)
|
|
#:use-module (lieferhund proto)
|
|
#:use-module ((lieferhund db) :prefix db:)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-19)
|
|
#:use-module (rnrs sorting)
|
|
#:use-module (ice-9 match)
|
|
|
|
#:export (preprocess-flatten
|
|
preprocess-sort
|
|
|
|
process))
|
|
|
|
(define (flatten l)
|
|
(fold
|
|
(lambda (c e) (append e c))
|
|
'() l))
|
|
|
|
(define (fn-apply fn)
|
|
(use-modules (lieferhund util)
|
|
(lieferhund interpolator)
|
|
(lieferhund hooks printer)
|
|
(lieferhund hooks script)
|
|
|
|
(ice-9 textual-ports))
|
|
(lambda args
|
|
(eval `(,fn ,@args)
|
|
(interaction-environment))))
|
|
|
|
(define (preprocess-sort pe-items)
|
|
(list-sort
|
|
(lambda (item0-pair item1-pair)
|
|
(let* ((item0 (cadr item0-pair))
|
|
(item1 (cadr item1-pair))
|
|
|
|
(date-str-item0 (entry-date item0))
|
|
(date-str-item1 (entry-date item1))
|
|
|
|
(date-item0 (string->date date-str-item0
|
|
db:db-date-format))
|
|
(date-item1 (string->date date-str-item1
|
|
db:db-date-format))
|
|
|
|
(time-item0 (date->time-tai date-item0))
|
|
(time-item1 (date->time-tai date-item1)))
|
|
(time<? time-item0 time-item1)))
|
|
pe-items))
|
|
|
|
(define (preprocess-flatten pair-entries)
|
|
(flatten
|
|
(map
|
|
(lambda (channel-entry)
|
|
(match channel-entry
|
|
((config-entry items)
|
|
(map
|
|
(lambda (item)
|
|
`(,config-entry ,item))
|
|
items))))
|
|
pair-entries)))
|
|
|
|
(define* (process conf pair-entries #:optional post-hook-override)
|
|
(let ((post-hook (if (equal? post-hook-override #f)
|
|
(configuration-post-hook conf)
|
|
post-hook-override)))
|
|
(match post-hook
|
|
;; No post-hook action
|
|
(#f '())
|
|
;; Generic hooks
|
|
(('hook-gen hook-gen hook-args ...)
|
|
(process
|
|
conf pair-entries
|
|
(apply (fn-apply hook-gen) hook-args)))
|
|
;; Combined hooks
|
|
(('hook-cons hook-exps ...)
|
|
(for-each
|
|
(lambda (hook-exp)
|
|
(process conf pair-entries hook-exp))
|
|
hook-exps))
|
|
;; Feed type matching
|
|
(('hook-match-type (feed-types hook-exps-list ...) ...)
|
|
(let ((type-fn-pairs (zip feed-types hook-exps-list)))
|
|
(for-each
|
|
(match-lambda
|
|
((feed-type hook-exps)
|
|
(for-each
|
|
(lambda (hook-exp)
|
|
(process
|
|
conf
|
|
(filter
|
|
(match-lambda
|
|
((conf-entry news-items)
|
|
(eq? (config-entry-type conf-entry) feed-type))
|
|
(_ #f))
|
|
pair-entries)
|
|
hook-exp))
|
|
hook-exps))
|
|
(_ (begin
|
|
(format #t "malformed hook-match-type\n")
|
|
#f)))
|
|
type-fn-pairs)))
|
|
;; Process the news items one-by-one (lambda (conf-entry news-item) ...)
|
|
(('process-each fn)
|
|
(for-each
|
|
(lambda (entry)
|
|
(apply (fn-apply fn) entry))
|
|
(preprocess-sort (preprocess-flatten pair-entries))))
|
|
;; Process the news items by channel (lambda (conf-entry multiple-news-items) ...)
|
|
(('process-each-channel fn)
|
|
(for-each
|
|
(lambda (entry)
|
|
(apply (fn-apply fn) entry))
|
|
pair-entries))
|
|
;; Process the entries as a whole (lambda (pair-entries) ...)
|
|
(fn (eval `(,fn ',pair-entries)
|
|
(interaction-environment))))))
|