ssl.lisp

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