ql-https/ql-https.lisp at master · rudolfochrist/ql-https · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
;;;; ql-https.lisp

(defpackage #:ql-https
  (:use :cl)
  (:import-from #:ql-gunzipper #:gunzip)
  (:export
   #:fetcher
   #:*quietly-use-https*
   #:register-fetch-scheme-functions
   #:no-https-error))

(in-package #:ql-https)

(define-condition no-https-error (error)
  ((url :initarg :url
        :reader no-https-url))
  (:report (lambda (c stream)
             (format stream "We don't use HTTP here!~&URL: ~A" (no-https-url c)))))

(defvar *quietly-use-https* nil
  "If non-nil quietly use HTTPS.")

(defun fetcher (url file &rest args)
  "Fetch URL and safe it to FILE."
  (declare (ignorable args))
  (if (uiop:string-prefix-p "https://" url)
      ;; Convert the file path to a string with any leading "~" replaced by the
      ;; HOME directory, and then download.
      (let* ((file-namestring (namestring file))
             (file-namestring-full (if (uiop:string-prefix-p "~" file-namestring)
                                       (concatenate 'string
                                                    (namestring (user-homedir-pathname))
                                                    (subseq file-namestring 1))
                                       file-namestring))
             (output (uiop:run-program (list "curl" "-fsSL" url "-o" file-namestring-full)
                                       :force-shell nil
                                       :output '(:string :stripped t)
                                       :error-output :output))
             (file (and file (probe-file file)))
             (release (url-to-release url)))
        (values output file))
      (restart-case
          (handler-bind ((no-https-error (lambda (c)
                                           (declare (ignore c))
                                           (when *quietly-use-https*
                                             (invoke-restart 'use-https)))))
            (error 'no-https-error :url url))
        (use-https ()
          :report "Retry with HTTPS."
          (apply #'fetcher
                 (format nil "https~A" (subseq url 4))
                 file
                 args))
        (use-https-session ()
          :report "Retry with HTTPS and save decision for this session."
          (setf *quietly-use-https* t)
          (apply #'fetcher url file args)))))

(defun url-to-release (url)
  "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)))
    (when release
      (ql-dist:project-name release))))

#+sbcl
(defun md5 (file)
  "Returns md5sum of FILE"
  (format nil "~{~2,'0x~}" (coerce (sb-md5:md5sum-file file) 'list)))

(defun extract-openssl-digest (output)
  "Extracts digest from output of `openssl dgst'"
  (let ((space-pos (position #\Space output)))
    (subseq output (1+ space-pos))))    ; exclude space itself

#-sbcl
(defun md5 (file)
  "Returns md5sum of FILE"
  (extract-openssl-digest
   (uiop:run-program (list "openssl" "dgst" "-md5" (namestring file))
                     :output '(:string :stripped t))))

(defun file-size (file)
  "Returns the size of FILE in bytes"
  (with-open-file (f file)
    (file-length f)))

(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))

    (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*
        (list (cons "http" 'fetcher)
              (cons "https" 'fetcher))))