mirror of
https://codeberg.org/cage/tinmop/
synced 2025-01-29 04:09:19 +01:00
- added a draft for gemini client.
This commit is contained in:
cage
parent
b38b7eac25
commit
ffdd960673
@ -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
|
||||
|
||||
217
src/gemini/client.lisp
Normal file
217
src/gemini/client.lisp
Normal file
@ -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)))))))
|
||||
@ -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)))
|
||||
58
src/gemini/package.lisp
Normal file
58
src/gemini/package.lisp
Normal file
@ -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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
(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))
|
||||
@ -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
|
||||
|
||||
@ -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 " ")
|
||||
|
||||
@ -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")
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user