├── .gitignore ├── LICENSE.txt ├── README.md ├── content-hash.lisp ├── install.sh ├── ql-https.asd ├── ql-https.lisp ├── ql-setup.lisp ├── t └── tests.lisp └── version /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | /.DS_Store 3 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Sebastian Christ 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | 4 | ql-https — HTTPS support for Quicklisp via curl 5 | 6 | 7 | # SYNOPSIS 8 | 9 | (asdf:load-system "ql-https") 10 | 11 | 12 | # DESCRIPTION 13 | 14 | 15 | ## PREREQUISITES 16 | 17 | - [Quicklisp](https://www.quicklisp.org/beta/) 18 | - curl 19 | 20 | 21 | ## AUTOMATIC INSTALLATION 22 | 23 | The default implementation is sbcl, if you are using another then set the `LISP` 24 | environment variable, for example to use Clozure common lisp: 25 | 26 | export LISP=ccl 27 | 28 | now run the installer script: 29 | 30 | curl https://raw.githubusercontent.com/rudolfochrist/ql-https/master/install.sh | bash 31 | 32 | 33 | ## MANUAL INSTALLATION 34 | 35 | 1. `mkdir ~/quicklisp` and `cd ~/quicklisp` 36 | 2. Go to and lookup `:client-tar` URL, download it, verify 37 | hash and untar. 38 | 3. Clone ql-https from to 39 | to `~/common-lisp/ql-https` 40 | 4. Disconnect internet. (Prevent that anything leaks over HTTP during the installation) 41 | 5. Start a fresh REPL and (require 'asdf) 42 | 6. Load `~/common-lisp/ql-https/ql-setup.lisp` 43 | 7. Eval `(asdf:load-system "ql-https")` 44 | 8. Inspect `ql-http:*fetch-scheme-functions*` and verify everything was registered properly. Both `http` and 45 | `https` have `ql-https:fetcher` registered. 46 | 9. Connect internet. 47 | 10. Eval `(quicklisp:setup)` - use the USE-HTTPS restart if you hit the network. 48 | 49 | Removing the *Missing client-info.sexp, using mock info* warning. 50 | 51 | 1. Eval `(ql:update-client)` 52 | 2. move `~/quicklisp/tmp/client-info.sexp` to `~/quicklisp` 53 | 54 | Watch ASCIInema: 55 | 56 | [![asciicast](https://asciinema.org/a/585361.svg)](https://asciinema.org/a/585361) 57 | 58 | 59 | ## STARTUP 60 | 61 | ```lisp 62 | (let ((quicklisp-init #p"~/common-lisp/ql-https/ql-setup.lisp")) 63 | (when (probe-file quicklisp-init) 64 | (load quicklisp-init) 65 | (asdf:load-system "ql-https") 66 | (uiop:symbol-call :quicklisp :setup))) 67 | 68 | ;; optional 69 | #+ql-https 70 | (setf ql-https:*quietly-use-https* t) 71 | ``` 72 | 73 | # AUTHOR 74 | 75 | Sebastian Christ () 76 | 77 | 78 | # COPYRIGHT 79 | 80 | Copyright (c) 2022 Sebastian Christ (rudolfo.christ@pm.me) 81 | 82 | 83 | # LICENSE 84 | 85 | Released under the MIT license. 86 | 87 | -------------------------------------------------------------------------------- /content-hash.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013 Zachary Beane , All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | 27 | ;;; Commentary: 28 | ;;; 29 | ;;; copied from tarhash.lisp from quicklisp-controller: https://github.com/quicklisp/quicklisp-controller 30 | ;;; changed to use openssl to compute sha1 digest rather than depending on ironclad 31 | 32 | (in-package #:ql-https) 33 | 34 | (defconstant +block-octet-count+ 512) 35 | 36 | (defun make-block-buffer () 37 | (make-array +block-octet-count+ 38 | :element-type '(unsigned-byte 8) 39 | :initial-element 0)) 40 | 41 | (defun read-header-block (buffer stream) 42 | "Read a tar header block from STREAM into BUFFER. Returns NIL when 43 | at the terminating block of the end of input, BUFFER otherwise." 44 | (let ((size (read-sequence buffer stream))) 45 | (cond ((zerop size) 46 | nil) 47 | ((/= size 0 +block-octet-count+) 48 | (error "Short block (only ~D bytes)" size)) 49 | ((every #'zerop buffer) 50 | nil) 51 | (t 52 | buffer)))) 53 | 54 | (defun ascii-subseq (vector start end) 55 | (let ((string (make-string (- end start)))) 56 | (loop for i from 0 57 | for j from start below end 58 | do (setf (char string i) (code-char (aref vector j)))) 59 | string)) 60 | 61 | (defun block-asciiz-string (block start length) 62 | (let* ((end (+ start length)) 63 | (eos (or (position 0 block :start start :end end) 64 | end))) 65 | (ascii-subseq block start eos))) 66 | 67 | (defun payload-size (header) 68 | (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) 69 | 70 | (defun file-payload-p (header) 71 | (member (aref header 156) '(0 48))) 72 | 73 | (defparameter *ignored-path-substrings* 74 | '("/_darcs/" "/CVS/" "/.git/" "/CVS/" "/.hg/")) 75 | 76 | (defun ignored-path-p (path) 77 | (dolist (substring *ignored-path-substrings*) 78 | (when (search substring path) 79 | (return t)))) 80 | 81 | (defun prefix (header) 82 | (when (plusp (aref header 345)) 83 | (block-asciiz-string header 345 155))) 84 | 85 | (defun name (header) 86 | (block-asciiz-string header 0 100)) 87 | 88 | (defun full-path (header) 89 | (let ((prefix (prefix header)) 90 | (name (name header))) 91 | (if prefix 92 | (format nil "~A/~A" prefix name) 93 | name))) 94 | 95 | (defun skip-n-octets-blocks (n stream) 96 | (let ((count (ceiling n +block-octet-count+)) 97 | (block (make-block-buffer))) 98 | (dotimes (i count) 99 | (read-sequence block stream)))) 100 | 101 | (defun content-info (stream) 102 | "Return a list of file info for the POSIX tar stream STREAM. Each 103 | element in the result is a list of a filename, the position of its 104 | starting storage block in STREAM, and the total file size." 105 | (file-position stream :start) 106 | (let ((buffer (make-block-buffer)) 107 | (result '())) 108 | (loop 109 | (let ((header (read-header-block buffer stream)) 110 | (position (file-position stream))) 111 | (when (not header) 112 | (return result)) 113 | (let ((size (payload-size header))) 114 | (when (file-payload-p header) 115 | (let ((path (full-path header))) 116 | (unless (ignored-path-p path) 117 | (push (list path 118 | position 119 | size) 120 | result)))) 121 | (skip-n-octets-blocks size stream)))))) 122 | 123 | (defun read-binary-line (stream) 124 | "Read a line from a binary stream and return it as an ascii string." 125 | (with-output-to-string (string) 126 | (loop for byte = (read-byte stream) 127 | until (= byte (char-code #\Newline)) 128 | do (write-char (code-char byte) string)))) 129 | 130 | (defun content-hash (tarfile) 131 | "Return a hash string of TARFILE. The hash is computed by creating 132 | the digest of the files in TARFILE in order of their name." 133 | (uiop:with-temporary-file (:pathname temp) 134 | (setf tarfile (gunzip tarfile temp)) 135 | (unwind-protect 136 | (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) 137 | (let* ((openssl (uiop:launch-program "openssl dgst -sha1" 138 | :input :stream 139 | :element-type '(unsigned-byte 8) 140 | :output :stream)) 141 | (digest-stream (uiop:process-info-input openssl)) 142 | (buffer (make-block-buffer))) 143 | (flet ((add-file-content (position size) 144 | (file-position stream position) 145 | (multiple-value-bind (complete partial) 146 | (truncate size +block-octet-count+) 147 | (dotimes (i complete) 148 | (read-sequence buffer stream) 149 | (write-sequence buffer digest-stream)) 150 | (read-sequence buffer stream) 151 | (write-sequence buffer digest-stream :end partial)))) 152 | (let ((contents (content-info stream))) 153 | (setf contents (sort contents #'string< :key #'first)) 154 | (dolist (info contents) 155 | (destructuring-bind (position size) 156 | (rest info) 157 | (add-file-content position size)))) 158 | (close (uiop:process-info-input openssl)) 159 | (unless (zerop (uiop:wait-process openssl)) 160 | (error "openssl failed to calculate sha1")) 161 | (extract-openssl-digest (read-binary-line (uiop:process-info-output openssl)))))) 162 | (when (probe-file temp) 163 | (ignore-errors (delete-file temp)))))) 164 | -------------------------------------------------------------------------------- /install.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euo pipefail 4 | 5 | LISP=${LISP=sbcl} 6 | 7 | # For testers 8 | QL_TOPDIR="${QL_TOPDIR-$HOME/quicklisp}" 9 | CLDIR="${CLDIR-$HOME/common-lisp}" 10 | SKIP_USERINIT="${SKIP_USERINIT-no}" 11 | 12 | if test -d "$QL_TOPDIR"; then 13 | echo "Cannot install Quicklisp because it seems it is already installed!" 14 | echo "Please check $QL_TOPDIR" 15 | exit 1 16 | fi 17 | 18 | echo "Downloading quicklisp metadata..." 19 | mkdir -p "$QL_TOPDIR" 20 | meta=$( curl -s https://beta.quicklisp.org/client/quicklisp.sexp | \ 21 | awk '/:client-tar/,/)/' | tr '\n' ' ' | tr -s ' ' ) 22 | 23 | url=$( perl -nle 'print $& if m{(?<=:url ")[^"]*}g' <<< "$meta" ) 24 | [[ "$url" =~ ^http:// ]] && url="https${url#http}" 25 | sha256=$( perl -nle 'print $& if m{(?<=:sha256 ")[^"]*}g' <<< "$meta" ) 26 | 27 | echo "Downloading quicklisp client..." 28 | curl -s "$url" -o "$QL_TOPDIR"/quicklisp.tar 29 | 30 | if [ "$sha256" != "$(openssl dgst -sha256 "$QL_TOPDIR"/quicklisp.tar | cut -d' ' -f 2)" ] 31 | then 32 | echo "sha mismatch" >&2 33 | exit 1 34 | fi 35 | 36 | tar xf "$QL_TOPDIR"/quicklisp.tar -C "$QL_TOPDIR" 37 | rm "$QL_TOPDIR"/quicklisp.tar 38 | 39 | echo "Cloning ql-https..." 40 | git clone https://github.com/rudolfochrist/ql-https "$CLDIR"/ql-https 41 | 42 | if test "$SKIP_USERINIT" = no; then 43 | echo "Running setup code..." 44 | $LISP < "$QL_TOPDIR"/setup.lisp <" 5 | :maintainer "Sebastian Christ " 6 | :mailto "rudolfo.christ@pm.me" 7 | :license "MIT" 8 | :homepage "https://github.com/rudolfochrist/ql-https" 9 | :bug-tracker "https://github.com/rudolfochrist/ql-https/issues" 10 | :source-control (:git "https://github.com/rudolfochrist/ql-https.git") 11 | :version (:read-file-line "version") 12 | :depends-on ((:require "uiop") (:feature :sbcl :sb-md5)) 13 | :components ((:file "ql-https") 14 | (:file "content-hash")) 15 | :description "Enable HTTPS in Quicklisp" 16 | :long-description 17 | #.(uiop:read-file-string 18 | (uiop:subpathname *load-pathname* "README.md")) 19 | :perform (load-op :after (o c) 20 | (uiop:symbol-call :ql-https :register-fetch-scheme-functions) 21 | (pushnew :ql-https *features*)) 22 | :in-order-to ((test-op (test-op "ql-https/test")))) 23 | 24 | 25 | (defsystem "ql-https/test" 26 | :description "Tests for ql-https" 27 | :depends-on ((:require "uiop") 28 | "fiasco" 29 | "ql-https") 30 | :pathname "t/" 31 | :components ((:file "tests")) 32 | :perform (test-op (op c) 33 | (unless (uiop:symbol-call :fiasco :run-package-tests :package :ql-https/test) 34 | #+(not (or :swank :slynk)) 35 | (error "Tests failed.")))) 36 | 37 | 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /ql-https.lisp: -------------------------------------------------------------------------------- 1 | ;;;; ql-https.lisp 2 | 3 | (defpackage #:ql-https 4 | (:use :cl) 5 | (:import-from #:ql-gunzipper #:gunzip) 6 | (:export 7 | #:fetcher 8 | #:*quietly-use-https* 9 | #:register-fetch-scheme-functions 10 | #:no-https-error)) 11 | 12 | (in-package #:ql-https) 13 | 14 | (define-condition no-https-error (error) 15 | ((url :initarg :url 16 | :reader no-https-url)) 17 | (:report (lambda (c stream) 18 | (format stream "We don't use HTTP here!~&URL: ~A" (no-https-url c))))) 19 | 20 | (defvar *quietly-use-https* nil 21 | "If non-nil quietly use HTTPS.") 22 | 23 | (defun fetcher (url file &rest args) 24 | "Fetch URL and safe it to FILE." 25 | (declare (ignorable args)) 26 | (if (uiop:string-prefix-p "https://" url) 27 | ;; Convert the file path to a string with any leading "~" replaced by the 28 | ;; HOME directory, and then download. 29 | (let* ((file-namestring (namestring file)) 30 | (file-namestring-full (if (uiop:string-prefix-p "~" file-namestring) 31 | (concatenate 'string 32 | (namestring (user-homedir-pathname)) 33 | (subseq file-namestring 1)) 34 | file-namestring)) 35 | (output (uiop:run-program (list "curl" "-fsSL" url "-o" file-namestring-full) 36 | :force-shell nil 37 | :output '(:string :stripped t) 38 | :error-output :output)) 39 | (file (and file (probe-file file))) 40 | (release (url-to-release url))) 41 | (when release 42 | (verify-download file release)) 43 | (values output file)) 44 | (restart-case 45 | (handler-bind ((no-https-error (lambda (c) 46 | (declare (ignore c)) 47 | (when *quietly-use-https* 48 | (invoke-restart 'use-https))))) 49 | (error 'no-https-error :url url)) 50 | (use-https () 51 | :report "Retry with HTTPS." 52 | (apply #'fetcher 53 | (format nil "https~A" (subseq url 4)) 54 | file 55 | args)) 56 | (use-https-session () 57 | :report "Retry with HTTPS and save decision for this session." 58 | (setf *quietly-use-https* t) 59 | (apply #'fetcher url file args))))) 60 | 61 | (defun url-to-release (url) 62 | "extracts name of release from URL" 63 | (when (search "/archive/" url) 64 | (let* ((start (+ (search "/archive/" url) (length "/archive/"))) 65 | (end (position #\/ url :start start))) 66 | (subseq url start end)))) 67 | 68 | #+sbcl 69 | (defun md5 (file) 70 | "Returns md5sum of FILE" 71 | (format nil "~{~2,'0x~}" (coerce (sb-md5:md5sum-file file) 'list))) 72 | 73 | (defun extract-openssl-digest (output) 74 | "Extracts digest from output of `openssl dgst'" 75 | (let ((space-pos (position #\Space output))) 76 | (subseq output (1+ space-pos)))) ; exclude space itself 77 | 78 | #-sbcl 79 | (defun md5 (file) 80 | "Returns md5sum of FILE" 81 | (extract-openssl-digest 82 | (uiop:run-program (list "openssl" "dgst" "-md5" (namestring file)) 83 | :output '(:string :stripped t)))) 84 | 85 | (defun file-size (file) 86 | "Returns the size of FILE in bytes" 87 | (with-open-file (f file) 88 | (file-length f))) 89 | 90 | (defun verify-download (file name) 91 | "Checks that the md5 and size of FILE are as expected from the quicklisp 92 | dist." 93 | (let ((release (ql-dist:find-release name))) 94 | (unless (string-equal (ql-dist:archive-md5 release) (md5 file)) 95 | (error "md5 mismatch for ~A" name)) 96 | (unless (string-equal (ql-dist:archive-content-sha1 release) (content-hash file)) 97 | (error "sha1 mismatch for ~A" name)) 98 | (unless (= (ql-dist:archive-size release) (file-size file)) 99 | (error "file size mismatch for ~A" name)))) 100 | 101 | (defun register-fetch-scheme-functions () 102 | (setf ql-http:*fetch-scheme-functions* 103 | (list (cons "http" 'fetcher) 104 | (cons "https" 'fetcher)))) 105 | -------------------------------------------------------------------------------- /ql-setup.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2014 Zachary Beane 2 | 3 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 4 | ;; of this software and associated documentation files (the "Software"), to deal 5 | ;; in the Software without restriction, including without limitation the rights 6 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | ;; copies of the Software, and to permit persons to whom the Software is 8 | ;; furnished to do so, subject to the following conditions: 9 | 10 | ;; The above copyright notice and this permission notice shall be included in 11 | ;; all copies or substantial portions of the Software. 12 | 13 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | ;; THE SOFTWARE. 20 | 21 | ;;; Commentary: 22 | ;; 23 | ;; Copied to get rid the `(qicklisp:setup)' call. 24 | ;; Whenever the client is updated the setup.lisp is replaced 25 | ;; and contains the call to setup. 26 | 27 | (defpackage #:ql-setup 28 | (:use #:cl) 29 | (:export #:*quicklisp-home* 30 | #:qmerge 31 | #:qenough)) 32 | 33 | (in-package #:ql-setup) 34 | 35 | (unless *load-truename* 36 | (error "This file must be LOADed to set up quicklisp.")) 37 | 38 | (defvar *quicklisp-home* 39 | (make-pathname :name nil :type nil 40 | :defaults (let ((qlhome "~/quicklisp/")) 41 | (if (probe-file qlhome) 42 | qlhome 43 | (error "Quicklisp not installed to 44 | default location. Please set 45 | *quicklisp-home* manually and 46 | retry"))))) 47 | 48 | (defun qmerge (pathname) 49 | "Return PATHNAME merged with the base Quicklisp directory." 50 | (merge-pathnames pathname *quicklisp-home*)) 51 | 52 | (defun qenough (pathname) 53 | (enough-namestring pathname *quicklisp-home*)) 54 | 55 | ;;; ASDF is a hard requirement of quicklisp. Make sure it's either 56 | ;;; already loaded or load it from quicklisp's bundled version. 57 | 58 | (defvar *required-asdf-version* "3.0") 59 | 60 | ;;; Put ASDF's fasls in a separate directory 61 | 62 | (defun implementation-signature () 63 | "Return a string suitable for discriminating different 64 | implementations, or similar implementations with possibly-incompatible 65 | FASLs." 66 | ;; XXX Will this have problems with stuff like threads vs 67 | ;; non-threads fasls? 68 | (let ((*print-pretty* nil)) 69 | (format nil "lisp-implementation-type: ~A~%~ 70 | lisp-implementation-version: ~A~%~ 71 | machine-type: ~A~%~ 72 | machine-version: ~A~%" 73 | (lisp-implementation-type) 74 | (lisp-implementation-version) 75 | (machine-type) 76 | (machine-version)))) 77 | 78 | (defun dumb-string-hash (string) 79 | "Produce a six-character hash of STRING." 80 | (let ((hash #xD13CCD13)) 81 | (loop for char across string 82 | for value = (char-code char) 83 | do 84 | (setf hash (logand #xFFFFFFFF 85 | (logxor (ash hash 5) 86 | (ash hash -27) 87 | value)))) 88 | (subseq (format nil "~(~36,6,'0R~)" (mod hash 88888901)) 89 | 0 6))) 90 | 91 | (defun asdf-fasl-pathname () 92 | "Return a pathname suitable for storing the ASDF FASL, separated 93 | from ASDF FASLs from incompatible implementations. Also, save a file 94 | in the directory with the implementation signature, if it doesn't 95 | already exist." 96 | (let* ((implementation-signature (implementation-signature)) 97 | (original-fasl (compile-file-pathname (qmerge "asdf.lisp"))) 98 | (fasl 99 | (qmerge (make-pathname 100 | :defaults original-fasl 101 | :directory 102 | (list :relative 103 | "cache" 104 | "asdf-fasls" 105 | (dumb-string-hash implementation-signature))))) 106 | (signature-file (merge-pathnames "signature.txt" fasl))) 107 | (ensure-directories-exist fasl) 108 | (unless (probe-file signature-file) 109 | (with-open-file (stream signature-file :direction :output) 110 | (write-string implementation-signature stream))) 111 | fasl)) 112 | 113 | (defun ensure-asdf-loaded () 114 | "Try several methods to make sure that a sufficiently-new ASDF is 115 | loaded: first try (require \"asdf\"), then loading the ASDF FASL, then 116 | compiling asdf.lisp to a FASL and then loading it." 117 | (let ((source (qmerge "asdf.lisp"))) 118 | (labels ((asdf-symbol (name) 119 | (let ((asdf-package (find-package '#:asdf))) 120 | (when asdf-package 121 | (find-symbol (string name) asdf-package)))) 122 | (version-satisfies (version) 123 | (let ((vs-fun (asdf-symbol '#:version-satisfies)) 124 | (vfun (asdf-symbol '#:asdf-version))) 125 | (when (and vs-fun vfun 126 | (fboundp vs-fun) 127 | (fboundp vfun)) 128 | (funcall vs-fun (funcall vfun) version))))) 129 | (block nil 130 | (macrolet ((try (&body asdf-loading-forms) 131 | `(progn 132 | (handler-bind ((warning #'muffle-warning)) 133 | (ignore-errors 134 | ,@asdf-loading-forms)) 135 | (when (version-satisfies *required-asdf-version*) 136 | (return t))))) 137 | (try) 138 | (try (require "asdf")) 139 | (let ((fasl (asdf-fasl-pathname))) 140 | (try (load fasl :verbose nil)) 141 | (try (load (compile-file source :verbose nil :output-file fasl)))) 142 | (error "Could not load ASDF ~S or newer" *required-asdf-version*)))))) 143 | 144 | (ensure-asdf-loaded) 145 | 146 | ;;; 147 | ;;; Quicklisp sometimes must upgrade ASDF. Ugrading ASDF will blow 148 | ;;; away existing ASDF methods, so e.g. FASL recompilation :around 149 | ;;; methods would be lost. This config file will make it possible to 150 | ;;; ensure ASDF can be configured before loading Quicklisp itself via 151 | ;;; ASDF. Thanks to Nikodemus Siivola for pointing out this issue. 152 | ;;; 153 | 154 | (let ((asdf-init (probe-file (qmerge "asdf-config/init.lisp")))) 155 | (when asdf-init 156 | (with-simple-restart (skip "Skip loading ~S" asdf-init) 157 | (load asdf-init :verbose nil :print nil)))) 158 | 159 | (push (qmerge "quicklisp/") asdf:*central-registry*) 160 | 161 | (let ((*compile-print* nil) 162 | (*compile-verbose* nil) 163 | (*load-verbose* nil) 164 | (*load-print* nil)) 165 | (asdf:oos 'asdf:load-op "quicklisp" :verbose nil)) 166 | -------------------------------------------------------------------------------- /t/tests.lisp: -------------------------------------------------------------------------------- 1 | ;;; This Source Code Form is subject to the terms of the Mozilla Public 2 | ;;; License, v. 2.0. If a copy of the MPL was not distributed with this 3 | ;;; file, You can obtain one at http://mozilla.org/MPL/2.0/. 4 | 5 | (fiasco:define-test-package :ql-https/test) 6 | (in-package #:ql-https/test) 7 | 8 | (deftest test-ql-https-is-initialized-correctly () 9 | (let ((http-function (cdr (assoc "http" ql-http:*fetch-scheme-functions* :test #'string=))) 10 | (https-function (cdr (assoc "https" ql-http:*fetch-scheme-functions* :test #'string=)))) 11 | (is (eq 'ql-https:fetcher http-function) "HTTP doesn't use `ql-https:fetch'") 12 | (is (eq 'ql-https:fetcher https-function) "HTTP doesn't use `ql-https:fetch'"))) 13 | 14 | (deftest test-downloading-system () 15 | (let ((ql-https:*quietly-use-https* nil)) 16 | (signals ql-https:no-https-error 17 | (ql:quickload "str" :silent t)))) 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /version: -------------------------------------------------------------------------------- 1 | 0.7.0 2 | --------------------------------------------------------------------------------