Mercurial > emacs
comparison lisp/net/tls.el @ 91085:880960b70474
Merge from emacs--devo--0
Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-283
| author | Miles Bader <miles@gnu.org> |
|---|---|
| date | Sun, 11 Nov 2007 00:56:44 +0000 |
| parents | f55f9811f5d7 55afdd9000d3 |
| children | 53108e6cea98 |
comparison
equal
deleted
inserted
replaced
| 91084:a4347a111894 | 91085:880960b70474 |
|---|---|
| 52 (autoload 'format-spec-make "format-spec")) | 52 (autoload 'format-spec-make "format-spec")) |
| 53 | 53 |
| 54 (defgroup tls nil | 54 (defgroup tls nil |
| 55 "Transport Layer Security (TLS) parameters." | 55 "Transport Layer Security (TLS) parameters." |
| 56 :group 'comm) | 56 :group 'comm) |
| 57 | |
| 58 (defcustom tls-end-of-info | |
| 59 (concat | |
| 60 "\\(" | |
| 61 ;; `openssl s_client' regexp. See ssl/ssl_txt.c lines 219-220. | |
| 62 ;; According to apps/s_client.c line 1515 `---' is always the last | |
| 63 ;; line that is printed by s_client before the real data. | |
| 64 "^ Verify return code: .+\n---\n\\|" | |
| 65 ;; `gnutls' regexp. See src/cli.c lines 721-. | |
| 66 "^- Simple Client Mode:\n" | |
| 67 "\\(\n\\|" ; ignore blank lines | |
| 68 ;; According to GnuTLS v2.1.5 src/cli.c lines 640-650 and 705-715 | |
| 69 ;; in `main' the handshake will start after this message. If the | |
| 70 ;; handshake fails, the programs will abort. | |
| 71 "^\\*\\*\\* Starting TLS handshake\n\\)*" | |
| 72 "\\)") | |
| 73 "Regexp matching end of TLS client informational messages. | |
| 74 Client data stream begins after the last character matched by | |
| 75 this. The default matches `openssl s_client' (version 0.9.8c) | |
| 76 and `gnutls-cli' (version 2.0.1) output." | |
| 77 :version "22.2" | |
| 78 :type 'regexp | |
| 79 :group 'tls) | |
| 57 | 80 |
| 58 (defcustom tls-program '("gnutls-cli -p %p %h" | 81 (defcustom tls-program '("gnutls-cli -p %p %h" |
| 59 "gnutls-cli -p %p %h --protocols ssl3" | 82 "gnutls-cli -p %p %h --protocols ssl3" |
| 60 "openssl s_client -connect %h:%p -no_ssl2") | 83 "openssl s_client -connect %h:%p -no_ssl2") |
| 61 "List of strings containing commands to start TLS stream to a host. | 84 "List of strings containing commands to start TLS stream to a host. |
| 128 (let ((cmds tls-program) | 151 (let ((cmds tls-program) |
| 129 (use-temp-buffer (null buffer)) | 152 (use-temp-buffer (null buffer)) |
| 130 process cmd done) | 153 process cmd done) |
| 131 (if use-temp-buffer | 154 (if use-temp-buffer |
| 132 (setq buffer (generate-new-buffer " TLS"))) | 155 (setq buffer (generate-new-buffer " TLS"))) |
| 133 (message "Opening TLS connection to `%s'..." host) | 156 (with-current-buffer buffer |
| 134 (while (and (not done) (setq cmd (pop cmds))) | 157 (message "Opening TLS connection to `%s'..." host) |
| 135 (message "Opening TLS connection with `%s'..." cmd) | 158 (while (and (not done) (setq cmd (pop cmds))) |
| 136 (let ((process-connection-type tls-process-connection-type) | 159 (message "Opening TLS connection with `%s'..." cmd) |
| 137 response) | 160 (let ((process-connection-type tls-process-connection-type) |
| 138 (setq process (start-process | 161 response) |
| 139 name buffer shell-file-name shell-command-switch | 162 (setq process (start-process |
| 140 (format-spec | 163 name buffer shell-file-name shell-command-switch |
| 141 cmd | 164 (format-spec |
| 142 (format-spec-make | 165 cmd |
| 143 ?h host | 166 (format-spec-make |
| 144 ?p (if (integerp port) | 167 ?h host |
| 145 (int-to-string port) | 168 ?p (if (integerp port) |
| 146 port))))) | 169 (int-to-string port) |
| 147 (while (and process | 170 port))))) |
| 148 (memq (process-status process) '(open run)) | 171 (while (and process |
| 149 (save-excursion | 172 (memq (process-status process) '(open run)) |
| 150 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug | 173 (progn |
| 151 (goto-char (point-min)) | 174 (goto-char (point-min)) |
| 152 (not (setq done (re-search-forward tls-success nil t))))) | 175 (not (setq done (re-search-forward tls-success nil t))))) |
| 153 (unless (accept-process-output process 1) | 176 (unless (accept-process-output process 1) |
| 154 (sit-for 1))) | 177 (sit-for 1))) |
| 155 (message "Opening TLS connection with `%s'...%s" cmd | 178 (message "Opening TLS connection with `%s'...%s" cmd |
| 156 (if done "done" "failed")) | 179 (if done "done" "failed")) |
| 157 (if done | 180 (if (not done) |
| 158 (setq done process) | 181 (delete-process process) |
| 159 (delete-process process)))) | 182 ;; advance point to after all informational messages that |
| 160 (message "Opening TLS connection to `%s'...%s" | 183 ;; `openssl s_client' and `gnutls' print |
| 161 host (if done "done" "failed")) | 184 (let ((start-of-data nil)) |
| 185 (while | |
| 186 (not (setq start-of-data | |
| 187 ;; the string matching `tls-end-of-info' | |
| 188 ;; might come in separate chunks from | |
| 189 ;; `accept-process-output', so start the | |
| 190 ;; search where `tls-success' ended | |
| 191 (save-excursion | |
| 192 (if (re-search-forward tls-end-of-info nil t) | |
| 193 (match-end 0))))) | |
| 194 (accept-process-output process 1)) | |
| 195 (if start-of-data | |
| 196 ;; move point to start of client data | |
| 197 (goto-char start-of-data))) | |
| 198 (setq done process)))) | |
| 199 (message "Opening TLS connection to `%s'...%s" | |
| 200 host (if done "done" "failed"))) | |
| 162 (when use-temp-buffer | 201 (when use-temp-buffer |
| 163 (if done (set-process-buffer process nil)) | 202 (if done (set-process-buffer process nil)) |
| 164 (kill-buffer buffer)) | 203 (kill-buffer buffer)) |
| 165 done)) | 204 done)) |
| 166 | 205 |