From 648b23891839458641a8c4e5411067fbbc5d2bad Mon Sep 17 00:00:00 2001 From: Ethan Date: Sat, 15 Nov 2025 03:35:53 -0500 Subject: [PATCH 01/10] WIP: add :after method for check-local-archive file This is an initial test of the solution proposed in: https://github.com/rudolfochrist/ql-https/issues/14 What is odd is that the md5sum checksum succeeds, yet the sha1sum fails. --- ql-https.lisp | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/ql-https.lisp b/ql-https.lisp index 4b2dbc1..270fea3 100644 --- a/ql-https.lisp +++ b/ql-https.lisp @@ -98,6 +98,16 @@ dist." (unless (= (ql-dist:archive-size release) (file-size file)) (error "file size mismatch for ~A" name)))) +(defmethod ql-dist:check-local-archive-file :after ((release ql-dist:release)) + "Checks that the md5 and size of FILE are as expected from the quicklisp +dist." + (let ((name (ql-dist:name release)) + (file (ql-dist:local-archive-file release))) + (unless (string-equal (ql-dist:archive-md5 release) (md5 file)) + (error "md5 mismatch for ~A" name)) + (unless (string-equal (ql-dist:archive-content-sha1 release) (content-hash file)) + (error "sha1 mismatch for ~A" name)))) + (defun register-fetch-scheme-functions () (setf ql-http:*fetch-scheme-functions* (list (cons "http" 'fetcher) From c6aef3a2884206e7fe5c17b3a4e121479933a11e Mon Sep 17 00:00:00 2001 From: Ethan Date: Fri, 5 Dec 2025 11:18:59 -0500 Subject: [PATCH 02/10] ql-https: ultralisp uses a different sha1 scheme than quicklisp --- ql-https.lisp | 35 ++++++++++++++++++++++++++++++++--- 1 file changed, 32 insertions(+), 3 deletions(-) diff --git a/ql-https.lisp b/ql-https.lisp index 270fea3..4c951d4 100644 --- a/ql-https.lisp +++ b/ql-https.lisp @@ -98,15 +98,44 @@ dist." (unless (= (ql-dist:archive-size release) (file-size file)) (error "file size mismatch for ~A" name)))) +(defun content-hash-ultralisp (tarfile) + (let* ((octets (babel-streams:with-output-to-sequence (buffer) + (uiop:run-program + (apply #'concatenate + 'string (list "tar -xOf" (namestring tarfile))) + :output buffer))) + + ;; (openssl-sha1 + ;; (uiop:launch-program "openssl dgst -sha1" + ;; :input (copy-seq octets) + ;; :element-type '(unsigned-byte 8) + ;; :output :stream)) + ) + ;; (print + ;; (extract-openssl-digest + ;; (read-binary-line + ;; (uiop:process-info-output openssl-sha1)))) + + (ironclad:byte-array-to-hex-string + (ironclad:digest-sequence :sha1 (copy-seq octets))))) + (defmethod ql-dist:check-local-archive-file :after ((release ql-dist:release)) - "Checks that the md5 and size of FILE are as expected from the quicklisp + "Checks that the md5 and size of FILE are as expected from the quicklisp dist." (let ((name (ql-dist:name release)) (file (ql-dist:local-archive-file release))) + (unless (string-equal (ql-dist:archive-md5 release) (md5 file)) (error "md5 mismatch for ~A" name)) - (unless (string-equal (ql-dist:archive-content-sha1 release) (content-hash file)) - (error "sha1 mismatch for ~A" name)))) + + (let* ((archive-sha1 (ql-dist:archive-content-sha1 release)) + (ql-dist-name (slot-value (slot-value release 'ql-dist:dist) 'ql-dist:name)) + (expected (case ql-dist-name + ("quicklisp" (content-hash file)) + ("ultralisp" (content-hash-ultralisp file)) + (t nil)))) + (when (and expected (not (string-equal archive-sha1 expected))) + (error "sha1 mismatch for ~A" name))))) (defun register-fetch-scheme-functions () (setf ql-http:*fetch-scheme-functions* From 32612a24309ab9263a3a253000aabebe6cd864df Mon Sep 17 00:00:00 2001 From: Ethan Date: Mon, 8 Dec 2025 12:45:18 -0500 Subject: [PATCH 03/10] ql-https: use *features* to conditionally load ironclad & babel --- ql-https.asd | 15 ++++++++++++++- ql-https.lisp | 3 +++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/ql-https.asd b/ql-https.asd index d282ab7..1eed1a3 100644 --- a/ql-https.asd +++ b/ql-https.asd @@ -1,5 +1,13 @@ ;;;; ql-https.asd +(dolist (dist (ql-dist:all-dists)) + (let ((dist-name (slot-value dist 'ql-dist::name))) + (cond + ((string= dist-name "quicklisp") + (pushnew :ql-https/quicklisp-check-sha1 *features*)) + ((string= dist-name "ultralisp") + (pushnew :ql-https/ultralisp-check-sha1 *features*))))) + (defsystem "ql-https" :author "Sebastian Christ " :maintainer "Sebastian Christ " @@ -9,7 +17,10 @@ :bug-tracker "https://github.com/rudolfochrist/ql-https/issues" :source-control (:git "https://github.com/rudolfochrist/ql-https.git") :version (:read-file-line "version") - :depends-on ((:require "uiop") (:feature :sbcl :sb-md5)) + :depends-on ((:require "uiop") + #+ql-https/ultralisp-check-sha1 (:require "ironclad") + #+ql-https/ultralisp-check-sha1 (:require "babel-streams") + (:feature :sbcl :sb-md5)) :components ((:file "ql-https") (:file "content-hash")) :description "Enable HTTPS in Quicklisp" @@ -36,5 +47,7 @@ +(loop for f in (list :ql-https/quicklisp-check-sha1 :ql-https/ultralisp-check-sha1) + do (setf *features* (delete f *features*))) diff --git a/ql-https.lisp b/ql-https.lisp index 4c951d4..e7eb00f 100644 --- a/ql-https.lisp +++ b/ql-https.lisp @@ -98,6 +98,7 @@ dist." (unless (= (ql-dist:archive-size release) (file-size file)) (error "file size mismatch for ~A" name)))) +#+ql-https/ultralisp-check-sha1 (defun content-hash-ultralisp (tarfile) (let* ((octets (babel-streams:with-output-to-sequence (buffer) (uiop:run-program @@ -131,7 +132,9 @@ dist." (let* ((archive-sha1 (ql-dist:archive-content-sha1 release)) (ql-dist-name (slot-value (slot-value release 'ql-dist:dist) 'ql-dist:name)) (expected (case ql-dist-name + #+ql-https/quicklisp-check-sha1 ("quicklisp" (content-hash file)) + #+ql-https/ultralisp-check-sha1 ("ultralisp" (content-hash-ultralisp file)) (t nil)))) (when (and expected (not (string-equal archive-sha1 expected))) From b3d43f675f79dbccf64eaa515eece3cee4579549 Mon Sep 17 00:00:00 2001 From: Ethan Date: Mon, 8 Dec 2025 12:52:38 -0500 Subject: [PATCH 04/10] ql-https.asd: fix --- ql-https.asd | 2 -- 1 file changed, 2 deletions(-) diff --git a/ql-https.asd b/ql-https.asd index 1eed1a3..3cd1ca6 100644 --- a/ql-https.asd +++ b/ql-https.asd @@ -47,7 +47,5 @@ -(loop for f in (list :ql-https/quicklisp-check-sha1 :ql-https/ultralisp-check-sha1) - do (setf *features* (delete f *features*))) From a7ad1edf8c40c2e577cf9017b8358450ab9ce147 Mon Sep 17 00:00:00 2001 From: Ethan Date: Wed, 10 Dec 2025 02:40:43 -0500 Subject: [PATCH 05/10] ql-https.asd : move feature removal to the correct place --- ql-https.asd | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ql-https.asd b/ql-https.asd index 3cd1ca6..4333ccd 100644 --- a/ql-https.asd +++ b/ql-https.asd @@ -29,6 +29,8 @@ (uiop:subpathname *load-pathname* "README.md")) :perform (load-op :after (o c) (uiop:symbol-call :ql-https :register-fetch-scheme-functions) + (loop for f in (list :ql-https/quicklisp-check-sha1 :ql-https/ultralisp-check-sha1) + do (setf *features* (delete f *features*))) (pushnew :ql-https *features*)) :in-order-to ((test-op (test-op "ql-https/test")))) From c97148a48f57f6c00c0235b3d3c4c38ae7f28b73 Mon Sep 17 00:00:00 2001 From: Ethan Date: Wed, 10 Dec 2025 23:32:53 -0500 Subject: [PATCH 06/10] ql-https: don't use slot-value or concatenate --- ql-https.lisp | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ql-https.lisp b/ql-https.lisp index e7eb00f..0e2ee11 100644 --- a/ql-https.lisp +++ b/ql-https.lisp @@ -102,8 +102,7 @@ dist." (defun content-hash-ultralisp (tarfile) (let* ((octets (babel-streams:with-output-to-sequence (buffer) (uiop:run-program - (apply #'concatenate - 'string (list "tar -xOf" (namestring tarfile))) + (list "tar -xOf" (namestring tarfile)) :output buffer))) ;; (openssl-sha1 @@ -130,7 +129,7 @@ dist." (error "md5 mismatch for ~A" name)) (let* ((archive-sha1 (ql-dist:archive-content-sha1 release)) - (ql-dist-name (slot-value (slot-value release 'ql-dist:dist) 'ql-dist:name)) + (ql-dist-name (ql-dist:name (ql-dist:release 'ql-dist:dist))) (expected (case ql-dist-name #+ql-https/quicklisp-check-sha1 ("quicklisp" (content-hash file)) From a2142382e3d9a7bf47c806d3da0f53279c2c5ead Mon Sep 17 00:00:00 2001 From: Ethan Date: Thu, 11 Dec 2025 00:05:20 -0500 Subject: [PATCH 07/10] ql-https.lisp: fix computing ql-dist-name --- ql-https.asd | 4 +--- ql-https.lisp | 3 +-- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/ql-https.asd b/ql-https.asd index 4333ccd..223e12a 100644 --- a/ql-https.asd +++ b/ql-https.asd @@ -3,8 +3,6 @@ (dolist (dist (ql-dist:all-dists)) (let ((dist-name (slot-value dist 'ql-dist::name))) (cond - ((string= dist-name "quicklisp") - (pushnew :ql-https/quicklisp-check-sha1 *features*)) ((string= dist-name "ultralisp") (pushnew :ql-https/ultralisp-check-sha1 *features*))))) @@ -29,7 +27,7 @@ (uiop:subpathname *load-pathname* "README.md")) :perform (load-op :after (o c) (uiop:symbol-call :ql-https :register-fetch-scheme-functions) - (loop for f in (list :ql-https/quicklisp-check-sha1 :ql-https/ultralisp-check-sha1) + (loop for f in (list :ql-https/ultralisp-check-sha1) do (setf *features* (delete f *features*))) (pushnew :ql-https *features*)) :in-order-to ((test-op (test-op "ql-https/test")))) diff --git a/ql-https.lisp b/ql-https.lisp index 0e2ee11..afd8235 100644 --- a/ql-https.lisp +++ b/ql-https.lisp @@ -129,9 +129,8 @@ dist." (error "md5 mismatch for ~A" name)) (let* ((archive-sha1 (ql-dist:archive-content-sha1 release)) - (ql-dist-name (ql-dist:name (ql-dist:release 'ql-dist:dist))) + (ql-dist-name (ql-dist:name (ql-dist:dist release))) (expected (case ql-dist-name - #+ql-https/quicklisp-check-sha1 ("quicklisp" (content-hash file)) #+ql-https/ultralisp-check-sha1 ("ultralisp" (content-hash-ultralisp file)) From 13cdd0c26c9f9ffaed03173c3c8eeb094dfc7d2f Mon Sep 17 00:00:00 2001 From: Ethan Date: Mon, 23 Feb 2026 17:58:56 -0500 Subject: [PATCH 08/10] content-hash.lisp ~ add version for ultralisp --- content-hash.lisp | 40 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) diff --git a/content-hash.lisp b/content-hash.lisp index 4820bcc..083c1de 100644 --- a/content-hash.lisp +++ b/content-hash.lisp @@ -61,7 +61,7 @@ at the terminating block of the end of input, BUFFER otherwise." (defun block-asciiz-string (block start length) (let* ((end (+ start length)) (eos (or (position 0 block :start start :end end) - end))) + end))) (ascii-subseq block start eos))) (defun payload-size (header) @@ -161,3 +161,41 @@ the digest of the files in TARFILE in order of their name." (extract-openssl-digest (read-binary-line (uiop:process-info-output openssl)))))) (when (probe-file temp) (ignore-errors (delete-file temp)))))) + +(defun content-hash-ultralisp (tarfile) + "Return a hash string of TARFILE. The hash is done with openssl, and done in +the order in which Ultralisp expects the SHA to be computed (which is subtly +different than standard quicklisp). + +Chiefly, Ultralisps processing is as follows: +`tar -xOf ` into a sequence (via babel-streams) & process said +sequence with ironclad. +" + (let* ((tar + (uiop:launch-program + (list "tar" "-xOf" (namestring tarfile)) + :output :stream + :element-type '(unsigned-byte 8))) + (openssl + (uiop:launch-program + (list "openssl" "dgst" "-sha1") + :input :stream + :output :stream + :element-type '(unsigned-byte 8))) + (tar-out (uiop:process-info-output tar)) + (openssl-in (uiop:process-info-input openssl)) + (buffer (make-array 8192 :element-type '(unsigned-byte 8)))) + (unwind-protect + (loop + for count = (read-sequence buffer tar-out) + while (> count 0) + do (write-sequence buffer openssl-in :end count)) + (close openssl-in)) + (unless (zerop (uiop:wait-process tar)) + (error "tar failed while extracting contents")) + (unless (zerop (uiop:wait-process openssl)) + (error "openssl failed to calculate sha1")) + + (extract-openssl-digest + (read-binary-line + (uiop:process-info-output openssl))))) From e32e2bf7ea6347fb4972ecac93762be9f3488044 Mon Sep 17 00:00:00 2001 From: Ethan Date: Mon, 23 Feb 2026 17:59:16 -0500 Subject: [PATCH 09/10] ql-https.asd: remove reader macros; unnecessary --- ql-https.asd | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/ql-https.asd b/ql-https.asd index 223e12a..8aea500 100644 --- a/ql-https.asd +++ b/ql-https.asd @@ -1,11 +1,5 @@ ;;;; ql-https.asd -(dolist (dist (ql-dist:all-dists)) - (let ((dist-name (slot-value dist 'ql-dist::name))) - (cond - ((string= dist-name "ultralisp") - (pushnew :ql-https/ultralisp-check-sha1 *features*))))) - (defsystem "ql-https" :author "Sebastian Christ " :maintainer "Sebastian Christ " @@ -16,8 +10,6 @@ :source-control (:git "https://github.com/rudolfochrist/ql-https.git") :version (:read-file-line "version") :depends-on ((:require "uiop") - #+ql-https/ultralisp-check-sha1 (:require "ironclad") - #+ql-https/ultralisp-check-sha1 (:require "babel-streams") (:feature :sbcl :sb-md5)) :components ((:file "ql-https") (:file "content-hash")) @@ -27,8 +19,6 @@ (uiop:subpathname *load-pathname* "README.md")) :perform (load-op :after (o c) (uiop:symbol-call :ql-https :register-fetch-scheme-functions) - (loop for f in (list :ql-https/ultralisp-check-sha1) - do (setf *features* (delete f *features*))) (pushnew :ql-https *features*)) :in-order-to ((test-op (test-op "ql-https/test")))) From be00de2e1dfae612a9636b3033e3bf684cd8b7a8 Mon Sep 17 00:00:00 2001 From: Ethan Date: Mon, 23 Feb 2026 17:59:32 -0500 Subject: [PATCH 10/10] ql-https.lisp: remove ultralisp reader macros --- ql-https.lisp | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/ql-https.lisp b/ql-https.lisp index afd8235..6ab9328 100644 --- a/ql-https.lisp +++ b/ql-https.lisp @@ -98,27 +98,6 @@ dist." (unless (= (ql-dist:archive-size release) (file-size file)) (error "file size mismatch for ~A" name)))) -#+ql-https/ultralisp-check-sha1 -(defun content-hash-ultralisp (tarfile) - (let* ((octets (babel-streams:with-output-to-sequence (buffer) - (uiop:run-program - (list "tar -xOf" (namestring tarfile)) - :output buffer))) - - ;; (openssl-sha1 - ;; (uiop:launch-program "openssl dgst -sha1" - ;; :input (copy-seq octets) - ;; :element-type '(unsigned-byte 8) - ;; :output :stream)) - ) - ;; (print - ;; (extract-openssl-digest - ;; (read-binary-line - ;; (uiop:process-info-output openssl-sha1)))) - - (ironclad:byte-array-to-hex-string - (ironclad:digest-sequence :sha1 (copy-seq octets))))) - (defmethod ql-dist:check-local-archive-file :after ((release ql-dist:release)) "Checks that the md5 and size of FILE are as expected from the quicklisp dist." @@ -132,7 +111,6 @@ dist." (ql-dist-name (ql-dist:name (ql-dist:dist release))) (expected (case ql-dist-name ("quicklisp" (content-hash file)) - #+ql-https/ultralisp-check-sha1 ("ultralisp" (content-hash-ultralisp file)) (t nil)))) (when (and expected (not (string-equal archive-sha1 expected)))