- used 'gpub' as file extension for generated gempub files.

- fixed parser for gempub metadata;
- fixed typo: "clrs" instead of "clsr";
- added dependency to "zip" binary.

Makefile.in

@@ -343,6 +343,7 @@ XDG_OPEN = @XDG_OPEN@
 XGETTEXT = @XGETTEXT@
 XGETTEXT_015 = @XGETTEXT_015@
 XGETTEXT_EXTRA_OPTIONS = @XGETTEXT_EXTRA_OPTIONS@
+ZIP = @ZIP@
 abs_builddir = @abs_builddir@
 abs_srcdir = @abs_srcdir@
 abs_top_builddir = @abs_top_builddir@

aclocal.m4

@@ -14,8 +14,8 @@
 m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])])
 m4_ifndef([AC_AUTOCONF_VERSION],
   [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl
-m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.71],,
-[m4_warning([this file was generated for autoconf 2.71.
+m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.72],,
+[m4_warning([this file was generated for autoconf 2.72.
 You have another version of autoconf.  It may work, but is not guaranteed to.
 If you have problems, you may need to regenerate the build system entirely.
 To do so, use the procedure documented by the package, typically 'autoreconf'.])])

configure.ac

@@ -76,6 +76,12 @@ if test "$UNZIP" = "no" ; then
    AC_MSG_WARN([Can not find unzip, genpub support will be disabled.])
 fi
 
+AC_PATH_PROG([ZIP],[zip],[no])
+
+if test "$UNZIP" = "no" ; then
+   AC_MSG_WARN([Can not find zip, genpub generation support will be disabled.])
+fi
+
 AC_PATH_PROG([MAN],[man],[no])
 
 if test "$MAN" = "no" ; then

src/config.lisp.in.in

@@ -30,6 +30,8 @@
 
 (alexandria:define-constant +unzip-bin+       "@UNZIP@"             :test #'string=)
 
+(alexandria:define-constant +zip-bin+         "@ZIP@"               :test #'string=)
+
 (alexandria:define-constant +man-bin+         "@MAN@"               :test #'string=)
 
 (alexandria:define-constant +montage-bin+     "@MONTAGE@"           :test #'string=)
@@ -45,6 +47,8 @@
 
   (allow-features +unzip-bin+ :gempub-support)
 
+  (allow-features +zip-bin+ :gempub-generation-support)
+
   (allow-features +man-bin+   :man-bin)
 
   (allow-features +montage-bin+ :montage-bin))

src/gempub.lisp

@@ -31,7 +31,7 @@
 (defrule gempub-version       "version"       (:constant :version))
 (defrule gempub-cover         "cover"         (:constant :cover))
 
-(defrule gempub-blank (or #\space #\Newline #\Tab)
+(defrule gempub-blank (or #\space #\Tab)
   (:constant nil))
 
 (defrule gempub-blanks (* gempub-blank)
@@ -39,7 +39,7 @@
 
 (defrule gempub-key-value-separator #\:)
 
-(defrule gempub-value (+ (not #\Newline))
+(defrule gempub-value (* (not #\Newline))
   (:text t))
 
 (defrule gempub-key (or gempub-title
@@ -58,7 +58,7 @@
                         gempub-cover))
 
 (defrule gempub-entry (and gempub-key (? gempub-blanks) gempub-key-value-separator
-                           (? gempub-blanks) gempub-value gempub-blanks)
+                           (? gempub-blanks) gempub-value #\NewLine)
   (:function (lambda (a)  (list (first a) (fifth a)))))
 
 (defrule gempub-metadata (* gempub-entry)
@@ -67,16 +67,18 @@
 (defgeneric parse-metadata (object))
 
 (defmethod parse-metadata ((object string))
-  (parse 'metadata object))
+  (parse 'gempub-metadata object))
 
-(define-constant +metadata-entry-name "metadata.txt" :test #'string=)
+(define-constant +metadata-entry-name+ "metadata.txt" :test #'string=)
+
+(define-constant +gempub-file-extension+ "gpub" :test #'string=)
 
 (defun extract-metadata (zip-file)
   (when (gempub:gempub-file-p zip-file :ignore-errors t)
     (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
-                                                             +metadata-entry-name)))
+                                                             +metadata-entry-name+)))
           (parse 'gempub-metadata metadata-raw))))))
 
 (defun save-metadata (zip-file)

src/gui/client/certificates-window.lisp

@@ -55,7 +55,7 @@
             (let ((new-rows (all-rows)))
               (resync-rows certificate-frame new-rows))))))))
 
-(defun contextual-menu-clrs (treeview-widget)
+(defun contextual-menu-clsr (treeview-widget)
   (labels ((row-values ()
              (a:when-let* ((item (first (gui:treeview-get-selection treeview-widget))))
                (gui:column-values item)))
@@ -279,4 +279,4 @@
       (gui:grid import-button 0 1 :sticky :s)
       (gui:bind (gui:treeview (gui-goodies:tree table))
                 #$<3>$
-                (contextual-menu-clrs (gui:treeview (gui-goodies:tree table)))))))
+                (contextual-menu-clsr (gui:treeview (gui-goodies:tree table)))))))

src/gui/client/gemlog-window.lisp

@@ -160,7 +160,7 @@
                                         ev:+standard-event-priority+
                                         gemlog-url))
 
-(defun contextual-menu-clrs (gemlog-frame treeview-widget)
+(defun contextual-menu-clsr (gemlog-frame treeview-widget)
   (labels ((copy-uri ()
              (a:when-let* ((selections (gui:treeview-get-selection treeview-widget))
                            (links      (with-output-to-string (stream)
@@ -232,7 +232,7 @@
                 (open-gemlog-clsr main-window table))
       (gui:bind (gui:treeview (gui-goodies:tree table))
                 #$<3>$
-                (contextual-menu-clrs table (gui:treeview (gui-goodies:tree table))))
+                (contextual-menu-clsr table (gui:treeview (gui-goodies:tree table))))
       (gui:bind (gui:treeview (gui-goodies:tree table))
                 #$<KeyPress>$
                 (lambda (e)

src/gui/client/gempub-window.lisp

@@ -159,3 +159,173 @@
                 (open-gempub-clsr main-window table))
       (gui:focus (gui:treeview (gui-goodies:tree table)))
       (gui:transient toplevel master))))
+
+(defun %make-gempub (gemtext-directory title index-file author language description published-date license copyright cover-file)
+  (let ((index-filename (fs:path-last-element index-file))
+        (cover-filename (fs:path-last-element cover-file)))
+    (fs:copy-a-file index-file (fs:cat-parent-dir gemtext-directory index-filename) :overwrite t)
+    (fs:copy-a-file cover-file (fs:cat-parent-dir gemtext-directory cover-filename) :overwrite t)
+    (with-open-file (stream
+                     (fs:cat-parent-dir gemtext-directory gempub:+metadata-entry-name+)
+                   :direction :output
+                   :if-does-not-exist :create
+                   :if-exists :supersede)
+      (format stream
+              "title: ~a~%index: ~a~%author: ~a~%language: ~a~%description: ~a~%published: ~a~%license: ~a~%copyright: ~a~%cover: ~a~%"
+              title
+              index-filename
+              author
+              language
+              description
+              published-date
+              license
+              copyright
+              cover-filename))
+    (os-utils:zip-directory gemtext-directory
+                            :extension gempub:+gempub-file-extension+
+                            :flat t)))
+
+(defun create-gempub (gemtext-dir)
+  (gui:with-modal-toplevel (toplevel :title (_ "Add Metadata"))
+    (let* ((toplevel-widget (gui:modal-toplevel-root-widget toplevel))
+           (summary           (make-instance 'gui:label
+                                             :master toplevel-widget
+                                             :text (_ "Provide the information as metadata for your book then presso OK button: fields marched with \"*\" are mandatory")
+                                             :grid '(0 0)))
+           (frame             (make-instance 'gui:frame
+                                             :master toplevel-widget
+                                             :grid '(1 0 :sticky :news)))
+           (title-label       (make-instance 'gui:label
+                                             :master frame
+                                             :text (_ "Title*")
+                                             :grid '(0 0)))
+           (title-entry       (make-instance 'gui:entry
+                                             :master frame
+                                             :grid '(1 0)))
+           (index-label       (make-instance 'gui:label
+                                             :master frame
+                                             :text ""
+                                             :grid '(2 1)))
+           (index-button      (make-instance 'gui:button
+                                             :master frame
+                                             :text (_ "Choose index file")
+                                             :grid '(2 0)
+                                             :command
+                                             (lambda ()
+                                               (let* ((file-types `((,(_ "Gempub") "*.gmi")))
+                                                      (file (gui:get-open-file :file-types
+                                                                               file-types
+                                                                               :initial-dir
+                                                                               gemtext-dir
+                                                                               :parent
+                                                                               toplevel-widget)))
+                                                 (setf (gui:text index-label) file)))))
+           (author-label      (make-instance 'gui:label
+                                             :master frame
+                                             :text (_ "Author")
+                                             :grid '(3 0)))
+           (author-entry      (make-instance 'gui:entry
+                                             :master frame
+                                             :grid '(4 0)))
+           (language-label    (make-instance 'gui:label
+                                             :master frame
+                                             :text (_ "Language")
+                                             :grid '(5 0)))
+           (language-entry    (make-instance 'gui:entry
+                                             :master frame
+                                             :grid '(6 0)))
+           (description-label (make-instance 'gui:label
+                                             :master frame
+                                             :text (_ "Description")
+                                             :grid '(7 0)))
+           (description-entry (make-instance 'gui:entry
+                                             :master frame
+                                             :grid '(8 0)))
+           (published-label   (make-instance 'gui:label
+                                             :master frame
+                                             :text (_ "Published* (format: YYYY-MM-DD)")
+                                             :grid '(9 0)))
+           (published-entry   (make-instance 'gui:entry
+                                             :master frame
+                                             :grid '(10 0)))
+
+           (license-label     (make-instance 'gui:label
+                                             :master frame
+                                             :text (_ "License")
+                                             :grid '(11 0)))
+           (license-entry     (make-instance 'gui:entry
+                                             :master frame
+                                             :grid '(12 0)))
+           (copyright-label   (make-instance 'gui:label
+                                             :master frame
+                                             :text (_ "Copyright")
+                                             :grid '(13 0)))
+           (copyright-entry   (make-instance 'gui:entry
+                                             :text "©…"
+                                             :master frame
+                                             :grid '(14 0)))
+           (cover-label       (make-instance 'gui:label
+                                             :master frame
+                                             :text (_ "")
+                                             :grid '(15 1)))
+           (cover-button      (make-instance 'gui:button
+                                             :master frame
+                                             :text (_ "Choose a cover file")
+                                             :grid '(15 0)
+                                             :command
+                                             (lambda ()
+                                               (let* ((file-types `((,(_ "Jpeg files") "*.jpeg")
+                                                                    (,(_ "Jpeg files") "*.jpg")
+                                                                    (,(_ "PNG files") "*.png")))
+                                                      (file (gui:get-open-file :file-types
+                                                                               file-types
+                                                                               :initial-dir
+                                                                               gemtext-dir
+                                                                               :parent
+                                                                               toplevel-widget)))
+                                                 (setf (gui:text cover-label) file)))))
+
+           (ok-button-cb      (lambda ()
+                                (cond
+                                  ((not (ignore-errors (misc:parse-timestring (gui:text published-entry))))
+                                   (gui-goodies:error-dialog toplevel-widget (_ "The format of the puiblished data is invalid")))
+                                  ((text-utils:string-empty-p (gui:text title-entry))
+                                   (gui-goodies:error-dialog toplevel-widget
+                                                             (_ "The title is mandatory")))
+                                  (t
+                                   (gui-goodies:with-busy* (toplevel-widget)
+                                     (%make-gempub gemtext-dir
+                                                   (gui:text title-entry)
+                                                   (gui:text index-label)
+                                                   (gui:text author-entry)
+                                                   (gui:text language-entry)
+                                                   (gui:text description-entry)
+                                                   (gui:text published-entry)
+                                                   (gui:text license-entry)
+                                                   (gui:text copyright-entry)
+                                                   (gui:text cover-label))
+                                     (gui:exit-from-modal-toplevel toplevel))))))
+           (ok-button         (make-instance 'gui:button
+                                             :grid '(2 0)
+                                             :master  toplevel-widget
+                                             :text    (_ "OK")
+                                             :command ok-button-cb))
+           (cancel-button     (make-instance 'gui:button
+                                             :grid '(2 1)
+                                             :master  toplevel-widget
+                                             :text    (_ "Cancel")
+                                             :command
+                                             (lambda ()
+                                               (gui:exit-from-modal-toplevel toplevel)))))
+    (declare (ignore summary
+                     title-label
+                     index-button
+                     author-label
+                     language-label
+                     description-label
+                     published-label
+                     license-label
+                     copyright-label
+                     cover-button
+                     ok-button
+                     cancel-button)))))

src/gui/client/main-window.lisp

@@ -267,8 +267,12 @@
                          :accelerator (client-configuration:get-keybinding :view-source))
     (gui:make-menubutton gempub
                          (_ "Search gempub library")
-                         (menu:search-gempub-library-clrs main-window)
+                         (menu:search-gempub-library-clsr main-window)
                          :accelerator (client-configuration:get-keybinding :search-gempub-library))
+    #+:gempub-generation-support
+    (gui:make-menubutton gempub
+                         (_ "Make gempub file")
+                         (menu:make-gempub-clsr main-window))
     (gui:make-menubutton file
                          (_ "Quit")
                          #'menu:quit
@@ -640,7 +644,7 @@ local file paths."
         (gui:make-menubutton popup-menu (_ "Add all links to tour") #'add-to-tour-callback)
         (gui:popup popup-menu x y)))))
 
-(defun contextual-menu-link-clrs (link-name link-value main-window)
+(defun contextual-menu-link-clsr (link-name link-value main-window)
   (labels ((add-to-tour-callback ()
              (enqueue-add-link-to-tour link-value link-name))
            (download-background-callback ()
@@ -863,7 +867,7 @@ local file paths."
                                                                :cursor-outside
                                                                (gui:find-cursor :xterm)
                                                                :button-3-callback
-                                                               (contextual-menu-link-clrs link-name
+                                                               (contextual-menu-link-clsr link-name
                                                                                           target-iri
                                                                                           main-window)
                                                                :button-2-callback
@@ -1960,7 +1964,7 @@ local file paths."
             (client-configuration:get-keybinding :search-gempub-library)
             (lambda (e)
               (declare (ignore e))
-              (funcall (menu:search-gempub-library-clrs main-window))))
+              (funcall (menu:search-gempub-library-clsr main-window))))
   (gui:bind target
             (client-configuration:get-keybinding :quit)
             (lambda (e)

src/gui/client/menu-command.lisp

@@ -148,7 +148,7 @@
       (client-main-window::set-address-bar-text main-window (to-s iri))
       (client-main-window::open-iri (to-s iri) main-window nil))))
 
-(defun search-gempub-library-clrs (main-window)
+(defun search-gempub-library-clsr (main-window)
   (lambda ()
     (gui-goodies:with-notify-errors
       (let* ((query (gui-mw:text-input-dialog main-window
@@ -161,3 +161,10 @@
                                                                   ev:+standard-event-priority+
                                                                   query)))
         (client-gempub-window:init-window main-window main-window table-results)))))
+
+(defun make-gempub-clsr (main-window)
+  (declare (ignore main-window))
+  (lambda ()
+    (let ((directory (gui:choose-directory :title (_ "Choose directory with the gempub sources"))))
+      (when (text-utils:string-not-empty-p directory)
+        (client-gempub-window:create-gempub directory)))))

src/misc-utils.lisp

@@ -955,6 +955,9 @@ to the array"
   ;; unix timestamp is seconds from 1970-01-01T00:00:00Z
   (+ unix-timestamp +unix-epoch+))
 
+(defun parse-timestring (string)
+  (local-time:parse-timestring string))
+
 (defmacro gen-time-access (name pos)
   `(defun ,(format-fn-symbol t "time-~a-of" name) (time-list)
      (elt time-list ,pos)))

src/os-utils.lisp

@@ -319,5 +319,23 @@ numerical user ID, as an assoc-list."
       (when (not (process-exit-success-p process))
         (error (format nil (_ "File ~s extraction from ~s failed") file-entry zip-file))))))
 
+(defun zip-directory (dir &key (extension nil) (flat nil))
+  (with-output-to-string (stream)
+    (let* ((process (run-external-program +zip-bin+
+                                          (append (when flat
+                                                    (list "-j"))
+                                                  (list "-r"
+                                                        (format nil
+                                                                "~a~@[.~a~]"
+                                                                dir
+                                                                extension)
+                                                        dir))
+                                          :search t
+                                          :wait   t
+                                          :output stream
+                                          :error  :output)))
+      (when (not (process-exit-success-p process))
+        (error (format nil (_ "Compressing directory ~s failed") dir))))))
+
 (defun copy-to-clipboard (text)
   (trivial-clipboard:text text))

src/package.lisp

@@ -36,6 +36,7 @@
    :+openssl-bin+
    :+xdg-open-bin+
    :+unzip-bin+
+   :+zip-bin+
    :+man-bin+
    :+montage-bin+
    :+file-bin+
@@ -253,6 +254,7 @@
    :null-pointer-p
    :with-load-forms-in-var
    :time-unix->universal
+   :parse-timestring
    :time-seconds-of
    :time-minutes-of
    :time-hour-of
@@ -432,6 +434,7 @@
    :file->mime-type
    :unzip-file
    :unzip-single-file
+   :zip-directory
    :copy-to-clipboard
    :user-info
    :user-info-name
@@ -2942,6 +2945,8 @@
   (:shadowing-import-from :text-utils :split-lines)
   (:shadowing-import-from :misc :random-elt :shuffle)
   (:export
+   :+metadata-entry-name+
+   :+gempub-file-extension+
    :gempub-file-p
    :extract-metadata
    :sync-library
@@ -3610,7 +3615,8 @@
    :show-tour-clsr
    :manage-gemlogs
    :show-page-source-clsr
-   :search-gempub-library-clrs))
+   :search-gempub-library-clsr
+   :make-gempub-clsr))
 
 (defpackage :client-certificates-window
   (:use
@@ -3753,7 +3759,8 @@
                     (:gui-shapes :nodgui.shapes)
                     (:menu       :client-menu-command))
   (:export
-   :init-window))
+   :init-window
+   :create-gempub))
 
 (defpackage :client-search-frame
   (:use