- [gempub] added extraction of metadata from gempub;

- added table to save gempub's metadata.

src/db.lisp

@@ -131,6 +131,9 @@
 (define-constant +table-bookmark+               :bookmark
   :test #'eq)
 
+(define-constant +table-gempub-metadata+        :gempub-metadata
+  :test #'eq)
+
 (define-constant +bookmark-gemini-type-entry+   "gemini"
   :test #'string=)
 
@@ -583,6 +586,28 @@
                            " UNIQUE(url) ON CONFLICT FAIL"
                            +make-close+)))
 
+(defun make-gempub-metadata ()
+  (query-low-level (strcat (prepare-table +table-gempub-metadata+ :autoincrementp t)
+                           " \"local-uri\"      TEXT, "
+                           " \"original-uri\"   TEXT, "
+                           " title              TEXT, "
+                           " gpubVersion        TEXT, "
+                           " \"index\"          TEXT, "
+                           " author             TEXT, "
+                           " language           TEXT, "
+                           " charset            TEXT, "
+                           " description        TEXT, "
+                           " published          TEXT, "
+                           " publishDate        TEXT, "
+                           " revisionDate       TEXT, "
+                           " copyright          TEXT, "
+                           " license            TEXT, "
+                           " version            TEXT, "
+                           " cover              TEXT, "
+                           ;; timestamp
+                           " \"created-at\"     TEXT NOT NULL"
+                           +make-close+)))
+
 (defun build-all-indices ()
   (create-table-index +table-status+              '(:folder :timeline :status-id))
   (create-table-index +table-account+             '(:id :acct))
@@ -596,8 +621,8 @@
   (create-table-index +table-gemini-tofu-cert+    '(:host))
   (create-table-index +table-gemini-subscription+ '(:url))
   (create-table-index +table-gemlog-entries+      '(:url))
-  (create-table-index +table-bookmark+            '(:type :section :value)))
-
+  (create-table-index +table-bookmark+            '(:type :section :value))
+  (create-table-index +table-gempub-metadata+     '(:local-uri)))
 
 (defmacro gen-delete (suffix &rest names)
   `(progn
@@ -625,7 +650,8 @@
               +table-gemini-tofu-cert+
               +table-gemini-subscription+
               +table-gemlog-entries+
-              +table-bookmark+))
+              +table-bookmark+
+              +table-gempub-metadata+))
 
 (defun build-views ())
 
@@ -660,6 +686,7 @@
     (make-gemini-subscription)
     (make-gemlog-entries)
     (make-bookmark)
+    (make-gempub-metadata)
     (build-all-indices)
     (fs:set-file-permissions (db-path) (logior fs:+s-irusr+ fs:+s-iwusr+))))
 

src/gempub.lisp

@@ -0,0 +1,79 @@
+;; tinmop: an humble gemini and pleroma client
+;; Copyright (C) 2021  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 :gempub)
+
+(defrule title         "title"         (:constant :title))
+(defrule gpubVersion   "gpubVersion"   (:constant :gpubVersion))
+(defrule index         "index"         (:constant :index))
+(defrule author        "author"        (:constant :author))
+(defrule language      "language"      (:constant :language))
+(defrule charset       "charset"       (:constant :charset))
+(defrule description   "description"   (:constant :description))
+(defrule published     "published"     (:constant :published))
+(defrule publishDate   "publishDate"   (:constant :publishDate))
+(defrule revisionDate  "revisionDate"  (:constant :revisionDate))
+(defrule copyright     "copyright"     (:constant :copyright))
+(defrule license       "license"       (:constant :license))
+(defrule version       "version"       (:constant :version))
+(defrule cover         "cover"         (:constant :cover))
+
+(defrule blank (or #\space #\Newline #\Tab)
+  (:constant nil))
+
+(defrule blanks (* blank)
+  (:constant nil))
+
+(defrule key-value-separator #\:)
+
+(defrule value (+ (not #\Newline))
+  (:text t))
+
+(defrule key (or title
+                 gpubVersion
+                 index
+                 author
+                 language
+                 charset
+                 description
+                 published
+                 publishDate
+                 revisionDate
+                 copyright
+                 license
+                 version
+                 cover))
+
+(defrule entry (and key (? blanks) key-value-separator (? blanks) value blanks)
+  (:function (lambda (a)  (list (first a) (fifth a)))))
+
+(defrule metadata (* entry)
+  (:function flatten))
+
+(defgeneric parse-metadata (object))
+
+(defmethod parse-metadata ((object string))
+  (parse 'metadata object))
+
+(define-constant +metadata-entry-name "metadata.txt" :test #'string=)
+
+(defmethod extract-metadata (zip-file)
+  (when (zip-info:zip-file-p zip-file)
+    (let ((entries (zip-info:list-entries zip-file)))
+      (when (find +metadata-entry-name entries :test #'String=)
+        (when-let ((metadata-raw (os-utils:unzip-single-file zip-file
+                                                             +metadata-entry-name)))
+          (parse 'metadata metadata-raw))))))

src/line-oriented-window.lisp

@@ -1,5 +1,5 @@
 ;; tinmop: an humble gemini and pleroma client
-;; Copyright (C) 2020  cage
+;; Copyright (C) 2020,2021  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

src/os-utils.lisp

@@ -174,5 +174,17 @@
                            (list "-o" zip-file "-d" destination-dir)
                            :search t
                            :wait   t
-                           :output *standard-output*
-                           :error  *standard-output*))))
+                           :output nil
+                           :error  :output))))
+
+(defun unzip-single-file (zip-file file-entry)
+  (with-output-to-string (stream)
+    (let* ((process   (run-external-program +unzip-bin+
+                                            (list "-p" zip-file file-entry)
+                                            :search t
+                                            :wait   t
+                                            :output stream
+                                            :error  :output))
+           (exit-code (sb-ext:process-exit-code process)))
+      (when (/= exit-code 0)
+        (error (format nil "File ~s extraction from ~s failed" file-entry zip-file))))))

src/package.lisp

@@ -345,7 +345,8 @@
    :send-to-pipe
    :open-link-with-program
    :open-resource-with-external-program
-   :unzip-file))
+   :unzip-file
+   :unzip-single-file))
 
 (defpackage :text-utils
   (:use
@@ -2410,6 +2411,22 @@
    :open-gemini-stream-window
    :load-gemini-url))
 
+(defpackage :gempub
+  (:use
+   :cl
+   :alexandria
+   :cl-ppcre
+   :esrap
+   :config
+   :constants
+   :text-utils
+   :misc
+   :specials)
+  (:shadowing-import-from :text-utils :split-lines)
+  (:shadowing-import-from :misc :random-elt :shuffle)
+  (:export
+   :extract-metadata))
+
 (defpackage :main-window
   (:use
    :cl

tinmop.asd

@@ -129,6 +129,7 @@
                (:file "conversations-window")
                (:file "chats-list-window")
                (:file "gemini-viewer")
+               (:file "gempub")
                (:file "main-window")
                (:file "ui-goodies")
                (:file "scheduled-events")