added tests (#18)
This commit is contained in:
parent
852a9c7574
commit
16c25ee81e
GPG Key ID:
83289D84AA7C9A54
|
|
@ -71,18 +71,18 @@ flycheck_*.el
|
|||
# End of https://www.toptal.com/developers/gitignore/api/scheme
|
||||
|
||||
# autotools cleanup
|
||||
*.log
|
||||
*.trs
|
||||
Makefile
|
||||
Makefile.in
|
||||
aclocal.m4
|
||||
autom4te.cache
|
||||
build-aux/*
|
||||
!build-aux/test-driver.scm
|
||||
config.log
|
||||
config.status
|
||||
configure
|
||||
pre-inst-env
|
||||
doc/*
|
||||
test-suite.log
|
||||
|
||||
# documentation
|
||||
!doc/lieferhund.texi
|
||||
|
|
@ -50,7 +50,11 @@ SOURCES = \
|
|||
|
||||
SUBDIRS =
|
||||
|
||||
TESTS =
|
||||
TESTS = \
|
||||
tests/test-config.scm \
|
||||
tests/test-db.scm \
|
||||
tests/test-proto.scm \
|
||||
tests/test-processor.scm
|
||||
|
||||
TEST_EXTENSIONS = .scm
|
||||
SCM_LOG_DRIVER = \
|
||||
|
|
|
|||
|
|
@ -28,9 +28,7 @@
|
|||
(lieferhund hooks script)
|
||||
|
||||
(ice-9 textual-ports))
|
||||
(lambda args
|
||||
(eval `(,fn ,@args)
|
||||
(interaction-environment))))
|
||||
(eval fn (interaction-environment)))
|
||||
|
||||
(define (preprocess-sort pe-items)
|
||||
(list-sort
|
||||
|
|
|
|||
|
|
@ -0,0 +1,15 @@
|
|||
(configuration
|
||||
(post-hook
|
||||
(hook-cons
|
||||
(hook-gen make-printer-hook)))
|
||||
(store-size 250)
|
||||
(entry
|
||||
(name "guix ci")
|
||||
(url "http://ci.guix.gnu.org/events/rss/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.gnu.guix.ci"))))
|
||||
(entry
|
||||
(name "arch news")
|
||||
(url "https://archlinux.org/feeds/news/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.arch.news")))))
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
(configuration
|
||||
(store-size 250)
|
||||
(entry
|
||||
(name "guix ci")
|
||||
(url "http://ci.guix.gnu.org/events/rss/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.gnu.guix.ci"))))
|
||||
(entry
|
||||
(name "arch news")
|
||||
(url "https://archlinux.org/feeds/news/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.arch.news")))))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
(configuration
|
||||
(post-hook
|
||||
(hook-cons
|
||||
(hook-gen make-printer-hook)))
|
||||
(entry
|
||||
(name "guix ci")
|
||||
(url "http://ci.guix.gnu.org/events/rss/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.gnu.guix.ci"))))
|
||||
(entry
|
||||
(name "arch news")
|
||||
(url "https://archlinux.org/feeds/news/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.arch.news")))))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
(configuration
|
||||
(post-hook
|
||||
(hook-cons
|
||||
(hook-gen make-printer-hook)))
|
||||
(store-size 250)
|
||||
(entry
|
||||
(url "http://ci.guix.gnu.org/events/rss/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.gnu.guix.ci"))))
|
||||
(entry
|
||||
(name "arch news")
|
||||
(url "https://archlinux.org/feeds/news/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.arch.news")))))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
(configuration
|
||||
(post-hook
|
||||
(hook-cons
|
||||
(hook-gen make-printer-hook)))
|
||||
(store-size 250)
|
||||
(entry
|
||||
(name "guix ci")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.gnu.guix.ci"))))
|
||||
(entry
|
||||
(name "arch news")
|
||||
(url "https://archlinux.org/feeds/news/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.arch.news")))))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
(configuration
|
||||
(post-hook
|
||||
(hook-cons
|
||||
(hook-gen make-printer-hook)))
|
||||
(store-size 250)
|
||||
(entry
|
||||
(name "guix ci")
|
||||
(url "http://ci.guix.gnu.org/events/rss/")
|
||||
(opts (("newsgroup" . "org.gnu.guix.ci"))))
|
||||
(entry
|
||||
(name "arch news")
|
||||
(url "https://archlinux.org/feeds/news/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.arch.news")))))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
(configuration
|
||||
(post-hook
|
||||
(hook-cons
|
||||
(hook-gen make-printer-hook)))
|
||||
(store-size 250)
|
||||
(entry
|
||||
(name "guix ci")
|
||||
(url "http://ci.guix.gnu.org/events/rss/")
|
||||
(type rss))
|
||||
(entry
|
||||
(name "arch news")
|
||||
(url "https://archlinux.org/feeds/news/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.arch.news")))))
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
(database
|
||||
(table (channel-name "lwn")
|
||||
(channel-url "https://lwn.net/headlines/newrss")
|
||||
(last-updated "11 July 2021 20:45:25 +0300")
|
||||
(entries
|
||||
((entry (title "Security updates for Saturday")
|
||||
(description "a")
|
||||
(link "https://lwn.net/Articles/862487/rss")
|
||||
(date "10 July 2021 23:58:13 Z"))
|
||||
(entry (title "Announcing Arti, a pure-Rust Tor implementation (Tor blog)")
|
||||
(description "b")
|
||||
(link "https://lwn.net/Articles/862329/rss")
|
||||
(date "09 July 2021 18:05:12 Z")))))
|
||||
(table (channel-name "julia evans")
|
||||
(channel-url "https://jvns.ca/atom.xml")
|
||||
(last-updated "11 July 2021 20:45:27 +0300")
|
||||
(entries
|
||||
((entry (title "Write good examples by starting with real code")
|
||||
(description "")
|
||||
(link "https://jvns.ca/blog/2021/07/08/writing-great-examples/")
|
||||
(date "08 July 2021 11:00:46 Z"))
|
||||
(entry (title "Reasons why bugs might feel \"impossible\"")
|
||||
(description "")
|
||||
(link "https://jvns.ca/blog/2021/06/08/reasons-why-bugs-might-feel-impossible/")
|
||||
(date "08 June 2021 09:28:08 Z"))))))
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
(configuration
|
||||
(post-hook
|
||||
(hook-cons
|
||||
(hook-gen make-printer-hook)))
|
||||
(store-size 250)
|
||||
(entry
|
||||
(name "guix ci")
|
||||
(url "http://ci.guix.gnu.org/events/rss/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.gnu.guix.ci"))))
|
||||
(entry
|
||||
(name "arch news")
|
||||
(url "https://archlinux.org/feeds/news/")
|
||||
(type rss)
|
||||
(opts (("newsgroup" . "org.arch.news")))))
|
||||
|
|
@ -0,0 +1,95 @@
|
|||
;;
|
||||
;; Copyright © 2021 kitzman <kitzman @ disroot . org>
|
||||
;;
|
||||
|
||||
(use-modules (lieferhund config)
|
||||
(lieferhund util)
|
||||
(srfi srfi-64)
|
||||
(ice-9 pretty-print))
|
||||
|
||||
;;
|
||||
;; Sample configurations
|
||||
;;
|
||||
|
||||
(define sample-store-size 250)
|
||||
|
||||
(define sample-entries
|
||||
`(,(make-configuration-entry
|
||||
"guix ci"
|
||||
"http://ci.guix.gnu.org/events/rss/"
|
||||
'rss
|
||||
'(("newsgroup" . "org.gnu.guix.ci")))
|
||||
,(make-configuration-entry
|
||||
"arch news"
|
||||
"https://archlinux.org/feeds/news/"
|
||||
'rss
|
||||
'(("newsgroup" . "org.arch.news")))))
|
||||
|
||||
(define sample-post-hook
|
||||
'(hook-cons
|
||||
(hook-gen make-printer-hook)))
|
||||
|
||||
(define sample-configuration
|
||||
(make-configuration
|
||||
sample-store-size
|
||||
sample-entries
|
||||
sample-post-hook))
|
||||
|
||||
;;
|
||||
;; Configuration expressions
|
||||
;;
|
||||
|
||||
(define (config-sample-filename no)
|
||||
(format #f "tests/data/sample-config~a.scm" no))
|
||||
|
||||
;;
|
||||
;; Testing reading/writing
|
||||
;;
|
||||
|
||||
(test-begin "reading the configuration")
|
||||
|
||||
(test-equal "correct configuration"
|
||||
sample-configuration
|
||||
(read-config-file (config-sample-filename 0)))
|
||||
|
||||
(test-error
|
||||
"missing post-hook"
|
||||
(read-config-file (config-sample-filename 1)))
|
||||
|
||||
(test-error
|
||||
"missing store size"
|
||||
(read-config-file (config-sample-filename 2)))
|
||||
|
||||
(test-error
|
||||
"missing name"
|
||||
(read-config-file (config-sample-filename 3)))
|
||||
|
||||
(test-error
|
||||
"missing url"
|
||||
(read-config-file (config-sample-filename 4)))
|
||||
|
||||
(test-error
|
||||
"missing type"
|
||||
(read-config-file (config-sample-filename 5)))
|
||||
|
||||
(test-error
|
||||
"missing opts"
|
||||
(read-config-file (config-sample-filename 6)))
|
||||
|
||||
(test-end "reading the configuration")
|
||||
|
||||
(test-begin "writing the configuration")
|
||||
|
||||
(test-equal "saving to a file, checking consistency"
|
||||
sample-configuration
|
||||
(let* ((directory (or (getenv "TMPDIR") "/tmp"))
|
||||
(template (string-append directory "/lieferhund.XXXXXX"))
|
||||
(out (mkstemp! template))
|
||||
(_ (close out))
|
||||
(_ (save-config-file template sample-configuration))
|
||||
(_ (flush-all-ports))
|
||||
(rconfig (read-config-file template))
|
||||
(_ (delete-file template)))
|
||||
rconfig))
|
||||
|
||||
(test-end "writing the configuration")
|
||||
|
|
@ -0,0 +1,212 @@
|
|||
;;
|
||||
;; Copyright © 2021 kitzman <kitzman @ disroot . org>
|
||||
;;
|
||||
|
||||
(use-modules (lieferhund db)
|
||||
(lieferhund proto)
|
||||
(lieferhund config)
|
||||
(srfi srfi-1)
|
||||
(srfi srfi-64)
|
||||
(srfi srfi-19)
|
||||
(srfi srfi-69)
|
||||
(ice-9 pretty-print))
|
||||
|
||||
;;
|
||||
;; Utilities
|
||||
;;
|
||||
|
||||
(define (db->sexp-db db)
|
||||
(make-channel-database
|
||||
(hash-table->alist (database-tables db))))
|
||||
|
||||
;;
|
||||
;; Test data
|
||||
;;
|
||||
|
||||
;; Date data
|
||||
(define test-db-date-str "10 June 2020 16:16:09 Z")
|
||||
(define test-db-date (make-date 0 9 16 16 10 6 2020 0))
|
||||
|
||||
;; Db data
|
||||
(define test-table-name0 "lwn")
|
||||
(define test-table-name1 "julia evans")
|
||||
(define test-table-name2 "lala")
|
||||
|
||||
(define test-table-url0 "https://lwn.net/headlines/newrss")
|
||||
(define test-table-url1 "https://jvns.ca/atom.xml")
|
||||
|
||||
(define test-config-entries
|
||||
`(,(make-configuration-entry
|
||||
test-table-name0
|
||||
test-table-url0
|
||||
'rss
|
||||
'(()))
|
||||
,(make-configuration-entry
|
||||
test-table-name1
|
||||
test-table-url1
|
||||
'rss
|
||||
'(()))
|
||||
,(make-configuration-entry
|
||||
test-table-name2
|
||||
test-table-url1
|
||||
'rss
|
||||
'(()))))
|
||||
|
||||
(define test-config
|
||||
(make-configuration
|
||||
10
|
||||
test-config-entries
|
||||
#f))
|
||||
|
||||
(define test-entries0
|
||||
`(,(make-feed-entry
|
||||
"Security updates for Saturday"
|
||||
"a"
|
||||
"https://lwn.net/Articles/862487/rss"
|
||||
"10 July 2021 23:58:13 Z")
|
||||
,(make-feed-entry
|
||||
"Announcing Arti, a pure-Rust Tor implementation (Tor blog)"
|
||||
"b"
|
||||
"https://lwn.net/Articles/862329/rss"
|
||||
"09 July 2021 18:05:12 Z")))
|
||||
|
||||
(define test-entries1
|
||||
`(,(make-feed-entry
|
||||
"Write good examples by starting with real code"
|
||||
""
|
||||
"https://jvns.ca/blog/2021/07/08/writing-great-examples/"
|
||||
"08 July 2021 11:00:46 Z")
|
||||
,(make-feed-entry
|
||||
"Reasons why bugs might feel \"impossible\""
|
||||
""
|
||||
"https://jvns.ca/blog/2021/06/08/reasons-why-bugs-might-feel-impossible/"
|
||||
"08 June 2021 09:28:08 Z")))
|
||||
|
||||
(define test-extra-entries
|
||||
`(,(make-feed-entry
|
||||
"Random title"
|
||||
"Random description"
|
||||
"https://lwn.net/Articles/1234567890/rss"
|
||||
"16 July 2021 18:05:12 Z")))
|
||||
|
||||
(define test-table0
|
||||
(make-channel-table
|
||||
test-table-name0
|
||||
test-table-url0
|
||||
(false-if-exception
|
||||
(string->date
|
||||
"11 July 2021 20:45:25 +0300"
|
||||
db-date-format))
|
||||
test-entries0))
|
||||
|
||||
(define test-table0-trunc
|
||||
(make-channel-table
|
||||
test-table-name0
|
||||
test-table-url0
|
||||
(false-if-exception
|
||||
(string->date
|
||||
"11 July 2021 20:45:25 +0300"
|
||||
db-date-format))
|
||||
`(,(car test-entries0))))
|
||||
|
||||
(define test-table1
|
||||
(make-channel-table
|
||||
test-table-name1
|
||||
test-table-url1
|
||||
(false-if-exception
|
||||
(string->date
|
||||
"11 July 2021 20:45:27 +0300"
|
||||
db-date-format))
|
||||
test-entries1))
|
||||
|
||||
(define test-db
|
||||
(make-channel-database
|
||||
(database-tables-list->database-tables
|
||||
`(,test-table0 ,test-table1))))
|
||||
|
||||
;;
|
||||
;; Date tests
|
||||
;;
|
||||
|
||||
(test-begin "testing date format")
|
||||
|
||||
(test-equal "to-string conversion"
|
||||
test-db-date
|
||||
(string->date test-db-date-str db-date-format))
|
||||
|
||||
(test-equal "from-string conversion"
|
||||
test-db-date-str
|
||||
(date->string test-db-date db-date-format))
|
||||
|
||||
(test-end "testing date format")
|
||||
|
||||
;;
|
||||
;; Database parsing
|
||||
;;
|
||||
|
||||
(define (db-sample no)
|
||||
(format #f "tests/data/sample-db~a.scm" no))
|
||||
|
||||
(test-begin "database parsing")
|
||||
|
||||
(test-equal "db reading"
|
||||
(db->sexp-db test-db)
|
||||
(db->sexp-db (read-database (db-sample 0))))
|
||||
|
||||
(test-equal "db writing, and consistency check"
|
||||
(db->sexp-db test-db)
|
||||
(let* ((directory (or (getenv "TMPDIR") "/tmp"))
|
||||
(template (string-append directory "/lieferhund.XXXXXX"))
|
||||
(out (mkstemp! template))
|
||||
(_ (close out))
|
||||
(_ (save-database template test-db))
|
||||
(_ (flush-all-ports))
|
||||
(rdb (read-database template))
|
||||
(_ (delete-file template)))
|
||||
(db->sexp-db rdb)))
|
||||
|
||||
(test-end "database parsing")
|
||||
|
||||
;;
|
||||
;; Database operations
|
||||
;;
|
||||
|
||||
(test-begin "database operations")
|
||||
|
||||
(test-assert "db exists"
|
||||
(and (database-has-table test-db test-table-name0)
|
||||
(database-has-table test-db test-table-name1)))
|
||||
|
||||
(test-group
|
||||
"db get"
|
||||
(test-equal "table 0"
|
||||
test-table0
|
||||
(database-get test-db test-table-name0))
|
||||
(test-equal "table 1"
|
||||
test-table1
|
||||
(database-get test-db test-table-name1)))
|
||||
|
||||
(test-equal
|
||||
"db insert (existing table, no new config entries)"
|
||||
test-extra-entries
|
||||
(database-insert-entries!
|
||||
test-db
|
||||
test-config
|
||||
(car test-config-entries)
|
||||
test-extra-entries))
|
||||
|
||||
(test-equal
|
||||
"db insert (new table, new config tables))"
|
||||
test-extra-entries
|
||||
(database-insert-entries!
|
||||
test-db
|
||||
test-config
|
||||
(caddr test-config-entries)
|
||||
test-extra-entries))
|
||||
|
||||
(test-equal
|
||||
"db truncation"
|
||||
test-table0-trunc
|
||||
((@@ (lieferhund db) table-cleanup) test-table0 1))
|
||||
|
||||
(test-begin "database operations")
|
||||
|
|
@ -0,0 +1,231 @@
|
|||
;;
|
||||
;; Copyright © 2021 kitzman <kitzman @ disroot . org>
|
||||
;;
|
||||
|
||||
(use-modules (lieferhund processor)
|
||||
(lieferhund config)
|
||||
(lieferhund proto)
|
||||
((lieferhund db) :prefix db:)
|
||||
(srfi srfi-1)
|
||||
(srfi srfi-19)
|
||||
(ice-9 match))
|
||||
;;
|
||||
;; Test data
|
||||
;;
|
||||
|
||||
(define test-table-name "lwn")
|
||||
|
||||
(define test-table-url "https://lwn.net/headlines/newrss")
|
||||
|
||||
(define test-config-entry0
|
||||
(make-configuration-entry
|
||||
test-table-name
|
||||
test-table-url
|
||||
'dummy
|
||||
'(())))
|
||||
|
||||
(define test-config-entry1
|
||||
(make-configuration-entry
|
||||
test-table-name
|
||||
test-table-url
|
||||
'another-dummy
|
||||
'(())))
|
||||
|
||||
(define test-config
|
||||
(make-configuration
|
||||
10
|
||||
`(,test-config-entry0)
|
||||
#f))
|
||||
|
||||
(define test-config-multi
|
||||
(make-configuration
|
||||
10
|
||||
`(,test-config-entry0 ,test-config-entry1)
|
||||
#f))
|
||||
|
||||
(define test-items
|
||||
`((,test-config-entry0
|
||||
(,(make-feed-entry
|
||||
"a"
|
||||
"a desc"
|
||||
"scheme://lala_a"
|
||||
"20 June 2020 06:06:06 Z")
|
||||
,(make-feed-entry
|
||||
"b"
|
||||
"b desc"
|
||||
"scheme://lala_b"
|
||||
"16 June 2020 06:06:06 Z")))))
|
||||
|
||||
(define test-items-multi
|
||||
`((,test-config-entry0
|
||||
(,(make-feed-entry
|
||||
"a"
|
||||
"a desc"
|
||||
"scheme://lala_a"
|
||||
"20 June 2020 06:06:06 Z")
|
||||
,(make-feed-entry
|
||||
"b"
|
||||
"b desc"
|
||||
"scheme://lala_b"
|
||||
"16 June 2020 06:06:06 Z")))
|
||||
(,test-config-entry1
|
||||
(,(make-feed-entry
|
||||
"a"
|
||||
"a desc"
|
||||
"scheme://lala_a"
|
||||
"20 June 2020 06:06:06 Z")
|
||||
,(make-feed-entry
|
||||
"b"
|
||||
"b desc"
|
||||
"scheme://lala_b"
|
||||
"16 June 2020 06:06:06 Z")))))
|
||||
|
||||
(define test-items-flattened
|
||||
`((,test-config-entry0
|
||||
,(make-feed-entry
|
||||
"a"
|
||||
"a desc"
|
||||
"scheme://lala_a"
|
||||
"20 June 2020 06:06:06 Z"))
|
||||
(,test-config-entry0
|
||||
,(make-feed-entry
|
||||
"b"
|
||||
"b desc"
|
||||
"scheme://lala_b"
|
||||
"16 June 2020 06:06:06 Z"))))
|
||||
|
||||
(define test-items-flattened-sorted
|
||||
`((,test-config-entry0
|
||||
,(make-feed-entry
|
||||
"b"
|
||||
"b desc"
|
||||
"scheme://lala_b"
|
||||
"16 June 2020 06:06:06 Z"))
|
||||
(,test-config-entry0
|
||||
,(make-feed-entry
|
||||
"a"
|
||||
"a desc"
|
||||
"scheme://lala_a"
|
||||
"20 June 2020 06:06:06 Z"))))
|
||||
|
||||
;;
|
||||
;; Preprocessing functions
|
||||
;;
|
||||
|
||||
(test-begin "preprocessing functions")
|
||||
|
||||
(test-equal "sorting"
|
||||
test-items-flattened-sorted
|
||||
((@@ (lieferhund processor) preprocess-sort) test-items-flattened))
|
||||
|
||||
(test-equal "flatten"
|
||||
test-items-flattened
|
||||
((@@ (lieferhund processor) preprocess-flatten) test-items))
|
||||
|
||||
(test-end "preprocessing functions")
|
||||
|
||||
;;
|
||||
;; Processing function
|
||||
;;
|
||||
|
||||
(test-begin "hook processing function")
|
||||
|
||||
(test-equal "no hook"
|
||||
'()
|
||||
(process test-config test-items #f))
|
||||
|
||||
(define result '())
|
||||
(test-equal "process each hook"
|
||||
'("b" "a")
|
||||
(begin
|
||||
(process
|
||||
test-config
|
||||
test-items
|
||||
'(process-each
|
||||
(lambda (config-entry item)
|
||||
(set! result (append result `(,(entry-title item)))))))
|
||||
result))
|
||||
|
||||
|
||||
(define result '())
|
||||
(test-equal "process each channel hook"
|
||||
test-items
|
||||
(begin
|
||||
(process
|
||||
test-config
|
||||
test-items
|
||||
'(process-each-channel
|
||||
(lambda (config-entry items)
|
||||
(set!
|
||||
result
|
||||
(cons
|
||||
`(,config-entry ,items)
|
||||
result)))))
|
||||
result))
|
||||
|
||||
(test-equal "hook generation"
|
||||
'(("xa" "xb"))
|
||||
(process
|
||||
test-config
|
||||
test-items
|
||||
'(hook-gen
|
||||
(lambda (p)
|
||||
(lambda (pair-entries)
|
||||
(map
|
||||
(lambda (pair-entry)
|
||||
(map
|
||||
(lambda (item)
|
||||
(string-append p (entry-title item)))
|
||||
(cadr pair-entry)))
|
||||
pair-entries)))
|
||||
"x")))
|
||||
|
||||
|
||||
(define result '())
|
||||
(test-equal "hook cons"
|
||||
'(#t #t)
|
||||
(begin
|
||||
(process
|
||||
test-config
|
||||
test-items
|
||||
'(hook-cons
|
||||
(lambda (_)
|
||||
(set!
|
||||
result
|
||||
(cons #t result)))
|
||||
(lambda (_)
|
||||
(set!
|
||||
result
|
||||
(cons #t result)))))
|
||||
result))
|
||||
|
||||
(define result '())
|
||||
(test-equal "hook match type"
|
||||
'((#t) (#t))
|
||||
(begin
|
||||
(process
|
||||
test-config
|
||||
test-items
|
||||
`(hook-match-type
|
||||
(dummy
|
||||
(lambda (_)
|
||||
(set!
|
||||
result
|
||||
(cons '(#t) result))))
|
||||
(dummy-another
|
||||
(lambda (_)
|
||||
(set!
|
||||
result
|
||||
(cons '(#t) result))))))
|
||||
(format #t "~a\n" result)
|
||||
result))
|
||||
|
||||
(test-equal "hook generic"
|
||||
#t
|
||||
(process
|
||||
test-config
|
||||
test-items
|
||||
'(lambda (_) #t)))
|
||||
|
||||
|
||||
(test-end "hook processing function")
|
||||
|
|
@ -0,0 +1,134 @@
|
|||
;;
|
||||
;; Copyright © 2021 kitzman <kitzman @ disroot . org>
|
||||
;;
|
||||
|
||||
(use-modules (lieferhund proto)
|
||||
(lieferhund config)
|
||||
(lieferhund db))
|
||||
|
||||
;;
|
||||
;; Test data
|
||||
;;
|
||||
|
||||
(fluid-set!
|
||||
lieferhund-proto-map
|
||||
`((dummy0 . (,(lambda (config-entry) '(a))
|
||||
,(lambda (response-items) '(a))))
|
||||
(dummy1 . (,(lambda (config-entry) #f)
|
||||
,(lambda (response-items) '(a))))
|
||||
(dummy2 . (,(lambda (config-entry) '(a))
|
||||
,(lambda (response-items) '())))))
|
||||
|
||||
;; Db data
|
||||
(define test-table-name0 "lwn")
|
||||
|
||||
(define test-table-url0 "https://lwn.net/headlines/newrss")
|
||||
|
||||
(define test-config-entries
|
||||
`(,(make-configuration-entry
|
||||
test-table-name0
|
||||
test-table-url0
|
||||
'dummy0
|
||||
'(()))
|
||||
,(make-configuration-entry
|
||||
test-table-name0
|
||||
test-table-url0
|
||||
'dummy1
|
||||
'(()))
|
||||
,(make-configuration-entry
|
||||
test-table-name0
|
||||
test-table-url0
|
||||
'dummy2
|
||||
'(()))
|
||||
,(make-configuration-entry
|
||||
test-table-name0
|
||||
test-table-url0
|
||||
'dummy3
|
||||
'(()))))
|
||||
|
||||
(define test-config
|
||||
(make-configuration
|
||||
10
|
||||
test-config-entries
|
||||
#f))
|
||||
|
||||
(define test-entries0
|
||||
`(,(make-feed-entry
|
||||
"Security updates for Saturday"
|
||||
"a"
|
||||
"https://lwn.net/Articles/862487/rss"
|
||||
"10 July 2021 23:58:13 Z")
|
||||
,(make-feed-entry
|
||||
"Announcing Arti, a pure-Rust Tor implementation (Tor blog)"
|
||||
"b"
|
||||
"https://lwn.net/Articles/862329/rss"
|
||||
"09 July 2021 18:05:12 Z")))
|
||||
|
||||
(define test-table
|
||||
(make-channel-table
|
||||
test-table-name0
|
||||
test-table-url0
|
||||
(false-if-exception
|
||||
(string->date
|
||||
"11 July 2021 20:45:25 +0300"
|
||||
db-date-format))
|
||||
test-entries0))
|
||||
|
||||
(define test-db
|
||||
(make-channel-database
|
||||
(database-tables-list->database-tables
|
||||
`(,test-table))))
|
||||
|
||||
;;
|
||||
;; Proto map functions
|
||||
;;
|
||||
|
||||
(test-begin "testing the proto map functions")
|
||||
|
||||
(test-assert "map retrieval fn, correct proto behaviour"
|
||||
((@@ (lieferhund proto) proto-map-retrieval-fn) 'dummy0))
|
||||
|
||||
(test-assert "map retrieval fn, wrong proto behaviour"
|
||||
(not ((@@ (lieferhund proto) proto-map-retrieval-fn) 'dummy9)))
|
||||
|
||||
(test-assert "map parsing fn, correct proto behaviour"
|
||||
((@@ (lieferhund proto) proto-map-parse-fn) 'dummy0))
|
||||
|
||||
(test-assert "map parsing fn, wrong proto behaviour"
|
||||
(not ((@@ (lieferhund proto) proto-map-parse-fn) 'dummy9)))
|
||||
|
||||
;;
|
||||
;; Retrieval test
|
||||
;;
|
||||
|
||||
(test-begin "testing the retrieval of entries")
|
||||
|
||||
(test-assert "failsafety in case feed type is not found"
|
||||
(not
|
||||
(retrieve-feed-entries
|
||||
(cadddr test-config-entries)
|
||||
test-config
|
||||
test-db)))
|
||||
|
||||
(test-equal "failed retrieval"
|
||||
`(,(cadr test-config-entries) ())
|
||||
(retrieve-feed-entries
|
||||
(cadr test-config-entries)
|
||||
test-config
|
||||
test-db))
|
||||
|
||||
(test-equal "failed parsing"
|
||||
`(,(caddr test-config-entries) ())
|
||||
(retrieve-feed-entries
|
||||
(caddr test-config-entries)
|
||||
test-config
|
||||
test-db))
|
||||
|
||||
(test-equal "working feed retrieval"
|
||||
`(,(car test-config-entries) (a))
|
||||
(retrieve-feed-entries
|
||||
(car test-config-entries)
|
||||
test-config
|
||||
test-db))
|
||||
|
||||
(test-end "testing the retrieval of entries")
|
||||
Loading…
Reference in New Issue