;; 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 . (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)) (defrule gopher-url (and (+ (not #\:)) "://" (or (and (+ (not #\:)) #\: (+ (not #\/)) #\/) (and (+ (not #\/)) #\/)) (? (and (+ (not #\/)) #\/)) (* (character-ranges (#\u0000 #\uffff)))) (:function (lambda (a) (let* ((host-port (third a)) (host (coerce (first host-port) 'string)) (port (if (third host-port) (parse-integer (coerce (third host-port) 'string)) 70)) (type-path (fourth a)) (type (if (car type-path) (coerce (car type-path) 'string) +line-type-dir+)) (path (coerce (fifth a) 'string))) (list host port path type))))) (defun parse-iri (iri) (let* ((parsed (parse 'gopher-url iri)) (host (first parsed)) (port (second parsed)) (selector (third parsed)) (type (fourth parsed))) (values host port type selector)))