From ffdd960673c7f76b9c49aa380c40b3f20c53a105 Mon Sep 17 00:00:00 2001 From: cage Date: Fri, 19 Jun 2020 11:40:20 +0200 Subject: [PATCH] - added a draft for gemini client. --- src/conditions.lisp | 5 +- src/gemini/client.lisp | 217 ++++++++++++++++++++++++++++ src/{ => gemini}/gemini-parser.lisp | 100 +++++++++++-- src/gemini/package.lisp | 58 ++++++++ src/package.lisp | 30 +--- src/text-utils.lisp | 6 + tinmop.asd | 5 +- 7 files changed, 388 insertions(+), 33 deletions(-) create mode 100644 src/gemini/client.lisp rename src/{ => gemini}/gemini-parser.lisp (65%) create mode 100644 src/gemini/package.lisp diff --git a/src/conditions.lisp b/src/conditions.lisp index 2929bac..e794037 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -49,6 +49,9 @@ ((seq :initarg :seq :reader seq)) + (:report (lambda (condition stream) + (format stream "~s ~a" (seq condition) (text condition)))) + (:documentation "Length error")) (define-condition different-length-error (error) @@ -60,7 +63,7 @@ :reader seq2)) (:report (lambda (condition stream) (format stream "~a ~a" (seq1 condition) (seq2 condition)))) - (:documentation "Length error")) + (:documentation "Different length error")) (define-condition column-not-found (error) ((table diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp new file mode 100644 index 0000000..cfa8fd5 --- /dev/null +++ b/src/gemini/client.lisp @@ -0,0 +1,217 @@ +;; tinmop: an humble mastodon 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/][http://www.gnu.org/licenses/]]. + +(in-package :gemini-client) + +(define-constant +gemini-scheme+ "gemini" :test #'string=) + +(define-constant +gemini-default-port+ 1965 :test #'=) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass response-status-code () + ((code + :initform nil + :initarg :code + :accessor code) + (description + :initform nil + :initarg :description + :accessor description))) + + (defun response= (a b) + (= (code a) + (code b)))) + +(defmacro gen-status-constant (value description) + `(define-constant ,(format-fn-symbol t "+~a+" value) + (make-instance 'response-status-code + :code ,value + :description ,description) + :test #'response=)) + +(gen-status-constant 10 "Input") + +(gen-status-constant 11 "Sensitive input") + +(gen-status-constant 20 "success") + +(gen-status-constant 30 "redirect - temporary") + +(gen-status-constant 31 "redirect - permanent") + +(gen-status-constant 40 "temporary failure") + +(gen-status-constant 41 "server unavailable") + +(gen-status-constant 42 "cgi error") + +(gen-status-constant 43 "proxy error") + +(gen-status-constant 44 "slow down") + +(gen-status-constant 50 "permanent failure") + +(gen-status-constant 51 "not found") + +(gen-status-constant 52 "gone") + +(gen-status-constant 53 "proxy request refused") + +(gen-status-constant 59 "bad request") + +(gen-status-constant 60 "client certificate required") + +(gen-status-constant 61 "certificate not authorised") + +(gen-status-constant 62 "certificate not valid") + +(defparameter *all-codes* (list +10+ +11+ + +20+ + +30+ +31+ + +40+ +41+ +42+ +43+ +44+ + +50+ +51+ +52+ +53+ +59+ + +60+ +61+ +62+)) + +(defun code= (code code-class) + (= code + (code code-class))) + +(defun find-code-class (code) + (find-if (lambda (a) (code= code a)) *all-codes*)) + +(defun read-all (stream) + (let ((raw (loop + for c = (read-byte stream nil nil) + while c + collect c))) + (coerce raw '(vector (unsigned-byte 8))))) + +(defun mime-gemini-p (header-meta) + (string-starts-with-p "text/gemini" header-meta)) + +(defun header-code= (header code-class) + (code= (status-code header) + code-class)) + +(defun header-input-request-p (header) + (or (header-code= header +10+) + (header-code= header +11+))) + +(defun header-success-p (header) + (header-code= header +20+)) + +(defun header-redirect-p (header) + (or (header-code= header +30+) + (header-code= header +31+))) + +(defun header-temporary-failure-p (header) + (or (header-code= header +40+) + (header-code= header +41+) + (header-code= header +42+) + (header-code= header +43+) + (header-code= header +44+))) + +(defun header-permanent-failure-p (header) + (or (header-code= header +50+) + (header-code= header +51+) + (header-code= header +52+) + (header-code= header +53+) + (header-code= header +59+))) + +(defun header-not-implemented-p (header) + (or (header-code= header +60+) + (header-code= header +61+) + (header-code= header +62+))) + +(define-condition gemini-protocol-error (error) + ((error-code + :initarg :error-code + :reader error-code) + (error-description + :initarg :error-description + :reader error-description)) + (:report (lambda (condition stream) + (format stream + "The server responded with the error ~a: ~a" + (error-code condition) + (error-description condition)))) + (:documentation "The condition signalled for error codes (i.e. 4x and 5x)")) + +(defun parse-response (stream) + (let* ((header (read-line stream)) + (parsed-header (parse-gemini-response-header (format nil "~a~a" header #\Newline)))) + (with-accessors ((meta meta) + (status-code status-code)) parsed-header + (flet ((results (code-class body) + (values status-code + (description code-class) + meta + body))) + (cond + ((header-success-p parsed-header) + (let ((body (read-all stream))) + (if (mime-gemini-p meta) + (let ((parsed (parse-gemini-file (babel:octets-to-string body)))) + (values status-code + (description +20+) + meta + parsed + (sexp->text parsed) + (sexp->links parsed))) + (results +20+ body)))) + ((or (header-input-request-p parsed-header) + (header-redirect-p parsed-header)) + (results (find-code-class status-code) nil)) + ((or (header-permanent-failure-p parsed-header) + (header-temporary-failure-p parsed-header)) + (let ((response-code (find-code-class status-code))) + (error 'gemini-protocol-error + :error-code (code response-code) + :error-description (description response-code)))) + ((header-not-implemented-p parsed-header) + (error 'conditions:not-implemented-error + :text (_ "The server requested a certificate but client validation is not implemented by this program"))) + (t + parsed-header)))))) + +(defun request (host path &key + (query nil) + (port +gemini-default-port+)) + (let ((uri (strcat +gemini-scheme+ "://" + host ":" + (to-s port) "/" + path)) + (ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+))) + (when query + (setf uri (strcat uri "?" query))) + (cl+ssl:with-global-context (ctx :auto-free-p t) + (usocket:with-client-socket (socket stream + host + port + :element-type '(unsigned-byte 8)) + (let* ((ssl-stream (cl+ssl:make-ssl-client-stream stream + :external-format + '(:utf-8) + :unwrap-stream-p t + :verify nil + :hostname host)) + (request (format nil "~a~a~a" uri #\Return #\Newline))) + (write-string request ssl-stream) + (force-output ssl-stream) + (multiple-value-bind (status description meta body gemini-text gemini-links) + (parse-response ssl-stream) + (values status description meta body gemini-text gemini-links))))))) diff --git a/src/gemini-parser.lisp b/src/gemini/gemini-parser.lisp similarity index 65% rename from src/gemini-parser.lisp rename to src/gemini/gemini-parser.lisp index 8fe22ca..31e5cfd 100644 --- a/src/gemini-parser.lisp +++ b/src/gemini/gemini-parser.lisp @@ -27,7 +27,7 @@ (:constant nil)) (defrule cr-lf (and (? carriage-return) new-line) - (:constant "")) + (:constant nil)) (defrule h1-prefix "#" (:constant :h1)) @@ -57,7 +57,10 @@ (:constant :a)) (defrule text-line (and (+ (not cr-lf)) cr-lf) - (:text t)) + (:function (lambda (a) + (list :text + nil + (coerce (first a) 'string))))) (defrule link-url (+ (not (or space cr-lf))) @@ -81,28 +84,28 @@ (:function (lambda (a) (list (first a) nil - (second a))))) + (tag-value (second a)))))) (defrule h2 (and h2-prefix text-line) (:function (lambda (a) (list (first a) nil - (second a))))) + (tag-value (second a)))))) (defrule h3 (and h3-prefix text-line) (:function (lambda (a) (list (first a) nil - (second a))))) + (tag-value (second a)))))) (defrule list-item (and list-bullet text-line) (:function (lambda (a) (list (first a) nil - (second a))))) + (tag-value (second a)))))) (defrule preformatted-text (and preformatted-text-tag (* (not preformatted-text-tag)) @@ -114,7 +117,7 @@ text-line) (:function (lambda (a) (list (first a) nil - (second a))))) + (tag-value (second a)))))) (defrule gemini-file (* (or h3 h2 @@ -137,6 +140,32 @@ (define-constant +bullet-line-prefix+ #\• :test #'char=) +(defclass gemini-link () + ((target + :initform nil + :initarg :target + :accessor target) + (name + :initform nil + :initarg :name + :accessor name))) + +(defmethod print-object ((object gemini-link) stream) + (print-unreadable-object (object stream :type t :identity t) + (with-accessors ((target target) + (name name)) object + (format stream "target: ~s name: ~s" target name)))) + +(defun tag-value (node) + (first (html-utils:children node))) + +(defun sexp->links (parsed-gemini) + (loop for node in parsed-gemini when (html-utils:tag= :a node) collect + (make-instance 'gemini-link + :target (html-utils:attribute-value (html-utils:find-attribute :href + node)) + :name (tag-value node)))) + (defun sexp->text (parsed-gemini) (labels ((underlineize (stream text underline-char) (let* ((size (length text)) @@ -152,8 +181,8 @@ (with-output-to-string (stream) (loop for node in parsed-gemini do (cond - ((stringp node) - (format stream "~a~%" (trim node))) + ((null node) + (format stream "~%")) ((html-utils:tag= :h1 node) (underlineize stream (text-value node) @@ -187,3 +216,56 @@ (format stream "[~a]~%" link-name) (format stream "[~a]~%" link-value))))))))) +(defun parse-gemini-file (data) + (parse 'gemini-file data :junk-allowed t)) + +;; response header + +(define-constant +max-meta-length+ 1024 :test #'=) + +(defrule response-first-digit (or "1" "2" "3" "4" "5" "6") + (:text t)) + +(defrule response-second-digit (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9") + (:text t)) + +(defrule meta (+ (not carriage-return)) + (:text t)) + +(defclass gemini-response () + ((status-code + :initform nil + :initarg :status-code + :accessor status-code) + (meta + :initarg :meta + :accessor meta))) + +(defmethod print-object ((object gemini-response) stream) + (print-unreadable-object (object stream :type t :identity t) + (with-accessors ((status-code status-code) + (meta meta)) object + (format stream "status: ~a meta: ~a" status-code meta)))) + +(defrule response (and response-first-digit + response-second-digit + space + meta + carriage-return + new-line) + (:function (lambda (a) + (make-instance 'gemini-response + :status-code (parse-integer (strcat (first a) + (second a))) + :meta (fourth a))))) + +(defun parse-gemini-response-header (data) + (let ((parsed (parse 'response data))) + (if (> (length (meta parsed)) + +max-meta-length+) + (error 'conditions:length-error + :seq (meta parsed) + :text (format nil + " is too long. Maximum allowed length is ~a" + +max-meta-length+)) + parsed))) diff --git a/src/gemini/package.lisp b/src/gemini/package.lisp new file mode 100644 index 0000000..da3adef --- /dev/null +++ b/src/gemini/package.lisp @@ -0,0 +1,58 @@ +;; tinmop: an humble mastodon 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 . + +(defpackage :gemini-parser + (:use + :cl + :alexandria + :cl-ppcre + :esrap + :config + :constants + :text-utils + :misc + :alexandria) + (:shadowing-import-from :misc :random-elt :shuffle) + (:export + :gemini-link + :target + :name + :gemini-response + :status-code + :meta + :parse-gemini-file + :sexp->links + :sexp->text + :parse-gemini-response-header)) + +(defpackage :gemini-client + (:use + :cl + :alexandria + :cl-ppcre + :esrap + :config + :constants + :text-utils + :misc + :alexandria + :gemini-parser) + (:shadowing-import-from :misc :random-elt :shuffle) + (:export + :gemini-protocol-error + :error-code + :error-description + :request)) diff --git a/src/package.lisp b/src/package.lisp index 13c4174..4767745 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -347,6 +347,7 @@ :string-empty-p :string-not-empty-p :string-starts-with-p + :trim-blanks :find-max-line-length :box-fit-single-column :box-fit-multiple-column @@ -362,13 +363,13 @@ :config :text-utils) (:export - :tag - :attributes - :attribute-key - :attribute-value - :children - :tag= - :find-attribute + :tag + :attributes + :attribute-key + :attribute-value + :children + :tag= + :find-attribute :html->text)) (defpackage :resources-utils @@ -593,21 +594,6 @@ :stack-empty-p :do-stack-element)) -(defpackage :gemini-parser - (:use - :cl - :alexandria - :cl-ppcre - :esrap - :config - :constants - :text-utils - :misc - :alexandria) - (:shadowing-import-from :misc :random-elt :shuffle) - (:export - :parse)) - (defpackage :db-utils (:use :cl diff --git a/src/text-utils.lisp b/src/text-utils.lisp index 5573b4c..b26b69e 100644 --- a/src/text-utils.lisp +++ b/src/text-utils.lisp @@ -230,6 +230,12 @@ (length start)) (funcall test s start :start1 0 :end1 (length start)))) +(defvar *blanks* '(#\Space #\Newline #\Backspace #\Tab + #\Linefeed #\Page #\Return #\Rubout)) + +(defun trim-blanks (s) + (string-trim *blanks* s)) + (defun justify-monospaced-text (text &optional (chars-per-line 30)) (if (null (split-words text)) (list " ") diff --git a/tinmop.asd b/tinmop.asd index 9ea8f9f..50d5865 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -69,7 +69,10 @@ (:file "priority-queue") (:file "queue") (:file "stack") - (:file "gemini-parser") + (:module gemini + :components ((:file "package") + (:file "gemini-parser") + (:file "client"))) (:file "db-utils") (:file "db") (:file "date-formatter")