Merge branch 'rudolfochrist:master' into install-script

Author: bo-tato

ql-https.lisp

@@ -16,10 +16,14 @@
   "Fetch URL and safe it to FILE."
   (declare (ignorable args))
   (if (uiop:string-prefix-p "https://" url)
-      (values (uiop:run-program (format nil "curl -fsSL ~A -o ~A" url file)
-                                :output '(:string :stripped t)
-                                :error-output :output)
-              (and file (probe-file file)))
+      (let ((output (uiop:run-program (format nil "curl -fsSL ~A -o ~A" url file)
+                                      :output '(:string :stripped t)
+                                      :error-output :output))
+            (file (and file (probe-file file)))
+            (release (url-to-release url)))
+        (when release
+          (verify-download file release))
+        (values output file))
       (restart-case
           (handler-bind ((error (lambda (c)
                                   (declare (ignore c))
@@ -37,6 +41,31 @@
           (setf *quietly-use-https* t)
           (apply #'fetcher url file args)))))
 
+(defun url-to-release (url)
+  "extracts name of release from URL"
+  (when (search "/archive/" url)
+    (let* ((start (+ (search "/archive/" url) (length "/archive/")))
+           (end (position #\/ url :start start)))
+      (subseq url start end))))
+
+(defun md5 (file)
+  "Returns md5sum of FILE"
+  (uiop:run-program (format nil "md5sum \"~A\" | cut -d' ' -f 1" file)
+                    :output '(:string :stripped t)))
+
+(defun file-size (file)
+  "Returns the size of FILE in bytes"
+  (with-open-file (f file)
+    (file-length f)))
+
+(defun verify-download (file name)
+  "Checks that the md5 and size of FILE are as expected from the quicklisp
+dist."
+  (let ((release (ql-dist:find-release name)))
+    (unless (string= (ql-dist:archive-md5 release) (md5 file))
+      (error "md5 mismatch for ~A" name))
+    (unless (= (ql-dist:archive-size release) (file-size file))
+      (error "file size mismatch for ~A" name))))
 
 (defun register-fetch-scheme-functions ()
   (setf ql-http:*fetch-scheme-functions*