cgit.sxemacs.org Git - sxemacs/blob - contrib/starttls.el.patch

   1 --- starttls.el 2006-03-08 09:59:10.000000000 +0000
   2 +++ starttls.el.mod     2007-08-15 21:04:34.000000000 +0000
   3 @@ -1,4 +1,5 @@
   4  ;;; starttls.el --- STARTTLS functions
   5 +;;; in fact this file pretends to be starttls.el!
   6
   7  ;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
   8  ;;   2005, 2006 Free Software Foundation, Inc.
   9 @@ -125,37 +126,28 @@
  10
  11  (defcustom starttls-gnutls-program "gnutls-cli"
  12    "Name of GNUTLS command line tool.
  13 -This program is used when GNUTLS is used, i.e. when
  14 -`starttls-use-gnutls' is non-nil."
  15 +This program is not used at all, so ... :)"
  16    :type 'string
  17    :group 'starttls)
  18
  19  (defcustom starttls-program "starttls"
  20    "The program to run in a subprocess to open an TLSv1 connection.
  21 -This program is used when the `starttls' command is used,
  22 -i.e. when `starttls-use-gnutls' is nil."
  23 +This program is not used at all, so ... :)"
  24    :type 'string
  25    :group 'starttls)
  26
  27 -(defcustom starttls-use-gnutls (not (executable-find starttls-program))
  28 -  "*Whether to use GNUTLS instead of the `starttls' command."
  29 +(defcustom starttls-use-gnutls t
  30 +  "*Set whatever you want.  I will not care anyway."
  31    :type 'boolean
  32    :group 'starttls)
  33
  34  (defcustom starttls-extra-args nil
  35 -  "Extra arguments to `starttls-program'.
  36 -These apply when the `starttls' command is used, i.e. when
  37 -`starttls-use-gnutls' is nil."
  38 +  "Extra arguments to `starttls-program'. ;)"
  39    :type '(repeat string)
  40    :group 'starttls)
  41
  42  (defcustom starttls-extra-arguments nil
  43 -  "Extra arguments to `starttls-program'.
  44 -These apply when GNUTLS is used, i.e. when `starttls-use-gnutls' is non-nil.
  45 -
  46 -For example, non-TLS compliant servers may require
  47 -'(\"--protocols\" \"ssl3\").  Invoke \"gnutls-cli --help\" to
  48 -find out which parameters are available."
  49 +  "Extra arguments to `starttls-program'. ;)"
  50    :type '(repeat string)
  51    :group 'starttls)
  52
  53 @@ -191,81 +183,38 @@
  54    :type 'regexp
  55    :group 'starttls)
  56
  57 +(defcustom starttls-ca-list nil
  58 +  "*List of certificate authorities to add to every tls connection
  59 +in order to verify."
  60 +  :type '(repeat string)
  61 +  :group 'starttls)
  62 +
  63  (defun starttls-negotiate-gnutls (process)
  64    "Negotiate TLS on PROCESS opened by `open-starttls-stream'.
  65  This should typically only be done once.  It typically returns a
  66  multi-line informational message with information about the
  67  handshake, or nil on failure."
  68 -  (let (buffer info old-max done-ok done-bad)
  69 -    (if (null (setq buffer (process-buffer process)))
  70 -       ;; XXX How to remove/extract the TLS negotiation junk?
  71 -       (signal-process (process-id process) 'SIGALRM)
  72 -      (with-current-buffer buffer
  73 -       (save-excursion
  74 -         (setq old-max (goto-char (point-max)))
  75 -         (signal-process (process-id process) 'SIGALRM)
  76 -         (while (and (processp process)
  77 -                     (eq (process-status process) 'run)
  78 -                     (save-excursion
  79 -                       (goto-char old-max)
  80 -                       (not (or (setq done-ok (re-search-forward
  81 -                                               starttls-success nil t))
  82 -                                (setq done-bad (re-search-forward
  83 -                                                starttls-failure nil t))))))
  84 -           (accept-process-output process 1 100)
  85 -           (sit-for 0.1))
  86 -         (setq info (buffer-substring-no-properties old-max (point-max)))
  87 -         (delete-region old-max (point-max))
  88 -         (if (or (and done-ok (not done-bad))
  89 -                 ;; Prevent mitm that fake success msg after failure msg.
  90 -                 (and done-ok done-bad (< done-ok done-bad)))
  91 -             info
  92 -           (message "STARTTLS negotiation failed: %s" info)
  93 -           nil))))))
  94 -
  95 -(defun starttls-negotiate (process)
  96 -  (if starttls-use-gnutls
  97 -      (starttls-negotiate-gnutls process)
  98 -    (signal-process (process-id process) 'SIGALRM)))
  99 +  (let* (reason
 100 +         ;; we just snarf what we need from the extra arguments
 101 +         (cert (car-safe
 102 +                (cdr-safe
 103 +                 (member "--x509certfile" starttls-extra-arguments))))
 104 +         (key (car-safe
 105 +                (cdr-safe
 106 +                 (member "--x509keyfile" starttls-extra-arguments))))
 107 +         (ca (car-safe
 108 +              (cdr-safe
 109 +               (member "--x509cafile" starttls-extra-arguments)))))
 110 +    (ossl-ssl-handshake process 'tls1 ca cert key)
 111 +    t))
 112 +
 113 +(defalias 'starttls-negotiate #'starttls-negotiate-gnutls)
 114
 115  (eval-and-compile
 116 -  (if (fboundp 'set-process-query-on-exit-flag)
 117 -      (defalias 'starttls-set-process-query-on-exit-flag
 118 -       'set-process-query-on-exit-flag)
 119 -    (defalias 'starttls-set-process-query-on-exit-flag
 120 -      'process-kill-without-query)))
 121 +  (defalias 'starttls-set-process-query-on-exit-flag
 122 +    'process-kill-without-query))
 123
 124  (defun starttls-open-stream-gnutls (name buffer host port)
 125 -  (message "Opening STARTTLS connection to `%s'..." host)
 126 -  (let* (done
 127 -        (old-max (with-current-buffer buffer (point-max)))
 128 -        (process-connection-type starttls-process-connection-type)
 129 -        (process (apply #'start-process name buffer
 130 -                        starttls-gnutls-program "-s" host
 131 -                        "-p" (if (integerp port)
 132 -                                 (int-to-string port)
 133 -                               port)
 134 -                        starttls-extra-arguments)))
 135 -    (starttls-set-process-query-on-exit-flag process nil)
 136 -    (while (and (processp process)
 137 -               (eq (process-status process) 'run)
 138 -               (save-excursion
 139 -                 (set-buffer buffer)
 140 -                 (goto-char old-max)
 141 -                 (not (setq done (re-search-forward
 142 -                                  starttls-connect nil t)))))
 143 -      (accept-process-output process 0 100)
 144 -      (sit-for 0.1))
 145 -    (if done
 146 -       (with-current-buffer buffer
 147 -         (delete-region old-max done))
 148 -      (delete-process process)
 149 -      (setq process nil))
 150 -    (message "Opening STARTTLS connection to `%s'...%s"
 151 -            host (if done "done" "failed"))
 152 -    process))
 153 -
 154 -(defun starttls-open-stream (name buffer host port)
 155    "Open a TLS connection for a port to a host.
 156  Returns a subprocess object to represent the connection.
 157  Input and output work as for subprocesses; `delete-process' closes it.
 158 @@ -277,18 +226,28 @@
 159   BUFFER may be also nil, meaning that this process is not associated
 160   with any buffer
 161  Third arg is name of the host to connect to, or its IP address.
 162 -Fourth arg PORT is an integer specifying a port to connect to.
 163 -If `starttls-use-gnutls' is nil, this may also be a service name, but
 164 -GNUTLS requires a port number."
 165 -  (if starttls-use-gnutls
 166 -      (starttls-open-stream-gnutls name buffer host port)
 167 -    (let* ((process-connection-type starttls-process-connection-type)
 168 -          (process (apply #'start-process
 169 -                          name buffer starttls-program
 170 -                          host (format "%s" port)
 171 -                          starttls-extra-args)))
 172 -      (starttls-set-process-query-on-exit-flag process nil)
 173 -      process)))
 174 +Fourth arg PORT is an integer specifying a port to connect to."
 175 +  (message "Opening STARTTLS connection to `%s'..." host)
 176 +  (let* (done
 177 +        (old-max (with-current-buffer buffer (point-max)))
 178 +        (process-connection-type starttls-process-connection-type)
 179 +        (process (open-network-stream name buffer host port)))
 180 +    (starttls-set-process-query-on-exit-flag process nil)
 181 +    (when (and (processp process)
 182 +               (or (eq (process-status process) 'open)
 183 +                   (eq (process-status process) 'run)))
 184 +;;       ;; how 'bout a STARTTLS?
 185 +;;       (process-send-string process "STARTTLS\r\n")
 186 +;;       (when (and (processp process)
 187 +;;                  (or (eq (process-status process) 'open)
 188 +;;                      (eq (process-status process) 'run)))
 189 +        (setq done (starttls-negotiate-gnutls process))) ;;)
 190 +    (message "Opening STARTTLS connection to `%s'...%s"
 191 +            host (if done "done" "failed"))
 192 +    process))
 193 +
 194 +(defalias 'starttls-open-stream #'starttls-open-stream-gnutls)
 195 +
 196
 197  (provide 'starttls)
 198