OpenPGP/SHA checking updates.

- Rework package layout
- Check client and version updates
- Make missing keys an error

Author: xach

quicklisp/checked-fetch.lisp

@@ -0,0 +1,42 @@
+;;;; checked-fetch.lisp
+
+(in-package #:ql-http)
+
+(define-condition verification-error (error) ())
+(define-condition unexpected-sha256-error (verification-error) ())
+(define-condition signature-verification-error (verification-error) ())
+
+(defun openpgp-signature-url (url)
+  (format nil "~A.asc" url))
+
+(defun fetch-digest-checked (url output expected-digest &key quietly)
+  "Fetch the data at URL and save to the file OUTPUT. The
+  EXPECTED-DIGEST value of OBJECT is checked against the actual SHA256
+  digest of the retrieved file, and if they match, the output file is
+  returned, otherwise an UNEXPECTED-SHA256-ERROR is signaled."
+  (with-temp-output-file (file "digest-checked.dat")
+    (fetch url file :quietly quietly)
+    (let ((actual-digest (file-sha-string 'sha256 file)))
+      (unless (equalp actual-digest expected-digest)
+        (error 'unexpected-sha256-error)))
+    (rename-mundanely file output)
+    (probe-file output)))
+
+(defun fetch-openpgp-checked (url output &key quietly)
+  (with-temp-output-files ((file "openpgp-checked.dat")
+                           (sig "openpgp-signature.asc"))
+    (let ((sig-url (openpgp-signature-url url)))
+      (fetch sig-url sig :quietly quietly)
+      (fetch url file :quietly quietly)
+      (let* ((signature (ql-openpgp:load-signature sig))
+             (id (ql-openpgp:key-id-string signature))
+             (key (ql-openpgp:find-key id)))
+        (unless key
+          (error "No key available for id ~S" id))
+        (let ((result (ql-openpgp:verify-signature file signature key)))
+          (unless result
+            (error "Signature failed for file ~A"
+                   output))
+          (unless quietly
+            (format t "~&; Signature check result: ~A~%" result)))
+        (rename-mundanely file output)))))

quicklisp/client-info.lisp

@@ -83,6 +83,12 @@
                      (badly-sized-client-file-expected-size condition)
                      (badly-sized-client-file-actual-size condition)))))
 
+(define-condition sha-mismatched-client-file (invalid-client-file)
+  ()
+  (:report (lambda (condition stream)
+             (format stream "SHA digest mismatch on client file ~A"
+                     (invalid-client-file-file condition)))))
+
 (defun check-client-file-size (file expected-size)
   (let ((actual-size (file-size file)))
     (unless (eql expected-size actual-size)
@@ -99,6 +105,10 @@
    metadata in CLIENT-FILE-INFO.")
   (:method (file client-file-info)
     (check-client-file-size file (size client-file-info))
+    (let ((actual-sha (ql-sha:file-sha-string  'sha256 file ))
+          (expected-sha (sha256 client-file-info)))
+      (unless (equalp expected-sha actual-sha)
+        (error "SHA mismatch on ~A" client-file-info)))
     client-file-info))
 
 ;;; Structuring and loading information about the Quicklisp client
@@ -207,9 +217,8 @@
                                      'client-tar-file-info))))
 
 (defun fetch-client-info (url)
-  (let ((info-file (qmerge "tmp/client-info.sexp")))
-    (delete-file-if-exists info-file)
-    (fetch url info-file :quietly t)
+  (with-temp-output-file (info-file "client-info.sexp")
+    (ql-http:fetch-openpgp-checked url info-file :quietly t)
     (handler-case
         (load-client-info info-file)
       ;; FIXME: So many other things could go wrong here; I think it

quicklisp/client-update.lisp

@@ -3,9 +3,11 @@
 (in-package #:quicklisp-client)
 
 (defun fetch-client-file-info (client-file-info output-file)
-  (maybe-fetch-gzipped (file-url client-file-info) output-file)
-  (check-client-file output-file client-file-info)
-  (probe-file output-file))
+  (with-temp-output-file (temp "client-info.dat")
+    (maybe-fetch-gzipped (file-url client-file-info) temp)
+    (check-client-file temp client-file-info)
+    (rename-mundanely temp output-file)
+    (probe-file output-file)))
 
 (defun retirement-directory (base)
   (let ((suffix 0))

quicklisp/dist-update.lisp

@@ -30,7 +30,7 @@
       (delete-directory-tree (qmerge "tmp/distinfo-update/")))
     (when url
       (ensure-directories-exist target)
-      (fetch url target :quietly t)
+      (fetch-openpgp-checked url target :quietly t)
       (let ((new (make-dist-from-file target)))
         (setf (base-directory new)
               (make-pathname :name nil
@@ -135,7 +135,7 @@
     (let ((temp-file (qmerge "tmp/install-dist-distinfo.txt")))
       (ensure-directories-exist temp-file)
       (delete-file-if-exists temp-file)
-      (fetch url temp-file)
+      (fetch-openpgp-checked url temp-file)
       (let* ((new-dist (make-dist-from-file temp-file))
              (old-dist (find-dist (name new-dist))))
         (when old-dist

quicklisp/dist.lisp

@@ -456,33 +456,10 @@
   (setf (available-versions-url dist)
         (make-versions-url (distinfo-subscription-url dist))))
 
-(defun fetch-signed-index-file (url target)
-  (let ((signature-url (format nil "~A.asc" url))
-        (temp-file (temp-output-file "index.txt"))
-        (temp-signature-file (temp-output-file "signature.asc")))
-    (unwind-protect
-         (progn
-           (fetch signature-url temp-signature-file)
-           (fetch url temp-file)
-           (let* ((signature (ql-openpgp:load-signature temp-signature-file))
-                  (id (ql-openpgp:key-id-string signature))
-                  (key (ql-openpgp:find-key id)))
-             (unless key
-               (error "No key available for id ~S" id))
-             (let ((result (ql-openpgp:verify-signature temp-file signature key)))
-               (unless result
-                 (error "Signature failed for index file ~A"
-                        target))
-               (format t "~&; Signature check result: ~A~%" result)))
-           (rename-file temp-file target)
-           (delete-file temp-signature-file))
-      (delete-file-if-exists temp-file)
-      (delete-file-if-exists temp-signature-file))))
-
 (defmethod ensure-system-index-file ((dist dist))
   (let ((pathname (relative-to dist "systems.txt")))
     (or (probe-file pathname)
-        (fetch-signed-index-file (system-index-url dist) pathname))))
+        (fetch-openpgp-checked (system-index-url dist) pathname))))
 
 (defmethod ensure-system-cdb-file ((dist dist))
   (let* ((system-file (ensure-system-index-file dist))
@@ -495,7 +472,7 @@
 (defmethod ensure-release-index-file ((dist dist))
   (let ((pathname (relative-to dist "releases.txt")))
     (or (probe-file pathname)
-        (fetch-signed-index-file (release-index-url dist) pathname))))
+        (fetch-openpgp-checked (release-index-url dist) pathname))))
 
 (defmethod ensure-release-cdb-file ((dist dist))
   (let* ((release-file (ensure-release-index-file dist))
@@ -752,6 +729,21 @@ the given NAME."
              (file-namestring (invalid-local-archive-file condition))
              (name (invalid-local-archive-release condition))))))
 
+(defmethod archive-digest ((release release))
+  (let* ((dist (dist release))
+         (index (relative-to dist "digests.txt"))
+         (cdb (relative-to dist "digests.cdb"))
+         (key (format nil "release/~A" (name release))))
+    (unless (probe-file index)
+      (error "Digest index file is missing"))
+    (unless (probe-file cdb)
+      (ql-cdb:convert-index-file index :cdb-file cdb))
+    (let ((value (ql-cdb:lookup key cdb)))
+      (destructuring-bind (k sha256)
+          (split-spaces value)
+        (declare (ignore k))
+        sha256))))
+
 (defmethod check-local-archive-file ((release release))
   (let ((file (local-archive-file release)))
     (unless (probe-file file)
@@ -787,7 +779,9 @@ the given NAME."
        (or (probe-file pathname)
            (progn
              (ensure-directories-exist pathname)
-             (fetch (archive-url release) pathname)))
+             (fetch-digest-checked (archive-url release)
+                                   pathname
+                                   (archive-digest release))))
        (restart-case
            (check-local-archive-file release)
          (delete-and-retry (&optional v)
@@ -871,16 +865,6 @@ the given NAME."
             (unless (ignorable line)
               (funcall fun line))))))
 
-
-(defmethod archive-digest ((release release))
-  (let ((entry (cdb-lookup (dist release) (name release)
-                           "archive-digests.cdb")))
-    (unless entry
-      (error "No digest indexed for ~S. That's pretty weird!" release))
-    (let ((digest-position (position #\Space entry)))
-      (subseq entry (1+ digest-position)))))
-
-
 (defmethod slot-unbound (class (dist dist) (slot (eql 'release-index)))
   (declare (ignore class))
   (setf (slot-value dist 'release-index)
@@ -1177,23 +1161,23 @@ FUN."
 ;;;
 
 (defmethod available-versions ((dist dist))
-  (let ((temp (qmerge "tmp/dist-versions.txt"))
-        (versions '())
-        (url (available-versions-url dist)))
-    (when url
-      (ensure-directories-exist temp)
-      (delete-file-if-exists temp)
-      (handler-case
-          (fetch url temp)
-        (unexpected-http-status ()
-          (return-from available-versions nil)))
-      (with-open-file (stream temp)
-        (loop for line = (read-line stream nil)
-              while line do
-              (destructuring-bind (version url)
-                  (split-spaces line)
-                (setf versions (acons version url versions)))))
-      versions)))
+  (with-temp-output-file (temp "dist-versions.txt")
+    (let ((versions '())
+          (url (available-versions-url dist)))
+      (when url
+        (ensure-directories-exist temp)
+        (delete-file-if-exists temp)
+        (handler-case
+            (fetch-openpgp-checked url temp)
+          (unexpected-http-status ()
+            (return-from available-versions nil)))
+        (with-open-file (stream temp)
+          (loop for line = (read-line stream nil)
+                while line do
+                  (destructuring-bind (version url)
+                      (split-spaces line)
+                    (setf versions (acons version url versions)))))
+        versions))))
 
 
 ;;;

quicklisp/fetch-gzipped.lisp

@@ -9,7 +9,7 @@
 (defun fetch-gzipped-version (url file &key quietly)
   (let ((gzipped (gzipped-url url))
         (gzipped-temp (merge-pathnames "gzipped.tmp" file)))
-    (fetch gzipped gzipped-temp :quietly quietly)
+    (fetch-openpgp-checked gzipped gzipped-temp :quietly quietly)
     (gunzip gzipped-temp file)
     (delete-file-if-exists gzipped-temp)
     (probe-file file)))

quicklisp/package.lisp

@@ -7,6 +7,7 @@
   (:export #:write-line-to-file
            #:without-prompting
            #:press-enter-to-continue
+           #:rename-mundanely
            #:replace-file
            #:copy-file
            #:delete-file-if-exists
@@ -18,7 +19,9 @@
            #:safely-read-file
            #:make-versions-url
            #:random-pathname-string
-           #:temp-output-file))
+           #:temp-output-file
+           #:with-temp-output-file
+           #:with-temp-output-files))
 
 (defpackage #:ql-setup
   (:documentation
@@ -93,10 +96,25 @@
            #:update-progress
            #:finish-display))
 
+(defpackage #:ql-sha
+  (:documentation
+   "Compute SHA digests. Used for verification.")
+  (:use #:cl)
+  (:export #:file-sha
+           #:file-sha-string
+           #:sha1
+           #:sha256
+           #:sha512)
+  (:export #:update-sha-from-file
+           #:update-sha
+           #:finish-sha))
+
 (defpackage #:ql-http
   (:documentation
    "A simple HTTP client.")
-  (:use #:cl #:ql-network #:ql-progress #:ql-config)
+  (:use #:cl
+        #:ql-network #:ql-progress #:ql-config #:ql-util
+        #:ql-sha)
   (:export #:*proxy-url*
            #:fetch
            #:http-fetch
@@ -108,13 +126,17 @@
            #:url
            #:*maximum-redirects*
            #:*default-url-defaults*)
+  (:export #:fetch-digest-checked
+           #:fetch-openpgp-checked)
   (:export #:fetch-error
            #:unexpected-http-status
            #:unexpected-http-status-code
            #:unexpected-http-status-url
            #:too-many-redirects
            #:too-many-redirects-url
-           #:too-many-redirects-count))
+           #:too-many-redirects-count
+           #:digest-check-error
+           #:openpgp-check-error))
 
 (defpackage #:ql-minitar
   (:documentation
@@ -136,18 +158,7 @@
            #:map-cdb
            #:convert-index-file))
 
-(defpackage #:ql-sha
-  (:documentation
-   "Compute SHA digests. Used for verification.")
-  (:use #:cl)
-  (:export #:file-sha
-           #:file-sha-string
-           #:sha1
-           #:sha256
-           #:sha512)
-  (:export #:update-sha-from-file
-           #:update-sha
-           #:finish-sha))
+
 
 (defpackage #:ql-openpgp
   (:documentation

quicklisp/quicklisp.asd

@@ -27,6 +27,7 @@
                (:file "sha")
                (:file "openpgp")
                (:file "key-management")
+               (:file "checked-fetch")
                (:file "dist")
                (:file "setup")
                (:file "client")

quicklisp/utils.lisp

@@ -25,6 +25,13 @@
   (let ((result (read-line *query-io*)))
     (zerop (length result))))
 
+(defun rename-mundanely (from to)
+  "Renames file FROM to TO, but inhibit's CL:RENAME-FILE's merging behavior."
+  (setf from (merge-pathnames from (make-pathname :type :unspecific
+                                                 :name :unspecific
+                                                 :version :unspecific)))
+  (rename-file from to))
+
 (defun replace-file (from to)
   "Like RENAME-FILE, but deletes TO if it exists, first."
   (when (probe-file to)
@@ -142,3 +149,24 @@ http://foo/bar-versions.txt."
     (merge-pathnames (make-pathname :name temp-name
                                     :type (pathname-type template-pathname))
                      (ql-setup:qmerge "tmp/"))))
+
+(defun call-with-temp-output-file (template-pathname fun)
+  (let ((file (temp-output-file template-pathname)))
+    (ensure-directories-exist file)
+    (unwind-protect
+         (funcall fun file)
+      (delete-file-if-exists file))))
+
+(defmacro with-temp-output-file ((var template-pathname) &body body)
+  `(call-with-temp-output-file ,template-pathname (lambda (,var) ,@body)))
+
+(defmacro with-temp-output-files (bindings &body body)
+  (labels ((expand (bindings body)
+             (let ((binding (first bindings)))
+               (if (rest bindings)
+                   `(with-temp-output-file (,(first binding) ,(second binding))
+                      ,(expand (rest bindings) body))
+                   `(with-temp-output-file (,(first binding) ,(second binding))
+                      ,@body)))))
+    (expand bindings body)))
+