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))))) diff --git a/ql-https.asd b/ql-https.asd index d282ab7..8aea500 100644 --- a/ql-https.asd +++ b/ql-https.asd @@ -9,7 +9,8 @@ :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") + (:feature :sbcl :sb-md5)) :components ((:file "ql-https") (:file "content-hash")) :description "Enable HTTPS in Quicklisp" diff --git a/ql-https.lisp b/ql-https.lisp index 4b2dbc1..6ab9328 100644 --- a/ql-https.lisp +++ b/ql-https.lisp @@ -98,6 +98,24 @@ 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)) + + (let* ((archive-sha1 (ql-dist:archive-content-sha1 release)) + (ql-dist-name (ql-dist:name (ql-dist:dist release))) + (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* (list (cons "http" 'fetcher)