cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-13 07:30:35 +01:00
Code Issues

- added a directory to store gempub, the software will sync the directory's contents with its internal metadata database.

Browse Source
This commit is contained in:
cage 2021-08-23 18:20:11 +02:00
parent ff5f8f0cd7
commit a8dca176f3
9 changed files with 233 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
etc/shared.conf
View File

@ -41,6 +41,10 @@ editor = "nano --locking"
# (default 'no', change to 'yes' if desired) # (default 'no', change to 'yes' if desired)
start.update.gemlog = yes start.update.gemlog = yes
# directory to scan for gempub files
gempub.directory.library = /home/cage/lisp/tinmop/
# close links window when opening the selected link # close links window when opening the selected link
open-message-link-window.close-after-select = yes open-message-link-window.close-after-select = yes

3
src/db-utils.lisp
View File

@ -331,7 +331,6 @@ example
example example
(make-delete :table-name (make-delete :table-name
(:col-a :col-b)
(:and (:= col-a 1) (:and (:= col-a 1)
(:= col-b 2))) (:= col-b 2)))
" "
@ -343,7 +342,7 @@ example
example example
(make-delete :table-name (make-update :table-name
(:col-a :col-b) (:col-a :col-b)
(1 2) (1 2)
(:and (:= col-a 1) (:and (:= col-a 1)

100
src/db.lisp
View File

@ -591,15 +591,15 @@
" \"local-uri\" TEXT, " " \"local-uri\" TEXT, "
" \"original-uri\" TEXT, " " \"original-uri\" TEXT, "
" title TEXT, " " title TEXT, "
" gpubVersion TEXT, " " \"gpub-version\" TEXT, "
" \"index\" TEXT, " " \"index-file\" TEXT, "
" author TEXT, " " author TEXT, "
" language TEXT, " " language TEXT, "
" charset TEXT, " " charset TEXT, "
" description TEXT, " " description TEXT, "
" published TEXT, " " published TEXT, "
" publishDate TEXT, " " \"publish-date\" TEXT, "
" revisionDate TEXT, " " \"revision-date\" TEXT, "
" copyright TEXT, " " copyright TEXT, "
" license TEXT, " " license TEXT, "
" version TEXT, " " version TEXT, "
@ -1861,6 +1861,34 @@ row."
(gen-access-message-row section :section) (gen-access-message-row section :section)
(gen-access-message-row local-uri :local-uri)
(gen-access-message-row original-uri :original-uri)
(gen-access-message-row gpub-version :gpub-version)
(gen-access-message-row index-file :index-file)
(gen-access-message-row author :author)
(gen-access-message-row language :language)
(gen-access-message-row charset :charset)
(gen-access-message-row publishedp :published)
(gen-access-message-row publish-date :publish-date)
(gen-access-message-row revision-date :revision-date)
(gen-access-message-row copyright :copyright)
(gen-access-message-row license :license)
(gen-access-message-row version :version)
(gen-access-message-row cover :cover)
(defun row-votes-count (row) (defun row-votes-count (row)
(and row (db-getf row :votes-count :default 0))) (and row (db-getf row :votes-count :default 0)))
@ -3170,3 +3198,67 @@ days in the past"
(defun bookmark-delete (id) (defun bookmark-delete (id)
(delete-by-id +table-bookmark+ id)) (delete-by-id +table-bookmark+ id))
(defun gempub-metadata-add (local-uri
&optional
original-uri
title
gpub-version
index-file
author
language
charset
description
published
publish-date
revision-date
copyright
license
version
cover)
(assert (stringp local-uri))
(with-db-current-timestamp (now)
(query (make-insert +table-gempub-metadata+
(:local-uri
:original-uri
:title
:gpub-version
:index-file
:author
:language
:charset
:description
:published
:publish-date
:revision-date
:copyright
:license
:version
:cover
:created-at)
(local-uri
original-uri
title
gpub-version
index-file
author
language
charset
description
published
publish-date
revision-date
copyright
license
version
cover
now)))))
(defun all-gempub-metadata ()
(query (select :* (from +table-gempub-metadata+))))
(defun gempub-metadata-delete (local-uri)
(query (delete-from +table-gempub-metadata+ (where (:= :local-uri local-uri)))))
(defun gempub-metadata-find (local-uri)
(query (select :* (from +table-gempub-metadata+) (where (:= :local-uri local-uri)))))

20
src/filesystem-utils.lisp
View File

@ -133,6 +133,26 @@
(setf all-paths (sort all-paths #'string<)) (setf all-paths (sort all-paths #'string<))
all-paths)) all-paths))
(defun collect-files/dirs (root)
(let ((all-files '())
(all-dirs '()))
(labels ((collect (dir)
(when (not (member dir all-files :test #'string=))
(let* ((all-children (collect-children dir))
(files (remove-if #'directory-exists-p all-children))
(directories (remove-if (lambda (a)
(or (file-exists-p a)
(string= (path-last-element a) ".")
(string= (path-last-element a) "..")))
all-children)))
(setf all-files (append all-files files))
(setf all-dirs (append all-dirs directories))
(loop for new-dir in directories do
(collect new-dir))))))
(collect root)
(values all-files
all-dirs))))
(defgeneric prepend-pwd (object)) (defgeneric prepend-pwd (object))
(defmethod prepend-pwd ((object string)) (defmethod prepend-pwd ((object string))

43
src/gempub.lisp
View File

@ -70,10 +70,51 @@
(define-constant +metadata-entry-name "metadata.txt" :test #'string=) (define-constant +metadata-entry-name "metadata.txt" :test #'string=)
(defmethod extract-metadata (zip-file) (defun extract-metadata (zip-file)
(when (zip-info:zip-file-p zip-file) (when (zip-info:zip-file-p zip-file)
(let ((entries (zip-info:list-entries zip-file))) (let ((entries (zip-info:list-entries zip-file)))
(when (find +metadata-entry-name entries :test #'String=) (when (find +metadata-entry-name entries :test #'String=)
(when-let ((metadata-raw (os-utils:unzip-single-file zip-file (when-let ((metadata-raw (os-utils:unzip-single-file zip-file
+metadata-entry-name))) +metadata-entry-name)))
(parse 'metadata metadata-raw)))))) (parse 'metadata metadata-raw))))))
(defun save-metadata (zip-file)
(when-let ((metadata (extract-metadata zip-file)))
(db:gempub-metadata-add zip-file
nil
(getf metadata :title)
(getf metadata :gpubVersion)
(getf metadata :index)
(getf metadata :author)
(getf metadata :language)
(getf metadata :charset)
(getf metadata :description)
(getf metadata :published)
(getf metadata :publishDate)
(getf metadata :revisionDate)
(getf metadata :copyright)
(getf metadata :license)
(getf metadata :version)
(getf metadata :cover))))
(defun sync-library (&key (notify nil))
(let ((all-known (db:all-gempub-metadata))
(all-gempub-files (remove-if-not (lambda (a) (ignore-errors (zip-info:zip-file-p a)))
(fs:collect-files/dirs (swconf:gempub-library-directory))))
(removed-known '())
(added-file '()))
(loop for known in all-known do
(let ((local-uri (db:row-local-uri known)))
(when (not (and (fs:file-exists-p local-uri)
(zip-info:zip-file-p local-uri)))
(push local-uri removed-known)
(db:gempub-metadata-delete local-uri))))
(loop for gempub-file in all-gempub-files do
(when (not (db:gempub-metadata-find gempub-file))
(push gempub-file added-file)
(save-metadata gempub-file)))
(when notify
(loop for removed in removed-known do
(ui:notify (format nil (_ "Removed gempub ~s from library, missing file") removed)))
(loop for added in added-file do
(ui:notify (format nil (_ "Added gempub ~s into the library") added))))))

26
src/package.lisp
View File

@ -282,6 +282,7 @@
:add-extension :add-extension
:do-directory :do-directory
:collect-children :collect-children
:collect-files/dirs
:prepend-pwd :prepend-pwd
:search-matching-file :search-matching-file
:regular-file-p :regular-file-p
@ -909,6 +910,20 @@
:row-seenp :row-seenp
:row-description :row-description
:row-value :row-value
:row-local-uri
:row-original-uri
:row-gpub-version
:row-index-file
:row-author
:row-language
:row-charset
:row-publishedp
:row-publish-date
:row-revision-date
:row-copyright
:row-license
:row-version
:row-cover
:next-status-tree :next-status-tree
:previous-status-tree :previous-status-tree
:message-tree-root-equal :message-tree-root-equal
@ -1036,12 +1051,15 @@
:delete-gemlog-entry :delete-gemlog-entry
:purge-seen-gemlog-entries :purge-seen-gemlog-entries
:bookmark-add :bookmark-add
:bookmark-delete
:bookmark-complete->id :bookmark-complete->id
:bookmark-description-for-complete :bookmark-description-for-complete
:bookmark-all-sections :bookmark-all-sections
:bookmark-all-grouped-by-section :bookmark-all-grouped-by-section
:bookmark-delete)) :bookmark-delete
:gempub-metadata-add
:all-gempub-metadata
:gempub-metadata-delete
:gempub-metadata-find))
(defpackage :date-formatter (defpackage :date-formatter
(:use (:use
@ -1176,6 +1194,7 @@
:max-report-comment-length :max-report-comment-length
:quote-char :quote-char
:max-attachments-allowed :max-attachments-allowed
:gempub-library-directory
:color-regexps :color-regexps
:ignore-users-regexps :ignore-users-regexps
:win-bg :win-bg
@ -2425,7 +2444,8 @@
(:shadowing-import-from :text-utils :split-lines) (:shadowing-import-from :text-utils :split-lines)
(:shadowing-import-from :misc :random-elt :shuffle) (:shadowing-import-from :misc :random-elt :shuffle)
(:export (:export
:extract-metadata)) :extract-metadata
:sync-library))
(defpackage :main-window (defpackage :main-window
(:use (:use

6
src/scheduled-events.lisp
View File

@ -70,10 +70,14 @@
(when (swconf:gemini-update-gemlog-at-start-p) (when (swconf:gemini-update-gemlog-at-start-p)
(ui:gemlog-refresh-all))) (ui:gemlog-refresh-all)))
(gen-at-boot-function sync-gempub-library
(gempub:sync-library :notify t))
(defun run-scheduled-events (ticks) (defun run-scheduled-events (ticks)
(refresh-all-chats-messages ticks) (refresh-all-chats-messages ticks)
(refresh-all-chats-data ticks) (refresh-all-chats-data ticks)
(refresh-gemlog-subscriptions ticks) (refresh-gemlog-subscriptions ticks)
(purge-gemlog-entries ticks) (purge-gemlog-entries ticks)
(purge-history) (purge-history)
(refresh-gemlog-posts)) (refresh-gemlog-posts)
(sync-gempub-library))

12
src/software-configuration.lisp
View File

@ -504,6 +504,9 @@
command-separator command-separator
gemini gemini
gemlog gemlog
gempub
library
sync
favicon favicon
tree tree
branch branch
@ -525,6 +528,7 @@
read read
unread unread
directory-symbol directory-symbol
directory
fetch fetch
update update
close-after-select close-after-select
@ -834,6 +838,14 @@
+key-max-numbers-allowed-attachments+) +key-max-numbers-allowed-attachments+)
4)) 4))
(defun gempub-library-directory ()
(or (access:accesses *software-configuration*
+key-gempub+
+key-directory+
+key-library+)
(res:home-datadir)))
(defun external-editor () (defun external-editor ()
(access:access *software-configuration* (access:access *software-configuration*
+key-editor+)) +key-editor+))

24
src/zip-info.lisp
View File

@ -130,19 +130,29 @@
(defun make-zip-error (reason) (defun make-zip-error (reason)
(error 'zip-error :text reason)) (error 'zip-error :text reason))
(alexandria:define-constant +max-eocd-total-size+ 65536 :test #'=)
(defun zip-file-p (path) (defun zip-file-p (path)
(let ((file-size (file-size path)) (let ((file-size (file-size path))
(eocd-start nil)) (eocd-start nil))
(if (>= file-size +eocd-fixed-size+) (if (>= file-size +eocd-fixed-size+)
(with-open-zip-file (stream path) (with-open-zip-file (stream path)
(loop named signature-finder for position (let ((buffer (make-array +max-eocd-total-size+ :element-type +byte-type+)))
from (- file-size +eocd-signature-size+) (file-position stream (- file-size +max-eocd-total-size+))
downto 0 do (read-sequence buffer stream)
(file-position stream position) (loop named signature-finder
(let ((maybe-signature (read-bytes->int stream +eocd-signature-size+))) for eocd-position
from (- file-size +eocd-signature-size+) downto 0
for position
from (- +max-eocd-total-size+ +eocd-signature-size+) downto 0
do
(let* ((maybe-signature (misc:byte->int (subseq buffer
position
(+ position
+eocd-signature-size+)))))
(when (= maybe-signature +eocd-signature-value+) (when (= maybe-signature +eocd-signature-value+)
(setf eocd-start position) (setf eocd-start eocd-position)
(return-from signature-finder t)))) (return-from signature-finder t)))))
(if eocd-start (if eocd-start
(let* ((eocd-fixed-part-offset (+ eocd-start +eocd-fixed-size+)) (let* ((eocd-fixed-part-offset (+ eocd-start +eocd-fixed-size+))
(eocd-offset-minus-zip-comment (- eocd-fixed-part-offset (eocd-offset-minus-zip-comment (- eocd-fixed-part-offset