From 5155749080231e13c29cb6c0f0881c48d9907e35 Mon Sep 17 00:00:00 2001 From: cage Date: Sun, 11 Feb 2024 12:32:22 +0100 Subject: [PATCH] - removed all direct references to package 'bt' (used wrappers instead); - addedd missing file 'dummy-server.lisp'; - updated LICENSES.org. --- LICENSES.org | 81 ++++++++++++++++------ src/api-client.lisp | 2 +- src/gemini-viewer.lisp | 6 +- src/gemini/dummy-server.lisp | 68 ++++++++++++++++++ src/gemini/gemini-parser.lisp | 2 +- src/gui/client/json-rpc-communication.lisp | 2 +- src/gui/client/main-window.lisp | 14 ++-- src/gui/client/program-events.lisp | 4 +- src/misc-utils.lisp | 13 ++-- src/package.lisp | 2 + src/program-events.lisp | 24 +++---- src/tests/gemini-parser-tests.lisp | 4 +- src/tests/program-events-tests.lisp | 10 +-- src/ui-goodies.lisp | 6 +- 14 files changed, 173 insertions(+), 65 deletions(-) create mode 100644 src/gemini/dummy-server.lisp diff --git a/LICENSES.org b/LICENSES.org index 130f22e..97bf8c3 100644 --- a/LICENSES.org +++ b/LICENSES.org @@ -1,6 +1,43 @@ +- src/gemini/dummy-server.lisp + + derived from: + + Copyright © 2001, 2003 Eric Marsden + Copyright © ???? Jochen Schmidt + Copyright © 2005 David Lichteblau + Copyright © 2007 Pixel // pinterface + Copyright © contributors as per cl+ssl git history + + - License first changed by Eric Marsden, Jochen Schmidt, and David Lichteblau + from plain LGPL to Lisp-LGPL in December 2005. + + - License then changed by Eric Marsden, Jochen Schmidt, and David Lichteblau + from Lisp-LGPL to MIT-style in January 2007. + + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation files + (the "Software"), to deal in the Software without restriction, + including without limitation the rights to use, copy, modify, merge, + publish, distribute, sublicense, and/or sell copies of the Software, + and to permit persons to whom the Software is furnished to do so, + subject to the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS + BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN + ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + - src/hooks derived from - Copyright (c) 2014 Paul M. Rodriguez + Copyright © 2014 Paul M. Rodriguez Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the @@ -29,7 +66,7 @@ uses code from: niccolo': a chemicals inventory - Copyright (C) 2016 Universita' degli Studi di Palermo + Copyright © 2016 Universita' degli Studi di Palermo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as @@ -71,7 +108,7 @@ function display-corrupting-utf8-p is derived from mutt: - Copyright (C) 2000 Edmund Grimley Evans + Copyright © 2000 Edmund Grimley Evans 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 @@ -119,7 +156,7 @@ - src/misc-utils.lisp 'unsplice' derived from - Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. + Copyright © 2011-2012, James M. Lawrence. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions @@ -152,7 +189,7 @@ according to: https://github.com/lmj/lparallel 'intersperse' family of functions derives from serapeum - Copyright (c) 2014 Paul M. Rodriguez + Copyright © 2014 Paul M. Rodriguez Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the @@ -177,7 +214,7 @@ uses code from: niccolo': a chemicals inventory - Copyright (C) 2016 Universita' degli Studi di Palermo + Copyright © 2016 Universita' degli Studi di Palermo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as @@ -213,7 +250,7 @@ SOFTWARE. uses code derived from: - local-time Copyright (c) 2005-2012 by Daniel Lowe + local-time Copyright © 2005-2012 by Daniel Lowe Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files @@ -236,7 +273,7 @@ SOFTWARE. uses code derived from: - local-time Copyright (c) 2005-2012 by Daniel Lowe + local-time Copyright © 2005-2012 by Daniel Lowe Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files @@ -260,7 +297,7 @@ uses code derived from: - quicklisp controller Copyright (c) 2013 Zachary Beane + quicklisp controller Copyright © 2013 Zachary Beane , All Rights Reserved Redistribution and use in source and binary forms, with or without @@ -289,7 +326,7 @@ - src/complete.lisp derived from linedit - Copyright (c) 2003, 2004 Nikodemus Siivola, Julian Squires + Copyright © 2003, 2004 Nikodemus Siivola, Julian Squires Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the @@ -312,11 +349,11 @@ - src/windows.lisp uses code from croatoan - Copyright (c) 2012-2019,2020 Anton Vidovic + Copyright © 2012-2019,2020 Anton Vidovic - Portions Copyright (c) 2018 Daniel Vedder - Portions Copyright (c) 2019 D4ryus - Portions Copyright (c) 2019-2020 cage2 + Portions Copyright © 2018 Daniel Vedder + Portions Copyright © 2019 D4ryus + Portions Copyright © 2019-2020 cage2 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -343,7 +380,7 @@ MIT License - Copyright (c) 2017-2019 Miles Johnson + Copyright © 2017-2019 Miles Johnson Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -367,10 +404,10 @@ derived from cl+ssl - Copyright (C) 2001, 2003 Eric Marsden - Copyright (C) ???? Jochen Schmidt - Copyright (C) 2005 David Lichteblau - Copyright (C) 2007 Pixel // pinterface + Copyright © 2001, 2003 Eric Marsden + Copyright © ???? Jochen Schmidt + Copyright © 2005 David Lichteblau + Copyright © 2007 Pixel // pinterface - License first changed by Eric Marsden, Jochen Schmidt, and David Lichteblau from plain LGPL to Lisp-LGPL in December 2005. @@ -407,9 +444,9 @@ (This is the MIT / X Consortium license as taken from http://www.opensource.org/licenses/mit-license.html) - Copyright (c) 2003 Erik Enge - Copyright (c) 2006-2007 Erik Huelsmann - Copyright (c) 2008-2019 Hans Hueber and Chun Tian + Copyright © 2003 Erik Enge + Copyright © 2006-2007 Erik Huelsmann + Copyright © 2008-2019 Hans Hueber and Chun Tian Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/src/api-client.lisp b/src/api-client.lisp index ba16d48..7841613 100644 --- a/src/api-client.lisp +++ b/src/api-client.lisp @@ -23,7 +23,7 @@ "An istance of 'credentials' used to holds the intormation needed to access a mastodon instance") -(defparameter *client-lock* (bt:make-lock) +(defparameter *client-lock* (make-lock) "The Lock for prevent race conditions when accessing the mastodon server") (define-constant +credentials-filename+ "client" :test #'string= diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index b09578f..3e49734 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -17,7 +17,7 @@ (in-package :gemini-viewer) -(defparameter *gemini-db-streams-lock* (bt:make-lock)) +(defparameter *gemini-db-streams-lock* (make-lock)) (define-constant +read-buffer-size+ 2048 :test #'= :documentation "Chunk's size of the buffer when reading non gemini contents from stream") @@ -107,7 +107,7 @@ (defclass gemini-stream () ((download-thread-lock - :initform (bt:make-lock "download-gemini") + :initform (make-lock "download-gemini") :initarg :download-thread-lock :accessor download-thread-lock) (download-thread-blocked @@ -261,7 +261,7 @@ (thread thread) (stream-status stream-status) (download-iri download-iri)) object - (setf thread (bt:make-thread function)) + (setf thread (make-thread function)) (setf start-time (db-utils:local-time-obj-now)) (setf download-iri (gemini-parser:make-gemini-iri host path diff --git a/src/gemini/dummy-server.lisp b/src/gemini/dummy-server.lisp new file mode 100644 index 0000000..c970059 --- /dev/null +++ b/src/gemini/dummy-server.lisp @@ -0,0 +1,68 @@ +;; 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)))) + (format t "SSL server listening on port ~d~%" port) + (unwind-protect + (labels ((get-data () + (let* ((client-socket (usocket:socket-accept server)) + (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)) + (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) + (when (null client-cert-fingerprint) + (let ((response (format nil + "~a please provide a certificate~a~a" + (code gemini-client::+60+) + #\return #\newline))) + (write-sequence (text-utils:string->octets response) + stream) + (close stream) + (get-data)))))))))) + (get-data)) + (usocket:socket-close server))))) diff --git a/src/gemini/gemini-parser.lisp b/src/gemini/gemini-parser.lisp index 1ed6993..d3bf463 100644 --- a/src/gemini/gemini-parser.lisp +++ b/src/gemini/gemini-parser.lisp @@ -21,7 +21,7 @@ (defparameter *list-detected* nil) -(defparameter *parser-lock* (bt:make-lock)) +(defparameter *parser-lock* (make-lock)) (defparameter *pre-group-id* -1) diff --git a/src/gui/client/json-rpc-communication.lisp b/src/gui/client/json-rpc-communication.lisp index 28b7601..595912e 100644 --- a/src/gui/client/json-rpc-communication.lisp +++ b/src/gui/client/json-rpc-communication.lisp @@ -45,7 +45,7 @@ (write-byte (logand object #xff) *server-stream*) (finish-output *server-stream*)) -(defparameter *request-lock* (bt:make-lock)) +(defparameter *request-lock* (make-lock)) (defgeneric make-request (method id &rest args)) diff --git a/src/gui/client/main-window.lisp b/src/gui/client/main-window.lisp index 8c004f9..07ff0f0 100644 --- a/src/gui/client/main-window.lisp +++ b/src/gui/client/main-window.lisp @@ -12,7 +12,7 @@ :initarg :status :accessor status) (status-lock - :initform (bt:make-lock) + :initform (make-lock) :reader status-lock) (fetching-thread :initform nil @@ -37,7 +37,7 @@ (defparameter *gemini-streams-db* ()) -(defparameter *gemini-streams-db-lock* (bt:make-lock "gemini-streams-db-lock")) +(defparameter *gemini-streams-db-lock* (make-lock "gemini-streams-db-lock")) (defun push-db-stream (stream-object) (misc:with-lock (*gemini-streams-db-lock*) @@ -80,9 +80,9 @@ (defmethod stop-stream-thread ((object gemini-stream)) (with-accessors ((fetching-thread fetching-thread)) object (abort-downloading object) - (when (and (bt:threadp fetching-thread) - (bt:thread-alive-p fetching-thread)) - (bt:join-thread fetching-thread))) + (when (and (threadp fetching-thread) + (thread-alive-p fetching-thread)) + (join-thread fetching-thread))) object) (defmethod stop-stream-thread ((object string)) @@ -204,7 +204,7 @@ (flet ((aborting-function () (eq (status stream-wrapper) +stream-status-canceled+))) (print-info-message (_ "Stream started")) - (let ((stream-thread (bt:make-thread (lambda () + (let ((stream-thread (make-thread (lambda () (slurp-gemini-stream main-window iri stream-wrapper @@ -1427,7 +1427,7 @@ local file paths." :initarg :ir-lines :accessor ir-lines) (interrupt-rendering-lock - :initform (bt:make-lock "render-lock") + :initform (make-lock "render-lock") :initarg :interrupt-rendering-lock :accessor interrupt-rendering-lock) (interrupt-rendering diff --git a/src/gui/client/program-events.lisp b/src/gui/client/program-events.lisp index d7d23f8..b0fa5ee 100644 --- a/src/gui/client/program-events.lisp +++ b/src/gui/client/program-events.lisp @@ -2,7 +2,7 @@ (defparameter *stop-events-loop* t) -(defparameter *events-loop-lock* (bt:make-lock "events-loop-lock")) +(defparameter *events-loop-lock* (make-lock "events-loop-lock")) (defparameter *events-loop-thread* nil) @@ -22,7 +22,7 @@ (misc:with-lock (*events-loop-lock*) (setf *stop-events-loop* nil)) (setf *events-loop-thread* - (bt:make-thread (lambda () + (make-thread (lambda () (let ((gui:*wish* gui-goodies:*gui-server*)) (loop while (events-loop-running-p) do (ev:dispatch-program-events-or-wait))))))) diff --git a/src/misc-utils.lisp b/src/misc-utils.lisp index fbab58d..b8f9dee 100644 --- a/src/misc-utils.lisp +++ b/src/misc-utils.lisp @@ -996,7 +996,7 @@ to the array" ;; threads -(defmacro with-lock ((lock) &body body) +(defmacro with-lock-held ((lock) &body body) `(bt:with-lock-held (,lock) ,@body)) @@ -1006,7 +1006,7 @@ to the array" `(defun ,name ,parameters ,doc-string ,declarations - (with-lock (,lock) + (with-lock-held (,lock) ,@remaining-forms)))) (defparameter *thread-default-special-bindings* bt:*default-special-bindings*) @@ -1017,10 +1017,6 @@ to the array" (definline make-lock (&optional name) (bt:make-lock name)) -(defmacro with-lock-held ((lock) &body body) - `(bt:with-lock-held (,lock) - ,@body)) - (definline make-condition-variable (&key (name nil)) (bt:make-condition-variable :name name)) @@ -1036,6 +1032,11 @@ to the array" (definline destroy-thread (thread) (bt:destroy-thread thread)) +(definline threadp (maybe-thread) + (bt:threadp maybe-thread)) + +(definline thread-alive-p (thread) + (bt:thread-alive-p thread)) ;; http diff --git a/src/package.lisp b/src/package.lisp index 7dd3fa0..dbb8c06 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -270,6 +270,8 @@ :condition-notify :join-thread :destroy-thread + :threadp + :thread-alive-p :get-url-content :with-profile-time :with-debug-print-profile-time diff --git a/src/program-events.lisp b/src/program-events.lisp index ac6f330..c3b4040 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -23,7 +23,7 @@ (define-constant +maximum-event-priority+ -2 :test #'=) -(defparameter *id-lock* (bt:make-lock)) +(defparameter *id-lock* (make-lock)) (defparameter *event-id* 0) @@ -100,15 +100,15 @@ (defclass events-queue (priority-queue) ((lock - :initform (bt:make-lock) + :initform (make-lock) :initarg :lock :accessor lock) (blocking-lock - :initform (bt:make-lock) + :initform (make-lock) :initarg :blocking-lock :accessor blocking-lock) (condition-variable - :initform (bt:make-condition-variable) + :initform (make-condition-variable) :initarg :condition-variable :accessor condition-variable))) @@ -155,14 +155,14 @@ (with-lock ((blocking-lock *events-queue*)) (loop while (emptyp *events-queue*) do - (bt:condition-wait (condition-variable *events-queue*) + (condition-wait (condition-variable *events-queue*) (blocking-lock *events-queue*))) (pop-element *events-queue*))) (defun push-event-unblock (value) (with-lock ((blocking-lock *events-queue*)) (push-element *events-queue* value) - (bt:condition-notify (condition-variable *events-queue*)))) + (condition-notify (condition-variable *events-queue*)))) (defun push-event (event) (wrapped-in-lock (*events-queue*) @@ -224,11 +224,11 @@ (defclass event-on-own-thread (program-event) ((lock - :initform (bt:make-lock) + :initform (make-lock) :initarg :lock :accessor lock) (condition-variable - :initform (bt:make-condition-variable) + :initform (make-condition-variable) :initarg :condition-variable :accessor condition-variable)) (:documentation "This is the parent of all events that are @@ -250,11 +250,11 @@ (progn (setf (box:unbox results) (funcall callback)) (with-lock (lock) - (bt:condition-notify condition-variable))) + (condition-notify condition-variable))) (error (e) (setf (box:unbox results) e) (with-lock (lock) - (bt:condition-notify condition-variable)))))) + (condition-notify condition-variable)))))) (defun push-function-and-wait-results (fn &key (priority +standard-event-priority+) @@ -269,7 +269,7 @@ (loop while (eq (box:unbox (results event)) :nothing) do - (bt:condition-wait condition-variable lock))) + (condition-wait condition-variable lock))) (let* ((event-results (results event)) (actual-results (box:unbox event-results))) (if (typep actual-results 'error) @@ -345,7 +345,7 @@ (setf (command-window:echo-character specials:*command-window*) :completed) (with-lock (lock) - (bt:condition-notify condition-variable)))) + (condition-notify condition-variable)))) (defclass notify-user-event (program-event) ((added-to-pending-p diff --git a/src/tests/gemini-parser-tests.lisp b/src/tests/gemini-parser-tests.lisp index 02b58bf..df73f19 100644 --- a/src/tests/gemini-parser-tests.lisp +++ b/src/tests/gemini-parser-tests.lisp @@ -53,10 +53,10 @@ baz collect (progn (sleep .01) - (bt:make-thread function)))) + (make-thread function)))) (results (loop for thread in threads collect - (bt:join-thread thread)))) + (join-thread thread)))) (elt results (random (length results))))) (defun parse-stream () diff --git a/src/tests/program-events-tests.lisp b/src/tests/program-events-tests.lisp index 7294b09..7d7c150 100644 --- a/src/tests/program-events-tests.lisp +++ b/src/tests/program-events-tests.lisp @@ -42,7 +42,7 @@ (push-event event) (with-lock (lock) (format t "wait!~%") - (bt:condition-wait condition-variable lock) + (condition-wait condition-variable lock) (format t "input was ~a~%" (dunbox (payload event))))))) (defun main-thread () @@ -57,11 +57,11 @@ (defun simulated-string-input () (let ((payload (dbox "bar")) (program-events::*events-queue* (make-instance 'events-queue)) - (main-thread (bt:make-thread #'main-thread))) + (main-thread (make-thread #'main-thread))) (sleep 3) - (bt:make-thread (lambda () + (make-thread (lambda () (dummy-ask-string-input payload))) - (bt:join-thread main-thread) + (join-thread main-thread) payload)) (defclass dummy-window () ()) @@ -81,7 +81,7 @@ (flet ((callback () "callback called!")) (client-events:start-events-loop) (let ((res nil)) - (bt:make-thread (lambda () + (make-thread (lambda () (sleep 3) (format t "push!~%") (setf res diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index f82675a..43a6e14 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -135,7 +135,7 @@ (ending-message (_ "Task completed")) (life-start nil) (life-end nil)) - (bt:make-thread (lambda () + (make-thread (lambda () (when (string-not-empty-p starting-message) (notify starting-message :life life-start)) (funcall procedure) @@ -246,10 +246,10 @@ while (not (eq (command-window:echo-character *command-window*) :completed)) do - (bt:condition-wait condition-variable lock)) + (condition-wait condition-variable lock)) (setf (command-window:echo-character *command-window*) nil) (funcall on-input-complete-fn (box:dunbox (payload event)))))))) - (bt:make-thread #'thread-fn))) + (make-thread #'thread-fn))) (defun thread-go-up () (thread-window:go-message-up *thread-window*))