Mercurial > hg > xemacs-beta

comparison lisp/code-process.el @ 5814:a216b3c2b09e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add TLS support. See xemacs-patches message with ID <CAHCOHQk6FNm2xf=XiGEpPq43+7WOzNZ=SuD9V79o3wb9WVCTrQ@mail.gmail.com>.
author Jerry James <james@xemacs.org>
date Tue, 07 Oct 2014 21:16:10 -0600
parents 91b3aa59f49b
children
comparison
equal deleted inserted replaced
5813:36dddf9d90d1 5814:a216b3c2b09e
269 If VAL is a function symbol, the function must return a coding system 269 If VAL is a function symbol, the function must return a coding system
270 or a cons of coding systems which are used as above. 270 or a cons of coding systems which are used as above.
271 271
272 See also the function `find-operation-coding-system'.") 272 See also the function `find-operation-coding-system'.")
273 273
274 (defun open-network-stream (name buffer host service &optional protocol) 274 (defun network-stream-get-response (stream start end-of-command)
275 (when end-of-command
276 (with-current-buffer (process-buffer stream)
277 (save-excursion
278 (goto-char start)
279 (while (and (memq (process-status stream) '(open run))
280 (not (re-search-forward end-of-command nil t)))
281 (accept-process-output stream 0 50)
282 (goto-char start))
283 ;; Return the data we got back, or nil if the process died.
284 (unless (= start (point))
285 (buffer-substring start (point)))))))
286
287 (defun network-stream-command (stream command eoc)
288 (when command
289 (let ((start (point-max (process-buffer stream))))
290 (process-send-string stream command)
291 (network-stream-get-response stream start eoc))))
292
293 (defun network-stream-open-plain (name buffer host service parameters)
294 (let ((start (point buffer))
295 (stream
296 (open-network-stream-internal name buffer host service
297 (plist-get parameters :protocol))))
298 (list stream
299 (network-stream-get-response stream start
300 (plist-get parameters :end-of-command))
301 nil
302 'plain)))
303
304 (defun network-stream-open-tls (name buffer host service parameters)
305 (with-current-buffer buffer
306 (let* ((start (point-max))
307 (stream
308 (open-network-stream-internal name buffer host service
309 (plist-get parameters :protocol) t)))
310 (if (null stream)
311 (list nil nil nil 'plain)
312 (let ((eoc (plist-get parameters :end-of-command))
313 (capability-command (plist-get parameters :capability-command)))
314 (list stream
315 (network-stream-get-response stream start eoc)
316 (network-stream-command stream capability-command eoc)
317 'tls))))))
318
319 (defun network-stream-certificate (host service parameters)
320 (let ((spec (plist-get :client-certificate parameters)))
321 (cond
322 ((listp spec)
323 ;; Either nil or a list with a key/certificate pair.
324 spec)
325 ((eq spec t)
326 (when (fboundp 'auth-source-search)
327 (let* ((auth-info
328 (car (auth-source-search :max 1
329 :host host
330 :port service)))
331 (key (plist-get auth-info :key))
332 (cert (plist-get auth-info :cert)))
333 (and key cert
334 (list key cert))))))))
335
336 (defun network-stream-open-starttls (name buffer host service parameters)
337 (let* ((start (point buffer))
338 (require-tls (eq (plist-get parameters :type) 'starttls))
339 (starttls-function (plist-get parameters :starttls-function))
340 (success-string (plist-get parameters :success))
341 (capability-command (plist-get parameters :capability-command))
342 (eoc (plist-get parameters :end-of-command))
343 (eo-capa (or (plist-get parameters :end-of-capability) eoc))
344 (protocol (plist-get parameters :protocol))
345 ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE)
346 (stream (open-network-stream-internal name buffer host service
347 protocol))
348 (greeting (and (not (plist-get parameters :nogreeting))
349 (network-stream-get-response stream start eoc)))
350 (capabilities (network-stream-command stream capability-command
351 eo-capa))
352 (resulting-type 'plain)
353 starttls-available starttls-command error)
354
355 ;; First check whether the server supports STARTTLS at all.
356 (when (and capabilities success-string starttls-function)
357 (setq starttls-command
358 (funcall starttls-function capabilities)))
359 ;; If we have built-in STARTTLS support, try to upgrade the
360 ;; connection.
361 (when (and starttls-command
362 (setq starttls-available t)
363 (not (eq (plist-get parameters :type) 'plain)))
364 (when (let ((response
365 (network-stream-command stream starttls-command eoc)))
366 (and response (string-match success-string response)))
367 ;; The server said it was OK to begin STARTTLS negotiations.
368 (let ((cert (network-stream-certificate host service parameters)))
369 (condition-case nil
370 (tls-negotiate stream host (and cert (list cert)))
371 ;; If we get a tls-specific error (for instance if the
372 ;; certificate the server gives us is completely syntactically
373 ;; invalid), then close the connection and possibly (further
374 ;; down) try to create a non-encrypted connection.
375 (gnutls-error (delete-process stream))))
376 (if (memq (process-status stream) '(open run))
377 (setq resulting-type 'tls)
378 ;; We didn't successfully negotiate STARTTLS; if TLS
379 ;; isn't demanded, reopen an unencrypted connection.
380 (unless require-tls
381 (setq stream
382 (make-network-process :name name :buffer buffer
383 :host host :service service))
384 (network-stream-get-response stream start eoc)))
385 ;; Re-get the capabilities, which may have now changed.
386 (setq capabilities
387 (network-stream-command stream capability-command eo-capa))))
388
389 ;; If TLS is mandatory, close the connection if it's unencrypted.
390 (when (and require-tls
391 ;; ... but Emacs wasn't able to -- either no built-in
392 ;; support, or no gnutls-cli installed.
393 (eq resulting-type 'plain))
394 (setq error
395 (if (or (null starttls-command)
396 starttls-available)
397 "Server does not support TLS"
398 ;; See `starttls-available-p'. If this predicate
399 ;; changes to allow running under Windows, the error
400 ;; message below should be amended.
401 (if (memq system-type '(windows-nt ms-dos))
402 (concat "Emacs does not support TLS")
403 (concat "Emacs does not support TLS, and no external `"
404 (if starttls-use-gnutls
405 starttls-gnutls-program
406 starttls-program)
407 "' program was found"))))
408 (delete-process stream)
409 (setq stream nil))
410 ;; Return value:
411 (list stream greeting capabilities resulting-type error)))
412
413 ;; Requires that format-spec.el from gnus be loaded
414 (defun network-stream-open-shell (name buffer host service parameters)
415 (require 'format-spec)
416 (let* ((capability-command (plist-get parameters :capability-command))
417 (eo-capa (plist-get parameters :end-of-capability))
418 (eoc (plist-get parameters :end-of-command))
419 (start (point buffer))
420 (stream (let ((process-connection-type nil))
421 (start-process name buffer shell-file-name
422 shell-command-switch
423 (format-spec
424 (plist-get parameters :shell-command)
425 (format-spec-make
426 ?s host
427 ?p service))))))
428 (list stream
429 (network-stream-get-response stream start eoc)
430 (network-stream-command stream capability-command (or eo-capa eoc))
431 'plain)))
432
433 (defun open-network-stream (name buffer host service &rest parameters)
275 "Open a TCP connection for a service to a host. 434 "Open a TCP connection for a service to a host.
276 Return a process object to represent the connection. 435 Normally, return a process object to represent the connection. If the
436 :return-list parameter is non-NIL, instead return a list; see below.
277 Input and output work as for subprocesses; `delete-process' closes it. 437 Input and output work as for subprocesses; `delete-process' closes it.
278 NAME is name for process. It is modified if necessary to make it unique. 438 NAME is name for process. It is modified if necessary to make it unique.
279 BUFFER is the buffer (or buffer-name) to associate with the process. 439 BUFFER is the buffer (or buffer-name) to associate with the process.
280 Process output goes at end of that buffer, unless you specify 440 Process output goes at end of that buffer, unless you specify
281 an output stream or filter function to handle the output. 441 an output stream or filter function to handle the output.
282 BUFFER may be also nil, meaning that this process is not associated 442 BUFFER may be also nil, meaning that this process is not associated
283 with any buffer. 443 with any buffer.
284 Third arg is name of the host to connect to, or its IP address. 444 Third arg is name of the host to connect to, or its IP address.
285 Fourth arg SERVICE is name of the service desired, or an integer 445 Fourth arg SERVICE is name of the service desired, or an integer
286 specifying a port number to connect to. 446 specifying a port number to connect to.
287 Fifth argument PROTOCOL is a network protocol. Currently 'tcp 447
288 (Transmission Control Protocol) and 'udp (User Datagram Protocol) are 448 The remaining PARAMETERS should be a sequence of keywords and values:
289 supported. When omitted, 'tcp is assumed. 449 - :protocol is a network protocol. Currently 'tcp (Transmission Control
450 Protocol) and 'udp (User Datagram Protocol) are supported. When
451 omitted, 'tcp is assumed.
452 - :type specifies the connection type; it is one of the following:
453 nil or `network': begin with an ordinary network connection, and if
454 the parameters :success and :capability-command are also
455 supplied, try to upgrade to an encrypted connection via
456 STARTTLS. If that fails (e.g., HOST does not support TLS),
457 retain an unencrypted connection.
458 `plain': an ordinary, unencrypted network connection.
459 `starttls': begin with an ordinary network connection and try to
460 upgrade via STARTTLS. If that fails, drop the connection
461 and return a killed process object.
462 `tls': a TLS connection.
463 `ssl': a synonym for `tls'.
464 `shell': a shell connection.
465 - :return-list specifies this function's return value.
466 If omitted or nil, return a process object as usual. Otherwise, return
467 (PROC . PROPS), where PROC is a process object and PROPS is a plist of
468 connection properties, with these keywords:
469 :greeting: the greeting returned by HOST (a string), or nil.
470 :capabilities: a string representing HOST's capabilities, or nil if none
471 could be found.
472 :type: the resulting connection type, `plain' (unencrypted) or `tls'
473 (encrypted).
474 - :end-of-command specifies a regexp matching the end of a command.
475 - :end-of-capability specifies a regexp matching the end of the response
476 to the command specified for :capability-command. It defaults to the
477 regexp specified for :end-of-command.
478 - :success specifies a regexp matching a message indicating a successful
479 STARTTLS negotiation. For example, the default should be \"^3\" for an
480 NNTP connection.
481 - :capability-command specifies a command used to query HOST for its
482 capabilities. For example, this should be \"1 CAPABILITY\\r\\n\" for
483 IMAP.
484 - :starttls-function specifies a function for handling STARTTLS. This
485 function should take one parameter, the response to the capability
486 command, and should return the command to switch on STARTTLS if the
487 server supports it, or nil otherwise.
488 - :always-query-capabilities, if non-nil, indicates that the server should
489 be queried for capabilities even if constructing a `plain' network
490 connection.
491 - :client-certificate is either a list (certificate-key-filename
492 certificate-filename), or `t', meaning that `auth-source' will be
493 queried for the key and certificate. This parameter is used only when
494 constructing a TLS or STARTTLS connection.
495 - :use-starttls-if-possible, if non-nil, indicates that STARTTLS should
496 be used even if TLS support is not compiled in to XEmacs.
497 - :nogreeting, if non-nil, indicates that we should not wait for a
498 greeting from the server.
499 - :nowait, if non-nil, indicates that an asynchronous connection should be
500 made, if possible. NOTE: this is currently unimplemented.
501
502 For backwards compatibility, if exactly five arguments are given, the fifth
503 must be one of nil, 'tcp, or 'udp. Both nil and 'tcp select TCP (Transmission
504 Control Protocol) and 'udp selects UDP (User Datagram Protocol).
290 505
291 Output via `process-send-string' and input via buffer or filter (see 506 Output via `process-send-string' and input via buffer or filter (see
292 `set-process-filter') are stream-oriented. That means UDP datagrams are 507 `set-process-filter') are stream-oriented. That means UDP datagrams are
293 not guaranteed to be sent and received in discrete packets. (But small 508 not guaranteed to be sent and received in discrete packets. (But small
294 datagrams around 500 bytes that are not truncated by `process-send-string' 509 datagrams around 500 bytes that are not truncated by `process-send-string'
313 proceed essentially independently one from the other, as in `start-process'. 528 proceed essentially independently one from the other, as in `start-process'.
314 529
315 You can change the coding systems later on using 530 You can change the coding systems later on using
316 `set-process-coding-system', `set-process-input-coding-system', or 531 `set-process-coding-system', `set-process-input-coding-system', or
317 `set-process-output-coding-system'." 532 `set-process-output-coding-system'."
533 (when (and (car parameters) (not (cdr parameters)))
534 (setq parameters (list :protocol (car parameters))))
318 (let (cs-r cs-w) 535 (let (cs-r cs-w)
319 (let (ret) 536 (let (ret)
320 (catch 'found 537 (catch 'found
321 (let ((alist network-coding-system-alist) 538 (let ((alist network-coding-system-alist)
322 (case-fold-search nil) 539 (case-fold-search nil)
349 (car default-network-coding-system) 566 (car default-network-coding-system)
350 'undecided)) 567 'undecided))
351 (coding-system-for-write 568 (coding-system-for-write
352 (or coding-system-for-write cs-w 569 (or coding-system-for-write cs-w
353 (cdr default-network-coding-system) 570 (cdr default-network-coding-system)
354 'raw-text))) 571 'raw-text))
355 (open-network-stream-internal name buffer host service protocol)))) 572 (type (plist-get parameters :type))
573 (return-list (plist-get parameters :return-list))
574 (capability-command (plist-get parameters :capability-command)))
575 (if (and (not return-list)
576 (or (eq type 'plain)
577 (and (or (null type) (eq type 'network))
578 (not (and (plist-get parameters :success)
579 capability-command)))))
580 ;; The simplest case: a plain connection
581 (open-network-stream-internal name buffer host service
582 (plist-get parameters :protocol))
583 (let ((work-buffer (or buffer
584 (generate-new-buffer " *stream buffer*")))
585 (fun (cond ((and (eq type 'plain)
586 (not (plist-get parameters
587 :always-query-capabilities)))
588 #'network-stream-open-plain)
589 ((memq type '(nil network starttls plain))
590 #'network-stream-open-starttls)
591 ((memq type '(tls ssl)) #'network-stream-open-tls)
592 ((eq type 'shell) 'network-stream-open-shell)
593 (t (error "Invalid connection type" type))))
594 result)
595 (unwind-protect
596 (setq result
597 (funcall fun name work-buffer host service parameters))
598 (unless buffer
599 (and (processp (car result))
600 (set-process-buffer (car result) nil))
601 (kill-buffer work-buffer)))
602 (if return-list
603 (list (car result)
604 :greeting (nth 1 result)
605 :capabilities (nth 2 result)
606 :type (nth 3 result)
607 :error (nth 4 result))
608 (car result)))))))
356 609
357 (defun set-buffer-process-coding-system (decoding encoding) 610 (defun set-buffer-process-coding-system (decoding encoding)
358 "Set coding systems for the process associated with the current buffer. 611 "Set coding systems for the process associated with the current buffer.
359 DECODING is the coding system to be used to decode input from the process, 612 DECODING is the coding system to be used to decode input from the process,
360 ENCODING is the coding system to be used to encode output to the process. 613 ENCODING is the coding system to be used to encode output to the process.