ssl.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
   2 ;;; $Header$
   3
   4 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz.  All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :hunchentoot)
  31
  32 (defclass ssl-acceptor (acceptor)
  33   ((ssl-certificate-file :initarg :ssl-certificate-file
  34                          :reader acceptor-ssl-certificate-file
  35                          :documentation "A pathname designator for a
  36 certificate file in PEM format.")
  37    (ssl-privatekey-file :initarg :ssl-privatekey-file
  38                         :reader acceptor-ssl-privatekey-file
  39                         :documentation "A pathname designator for a
  40 private key file in PEM format, or \(only on LispWorks) NIL if the
  41 certificate file contains the private key.")
  42    (ssl-privatekey-password :initform nil
  43                             :initarg :ssl-privatekey-password
  44                             :reader acceptor-ssl-privatekey-password
  45                             :documentation "The password for the
  46 private key file or NIL for no password."))
  47   (:default-initargs
  48    :port 443)
  49   (:documentation "Create and START an instance of this class
  50 \(instead of ACCEPTOR) if you want an https server.  There are two
  51 required initargs, :SSL-CERTIFICATE-FILE and :SSL-PRIVATEKEY-FILE, for
  52 pathname designators denoting the certificate file and the key file in
  53 PEM format.  On LispWorks, you can have both in one file in which case
  54 the second initarg is optional.  You can also use the
  55 :SSL-PRIVATEKEY-PASSWORD initarg to provide a password \(as a string)
  56 for the key file \(or NIL, the default, for no password).
  57
  58 The default port for SSL-ACCEPTOR instances is 443 instead of 80"))
  59
  60 ;; general implementation
  61
  62 (defmethod acceptor-ssl-p ((acceptor ssl-acceptor))
  63   t)
  64
  65 (defmethod initialize-instance :after ((acceptor ssl-acceptor) &rest initargs)
  66   (declare (ignore initargs))
  67   ;; LispWorks can read both from the same file, so we can default one
  68   #+:lispworks
  69   (unless (slot-boundp acceptor 'ssl-privatekey-file)
  70     (setf (slot-value acceptor 'ssl-privatekey-file)
  71           (acceptor-ssl-certificate-file acceptor)))
  72   ;; OpenSSL doesn't know much about Lisp pathnames...
  73   (setf (slot-value acceptor 'ssl-privatekey-file)
  74         (namestring (truename (acceptor-ssl-privatekey-file acceptor)))
  75         (slot-value acceptor 'ssl-certificate-file)
  76         (namestring (truename (acceptor-ssl-certificate-file acceptor)))))
  77
  78 ;; usocket implementation
  79
  80 #-:lispworks
  81 (defmethod initialize-connection-stream ((acceptor ssl-acceptor) stream)
  82   ;; attach SSL to the stream if necessary
  83   (call-next-method acceptor
  84                     (cl+ssl:make-ssl-server-stream stream
  85                                                    :certificate (acceptor-ssl-certificate-file acceptor)
  86                                                    :key (acceptor-ssl-privatekey-file acceptor)
  87                                                    :password (acceptor-ssl-privatekey-password acceptor))))
  88
  89 ;; LispWorks implementation
  90
  91 #+:lispworks
  92 (defun make-ssl-server-stream (socket-stream &key certificate-file privatekey-file privatekey-password)
  93   "Given the acceptor socket stream SOCKET-STREAM attaches SSL to the
  94 stream using the certificate file CERTIFICATE-FILE and the private key
  95 file PRIVATEKEY-FILE.  Both of these values must be namestrings
  96 denoting the location of the files and will be fed directly to
  97 OpenSSL.  If PRIVATEKEY-PASSWORD is not NIL then it should be the
  98 password for the private key file \(if necessary).  Returns the
  99 stream."
 100   (flet ((ctx-configure-callback (ctx)
 101            (when privatekey-password
 102              (comm:set-ssl-ctx-password-callback ctx :password privatekey-password))
 103            (comm:ssl-ctx-use-certificate-file ctx
 104                                               certificate-file
 105                                               comm:ssl_filetype_pem)
 106            (comm:ssl-ctx-use-privatekey-file ctx
 107                                              privatekey-file
 108                                              comm:ssl_filetype_pem)))
 109     (comm:attach-ssl socket-stream
 110                      :ctx-configure-callback #'ctx-configure-callback)
 111     socket-stream))
 112
 113 #+:lispworks
 114 (defmethod initialize-connection-stream ((acceptor ssl-acceptor) stream)
 115   ;; attach SSL to the stream if necessary
 116   (call-next-method acceptor
 117                     (make-ssl-server-stream stream
 118                                             :certificate-file (acceptor-ssl-certificate-file acceptor)
 119                                             :privatekey-file (acceptor-ssl-privatekey-file acceptor)
 120                                             :privatekey-password (acceptor-ssl-privatekey-password acceptor))))