1
0
Fork 0
tinmop/src/gemini/subscription.lisp

96 lines
4.0 KiB
Common Lisp
Raw Normal View History

;; tinmop: an humble gemini and pleroma client
;; Copyright (C) 2020 cage
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :gemini-subscription)
(defun link-post-timestamp (link-text)
"Returns a local-time object parsing a gemlog entry's link text
A link text entry is like 'aaaa-mm-dd post title'
This function parses the 'aaaa-mm-dd' part.
"
(when (>= (length link-text) 10)
(local-time:parse-timestring link-text :start 0 :end 10 :fail-on-error nil)))
(defun link-post-title (link-text)
"Returns the title of gemlog entry from link text
A link text entry is like 'aaaa-mm-dd post title'
This function return the 'post-title' substring."
(misc:safe-subseq link-text 10))
(defun link-post-timestamp-p (link-text)
"Is this a valid gemlog link text?"
(link-post-timestamp link-text))
(defun subscribe (url)
"Subscribe to a gemlog that can be found at 'url'"
(labels ((subtitle-p (nodes h2-pos)
(when h2-pos
(let ((res t))
(loop for i from (1- h2-pos) downto 0 do
(let ((node (elt nodes i)))
(when (and node
(not (html-utils:tag= :h1
node)))
(return-from subtitle-p nil))))
res))))
(when-let* ((data (slurp-gemini-url url))
(page (text-utils:to-s data))
(parsed (parse-gemini-file page :initialize-parser t))
(iri (iri:iri-parse url))
2021-08-16 14:22:47 +02:00
(title (gemini-first-h1 parsed)))
(let* ((maybe-subtitle-pos (html-utils:position-tag :h2 parsed))
(subtitle (when (subtitle-p parsed maybe-subtitle-pos)
(first (html-utils:children (elt parsed
maybe-subtitle-pos))))))
(when (not (db:gemini-find-subscription url))
(db:gemini-subscribe-url url title subtitle))
t))))
(defun refresh-subscription-low-level (url)
(when-let* ((data (slurp-gemini-url url))
(page (text-utils:to-s data))
(parsed (parse-gemini-file page :initialize-parser t))
(gemlog-iri (iri:iri-parse url)))
(let ((links (remove-if-not (lambda (a) (link-post-timestamp-p (name a)))
(sexp->links parsed
(uri:host gemlog-iri)
(uri:port gemlog-iri)
(uri:path gemlog-iri)
(uri:query gemlog-iri))))
(new-posts-count 0))
(loop for link in links do
(when (not (db:find-gemlog-entry (to-s (target link))))
(incf new-posts-count)
(let ((date (link-post-timestamp (name link))))
(db:add-gemlog-entries (to-s gemlog-iri)
(target link)
(link-post-title (name link))
date
nil))))
new-posts-count)))
(defun refresh (url)
"Refresh gemlog entries that can be found at 'url'. The gemlog must
be subscribed before (see: 'gemini-subscription:subcribe'"
(handler-case
(refresh-subscription-low-level url)
(gemini-client:gemini-tofu-error (e)
2021-06-18 17:48:56 +02:00
(ui:ask-input-on-tofu-error e (lambda () (refresh url))))))