;; 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)))))))))))