cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [gemini] 

Started with gemlog subscription, added database table and interface
  and subscribing API.
This commit is contained in:
cage 2021-01-08 18:21:43 +01:00
parent 756cce52c4
commit 7e32091b6f
8 changed files with 279 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
src/db.lisp
View File

@ -122,6 +122,12 @@
(define-constant +table-gemini-tofu-cert+ :gemini-tofu-cert
:test #'eq)
(define-constant +table-gemini-subscription+ :gemini-subscription
:test #'eq)
(define-constant +table-gemlog-entries+ :gemlog-entries
:test #'eq)
(define-constant +federated-timeline+ "federated"
:test #'string=)
@ -525,6 +531,35 @@
" UNIQUE(host) ON CONFLICT FAIL"
+make-close+)))
(defun make-gemini-subscription ()
(query-low-level (strcat (prepare-table +table-gemini-subscription+
:autoincrementp nil
:autogenerated-id-p nil)
" url TEXT PRIMARY KEY, "
" title TEXT, "
" subtitle TEXT "
+make-close+)))
(defun make-gemlog-entries ()
(query-low-level (strcat (prepare-table +table-gemlog-entries+
:autoincrementp nil
:autogenerated-id-p nil)
" url TEXT PRIMARY KEY, "
" \"gemlog-id\" TEXT NON NULL "
(make-foreign +table-gemini-subscription+
:url
+cascade+
+cascade+
t)
;; timestamp
" date TEXT NOT NULL, "
" title TEXT, "
" snippet TEXT, "
;; boolean
" seenp INTEGER DEFAULT 0, "
" UNIQUE(url) ON CONFLICT FAIL"
+make-close+)))
(defun build-all-indices ()
(create-table-index +table-status+ '(:folder :timeline :status-id))
(create-table-index +table-account+ '(:id :acct))
@ -535,7 +570,9 @@
(create-table-index +table-pagination-status+ '(:folder :timeline :status-id))
(create-table-index +table-conversation+ '(:id))
(create-table-index +table-cache+ '(:id :key))
(create-table-index +table-gemini-tofu-cert+ '(:host)))
(create-table-index +table-gemini-tofu-cert+ '(:host))
(create-table-index +table-gemini-subscription+ '(:url))
(create-table-index +table-gemlog-entries+ '(:url)))
(defmacro gen-delete (suffix &rest names)
`(progn
@ -560,7 +597,9 @@
+table-poll+
+table-chat-message+
+table-chat+
+table-gemini-tofu-cert+))
+table-gemini-tofu-cert+
+table-gemini-subscription+
+table-gemlog-entries+))
(defun build-views ())
@ -592,6 +631,8 @@
(make-chat-message)
(make-chat)
(make-tofu-certs)
(make-gemini-subscription)
(make-gemlog-entries)
(build-all-indices)
(fs:set-file-permissions (db-path) (logior fs:+s-irusr+ fs:+s-iwusr+))))
@ -1734,6 +1775,8 @@ row."
(gen-access-message-row cache-created-at :created-at)
(gen-access-message-row seenp :seenp)
(defun row-votes-count (row)
(and row (db-getf row :votes-count 0)))
@ -2816,3 +2859,79 @@ than `days-in-the-past' days (default: `(swconf:config-purge-cache-days-offset)'
(:= :type +cache-tls-certificate-type+)))
(order-by (:desc :updated-at)))))
(fetch-all-rows query)))
(defun gemini-subscribe-url (url title subtitle)
(query (make-insert +table-gemini-subscription+
(:url :title :subtitle)
(url title subtitle))))
(defun gemini-find-subscription (url)
(when-let* ((query (select :*
(from +table-gemini-subscription+)
(where (:= :url url))))
(row (fetch-single query)))
row))
(defun find-gemlog-entry (post-url)
(when-let* ((query (select :*
(from +table-gemlog-entries+)
(where (:= :url post-url))))
(row (fetch-single query)))
row))
(defun add-gemlog-entries (gemlog-iri post-url post-title post-date seenp)
(query (make-insert +table-gemlog-entries+
(:url
:gemlog-id
:date
:title
:seenp)
(post-url
gemlog-iri
post-date
post-title
(prepare-for-db seenp :to-integer t)))))
(defun gemlog-mark-as-seen (post-url)
(let ((update-query (make-update +table-gemlog-entries+
(:seenp)
((prepare-for-db t :to-integer t))
(:= :url post-url))))
(query update-query)))
(gen-access-message-row gemlog-url :gemlog-url)
(gen-access-message-row gemlog-title :gemlog-title)
(gen-access-message-row gemlog-subtitle :gemlog-subtitle)
(gen-access-message-row post-date :post-date)
(gen-access-message-row post-title :post-title)
(defun gemlog-entries (gemlog-url &key (unseen-only nil) (seen-only nil))
(assert (not (and unseen-only
seen-only)))
(when-let* ((query (select ((:as :gemini-subscription.url :gemlog-url)
(:as :gemini-subscription.title :gemlog-title)
(:as :gemini-subscription.subtitle :gemlog-subtitle)
(:as :gemlog-entries.date :post-date)
(:as :gemlog-entries.title :post-title)
(:as :gemlog-entries.seenp :seenp))
(from :gemlog-entries)
(join :gemini-subscription
:on (:= :gemlog-entries.gemlog-id
:gemini-subscription.url))
(where (:= :gemini-subscription.url gemlog-url))
(order-by (:desc :gemlog-entries.date))))
(rows (fetch-all-rows query)))
(cond
(unseen-only
(remove-if-not (lambda (row) (db-nil-p (row-seenp row))) rows))
(seen-only
(remove-if (lambda (row) (db-nil-p (row-seenp row))) rows))
(t
rows))))
(defun delete-gemlog-entry (gemlog-url)
(query (delete-from +table-gemlog-entries+ (where (:= :url gemlog-url)))))

3
src/gemini/client.lisp
View File

@ -149,6 +149,9 @@
(or (code= code +30+)
(code= code +31+)))
(defun response-success-p (code)
(code= code +20+))
(define-condition gemini-protocol-error (error)
((error-code
:initarg :error-code

18
src/gemini/package.lisp
View File

@ -91,6 +91,7 @@
:response-input-p
:response-sensitive-input-p
:response-redirect-p
:response-success-p
:absolute-url-p
:init-default-gemini-theme
:gemini-file-response
@ -107,3 +108,20 @@
:close-ssl-socket
:make-client-certificate
:request))
(defpackage :gemini-subscription
(:use
:cl
:alexandria
:cl-ppcre
:config
:constants
:text-utils
:misc
:alexandria
:gemini-constants
:gemini-parser
:gemini-client)
(:shadowing-import-from :misc :random-elt :shuffle)
(:export
:subscribe))

106
src/gemini/subscription.lisp Normal file
View File

@ -0,0 +1,106 @@
;; 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 slurp-gemini-url (url)
"Read 'full' data from gemini address `url'; note that specs says
that gemini flow is streamed by default so this function has limited
use as there is a chance that it would not returns. Anyway for gemlog
subscription (for example) could be used.
TODO: No redirection is followed"
(let ((iri (iri:iri-parse url)))
(multiple-value-bind (status description meta response socket)
(gemini-client:request (uri:host iri)
(uri:path iri)
:query (uri:query iri)
:port (uri:port iri)
:fragment (uri:fragment iri))
(declare (ignore meta description))
(when (response-success-p status)
(let ((data (misc:make-fresh-array 0 0 '(unsigned-byte 8) nil)))
(loop for new-byte = (read-byte response nil nil)
while new-byte do
(vector-push-extend new-byte data))
(gemini-client:close-ssl-socket socket)
data)))))
(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.
"
(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 h2-pos downto 0 do
(let ((node (elt nodes i)))
(when (and node
(not (html-utils:tag= :h1
(html-utils:children node))))
(return-from subtitle-p nil))))
res))))
(when-let* ((data (slurp-gemini-url url))
(page (babel:octets-to-string data))
(parsed (parse-gemini-file page))
(iri (iri:iri-parse url)))
(let* ((title (first (html-utils:children (html-utils:find-tag :h1
parsed))))
(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))))))
(db:gemini-subscribe-url url title subtitle)))))
(defun refresh (url)
"Refresh gemlog entries that can be found at 'url'. The gemlog must
be subscribed before (see: 'gemini-subscription:subcribe'"
(when-let* ((data (slurp-gemini-url url))
(page (babel:octets-to-string data))
(parsed (parse-gemini-file page))
(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)))))
(loop for link in links do
(when (not (db:find-gemlog-entry (to-s gemlog-iri)))
(let ((date (link-post-timestamp (name link))))
(db:add-gemlog-entries (to-s gemlog-iri)
(target link)
(link-post-title (name link))
date
nil)))))))

10
src/html-utils.lisp
View File

@ -65,6 +65,16 @@
(attribute-key attribute)))
(attributes node)))
(defun find-tag (tag node)
"find tag on a node list, does not descend into children"
(find-if (lambda (a) (tag= tag a))
node))
(defun position-tag (tag node)
"find position of tag on a node list, does not descend into children"
(position-if (lambda (a) (tag= tag a))
node))
(defun html->text (html &key (add-link-footnotes t))
"Transform html to text, note that if `add-link-footnotes` is non nil footnotes that marks html link in the text are added aftere the body of the message

4
src/misc-utils.lisp
View File

@ -472,8 +472,8 @@ to the array"
(let ((first-byte (read-byte stream nil nil)))
(when first-byte
(let ((raw (loop
for c = (read-byte stream nil 10)
while (/= c 10)
for c = (read-byte stream nil (char-code #\Newline))
while (/= c (char-code #\Newline))
collect c)))
(push first-byte raw)
(when add-newline-stopper

18
src/package.lisp
View File

@ -393,6 +393,8 @@
:children
:tag=
:find-attribute
:find-tag
:position-tag
:html->text))
(defpackage :resources-utils
@ -738,6 +740,7 @@
:+table-attachment+
:+table-saved-status+
:+table-crypto-data+
:+table-gemini-subscription+
:+federated-timeline+
:+local-timeline+
:+home-timeline+
@ -840,6 +843,7 @@
:row-cache-type
:row-cache-accessed-at
:row-cache-created-at
:row-seenp
:next-status-tree
:previous-status-tree
:message-tree-root-equal
@ -944,7 +948,19 @@
:tofu-passes-p
:tofu-delete
:ssl-cert-find
:find-tls-certificates-rows))
:find-tls-certificates-rows
:gemini-subscribe-url
:gemini-find-subscription
:find-gemlog-entry
:add-gemlog-entries
:gemlog-mark-as-seen
:gemlog-url
:gemlog-title
:gemlog-subtitle
:post-date
:post-title
:gemlog-entries
:delete-gemlog-entry))
(defpackage :date-formatter
(:use

3
tinmop.asd
View File

@ -89,7 +89,8 @@
:components ((:file "package")
(:file "gemini-constants")
(:file "gemini-parser")
(:file "client")))
(:file "client")
(:file "subscription")))
(:file "command-line")
(:file "specials")
(:file "keybindings")