cgit.sxemacs.org Git - gnus/blob - lisp/sieve-manage.el

   1 ;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp
   2
   3 ;; Copyright (C) 2001-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Simon Josefsson <simon@josefsson.org>
   6 ;;         Albert Krewinkel <tarleb@moltkeplatz.de>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This library provides an elisp API for the managesieve network
  26 ;; protocol.
  27 ;;
  28 ;; It uses the SASL library for authentication, which means it
  29 ;; supports DIGEST-MD5, CRAM-MD5, SCRAM-MD5, NTLM, PLAIN and LOGIN
  30 ;; methods.  STARTTLS is not well tested, but should be easy to get to
  31 ;; work if someone wants.
  32 ;;
  33 ;; The API should be fairly obvious for anyone familiar with the
  34 ;; managesieve protocol, interface functions include:
  35 ;;
  36 ;; `sieve-manage-open'
  37 ;; open connection to managesieve server, returning a buffer to be
  38 ;; used by all other API functions.
  39 ;;
  40 ;; `sieve-manage-opened'
  41 ;; check if a server is open or not
  42 ;;
  43 ;; `sieve-manage-close'
  44 ;; close a server connection.
  45 ;;
  46 ;; `sieve-manage-listscripts'
  47 ;; `sieve-manage-deletescript'
  48 ;; `sieve-manage-getscript'
  49 ;; performs managesieve protocol actions
  50 ;;
  51 ;; and that's it.  Example of a managesieve session in *scratch*:
  52 ;;
  53 ;; (with-current-buffer (sieve-manage-open "mail.example.com")
  54 ;;   (sieve-manage-authenticate)
  55 ;;   (sieve-manage-listscripts))
  56 ;;
  57 ;; => ((active . "main") "vacation")
  58 ;;
  59 ;; References:
  60 ;;
  61 ;; draft-martin-managesieve-02.txt,
  62 ;; "A Protocol for Remotely Managing Sieve Scripts",
  63 ;; by Tim Martin.
  64 ;;
  65 ;; Release history:
  66 ;;
  67 ;; 2001-10-31 Committed to Oort Gnus.
  68 ;; 2002-07-27 Added DELETESCRIPT.  Suggested by Ned Ludd.
  69 ;; 2002-08-03 Use SASL library.
  70 ;; 2013-06-05 Enabled STARTTLS support, fixed bit rot.
  71
  72 ;;; Code:
  73
  74 (if (locate-library "password-cache")
  75     (require 'password-cache)
  76   (require 'password))
  77
  78 (eval-when-compile
  79   (require 'cl)                         ; caddr
  80   (require 'sasl)
  81   (require 'starttls))
  82 (autoload 'sasl-find-mechanism "sasl")
  83 (autoload 'auth-source-search "auth-source")
  84
  85 ;; User customizable variables:
  86
  87 (defgroup sieve-manage nil
  88   "Low-level Managesieve protocol issues."
  89   :group 'mail
  90   :prefix "sieve-")
  91
  92 (defcustom sieve-manage-log "*sieve-manage-log*"
  93   "Name of buffer for managesieve session trace."
  94   :type 'string
  95   :group 'sieve-manage)
  96
  97 (defcustom sieve-manage-server-eol "\r\n"
  98   "The EOL string sent from the server."
  99   :type 'string
 100   :group 'sieve-manage)
 101
 102 (defcustom sieve-manage-client-eol "\r\n"
 103   "The EOL string we send to the server."
 104   :type 'string
 105   :group 'sieve-manage)
 106
 107 (defcustom sieve-manage-authenticators '(digest-md5
 108                                          cram-md5
 109                                          scram-md5
 110                                          ntlm
 111                                          plain
 112                                          login)
 113   "Priority of authenticators to consider when authenticating to server."
 114   ;; FIXME Improve this.  It's not `set'.
 115   ;; It's like (repeat (choice (const ...))), where each choice can
 116   ;; only appear once.
 117   :type '(repeat symbol)
 118   :group 'sieve-manage)
 119
 120 (defcustom sieve-manage-authenticator-alist
 121   '((cram-md5   sieve-manage-cram-md5-p       sieve-manage-cram-md5-auth)
 122     (digest-md5 sieve-manage-digest-md5-p     sieve-manage-digest-md5-auth)
 123     (scram-md5  sieve-manage-scram-md5-p      sieve-manage-scram-md5-auth)
 124     (ntlm       sieve-manage-ntlm-p           sieve-manage-ntlm-auth)
 125     (plain      sieve-manage-plain-p          sieve-manage-plain-auth)
 126     (login      sieve-manage-login-p          sieve-manage-login-auth))
 127   "Definition of authenticators.
 128
 129 \(NAME CHECK AUTHENTICATE)
 130
 131 NAME names the authenticator.  CHECK is a function returning non-nil if
 132 the server support the authenticator and AUTHENTICATE is a function
 133 for doing the actual authentication."
 134   :type '(repeat (list (symbol :tag "Name") (function :tag "Check function")
 135                        (function :tag "Authentication function")))
 136   :group 'sieve-manage)
 137
 138 (defcustom sieve-manage-default-port "sieve"
 139   "Default port number or service name for managesieve protocol."
 140   :type '(choice integer string)
 141   :version "24.4"
 142   :group 'sieve-manage)
 143
 144 (defcustom sieve-manage-default-stream 'network
 145   "Default stream type to use for `sieve-manage'."
 146   :version "24.1"
 147   :type 'symbol
 148   :group 'sieve-manage)
 149
 150 ;; Internal variables:
 151
 152 (defconst sieve-manage-local-variables '(sieve-manage-server
 153                                          sieve-manage-port
 154                                          sieve-manage-auth
 155                                          sieve-manage-stream
 156                                          sieve-manage-process
 157                                          sieve-manage-client-eol
 158                                          sieve-manage-server-eol
 159                                          sieve-manage-capability))
 160 (defconst sieve-manage-coding-system-for-read 'binary)
 161 (defconst sieve-manage-coding-system-for-write 'binary)
 162 (defvar sieve-manage-stream nil)
 163 (defvar sieve-manage-auth nil)
 164 (defvar sieve-manage-server nil)
 165 (defvar sieve-manage-port nil)
 166 (defvar sieve-manage-state 'closed
 167   "Managesieve state.
 168 Valid states are `closed', `initial', `nonauth', and `auth'.")
 169 (defvar sieve-manage-process nil)
 170 (defvar sieve-manage-capability nil)
 171
 172 ;; Internal utility functions
 173 (autoload 'mm-enable-multibyte "mm-util")
 174
 175 (defun sieve-manage-make-process-buffer ()
 176   (with-current-buffer
 177       (generate-new-buffer (format " *sieve %s:%s*"
 178                                    sieve-manage-server
 179                                    sieve-manage-port))
 180     (mapc 'make-local-variable sieve-manage-local-variables)
 181     (mm-enable-multibyte)
 182     (buffer-disable-undo)
 183     (current-buffer)))
 184
 185 (defun sieve-manage-erase (&optional p buffer)
 186   (let ((buffer (or buffer (current-buffer))))
 187     (and sieve-manage-log
 188          (with-current-buffer (get-buffer-create sieve-manage-log)
 189            (mm-enable-multibyte)
 190            (buffer-disable-undo)
 191            (goto-char (point-max))
 192            (insert-buffer-substring buffer (with-current-buffer buffer
 193                                              (point-min))
 194                                     (or p (with-current-buffer buffer
 195                                             (point-max)))))))
 196   (delete-region (point-min) (or p (point-max))))
 197
 198 (defun sieve-manage-open-server (server port &optional stream buffer)
 199   "Open network connection to SERVER on PORT.
 200 Return the buffer associated with the connection."
 201   (with-current-buffer buffer
 202     (sieve-manage-erase)
 203     (setq sieve-manage-state 'initial)
 204     (destructuring-bind (proc . props)
 205         (open-protocol-stream
 206          "SIEVE" buffer server port
 207          :type stream
 208          :capability-command "CAPABILITY\r\n"
 209          :end-of-command "^\\(OK\\|NO\\).*\n"
 210          :success "^OK.*\n"
 211          :return-list t
 212          :starttls-function
 213          (lambda (capabilities)
 214            (when (string-match "\\bSTARTTLS\\b" capabilities)
 215              "STARTTLS\r\n")))
 216       (setq sieve-manage-process proc)
 217       (setq sieve-manage-capability
 218             (sieve-manage-parse-capability (plist-get props :capabilities)))
 219       ;; Ignore new capabilities issues after successful STARTTLS
 220       (when (and (memq stream '(nil network starttls))
 221                  (eq (plist-get props :type) 'tls))
 222         (sieve-manage-drop-next-answer))
 223       (current-buffer))))
 224
 225 ;; Authenticators
 226 (defun sieve-sasl-auth (buffer mech)
 227   "Login to server using the SASL MECH method."
 228   (message "sieve: Authenticating using %s..." mech)
 229   (with-current-buffer buffer
 230     (let* ((auth-info (auth-source-search :host sieve-manage-server
 231                                           :port "sieve"
 232                                           :max 1
 233                                           :create t))
 234            (user-name (or (plist-get (nth 0 auth-info) :user) ""))
 235            (user-password (or (plist-get (nth 0 auth-info) :secret) ""))
 236            (user-password (if (functionp user-password)
 237                               (funcall user-password)
 238                             user-password))
 239            (client (sasl-make-client (sasl-find-mechanism (list mech))
 240                                      user-name "sieve" sieve-manage-server))
 241            (sasl-read-passphrase
 242             ;; We *need* to copy the password, because sasl will modify it
 243             ;; somehow.
 244             `(lambda (prompt) ,(copy-sequence user-password)))
 245            (step (sasl-next-step client nil))
 246            (tag (sieve-manage-send
 247                  (concat
 248                   "AUTHENTICATE \""
 249                   mech
 250                   "\""
 251                   (and (sasl-step-data step)
 252                        (concat
 253                         " \""
 254                         (base64-encode-string
 255                          (sasl-step-data step)
 256                          'no-line-break)
 257                         "\"")))))
 258            data rsp)
 259       (catch 'done
 260         (while t
 261           (setq rsp nil)
 262           (goto-char (point-min))
 263           (while (null (or (progn
 264                              (setq rsp (sieve-manage-is-string))
 265                              (if (not (and rsp (looking-at
 266                                                 sieve-manage-server-eol)))
 267                                  (setq rsp nil)
 268                                (goto-char (match-end 0))
 269                                rsp))
 270                            (setq rsp (sieve-manage-is-okno))))
 271             (accept-process-output sieve-manage-process 1)
 272             (goto-char (point-min)))
 273           (sieve-manage-erase)
 274           (when (sieve-manage-ok-p rsp)
 275             (when (and (cadr rsp)
 276                        (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp)))
 277               (sasl-step-set-data
 278                step (base64-decode-string (match-string 1 (cadr rsp)))))
 279             (if (and (setq step (sasl-next-step client step))
 280                      (setq data (sasl-step-data step)))
 281                 ;; We got data for server but it's finished
 282                 (error "Server not ready for SASL data: %s" data)
 283               ;; The authentication process is finished.
 284               (throw 'done t)))
 285           (unless (stringp rsp)
 286             (error "Server aborted SASL authentication: %s" (caddr rsp)))
 287           (sasl-step-set-data step (base64-decode-string rsp))
 288           (setq step (sasl-next-step client step))
 289           (sieve-manage-send
 290            (if (sasl-step-data step)
 291                (concat "\""
 292                        (base64-encode-string (sasl-step-data step)
 293                                              'no-line-break)
 294                        "\"")
 295              ""))))
 296       (message "sieve: Login using %s...done" mech))))
 297
 298 (defun sieve-manage-cram-md5-p (buffer)
 299   (sieve-manage-capability "SASL" "CRAM-MD5" buffer))
 300
 301 (defun sieve-manage-cram-md5-auth (buffer)
 302   "Login to managesieve server using the CRAM-MD5 SASL method."
 303   (sieve-sasl-auth buffer "CRAM-MD5"))
 304
 305 (defun sieve-manage-digest-md5-p (buffer)