128 lines
3.8 KiB
Scheme
128 lines
3.8 KiB
Scheme
|
#!/usr/bin/guile \
|
||
|
-e main -s
|
||
|
!#
|
||
|
|
||
|
;;
|
||
|
;; Copyright © 2021 kitzman <kitzman @ disroot . org>
|
||
|
;;
|
||
|
|
||
|
(use-modules (lieferhund config)
|
||
|
(lieferhund db)
|
||
|
(lieferhund processor)
|
||
|
(lieferhund proto atom)
|
||
|
(lieferhund hooks printer)
|
||
|
(srfi srfi-19)
|
||
|
(srfi srfi-98)
|
||
|
(ice-9 match)
|
||
|
(ice-9 getopt-long))
|
||
|
|
||
|
(define default-config-path (string-append
|
||
|
(get-environment-variable "HOME")
|
||
|
"/.config/lieferhund/config.scm"))
|
||
|
(define default-db-path (string-append
|
||
|
(get-environment-variable "HOME")
|
||
|
"/.share/lieferhund/db.scm"))
|
||
|
|
||
|
(define new-database #t)
|
||
|
|
||
|
(false-if-exception (mkdir (dirname (dirname default-db-path))))
|
||
|
(false-if-exception (mkdir (dirname default-db-path)))
|
||
|
|
||
|
(define (main args)
|
||
|
(let* ((option-spec '((help (single-char #\h) (value #f))
|
||
|
(command (single-char #\x) (value #t))
|
||
|
(config-file (single-char #\c) (value #t))
|
||
|
(db-file (single-char #\b) (value #t))))
|
||
|
(options (getopt-long args option-spec))
|
||
|
(help-wanted (option-ref options 'help #f))
|
||
|
(command (option-ref options 'command #f))
|
||
|
(config-file (option-ref options 'config-file
|
||
|
default-config-path))
|
||
|
(db-file (option-ref options 'config-file
|
||
|
default-db-path)))
|
||
|
(if (or help-wanted (equal? command #f))
|
||
|
(begin
|
||
|
(display "\
|
||
|
lieferhund.scm (version 0.1)
|
||
|
|
||
|
Usage: ./lieferhund.scm -c <config file> -b <db file> -x <command>
|
||
|
<config file> - path to the configuration file
|
||
|
<db file> - path to the database file
|
||
|
<command> - one of \"pull\",\"read\",\"give-treat\"
|
||
|
")
|
||
|
(exit 0)))
|
||
|
(if (not (access? config-file R_OK))
|
||
|
(begin
|
||
|
(display "config file not found\n")
|
||
|
(flush-all-ports)
|
||
|
(exit 1)))
|
||
|
(if (access? (dirname db-file) (logior R_OK W_OK))
|
||
|
(if (file-exists? db-file)
|
||
|
(if (access? db-file (logior R_OK W_OK))
|
||
|
(set! new-database #f)
|
||
|
(begin
|
||
|
(display "unable to find/access db file\n")
|
||
|
(flush-all-ports)
|
||
|
(exit 1)))
|
||
|
(set! new-database #t))
|
||
|
(begin
|
||
|
(display "unable to find/access db directory\n")
|
||
|
(flush-all-ports)
|
||
|
(exit 1)))
|
||
|
(match command
|
||
|
("pull"
|
||
|
(let* ((conf (read-config-file config-file))
|
||
|
(db (if new-database
|
||
|
(make-channel-database
|
||
|
(database-tables-list->database-tables '()))
|
||
|
(read-database db-file)))
|
||
|
(new-news-items
|
||
|
(map-in-order
|
||
|
(lambda (entry)
|
||
|
(format #t "processing item \"~a\" (~a)\n"
|
||
|
(config-entry-name entry)
|
||
|
(config-entry-url entry))
|
||
|
(let* ((news-response (request-feed (config-entry-url entry)))
|
||
|
(news-entries (if (equal? news-response #f)
|
||
|
#f
|
||
|
(process-atom-feed-response
|
||
|
news-response)))
|
||
|
(new-items (if (equal? news-response #f)
|
||
|
'()
|
||
|
(database-insert-entries!
|
||
|
db conf entry news-entries))))
|
||
|
(if (equal? news-response #f)
|
||
|
(format #t "failed to get response!\n")
|
||
|
(format #t "new items: ~a\n" (length new-items)))
|
||
|
`(,entry ,new-items)))
|
||
|
(configuration-entries conf))))
|
||
|
(save-database db-file db)
|
||
|
(display "database saved\n")
|
||
|
(process conf new-news-items)))
|
||
|
("read"
|
||
|
(let* ((conf (read-config-file config-file))
|
||
|
(db (if new-database
|
||
|
(begin
|
||
|
(display "cannot read from an empty database\n")
|
||
|
(exit 1))
|
||
|
(read-database db-file)))
|
||
|
(news-items (map
|
||
|
(lambda (conf-entry)
|
||
|
(let* ((entry-name (config-entry-name conf-entry))
|
||
|
(entry-table (database-get db entry-name)))
|
||
|
(if (equal? entry-table #f)
|
||
|
(begin
|
||
|
(format #t "could not find entry with name \"~a\"\n" entry-name)
|
||
|
'())
|
||
|
`(,conf-entry ,(channel-table-entries entry-table)))))
|
||
|
(configuration-entries conf))))
|
||
|
(process conf news-items (make-printer-hook))))
|
||
|
("give-treat"
|
||
|
(begin
|
||
|
(display "woof woof\n")
|
||
|
(exit 0)))
|
||
|
(_
|
||
|
(begin
|
||
|
(display "unknown command\n")
|
||
|
(exit 1))))))
|