mirror of https://codeberg.org/cage/tinmop/
194 lines
9.2 KiB
Common Lisp
194 lines
9.2 KiB
Common Lisp
;; tinmop: a multiprotocol client
|
|
;; Copyright © 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 +chunk-buffer-size+ 2048 :test #'=
|
|
:documentation "Chunk's size of the buffer when writing to titan")
|
|
|
|
(define-constant +titan-mime-key+ "mime" :test #'string=)
|
|
|
|
(define-constant +titan-size-key+ "size" :test #'string=)
|
|
|
|
(define-constant +titan-token-key+ "token" :test #'string=)
|
|
|
|
(define-constant +titan-field-separator+ "=" :test #'string=)
|
|
|
|
(define-constant +titan-records-separator+ ";" :test #'string=)
|
|
|
|
(defun make-titan-parameters (mime-type size token)
|
|
(format nil
|
|
";~a~a~a~a~a~a~a~3*~@[~3:*~a~a~a~a~]"
|
|
+titan-mime-key+ +titan-field-separator+ mime-type +titan-records-separator+
|
|
+titan-size-key+ +titan-field-separator+ size +titan-records-separator+
|
|
+titan-token-key+ +titan-field-separator+ token))
|
|
|
|
(defun remove-titan-parameters-from-path (path)
|
|
(subseq path
|
|
0
|
|
(position +titan-records-separator+ path
|
|
:test (lambda (item char) (char= (first-elt item) char)))))
|
|
|
|
(defun parse-titan-parameters (path)
|
|
(flet ((get-value (key)
|
|
(multiple-value-bind (matchedp registers)
|
|
(scan-to-strings (format nil
|
|
"~a~a([^~a]+)~a?"
|
|
key
|
|
+titan-field-separator+
|
|
+titan-records-separator+
|
|
+titan-records-separator+)
|
|
path)
|
|
(when matchedp
|
|
(first-elt registers)))))
|
|
(let ((raw-size (get-value +titan-size-key+)))
|
|
(values (remove-titan-parameters-from-path path)
|
|
(get-value +titan-mime-key+)
|
|
(parse-integer raw-size)
|
|
(get-value +titan-token-key+)))))
|
|
|
|
(defgeneric titan-request (host path mime-type size token data
|
|
&key
|
|
query port fragment client-certificate certificate-key
|
|
certificate-key-password))
|
|
|
|
(defmethod titan-request (host path mime-type (size integer) token (data string)
|
|
&key
|
|
(query nil)
|
|
(port +gemini-default-port+)
|
|
(fragment nil)
|
|
(client-certificate nil)
|
|
(certificate-key nil)
|
|
(certificate-key-password nil))
|
|
(flex:with-input-from-sequence (stream (text-utils:string->octets data))
|
|
(titan-request host
|
|
path
|
|
mime-type
|
|
size
|
|
token
|
|
stream
|
|
:query query
|
|
:port port
|
|
:fragment fragment
|
|
:client-certificate client-certificate
|
|
:certificate-key certificate-key
|
|
:certificate-key-password certificate-key-password)))
|
|
|
|
(defmethod titan-request (host path mime-type (size integer) token (data pathname)
|
|
&key
|
|
(query nil)
|
|
(port +gemini-default-port+)
|
|
(fragment nil)
|
|
(client-certificate nil)
|
|
(certificate-key nil)
|
|
(certificate-key-password nil))
|
|
(with-open-file (stream
|
|
data
|
|
:direction :input
|
|
:if-does-not-exist :error
|
|
:element-type constants:+octect-type+)
|
|
(titan-request host
|
|
path
|
|
mime-type
|
|
size
|
|
token
|
|
stream
|
|
:query query
|
|
:port port
|
|
:fragment fragment
|
|
:client-certificate client-certificate
|
|
:certificate-key certificate-key
|
|
:certificate-key-password certificate-key-password)))
|
|
|
|
(defmethod titan-request (host path mime-type (size integer) token (data stream)
|
|
&key
|
|
(query nil)
|
|
(port +gemini-default-port+)
|
|
(fragment nil)
|
|
(client-certificate nil)
|
|
(certificate-key nil)
|
|
(certificate-key-password nil))
|
|
(let* ((iri (make-gemini-iri (idn:host-unicode->ascii host)
|
|
(strcat (percent-encode-path path)
|
|
(make-titan-parameters mime-type
|
|
size
|
|
token))
|
|
:query query
|
|
:scheme +titan-scheme+
|
|
:port port
|
|
:fragment (percent-encode-fragment fragment)))
|
|
(ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
|
|
(cl+ssl:with-global-context (ctx :auto-free-p t)
|
|
(let ((socket (open-tls-socket host port)))
|
|
(hooks:run-hooks 'hooks:*after-titan-socket*)
|
|
(let* ((stream (usocket:socket-stream socket))
|
|
(ssl-hostname (if (or (iri:ipv4-address-p host)
|
|
(iri:ipv6-address-p host))
|
|
nil
|
|
host))
|
|
(ssl-stream (cl+ssl:make-ssl-client-stream stream
|
|
:certificate client-certificate
|
|
:key certificate-key
|
|
:external-format nil ; unsigned byte 8
|
|
:unwrap-stream-p t
|
|
:verify nil
|
|
:password
|
|
certificate-key-password
|
|
:hostname ssl-hostname))
|
|
(request (format nil "~a~a~a" iri #\return #\newline))
|
|
(cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream))))
|
|
(debug-gemini "sending titan request ~a" request)
|
|
(if (not (db:tofu-passes-p host cert-hash))
|
|
(error 'gemini-tofu-error :host host)
|
|
(handler-case
|
|
(progn
|
|
(write-sequence (string->octets request) ssl-stream)
|
|
(force-output ssl-stream)
|
|
(read-stream-chunks data
|
|
+chunk-buffer-size+
|
|
(lambda (buffer read-so-far)
|
|
(write-sequence (subseq buffer 0 read-so-far)
|
|
ssl-stream)
|
|
(force-output ssl-stream)))
|
|
(hooks:run-hooks 'hooks:*after-titan-request-sent*)
|
|
(multiple-value-bind (status description meta response)
|
|
(parse-response ssl-stream)
|
|
(close-ssl-socket socket)
|
|
(values status description meta response socket)))
|
|
(gemini-protocol-error (e)
|
|
(close-ssl-socket socket)
|
|
(values (error-code e)
|
|
(error-description e)
|
|
(meta e)
|
|
(meta e)
|
|
socket))
|
|
(error ()
|
|
(handler-case
|
|
(multiple-value-bind (status description meta response)
|
|
(parse-response ssl-stream)
|
|
(close-ssl-socket socket)
|
|
(values status description meta response socket))
|
|
(error (e)
|
|
(close-ssl-socket socket)
|
|
(values 50
|
|
(format nil
|
|
(_ "Connection prematurely closed from the server: ~a")
|
|
e)
|
|
nil
|
|
nil
|
|
socket)))))))))))
|