cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-02 04:36:43 +01:00
Code Issues

- removed all direct references to package 'bt' (used wrappers instead);

Browse Source 
- addedd missing file 'dummy-server.lisp';

- updated LICENSES.org.
This commit is contained in:
cage 2024-02-11 12:32:22 +01:00
parent 346353d21d
commit 5155749080
14 changed files with 173 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
LICENSES.org
View File

@ -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 <edmundo@rano.org>
Copyright © 2000 Edmund Grimley Evans <edmundo@rano.org>
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
<xach@xach.com>, 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 <anton.vidovic@gmx.de>
Copyright © 2012-2019,2020 Anton Vidovic <anton.vidovic@gmx.de>
Portions Copyright (c) 2018 Daniel Vedder <d.vedder@web.de>
Portions Copyright (c) 2019 D4ryus <d4ryus@teknik.io>
Portions Copyright (c) 2019-2020 cage2 <github.com/cage2>
Portions Copyright © 2018 Daniel Vedder <d.vedder@web.de>
Portions Copyright © 2019 D4ryus <d4ryus@teknik.io>
Portions Copyright © 2019-2020 cage2 <github.com/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

2
src/api-client.lisp
View File

@ -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=

6
src/gemini-viewer.lisp
View File

@ -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

68
src/gemini/dummy-server.lisp Normal file
View File

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

2
src/gemini/gemini-parser.lisp
View File

@ -21,7 +21,7 @@
(defparameter *list-detected* nil)
(defparameter *parser-lock* (bt:make-lock))
(defparameter *parser-lock* (make-lock))
(defparameter *pre-group-id* -1)

2
src/gui/client/json-rpc-communication.lisp
View File

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

14
src/gui/client/main-window.lisp
View File

@ -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

4
src/gui/client/program-events.lisp
View File

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

13
src/misc-utils.lisp
View File

@ -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

2
src/package.lisp
View File

@ -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

24
src/program-events.lisp
View File

@ -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

4
src/tests/gemini-parser-tests.lisp
View File

@ -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 ()

10
src/tests/program-events-tests.lisp
View File

@ -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

6
src/ui-goodies.lisp
View File

@ -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*))