Merge branch 'gopher-support'

etc/default-theme.conf

@@ -108,21 +108,21 @@ notify-window.width                                  = 1/6
 
 # centered  notification window
 
-# notify-window.position.x                            = 7/16
+# notify-window.position.x                           = 7/16
 
-# notify-window.position.y                            = 1/2
+# notify-window.position.y                           = 1/2
 
 # top right corner notification window
 
-# notify-window.position.x                            = -1/6
+# notify-window.position.x                           = -1/6
 
-# notify-window.position.y                            = 0
+# notify-window.position.y                           = 0
 
 # top left corner notification window
 
-# notify-window.position.x                            = 0
+# notify-window.position.x                           = 0
 
-# notify-window.position.y                            = 0
+# notify-window.position.y                           = 0
 
 # bottom left corner notification window
 
@@ -516,7 +516,7 @@ gemini.downloading.animation                         = "⠇ ⠋ ⠙ ⠸ ⠴ ⠦"
 
 gemini.favicon                                       = "🌍"
 
-#gemini.link.background                               = white
+#gemini.link.background                              = white
 
 gemini.link.foreground                               = magenta
 
@@ -635,30 +635,54 @@ gemini-toc-window.padding                            = "⋅"
 
 # this is the message that shows an hierarchical filesystem
 
-file-explorer.background                        = black
+file-explorer.background                             = black
 
-file-explorer.foreground                        = #E2BE6F
+file-explorer.foreground                             = #E2BE6F
 
-file-explorer.height                            = 1/2
+file-explorer.height                                 = 1/2
 
 # see configuration for tree in thread window above
 
-file-explorer.tree.branch.foreground            = red
+file-explorer.tree.branch.foreground                 = red
 
-file-explorer.tree.arrow.foreground             = magenta
+file-explorer.tree.arrow.foreground                  = magenta
 
-file-explorer.tree.root.foreground              = #ffff00
+file-explorer.tree.root.foreground                   = #ffff00
 
-file-explorer.tree.data.foreground              = white
+file-explorer.tree.data.foreground                   = white
 
-file-explorer.tree.data-leaf.foreground         = cyan
+file-explorer.tree.data-leaf.foreground              = cyan
 
-file-explorer.tree.arrow.value                  = "🞂"
+file-explorer.tree.arrow.value                       = "🞂"
 
-file-explorer.tree.leaf.value                   = "╰"
+file-explorer.tree.leaf.value                        = "╰"
 
-file-explorer.tree.branch.value                 = "├"
+file-explorer.tree.branch.value                      = "├"
 
-file-explorer.tree.spacer.value                 = "─"
+file-explorer.tree.spacer.value                      = "─"
 
-file-explorer.tree.vertical-line.value          = "│"
+file-explorer.tree.vertical-line.value               = "│"
+
+# this is the window that show the content of a gopher response
+
+gopher-window.background                             = black
+
+gopher-window.foreground                             = #c9c0c0
+
+gopher-window.line.prefix.uri                        = "🕸 "
+
+gopher-window.line.prefix.directory                  = "🗀 "
+
+gopher-window.line.prefix.unknown                    = "❌"
+
+gopher-window.line.prefix.binary-file                = "⁽¹⁰¹⁾ "
+
+gopher-window.line.prefix.text-file                  = "🖹 "
+
+gopher-window.line.prefix.image-file                 = "🖼 "
+
+gopher-window.line.prefix.gif-file                   = "🖼 "
+
+gopher-window.line.prefix.foreground                 = cyan
+
+gopher-window.line.prefix.attribute                  = bold

etc/init.lisp

@@ -256,6 +256,8 @@
 
 ;; thread window keymap
 
+(define-key "Q"         #'gopher-window::tt                           *thread-keymap*)
+
 (define-key "up"        #'thread-go-up                                *thread-keymap*)
 
 (define-key "down"      #'thread-go-down                              *thread-keymap*)
@@ -752,6 +754,20 @@
 
 (define-key "M d"       #'file-explorer-download-mirror *filesystem-explorer-keymap*)
 
+;; gopher viewer keymap
+
+(define-key "up"        #'gopher-window:go-to-previous-link          *gopher-keymap*)
+
+(define-key "down"      #'gopher-window:go-to-next-link              *gopher-keymap*)
+
+(define-key "k"         #'gopher-window:go-to-previous-link          *gopher-keymap*)
+
+(define-key "j"         #'gopher-window:go-to-next-link              *gopher-keymap*)
+
+(define-key "C-J"       #'gopher-window:open-menu-link               *gopher-keymap*)
+
+(define-key "b"         #'gemini-history-back                        *gopher-keymap*)
+
 ;;;; hooks
 
 ;; this module  will install an  hook to  rewrite urls; By  default it

src/filesystem-utils.lisp

@@ -251,15 +251,16 @@
         (nix:s-isdir (nix:stat-mode (nix:stat path))))))
 
 (defun split-path-elements (path)
-  (cl-ppcre:split *directory-sep-regexp* path))
+  (let ((splitted (cl-ppcre:split *directory-sep-regexp* path)))
+    (substitute *directory-sep* "" splitted :test #'string=)))
 
 (defun path-last-element (path)
-  (let ((elements (cl-ppcre:split *directory-sep-regexp* path)))
+  (let ((elements (split-path-elements path)))
     (and elements
          (last-elt elements))))
 
 (defun path-first-element (path)
-  (let ((elements (cl-ppcre:split *directory-sep-regexp* path)))
+  (let ((elements (split-path-elements path)))
     (and elements
          (first-elt elements))))
 

src/gemini-viewer.lisp

@@ -760,13 +760,12 @@
   (when-let* ((metadata (message-window:metadata window))
               (history  (misc:safe-all-but-last-elt (gemini-metadata-history metadata)))
               (last     (last-elt history)))
-    (setf (gemini-metadata-history metadata)
+    (setf (gemini-metadata-history metadata) history)
-          history)
     (ui:info-message (format nil (_ "Going back to: ~a") last))
     (let ((found (find-db-stream-url last)))
       (if found
           (db-entry-to-foreground last)
-          (load-gemini-url last))))) ; this happens if navigating in a local tree
+          (ui:open-net-address last))))) ; this happens history kept a non gemini iri
 
 (defun view-source (window)
   (when-let* ((metadata (message-window:metadata window))

src/gemini/package.lisp

@@ -1,5 +1,5 @@
-;; tinmop: an humble gemini and pleroma client
+;; tinmop: an humble gemini kami and pleroma client
-;; Copyright (C) 2020  cage
+;; Copyright © 2022  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/gopher-window.lisp

@@ -0,0 +1,257 @@
+;; 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 :gopher-window)
+
+(defclass gopher-window (wrapper-window
+                         focus-marked-window
+                         title-window
+                         border-window
+                         row-oriented-widget)
+  ((page-type
+    :initarg :page-type
+    :initform nil
+    :accessor page-type
+    :documentation "The type of the page , 0,1,2,i etc.")))
+
+(defmethod refresh-config :after ((object gopher-window))
+  (refresh-config-colors object swconf:+key-gopher-window+)
+  (let* ((height (win-height *message-window*))
+         (width  (win-width *message-window*))
+         (x      (win-x *message-window*))
+         (y      (win-y *message-window*)))
+    (win-resize object width height)
+    (win-move   object x y)))
+
+(defmethod draw :after ((object gopher-window))
+  (with-accessors ((uses-border-p uses-border-p)) object
+    (when-window-shown (object)
+      (let ((max-line-size (if uses-border-p
+                               (win-width-no-border object)
+                               (win-width           object))))
+        (let ((rows    (renderizable-rows-data object))
+              (x       (if (uses-border-p object)
+                           1
+                           0))
+              (y-start (if (uses-border-p object)
+                           1
+                           0)))
+          (loop
+            for y from y-start
+            for ct from 0
+            for row in rows do
+              (let ((tui-text (if (selectedp row)
+                                  (tui:apply-attributes (selected-text row)
+                                                 :all
+                                                 (tui:combine-attributes (tui:attribute-reverse)
+                                                                         (tui:attribute-bold)))
+                                  (normal-text row))))
+                (print-text object (right-pad-text (text-ellipsis tui-text max-line-size)
+                                                   max-line-size)
+                            x y)))
+          (when (> (rows-length object) 0)
+            (let* ((current-selected (1+ (row-selected-index object)))
+                   (pages-count-line (format nil
+                                             (_ "line ~a of ~a")
+                                             current-selected
+                                             (rows-length object)))
+                   (x-count-line     (- (win-width object)
+                                        (length pages-count-line)
+                                        1))
+                   (y-count-line     (1- (win-height object))))
+              (print-text object
+                          (text-ellipsis pages-count-line (win-width-no-border object))
+                          x-count-line
+                          y-count-line))))))))
+
+(defgeneric gopher-line->text (line))
+
+(defun %gemline->text-simple (line prefix)
+  (let* ((prefix-color     (swconf:config-gopher-line-prefix-foreground))
+         (prefix-attribute (swconf:config-gopher-line-prefix-attribute))
+         (colorized        (message-window::colorize-lines (gopher-parser:username line)))
+         (colorized-prefix (tui:make-tui-string prefix
+                                                :attributes prefix-attribute
+                                                :fgcolor    prefix-color)))
+    (tui:cat-tui-string colorized-prefix
+                        (tui:apply-attributes colorized :all (tui:attribute-bold))
+                        :color-attributes-contagion nil)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-file))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-text-file)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-dir))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-directory)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-cso))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-unknown)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-error))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-unknown)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-mac-hex-file))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-binary-file)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-dos-archive-file))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-binary-file)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-uuencoded-file))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-binary-file)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-index-search))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-search-index)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-telnet-session))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-unknown)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-binary-file))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-binary-file)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-redundant-server))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-directory)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-tn3270-session))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-unknown)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-gif-file))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-gif-file)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-image-file))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-image-file)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-info))
+  (message-window::colorize-lines (gopher-parser:username line)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-uri))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-uri)))
+
+(defmethod gopher-line->text ((line gopher-parser:line-unknown))
+  (%gemline->text-simple line (swconf:config-gopher-line-prefix-unknown)))
+
+(defun print-response-rows (window gopher-lines)
+  (flet ((make-rows (lines)
+           (mapcar (lambda (line)
+                     (make-instance 'line
+                                    :fields        (list :original-object line)
+                                    :normal-text   (gopher-line->text line)
+                                    :selected-text (gopher-line->text line)))
+                   lines)))
+    (line-oriented-window:update-all-rows window (make-rows gopher-lines))))
+
+(defun init ()
+  (maybe-close-window *gopher-window*)
+  (let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
+    (setf *gopher-window*
+          (make-instance 'gopher-window
+                         :uses-border-p   t
+                         :title           (_ "Gopher menu")
+                         :keybindings     keybindings:*gopher-keymap*
+                         :key-config      swconf:+key-gopher-window+
+                         :croatoan-window low-level-window))
+    (refresh-config *gopher-window*)
+    (draw *gopher-window*)
+    *gopher-window*))
+
+(defun not-link-line-p (line)
+  (let ((original-object (message-window:extract-original-object line)))
+    (not (or (gopher-parser:line-type-info-p original-object)
+             (gopher-parser:line-type-error-p original-object)))))
+
+(defun go-to-next-link ()
+  (a:when-let* ((win                *gopher-window*)
+                (1+selected-row-pos (1+ (line-oriented-window:row-selected-index win)))
+                (link-line-pos      (rows-position-if win
+                                                      #'not-link-line-p
+                                                      :start 1+selected-row-pos)))
+    (line-oriented-window:unselect-all win)
+    (line-oriented-window:row-move win (- link-line-pos (1- 1+selected-row-pos)))
+    (win-clear win)
+    (windows:draw win)))
+
+(defun go-to-previous-link ()
+  (a:when-let* ((win              *gopher-window*)
+                (selected-row-pos (line-oriented-window:row-selected-index win))
+                (link-line-pos    (rows-position-if win
+                                                    #'not-link-line-p
+                                                    :from-end t
+                                                    :end    selected-row-pos)))
+    (line-oriented-window:unselect-all win)
+    (line-oriented-window:row-move win (- link-line-pos selected-row-pos))
+    (win-clear win)
+    (windows:draw win)))
+
+(defun make-request (host port type selector)
+  (let ((message-win     specials:*message-window*))
+    (gemini-viewer:maybe-initialize-metadata message-win)
+    (let ((link (format nil "~a://~a:~a/~a/~a"
+                        gopher-parser:+gopher-scheme+
+                        host
+                        port
+                        type
+                        selector)))
+      (gemini-viewer:push-url-to-history message-win link)))
+  (cond
+    ((gopher-parser::%line-type-dir-p type)
+     (let ((data (misc:make-fresh-array 0 :type '(unsigned-int 8))))
+       (gopher-client:request host
+                              type
+                              :port       port
+                              :selector   selector
+                              :collect-fn (gopher-client:make-collect-fn data))
+       (init)
+       (ui:focus-to-gopher-window)
+       (print-response-rows *gopher-window*
+                            (gopher-parser:parse-menu (text-utils:to-s data)))
+       (select-row *gopher-window* 0)
+       (draw *gopher-window*)))
+    ((gopher-parser::%line-type-file-p type)
+     (win-close *gopher-window*)
+     (let ((data (misc:make-fresh-array 0 :type '(unsigned-int 8))))
+       (gopher-client:request host
+                              type
+                              :port       port
+                              :selector   selector
+                              :collect-fn (gopher-client:make-collect-fn data))
+       (let* ((text      (to-s data))
+              (raw-lines (split-lines (gopher-parser:parse-text-file text)))
+              (lines     (mapcar (lambda (a)
+                                   (message-window:text->rendered-lines-rows *message-window*
+                                                                             a))
+                                 raw-lines)))
+         (line-oriented-window:update-all-rows *message-window* (a:flatten lines))
+         (draw *message-window*)
+         (ui:focus-to-message-window))))
+    (t
+     (fs:with-anaphoric-temp-file (stream)
+       (gopher-client:request host
+                              type
+                              :port       port
+                              :selector   selector
+                              :collect-fn (lambda (buffer)
+                                            (write-sequence buffer stream)))
+       (finish-output stream)
+       (os-utils:open-resource-with-external-program filesystem-utils:temp-file
+                                                     nil)))))
+
+(defun open-menu-link ()
+  (a:when-let* ((win          *gopher-window*)
+                (selected-row (selected-row win))
+                (line         (message-window:extract-original-object selected-row)))
+    (with-accessors ((line-type-id gopher-parser:line-type-id)
+                     (selector     gopher-parser:selector)
+                     (host         gopher-parser:host)
+                     (port         gopher-parser:port)) line
+      (make-request host port line-type-id selector))))

src/gopher/client.lisp

@@ -0,0 +1,128 @@
+;; tinmop: an humble gemini kami and pleroma client
+;; Copyright © 2022  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 :gopher-client)
+
+(a:define-constant +request-terminal+  (format nil "~a~a" #\Return #\Newline) :test #'string=)
+
+(a:define-constant +response-terminal+ (format nil ".~a~a" #\Return #\Newline) :test #'string=)
+
+(a:define-constant +response-read-buffer-size+ 4096 :test #'=)
+
+(defun make-collect-fn (collected)
+  (lambda (buffer)
+    (loop for b across buffer do
+      (vector-push-extend b collected 1024))))
+
+(defun %request (host &key
+                        (port 70)
+                        (selector "")
+                        (terminate-strategy :response-terminal)
+                        (collect-fn (lambda (data) (format t "~a" (to-s data)))))
+  (assert (or (null terminate-strategy)
+              (eq terminate-strategy :response-terminal)))
+  (flet ((open-socket (hostname port)
+           (usocket:socket-connect hostname
+                                   port
+                                   :element-type '(unsigned-byte 8)))
+         (end-response-p (read-so-far buffer)
+           (if (< read-so-far (length buffer))
+               t
+               (let ((maybe-terminal-data (subseq buffer
+                                                  (- read-so-far
+                                                     (length +response-terminal+))
+                                                  read-so-far)))
+                 (and (eq terminate-strategy :response-terminal)
+                      (string= (to-s maybe-terminal-data)
+                               +response-terminal+))))))
+    (let* ((socket (open-socket host port))
+           (stream (usocket:socket-stream socket)))
+      (write-sequence (babel:string-to-octets (format nil
+                                                      "~a~a"
+                                                      selector
+                                                      +request-terminal+))
+                      stream)
+      (finish-output stream)
+      (let* ((buffer (misc:make-fresh-array +response-read-buffer-size+
+                                            0
+                                            '(unsigned-byte 8)
+                                            t))
+             (first-chunk-size (read-sequence buffer stream)))
+        (labels ((read-all (buffer read-so-far)
+                   (funcall collect-fn (subseq buffer 0 read-so-far))
+                   (when (not (end-response-p read-so-far buffer))
+                     (let ((new-chunk-size (read-sequence buffer stream)))
+                       (read-all buffer new-chunk-size)))))
+          (read-all buffer first-chunk-size))))))
+
+(defmacro gen-request-function (return-types strategies)
+  `(defun ,(format-fn-symbol t "request")
+       (host response-type
+        &key
+          (port 70)
+          (selector "")
+          (collect-fn (lambda (data) (format t "~s" (to-s data)))))
+     (cond
+       ,@(append
+          (loop for return-type in return-types
+                for strategy    in strategies
+                collect
+                `((string= response-type ,return-type)
+                  (%request host
+                            :port               port
+                            :selector           selector
+                            :terminate-strategy ,strategy
+                            :collect-fn         collect-fn)))
+          `(((string= response-type +line-type-uri+)
+             (open-message-link-window:open-message-link selector nil)))
+          `((t
+             (%request host :port               port
+                            :selector           selector
+                            :terminate-strategy nil
+                            :collect-fn         collect-fn)))))))
+
+(gen-request-function (+line-type-file+
+                       +line-type-dir+
+                       +line-type-error+
+                       +line-type-mac-hex-file+
+                       +line-type-dos-archive-file+
+                       +line-type-uuencoded-file+
+                       +line-type-index-search+
+                       +line-type-binary-file+
+                       +line-type-gif-image-file+
+                       +line-type-image-file+
+                       +line-type-info+)
+                      (:response-terminal
+                       :response-terminal
+                       :response-terminal
+                       nil
+                       nil
+                       nil
+                       :response-terminal
+                       nil
+                       nil
+                       nil
+                       :response-terminal))
+
+(defun request-from-iri (iri &optional (collect-function (lambda (data)
+                                                           (format t "~a" (to-s data)))))
+  (multiple-value-bind (host port type selector)
+      (parse-iri iri)
+    (request host
+             type
+             :port     port
+             :selector selector
+             :collect-fn collect-function)))

src/gopher/package.lisp

@@ -0,0 +1,100 @@
+;; tinmop: an humble gemini kami and pleroma client
+;; Copyright © 2022  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/>.
+
+(defpackage gopher-parser
+  (:use
+   :cl
+   :cl-ppcre
+   :esrap
+   :config
+   :constants
+   :text-utils
+   :misc)
+  (:local-nicknames (:a :alexandria))
+  (:export
+   :+gopher-scheme+
+   :+line-type-file+
+   :+line-type-dir+
+   :+line-type-cso+
+   :+line-type-error+
+   :+line-type-mac-hex-file+
+   :+line-type-dos-archive-file+
+   :+line-type-uuencoded-file+
+   :+line-type-index-search+
+   :+line-type-telnet-session+
+   :+line-type-binary-file+
+   :+line-type-gif-image-file+
+   :+line-type-image-file+
+   :+line-type-info+
+   :+line-type-uri+
+   :line-type-id
+   :selector
+   :username
+   :port
+   :host
+   :line-file
+   :line-dir
+   :line-cso
+   :line-error
+   :line-mac-hex-file
+   :line-dos-archive-file
+   :line-uuencoded-file
+   :line-index-search
+   :line-telnet-session
+   :line-binary-file
+   :line-redundant-server
+   :line-tn3270-session
+   :line-gif-file
+   :line-image-file
+   :line-info
+   :line-uri
+   :line-unknown
+   :line-type-file-p
+   :line-type-info-p
+   :line-type-dir-p
+   :line-type-cso-p
+   :line-type-error-p
+   :line-type-mac-hex-file-p
+   :line-type-dos-archive-file-p
+   :line-type-uuencoded-file-p
+   :line-type-index-search-p
+   :line-type-telnet-session-p
+   :line-type-binary-file-p
+   :line-type-redundant-server-p
+   :line-type-tn3270-session-p
+   :line-type-gif-file-p
+   :line-type-image-file-p
+   :line-type-image-uri-p
+   :line-unknown-p
+   :parse-menu
+   :parse-text-file
+   :parse-iri))
+
+(defpackage gopher-client
+  (:use
+   :cl
+   :cl-ppcre
+   :config
+   :constants
+   :text-utils
+   :misc
+   :gopher-parser)
+  (:local-nicknames (:a :alexandria)
+                    (:parser :gopher-parser))
+  (:export
+   :make-collect-fn
+   :request
+   :request-from-iri))

src/gopher/parser.lisp

@@ -0,0 +1,326 @@
+;; tinmop: an humble gemini kami and pleroma client
+;; Copyright © 2022  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 :gopher-parser)
+
+(defmacro def-line-type-constant (name value documentation)
+  `(a:define-constant ,(format-fn-symbol t "+line-type-~a+" name) ,value
+     :test #'string=
+     :documentation ,documentation))
+
+(defmacro gen-line-constants (name-values-doc-list)
+  `(progn
+     ,@(loop for data in name-values-doc-list
+             collect
+             `(def-line-type-constant ,(first  data) ,(second data) ,(third data)))))
+
+(gen-line-constants ((file             "0" "identifier for a file")
+                     (dir              "1" "identifier for a directory")
+                     (cso              "2" "identifier for a CSO phone-book server")
+                     (error            "3" "identifier for an error")
+                     (mac-hex-file     "4" "identifier for a BinHexed Macintosh file")
+                     (dos-archive-file "5" "identifier for a DOS binary archive of some sort")
+                     (uuencoded-file   "6" "identifier for a UNIX uuencoded file")
+                     (index-search     "7" "identifier for Index-Search server")
+                     (telnet-session   "8" "identifier for a text-based telnet session.")
+                     (binary-file      "9" "identifier for a binary file")
+                     (redundant-server "+" "identifier for a redundant server")
+                     (tn3270-session   "T" "identifier for a tn3270 session")
+                     (gif-image-file   "g" "identifier for an image in GIF")
+                     (image-file       "I" "identifier for an image file")
+                     (info             "i" "information line")
+                     (uri              "h" "hyperlink")))
+
+(a:define-constant +gopher-scheme+ "gopher" :test #'string=)
+
+(defun %check-line-type (data reference)
+  (string= data reference))
+
+(defmacro %gen-check-line-predicate (name reference)
+  (a:with-gensyms (data)
+  `(defun ,(format-fn-symbol t "%line-type-~a-p" name) (,data)
+     (%check-line-type ,data ,reference))))
+
+(%gen-check-line-predicate file             +line-type-file+)
+
+(%gen-check-line-predicate dir              +line-type-dir+)
+
+(%gen-check-line-predicate cso              +line-type-cso+)
+
+(%gen-check-line-predicate error            +line-type-error+)
+
+(%gen-check-line-predicate mac-hex-file     +line-type-mac-hex-file+)
+
+(%gen-check-line-predicate dos-archive-file +line-type-dos-archive-file+)
+
+(%gen-check-line-predicate uuencoded-file   +line-type-uuencoded-file+)
+
+(%gen-check-line-predicate index-search     +line-type-index-search+)
+
+(%gen-check-line-predicate telnet-session   +line-type-telnet-session+)
+
+(%gen-check-line-predicate binary-file      +line-type-binary-file+)
+
+(%gen-check-line-predicate redundant-server +line-type-redundant-server+)
+
+(%gen-check-line-predicate tn3270-session   +line-type-tn3270-session+)
+
+(%gen-check-line-predicate gif-file         +line-type-gif-image-file+)
+
+(%gen-check-line-predicate image-file       +line-type-image-file+)
+
+(%gen-check-line-predicate info             +line-type-info+)
+
+(%gen-check-line-predicate uri              +line-type-uri+)
+
+(defclass gopher-line ()
+  ((line-type-id
+    :initarg :line-type-id
+    :initform ""
+    :accessor line-type-id
+    :type     string)
+   (username
+    :initarg :username
+    :initform ""
+    :accessor username
+    :type     string)
+   (selector
+    :initarg :selector
+    :initform ""
+    :accessor selector
+    :type     string)
+   (host
+    :initarg :host
+    :initform ""
+    :accessor host
+    :type     string)
+   (port
+    :initarg :port
+    :initform -1
+    :accessor port
+    :type     number)))
+
+(defmethod print-object ((object gopher-line) stream)
+  (with-accessors ((username username)
+                   (selector selector)
+                   (host     host)
+                   (port     port)) object
+    (print-unreadable-object (object stream :type t)
+      (format stream
+              "username: ~s selector: ~s host: ~s port ~a"
+              username selector host port))))
+
+(defmacro gen-selector-class (name)
+  `(defclass ,name (gopher-line) ()))
+
+(gen-selector-class line-file)
+
+(gen-selector-class line-dir)
+
+(gen-selector-class line-cso)
+
+(gen-selector-class line-error)
+
+(gen-selector-class line-mac-hex-file)
+
+(gen-selector-class line-dos-archive-file)
+
+(gen-selector-class line-uuencoded-file)
+
+(gen-selector-class line-index-search)
+
+(gen-selector-class line-telnet-session)
+
+(gen-selector-class line-binary-file)
+
+(gen-selector-class line-redundant-server)
+
+(gen-selector-class line-tn3270-session)
+
+(gen-selector-class line-gif-file)
+
+(gen-selector-class line-image-file)
+
+(gen-selector-class line-info)
+
+(gen-selector-class line-uri)
+
+(gen-selector-class line-unknown)
+
+(defun check-line-type (data reference)
+  (typep data reference))
+
+(defmacro gen-check-line-predicate (name reference)
+  (a:with-gensyms (data)
+  `(defun ,(format-fn-symbol t "line-type-~a-p" name) (,data)
+     (check-line-type ,data ,reference))))
+
+(gen-check-line-predicate file             'line-file)
+
+(gen-check-line-predicate dir              'line-dir)
+
+(gen-check-line-predicate cso              'line-cso)
+
+(gen-check-line-predicate error            'line-error)
+
+(gen-check-line-predicate mac-hex-file     'line-mac-hex-file)
+
+(gen-check-line-predicate dos-archive-file 'line-dos-archive-file)
+
+(gen-check-line-predicate uuencoded-file   'line-uuencoded-file)
+
+(gen-check-line-predicate index-search     'line-index-search)
+
+(gen-check-line-predicate telnet-session   'line-telnet-session)
+
+(gen-check-line-predicate binary-file      'line-binary-file)
+
+(gen-check-line-predicate redundant-server 'line-redundant-server)
+
+(gen-check-line-predicate tn3270-session   'line-tn3270-session)
+
+(gen-check-line-predicate gif-file         'line-gif-image-file)
+
+(gen-check-line-predicate image-file       'line-image-file)
+
+(gen-check-line-predicate info             'line-info)
+
+(gen-check-line-predicate uri              'line-uri)
+
+(gen-check-line-predicate unknown          'unknown)
+
+(defrule line-separator (and #\Return #\Newline)
+  (:constant :line-separator))
+
+(defrule field-separator #\tab
+  (:constant :field-separator))
+
+(defrule null-char #\Nul
+  (:constant :field-separator))
+
+(defrule unascii (not (or field-separator line-separator null-char))
+  (:text t))
+
+(defrule last-line (and #\. line-separator)
+  (:constant :last-line))
+
+(defrule line-type unascii
+  (:text t))
+
+(defrule red-type (and #\+ #\.)
+  (:constant :red-type))
+
+(defrule user-name (* unascii)
+  (:text t))
+
+(defrule selector (* unascii)
+  (:text t))
+
+(defrule hostname-component (* (not (or field-separator line-separator null-char
+                                        #\.)))
+  (:text t))
+
+(defrule host (and (* (and hostname-component #\.))
+                   hostname-component)
+  (:text t))
+
+(defrule digit (character-ranges #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+  (:text t))
+
+(defrule digit-sequence (and digit (* digit))
+  (:text t))
+
+(defrule port digit-sequence
+  (:function parse-integer))
+
+(defrule dir-entity (and line-type user-name field-separator
+                         selector field-separator
+                         host field-separator
+                         port line-separator)
+  (:function (lambda (line)
+               (list :type (first line)
+                     :user-name (second line)
+                     :selector  (fourth line)
+                     :host      (sixth  line)
+                     :port      (elt    line 7)))))
+
+(defrule menu (and (* dir-entity) last-line)
+  (:function first))
+
+(defun parse-menu (data)
+  (let ((menu (parse 'menu data)))
+    (loop for entry in menu
+          collect
+          (let* ((line-type (getf entry :type))
+                 (instance  (cond
+                              ((%line-type-file-p line-type)
+                               (make-instance 'line-file))
+                              ((%line-type-dir-p line-type)
+                               (make-instance 'line-dir))
+                              ((%line-type-cso-p line-type)
+                               (make-instance 'line-cso))
+                              ((%line-type-error-p line-type)
+                               (make-instance 'line-error))
+                              ((%line-type-mac-hex-file-p line-type)
+                               (make-instance 'line-mac-hex-file))
+                              ((%line-type-dos-archive-file-p line-type)
+                               (make-instance 'line-dos-archive-file))
+                              ((%line-type-uuencoded-file-p line-type)
+                               (make-instance 'line-uuencoded-file))
+                              ((%line-type-index-search-p line-type)
+                               (make-instance 'line-index-search))
+                              ((%line-type-telnet-session-p line-type)
+                               (make-instance 'line-telnet-session))
+                              ((%line-type-binary-file-p line-type)
+                               (make-instance 'line-binary-file))
+                              ((%line-type-redundant-server-p line-type)
+                               (make-instance 'line-redundant-server))
+                              ((%line-type-tn3270-session-p line-type)
+                               (make-instance 'line-tn3270-session))
+                              ((%line-type-gif-file-p line-type)
+                               (make-instance 'line-gif-file))
+                              ((%line-type-image-file-p line-type)
+                               (make-instance 'line-image-file))
+                              ((%line-type-info-p line-type)
+                               (make-instance 'line-info))
+                              ((%line-type-uri-p line-type)
+                               (make-instance 'line-uri))
+                              (t
+                               (make-instance 'line-unknown)))))
+            (setf (line-type-id instance) (getf entry :type)
+                  (username     instance) (getf entry :user-name)
+                  (selector     instance) (getf entry :selector)
+                  (host         instance) (getf entry :host)
+                  (port         instance) (getf entry :port))
+            instance))))
+
+(defrule text-block (+ (not (and #\Newline #\. #\Return #\Newline)))
+  (:text t))
+
+(defrule text-file (and (* text-block) (and #\Newline #\. #\Return #\Newline))
+  (:function caar))
+
+(defun parse-text-file (data)
+  (parse 'text-file data))
+
+(defun parse-iri (iri)
+  (let* ((parsed   (iri:iri-parse iri))
+         (host     (uri:host parsed))
+         (port     (or (uri:port parsed) 70))
+         (path     (uri:path parsed))
+         (type     (second (fs:split-path-elements path)))
+         (selector (subseq path (+ 2 (length type)))))
+    (values host port type selector)))

src/keybindings.lisp

@@ -276,6 +276,9 @@ produces a tree and graft the latter on `existing-tree'"
 (defparameter *filesystem-explorer-keymap* (make-starting-comand-tree)
   "The keymap for gempub library of publication.")
 
+(defparameter *gopher-keymap* (make-starting-comand-tree)
+  "The keymap for gempub library of publication.")
+
 (defparameter *all-keymaps* '(*global-keymap*
                               *thread-keymap*
                               *message-keymap*
@@ -294,7 +297,8 @@ produces a tree and graft the latter on `existing-tree'"
                               *gemlog-subscription-keymap*
                               *gemini-toc-keymap*
                               *gempub-library-keymap*
-                              *filesystem-explorer-keymap*))
+                              *filesystem-explorer-keymap*
+                              *gopher-keymap*))
 
 (defun define-key (key-sequence function &optional (existing-keymap *global-keymap*))
   "Define a key sequence that trigger a function:

src/package.lisp

@@ -1155,6 +1155,7 @@
    :+key-main-window+
    :+key-thread-window+
    :+key-message-window+
+   :+key-gopher-window+
    :+key-chat-window+
    :+key-chats-list-window+
    :+key-gemini-subscription-window+
@@ -1262,6 +1263,16 @@
    :config-username
    :config-password-echo-character
    :config-win-focus-mark
+   :config-gopher-line-prefix-directory
+   :config-gopher-line-prefix-uri
+   :config-gopher-line-prefix-unknown
+   :config-gopher-line-prefix-binary-file
+   :config-gopher-line-prefix-text-file
+   :config-gopher-line-prefix-image-file
+   :config-gopher-line-prefix-gif-file
+   :config-gopher-line-prefix-search-index
+   :config-gopher-line-prefix-attribute
+   :config-gopher-line-prefix-foreground
    :link-regex->program-to-use
    :link-regex->program-to-use-buffer-size
    :use-tinmop-as-external-program-p
@@ -1397,7 +1408,8 @@
    :*gemini-toc-window*
    :*chats-list-window*
    :*gempub-library-window*
-   :*filesystem-explorer-window*))
+   :*filesystem-explorer-window*
+   :*gopher-window*))
 
 (defpackage :complete
   (:use
@@ -1718,6 +1730,7 @@
    :*gemini-toc-keymap*
    :*gempub-library-keymap*
    :*filesystem-explorer-keymap*
+   :*gopher-keymap*
    :define-key
    :init-keyboard-mapping
    :find-keymap-node
@@ -2258,6 +2271,32 @@
    :init
    :search-gemini-fragment))
 
+(defpackage :gopher-window
+  (:use
+   :cl
+   :cl-ppcre
+   :config
+   :constants
+   :text-utils
+   :misc
+   :mtree
+   :keybindings
+   :specials
+   :windows
+   :modeline-window
+   :line-oriented-window
+   :tui-utils)
+  (:shadowing-import-from :text-utils :split-lines)
+  (:shadowing-import-from :misc :random-elt :shuffle)
+  (:local-nicknames (:c  :croatoan)
+                    (:a  :alexandria))
+  (:export
+   :gopher-window
+   :go-to-next-link
+   :go-to-previous-link
+   :open-menu-link
+   :init))
+
 (defpackage :open-attach-window
   (:use
    :cl
@@ -2706,6 +2745,8 @@
    :message-scroll-end
    :message-scroll-next-page
    :message-scroll-previous-page
+   :message-window-go-up
+   :message-window-go-down
    :message-search-regex
    :message-toggle-preformatted-block
    :focus-to-message-window
@@ -2714,6 +2755,7 @@
    :focus-to-follow-requests-window
    :focus-to-tags-window
    :focus-to-conversations-window
+   :focus-to-gopher-window
    :print-quick-help
    :apropos-help
    :apropos-help-global

src/software-configuration.lisp

@@ -463,7 +463,8 @@
      ,@(loop for name in names collect
              `(gen-key-constant ,name))))
 
-(gen-key-constants experimental
+(gen-key-constants unknown
+                   experimental
                    regex
                    background
                    foreground
@@ -478,6 +479,7 @@
                    height
                    position
                    exclusive
+                   search
                    mode
                    count
                    toc
@@ -492,6 +494,7 @@
                    focus
                    prefix
                    postfix
+                   line
                    padding
                    value
                    scheme
@@ -543,6 +546,7 @@
                    chats-list-window
                    gemini-subscription-window
                    gemini-toc-window
+                   gopher-window
                    attachment-header
                    max-numbers-allowed-attachments
                    max-message-length
@@ -591,6 +595,11 @@
                    unread
                    directory-symbol
                    directory
+                   file
+                   binary-file
+                   text-file
+                   image-file
+                   gif-file
                    fetch
                    update
                    iri
@@ -926,7 +935,6 @@
                        +key-library+)
       (res:home-datadir)))
 
-
 (defun external-editor ()
   (access:access *software-configuration*
                  +key-editor+))
@@ -1045,6 +1053,67 @@
 
 (gen-simple-access (all-link-open-program) +key-open-link-helper+)
 
+(gen-simple-access (gopher-line-prefix-directory)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-directory+)
+
+(gen-simple-access (gopher-line-prefix-uri)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-uri+)
+
+(gen-simple-access (gopher-line-prefix-unknown)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-unknown+)
+
+(gen-simple-access (gopher-line-prefix-binary-file)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-binary-file+)
+
+(gen-simple-access (gopher-line-prefix-text-file)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-text-file+)
+
+(gen-simple-access (gopher-line-prefix-image-file)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-image-file+)
+
+(gen-simple-access (gopher-line-prefix-gif-file)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-gif-file+)
+
+(gen-simple-access (gopher-line-prefix-search-index)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-search+)
+
+(gen-simple-access (gopher-line-prefix-foreground)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-foreground+)
+
+(gen-simple-access (gopher-line-prefix-attribute
+                    :transform-value-fn tui-utils:text->tui-attribute)
+                   +key-gopher-window+
+                   +key-line+
+                   +key-prefix+
+                   +key-attribute+)
+
 (defun link-regex->program-to-use-parameters (link)
   (find-if (lambda (a) (cl-ppcre:scan (re a) link))
            (config-all-link-open-program)))

src/specials.lisp

@@ -71,3 +71,5 @@
   "The window that shows the gempub library.")
 
 (defparameter *filesystem-explorer-window* nil)
+
+(defparameter *gopher-window* nil)

src/ui-goodies.lisp

@@ -412,6 +412,12 @@ Metadata includes:
 (defun message-scroll-previous-page ()
   (message-window:scroll-previous-page *message-window*))
 
+(defun message-window-go-down ()
+  (line-window-go-down *gemini-certificates-window*))
+
+(defun message-window-go-up ()
+  (line-window-go-up *gemini-certificates-window*))
+
 (defun message-search-regex-callback (regex &key (priority +maximum-event-priority+))
   (let ((event (make-instance 'search-regex-message-content-event
                               :priority priority
@@ -737,6 +743,11 @@ along the focused window."
                      :documentation      "Move focus on filesystem explorer window"
                      :info-change-focus-message (_ "Focus passed on file explorer window"))
 
+(gen-focus-to-window gopher-window
+                     *gopher-window*
+                     :documentation      "Move focus on gopher window"
+                     :info-change-focus-message (_ "Focus passed on gopher window"))
+
 (defun print-quick-help ()
   "Print a quick help"
   (keybindings:print-help *main-window*))
@@ -2164,11 +2175,16 @@ open-message-link-window:open-message-link"
 Currently the only recognized protocols are gemini and kami."
   (flet ((on-input-complete (url)
            (let ((trimmed-url (trim-blanks url)))
-             (if (text-utils:string-starts-with-p kami:+kami-scheme+ trimmed-url)
+             (cond
-                 (progn
+               ((text-utils:string-starts-with-p kami:+kami-scheme+ trimmed-url)
-                   (file-explorer-close-window)
+                (file-explorer-close-window)
-                   (open-kami-address trimmed-url))
+                (open-kami-address trimmed-url))
-                 (open-gemini-address trimmed-url)))))
+               ((text-utils:string-starts-with-p gopher-parser:+gopher-scheme+ trimmed-url)
+                (multiple-value-bind (host port type selector)
+                    (gopher-parser:parse-iri address)
+                  (gopher-window::make-request host port type selector)))
+               (t
+                (open-gemini-address trimmed-url))))))
     (if (null address)
         (let ((prompt (open-url-prompt)))
           (ask-string-input #'on-input-complete

tinmop.asd

@@ -100,6 +100,10 @@
                (:module kami
                 :components ((:file "package")
                              (:file "client")))
+               (:module gopher
+                :components ((:file "package")
+                             (:file "parser")
+                             (:file "client")))
                (:file "command-line")
                (:file "specials")
                (:file "keybindings")
@@ -122,6 +126,7 @@
                (:file "message-rendering-utils")
                (:file "thread-window")
                (:file "message-window")
+               (:file "gopher-window")
                (:file "open-attach-window")
                (:file "open-message-link-window")
                (:file "gemini-client-certificates-window")