source: release/1.2/source/tools/asdf-install/deprecated.lisp @ 9219

Last change on this file since 9219 was 9219, checked in by gb, 12 years ago

synch from trunk

File size: 8.8 KB
Line 
1(in-package asdf-install)
2
3#+(and ignore sbcl) ; Deprecated.
4(define-symbol-macro *sbcl-home* *asdf-install-dirs*)
5
6#+(and ignore sbcl) ; Deprecated.
7(define-symbol-macro *dot-sbcl* *private-asdf-install-dirs*)
8
9#+(or)
10;; uncalled
11(defun read-until-eof (stream)
12  (with-output-to-string (o)
13    (copy-stream stream o)))
14
15
16#+(or)
17(defun verify-gpg-signature/string (string file-name)
18  (block verify
19    (loop
20      (restart-case
21        (let ((gpg-stream (make-stream-from-gpg-command string file-name))
22              tags)
23          (unwind-protect
24            (loop for l = (read-line gpg-stream nil nil)
25                  while l
26                  do (print l)
27                  when (> (mismatch l "[GNUPG:]") 6)
28                  do (destructuring-bind (_ tag &rest data)
29                                         (split-sequence-if (lambda (x)
30                                                              (find x '(#\Space #\Tab)))
31                                                            l)
32                       (declare (ignore _))
33                       (pushnew (cons (intern (string-upcase tag) :keyword)
34                                      data) tags)))
35            (ignore-errors
36             (close gpg-stream)))
37          ;; test that command returned something
38          (unless tags
39            (error 'gpg-shell-error))
40          ;; test for obvious key/sig problems
41          (let ((errsig (header-value :errsig tags)))
42            (and errsig (error 'key-not-found :key-id errsig)))
43          (let ((badsig (header-value :badsig tags)))
44            (and badsig (error 'key-not-found :key-id badsig)))
45          (let* ((good (header-value :goodsig tags))
46                 (id (first good))
47                 (name (format nil "~{~A~^ ~}" (rest good))))
48            ;; good signature, but perhaps not trusted
49            (restart-case
50              (let ((trusted? (or (header-pair :trust_ultimate tags)
51                                  (header-pair :trust_fully tags)))
52                    (in-list? (assoc id *trusted-uids* :test #'equal)))
53                (cond ((or trusted? in-list?)
54                       ;; ok
55                       )
56                      ((not trusted?)
57                       (error 'key-not-trusted :key-user-name name :key-id id))
58                      ((not in-list?)
59                       (error 'author-not-trusted
60                         :key-user-name name :key-id id))
61                      (t
62                       (error "Boolean logic gone bad. Run for the hills"))))
63              (add-key (&rest rest)
64                       :report "Add to package supplier list"
65                       (declare (ignore rest))
66                       (pushnew (list id name) *trusted-uids*))))
67          (return-from verify t))
68        #+Ignore
69        (install-anyways (&rest rest)
70                               :report "Don't check GPG signature for this package"
71                               (declare (ignore rest))
72                               (return-from verify t))
73        (retry-gpg-check (&rest args)
74                         :report "Retry GPG check \(e.g., after downloading the key\)"
75                         (declare (ignore args))
76                         nil)))))
77
78#+(or)
79(defun verify-gpg-signature/url (url file-name)
80  (block verify
81    (loop
82      (restart-case
83        (when (verify-gpg-signatures-p url)
84          (let ((sig-url (concatenate 'string url ".asc")))
85            (destructuring-bind (response headers stream)
86                                (url-connection sig-url)
87              (unwind-protect
88                (flet (#-:digitool
89                       (read-signature (data stream)
90                         (read-sequence data stream))
91                       #+:digitool
92                       (read-signature (data stream)
93                         (multiple-value-bind (reader arg)
94                                              (ccl:stream-reader stream)
95                           (let ((byte 0))
96                             (dotimes (i (length data))
97                               (unless (setf byte (funcall reader arg))
98                                 (error 'download-error :url sig-url
99                                        :response 200))
100                               (setf (char data i) (code-char byte)))))))
101                  (if (= response 200)
102                    (let ((data (make-string (parse-integer
103                                              (header-value :content-length headers)
104                                              :junk-allowed t))))
105                      (read-signature data stream)
106                      (verify-gpg-signature/string data file-name))
107                    (error 'download-error :url sig-url
108                           :response response)))
109                (close stream)
110                (return-from verify t)))))
111        (install-anyways (&rest rest)
112                         :report "Don't check GPG signature for this package"
113                         (declare (ignore rest))
114                         (return-from verify t))
115        (retry-gpg-check (&rest args)
116                         :report "Retry GPG check \(e.g., after fixing the network connection\)"
117                         (declare (ignore args))
118                         nil)))))
119
120
121#+(or :sbcl :cmu :scl)
122(defun make-stream-from-gpg-command (string file-name)
123  (#+:sbcl sb-ext:process-output
124   #+(or :cmu :scl) ext:process-output
125   (#+:sbcl sb-ext:run-program
126    #+(or :cmu :scl) ext:run-program
127    "gpg"
128    (list
129     "--status-fd" "1" "--verify" "-"
130     (namestring file-name))
131    :output :stream
132    :error nil
133    #+sbcl :search #+sbcl t
134    :input (make-string-input-stream string)
135    :wait t)))
136
137#+(and :lispworks (not :win32))
138(defun make-stream-from-gpg-command (string file-name)
139  ;; kludge - we can't separate the in and out streams
140  (let ((stream (sys:open-pipe (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A"
141                                       string
142                                       (namestring file-name)))))
143    stream))
144
145
146#+(and :lispworks :win32)
147(defun make-stream-from-gpg-command (string file-name)
148  (sys:open-pipe (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\""
149                         (make-temp-sig file-name string)
150                         (namestring file-name))))
151
152#+(and :clisp (not (or :win32 :cygwin)))
153(defun make-stream-from-gpg-command (string file-name)
154  (let ((stream
155         (ext:run-shell-command (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A"
156                                        string
157                                        (namestring file-name))
158                                :output :stream
159                                :wait nil)))
160    stream))
161
162#+(and :clisp (or :win32 :cygwin))
163(defun make-stream-from-gpg-command (string file-name)
164  (ext:run-shell-command (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\""
165                                 (make-temp-sig file-name string)
166                                 (namestring file-name))
167                         :output :stream
168                         :wait nil))
169
170#+:allegro
171(defun make-stream-from-gpg-command (string file-name)
172  (multiple-value-bind (in-stream out-stream)
173                       (excl:run-shell-command
174                        #-:mswindows
175                        (concatenate 'vector
176                                     #("gpg" "gpg" "--status-fd" "1" "--verify" "-")
177                                     (make-sequence 'vector 1
178                                                    :initial-element (namestring file-name)))
179                        #+:mswindows
180                        (format nil "gpg --status-fd 1 --verify - \"~A\"" (namestring file-name))
181                        :input :stream
182                        :output :stream
183                        :separate-streams t
184                        :wait nil)
185    (write-string string in-stream)
186    (finish-output in-stream)
187    (close in-stream)
188    out-stream))
189
190#+:openmcl
191(defun make-stream-from-gpg-command (string file-name)
192  (let ((proc (ccl:run-program "gpg" (list "--status-fd" "1" "--verify" "-" (namestring file-name))
193                               :input :stream
194                               :output :stream
195                               :wait nil)))
196    (write-string string (ccl:external-process-input-stream proc))
197    (close (ccl:external-process-input-stream proc))
198    (ccl:external-process-output-stream proc)))
199
200#+:digitool
201(defun make-stream-from-gpg-command (string file-name)
202  (make-instance 'popen-input-stream
203    :command (format nil "echo '~A' | gpg --status-fd 1 --verify - '~A'"
204                     string
205                     (system-namestring file-name))))
206
207#+(or)
208(defun make-temp-sig (file-name content)
209  (let ((name (format nil "~A.asc" (namestring (truename file-name)))))
210    (with-open-file (out name
211                         :direction :output
212                         :if-exists :supersede)
213      (write-string content out))
214    (pushnew name *temporary-files*)
215    name))
216
Note: See TracBrowser for help on using the repository browser.