Merge pull request rudolfochrist#20 from digikar99/ultralisp

Support ultralisp

Author: rudolfochrist

content-hash.lisp

@@ -127,7 +127,7 @@ starting storage block in STREAM, and the total file size."
           until (= byte (char-code #\Newline))
           do (write-char (code-char byte) string))))
 
-(defun content-hash (tarfile)
+(defun content-hash (tarfile &optional content-info-processor)
   "Return a hash string of TARFILE. The hash is computed by creating
 the digest of the files in TARFILE in order of their name."
   (uiop:with-temporary-file (:pathname temp)
@@ -150,7 +150,10 @@ the digest of the files in TARFILE in order of their name."
                         (read-sequence buffer stream)
                         (write-sequence buffer digest-stream :end partial))))
                (let ((contents (content-info stream)))
-                 (setf contents (sort contents #'string< :key #'first))
+                 (setf contents
+                       (if content-info-processor
+                           (funcall content-info-processor contents)
+                           contents))
                  (dolist (info contents)
                    (destructuring-bind (position size)
                        (rest info)

ql-https.lisp

@@ -59,11 +59,15 @@
           (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))))
+  "obtains name of release from URL"
+  (let* ((http-url (if (string-equal "https" (subseq url 0 5))
+                       (uiop:strcat "http" (subseq url 5))
+                       url))
+         (all-releases (ql-dist:provided-releases t))
+         (release (find http-url all-releases
+                        :test #'string=
+                        :key #'ql-dist:archive-url)))
+    (ql-dist:project-name release)))
 
 #+sbcl
 (defun md5 (file)
@@ -91,12 +95,15 @@
   "Checks that the md5 and size of FILE are as expected from the quicklisp
 dist."
   (let ((release (ql-dist:find-release name)))
+    (unless (= (ql-dist:archive-size release) (file-size file))
+      (error "file size mismatch for ~A" name))
     (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))
-    (unless (= (ql-dist:archive-size release) (file-size file))
-      (error "file size mismatch for ~A" name))))
+    (unless (member (ql-dist:archive-content-sha1 release)
+                    (list (content-hash file (lambda (c) (sort c #'string< :key #'first)))
+                          (content-hash file #'reverse))
+                    :test #'string-equal)
+      (error "sha1 mismatch for ~A" name))))
 
 (defun register-fetch-scheme-functions ()
   (setf ql-http:*fetch-scheme-functions*