mirror of https://codeberg.org/cage/tinmop/
97 lines
6.3 KiB
Common Lisp
97 lines
6.3 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-dummy-server)
|
|
|
|
(cffi:defcallback no-verify :int ((preverify-ok :int) (x509-store-ctx :pointer))
|
|
(declare (ignore preverify-ok x509-store-ctx))
|
|
1)
|
|
|
|
(defun start (&optional (port +gemini-default-port+))
|
|
"Start a trivial server listening on `PORT' using the certificate
|
|
and key stored in the file pointed by the filesystem path
|
|
`CERTIFICATE' and `KEY' respectively"
|
|
(multiple-value-bind (certificate key)
|
|
(os-utils:generate-ssl-certificate (os-utils:default-temp-dir))
|
|
(format t
|
|
"generated certificate and private key in ~s ~s respectively~%"
|
|
certificate
|
|
key)
|
|
(let ((server (usocket:socket-listen "127.0.0.1" port :element-type '(unsigned-byte 8)))
|
|
(client-cert-fingerprint nil))
|
|
(format t "SSL server listening on port ~d~%" port)
|
|
(labels ((get-data ()
|
|
(format t "start~%")
|
|
(let* ((client-socket (usocket:socket-accept server)))
|
|
(format t "accepted ~a~%" client-socket)
|
|
(make-thread (lambda ()
|
|
(let ((client-stream (usocket:socket-stream client-socket)))
|
|
(format t "opening socket~%")
|
|
(let ((ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-peer+
|
|
:verify-callback 'no-verify)))
|
|
(cl+ssl:with-global-context (ctx :auto-free-p t)
|
|
(let* ((stream (cl+ssl:make-ssl-server-stream client-stream
|
|
:external-format
|
|
nil
|
|
:certificate
|
|
certificate
|
|
:key
|
|
key)))
|
|
(setf client-cert-fingerprint (x509:certificate-fingerprint stream))
|
|
(let* ((data (misc:read-line-into-array stream))
|
|
(request (text-utils:trim-blanks (text-utils:to-s data))))
|
|
(format t
|
|
"request ~s fingerprint ~a~%"
|
|
request
|
|
client-cert-fingerprint)
|
|
(cond
|
|
((cl-ppcre:scan "timeout" request)
|
|
(format t "timeout...~%")
|
|
(sleep 3600))
|
|
((null client-cert-fingerprint)
|
|
(let ((response (format nil
|
|
"~a please provide a certificate~a~a"
|
|
(code gemini-client::+60+)
|
|
#\return #\newline)))
|
|
(format t "sending: ~a~%" response)
|
|
(write-sequence (text-utils:string->octets response)
|
|
stream)
|
|
(close stream)
|
|
(get-data)))
|
|
((cl-ppcre:scan "^titan" request)
|
|
(format t "titan request reading first byte ~a~%" (read-byte stream))
|
|
(let ((response (format nil
|
|
"~a text/gemini~a~a#OK~%"
|
|
(code gemini-client::+20+)
|
|
#\return #\newline)))
|
|
(format t "sending: ~a~%" response)
|
|
(sleep 1)
|
|
(write-sequence (text-utils:string->octets response)
|
|
stream)
|
|
(close stream)))
|
|
(t
|
|
(let ((response (format nil
|
|
"~a text/gemini~a~a#OK~%"
|
|
(code gemini-client::+20+)
|
|
#\return #\newline)))
|
|
(format t "sending: ~a~%" response)
|
|
(write-sequence (text-utils:string->octets response)
|
|
stream)
|
|
(close stream)
|
|
(get-data))))))))))))))
|
|
(loop (get-data))))))
|